teratail header banner
teratail header banner
質問するログイン新規登録

質問編集履歴

1

全文の記載

2021/10/30 05:21

投稿

shunsuke_0319
shunsuke_0319

スコア2

title CHANGED
File without changes
body CHANGED
@@ -1,7 +1,50 @@
1
1
  今ワードに反応してメールを送るvbaを作成しています
2
2
  そこでf1がtureならoutlookを起動させたいのですが型が一致しませんとエラーが出ます
3
3
  なぜでしょうか?
4
+ エラーが出るのは
5
+
6
+ If CreateObject("Outlook.Application") Then です
7
+
8
+ Sub sample()
9
+ Const olMailItem = 0
10
+ Dim file As String
11
+ Dim pr As Presentation
12
+ Dim sl As Slide
13
+ Dim sh As Shape
14
+ Dim tb As Table
15
+ Dim r As Integer
16
+ Dim c As Integer
17
+ Dim s As String
18
+ Dim f1 As Boolean
19
+ Dim f2 As Boolean
20
+ Dim ol As Object
21
+ Dim mail As Object
22
+ Dim f As Object
23
+ Dim dic As Object
24
+ Dim k As Variant
25
+ Dim n As Variant
26
+
27
+ With Application.FileDialog(msoFileDialogOpen)
28
+ .Filters.Clear
29
+ .Filters.Add "ppt", "*.ppt?"
30
+ .InitialFileName = "C:\"
31
+ .AllowMultiSelect = False
32
+ If Not .Show Then Exit Sub
33
+ file = .SelectedItems(1)
34
+ End With
35
+ Do
36
+ Set pr = Presentations.Open(file)
37
+ For Each sl In pr.Slides
38
+ f1 = False
39
+ f2 = False
40
+ For Each sh In sl.Shapes
41
+ If sh.HasTable Then
42
+ Set tb = sh.Table
43
+ For r = 1 To tb.Rows.Count
44
+ For c = 1 To tb.Rows(r).Cells.Count
45
+ s = tb.Rows(r).Cells(c).Shape.TextFrame2.TextRange.Text
46
+ If InStr(s, "フレッツ") Then f1 = True
4
- If InStr(s, "専用") Then f1 = True
47
+ If InStr(s, "専用") Then f1 = True
5
48
  If InStr(s, "秋田") Then
6
49
  If r <> tb.Rows.Count Then
7
50
  If IsNumeric(tb.Rows(r + 1).Cells(c).Shape.TextFrame2.TextRange.Text) Then f2 = True
@@ -13,10 +56,132 @@
13
56
  End If
14
57
  Next
15
58
  Next
59
+ MsgBox "無かった"
16
60
  Loop Until True
61
+ pr.Close
62
+ If Not (f1 And f2) Then Exit Sub
63
+ '
64
+ MsgBox "見つけた"
65
+ '添付ファイル
66
+ Set dic = CreateObject("Scripting.Dictionary")
67
+ With Application.FileDialog(msoFileDialogOpen)
68
+ .Filters.Clear
69
+ .Filters.Add "添付ファイル", "*.*"
70
+ .InitialFileName = "C:\"
71
+ .AllowMultiSelect = True
72
+ If Not .Show Then Exit Sub
73
+ file = .SelectedItems(1)
74
+ Set dic = CreateObject("Scripting.Dictionary")
75
+ Dim i As Integer
76
+ For i = 1 To .SelectedItems.Count
77
+ dic.Add .SelectedItems(i), Null
78
+ Next
79
+ End With
80
+ 'メール送信
81
+ With Application.FileDialog(msoFileDialogOpen)
82
+ .Filters.Clear
83
+ .Filters.Add "ppt", "*.ppt?"
84
+ .InitialFileName = "C:\"
85
+ .AllowMultiSelect = False
86
+ If Not .Show Then Exit Sub
87
+ file = .SelectedItems(1)
88
+ End With
89
+ Do
90
+ Set pr = Presentations.Open(file)
91
+ For Each sl In pr.Slides
92
+ f1 = False
93
+ f2 = False
94
+ For Each sh In sl.Shapes
95
+ If sh.HasTable Then
96
+ Set tb = sh.Table
97
+ For r = 1 To tb.Rows.Count
98
+ For c = 1 To tb.Rows(r).Cells.Count
99
+ s = tb.Rows(r).Cells(c).Shape.TextFrame2.TextRange.Text
100
+ If InStr(s, "専用") Then f1 = True
101
+ If InStr(s, "秋田") Then
102
+ If r <> tb.Rows.Count Then
103
+ If IsNumeric(tb.Rows(r + 1).Cells(c).Shape.TextFrame2.TextRange.Text) Then f2 = True
104
+ End If
105
+ End If
106
+ If f1 And f2 Then Exit Do
107
+ Next
108
+ Next
109
+ End If
110
+ Next
111
+ Next
112
+ Loop Until True
17
113
  If CreateObject("Outlook.Application") Then f1 = True
18
114
  If mail = ol.CreateItem(olMailItem) Then f1 = True
19
115
  mail.Display
20
116
  mail.To = "aquarius0319" '宛先
21
117
  mail.Subject = "件名"
22
- mail.Body = "本文"
118
+ mail.Body = "本文"
119
+ For Each k In dic.keys
120
+ mail.Attachments.Add k
121
+ Next
122
+ Set dic = CreateObject("Scripting.Dictionary")
123
+ With Application.FileDialog(msoFileDialogOpen)
124
+ .Filters.Clear
125
+ .Filters.Add "添付ファイル", "*.*"
126
+ .InitialFileName = "C:\"
127
+ .AllowMultiSelect = True
128
+ If Not .Show Then Exit Sub
129
+ file = .SelectedItems(1)
130
+ Set dic = CreateObject("Scripting.Dictionary")
131
+ Dim l As Integer
132
+ For l = 1 To .SelectedItems.Count
133
+ dic.Add .SelectedItems(l), Null
134
+ Next
135
+ End With
136
+ mail.Attachments.Add file
137
+ Do
138
+ Set pr = Presentations.Open(file)
139
+ For Each sl In pr.Slides
140
+ f1 = False
141
+ f2 = False
142
+ For Each sh In sl.Shapes
143
+ If sh.HasTable Then
144
+ Set tb = sh.Table
145
+ For r = 1 To tb.Rows.Count
146
+ For c = 1 To tb.Rows(r).Cells.Count
147
+ s = tb.Rows(r).Cells(c).Shape.TextFrame2.TextRange.Text
148
+ If InStr(s, "フレッツ") Then f1 = True
149
+ If InStr(s, "秋田") Then
150
+ If r <> tb.Rows.Count Then
151
+ If IsNumeric(tb.Rows(r + 1).Cells(c).Shape.TextFrame2.TextRange.Text) Then f2 = True
152
+ End If
153
+ End If
154
+ Next
155
+ Next
156
+ End If
157
+ Next
158
+ Next
159
+ Loop Until True
160
+ Set ol = CreateObject("Outlook.Application")
161
+ Set mail = ol.CreateItem(olMailItem)
162
+ mail.Display
163
+ mail.To = "b230420" '宛先
164
+ mail.Subject = "件名"
165
+ mail.Body = "本文"
166
+ For Each n In dic.keys
167
+ mail.Attachments.Add n
168
+ 'ファイルを添付
169
+ Next
170
+ Set dic = CreateObject("Scripting.Dictionary")
171
+ With Application.FileDialog(msoFileDialogOpen)
172
+ .Filters.Clear
173
+ .Filters.Add "添付ファイル", "*.*"
174
+ .InitialFileName = "C:\"
175
+ .AllowMultiSelect = True
176
+ If Not .Show Then Exit Sub
177
+ file = .SelectedItems(1)
178
+ Set dic = CreateObject("Scripting.Dictionary")
179
+ Dim o As Integer
180
+ For o = 1 To .SelectedItems.Count
181
+ dic.Add .SelectedItems(o), Null
182
+ Next
183
+ End With
184
+ mail.Attachments.Add file
185
+ mail.Send '送信
186
+ ol.Quit
187
+ End Sub