teratail
回答率
85.37%
teratail 10th-anniversary
teratail 10th-anniversary
質問するログイン新規登録
トップに関する質問VBAでOutlook操作

編集履歴

質問編集履歴

1

書式の改善、様式の添付等

2020/02/18 00:27

投稿

ichigo15
ichigo15

スコア14

test CHANGED
File without changes
test CHANGED
@@ -1,4 +1,4 @@
1
- ### 前提・実現したいこと
1
+ ### 前提
2
2
 
3
3
 
4
4
 
@@ -14,17 +14,33 @@
14
14
 
15
15
 
16
16
 
17
+ ### 実現したいこと
18
+
19
+
20
+
21
+ 1.Excelに情報を入力
22
+
23
+ 2.マクロを実行する
24
+
25
+ 3.Excelの情報を基にメールを作成
26
+
27
+
28
+
17
- サイトからの変更事項
29
+ ###サイトからの変更事項
18
30
 
19
31
 
20
32
 
21
33
  1）A列が"1"なら送信メールを作成する
22
34
 
23
- 2）B列が"添付"なら添付ファイルをデスクトップに保存し、送信メールに添付する
35
+ 2）B列に"添付"があれば、同ファイルの添付（シート名）をデスクトップに保存する
36
+
24
-
37
+ 3）B列が"添付"のものは、2）で作成したファイルを添付する
25
-
26
-
38
+
39
+
40
+
27
- 各人のデスクトップにファイルを保管し、実行できるようにしたいです。
41
+ **※**サイトではキーワードが一致した場合だけフォルダよりファイルを探して
42
+
43
+ メールに添付しております。
28
44
 
29
45
 
30
46
 
@@ -32,17 +48,33 @@
32
48
 
33
49
 
34
50
 
35
- 2）B列が"添付"なら添付ファイルをデスクトップに保存し、送信メールに添付する
51
+ a）コンパイルエラー：名前が適切でありません（col）
52
+
36
-
53
+ となります。
54
+
55
+
56
+
37
-
57
+ b）3）の変更で
38
-
58
+
59
+
60
+
39
- 問題点①　B列に"添付"がひとつでもあったらという構文（IF？）
61
+ 問題点①：B列に"添付"がひとつでもあったらという構文（IF？）の作り方、挿入場所が分かりません
40
-
62
+
63
+
64
+
41
- 問題点②　ユーザー名やWindowsのバージョンにかかわらずデスクトップにあるファイルのパス
65
+ 問題点②：ユーザー名やWindowsのバージョンにかかわらずデスクトップにあるファイルのパスをどのように書いてよいのか分かりません
42
-
66
+
67
+
68
+
43
- 問題点③　送信メールへの添付
69
+ 問題点③：送信メールへの添付の構文の書き方が分かりません
70
+
71
+
72
+
44
-
73
+ ### ファイル様式
74
+
75
+
76
+
45
-
77
+ ![イメージ説明](8db8a4948781c1ad84bbd2c2d8abfc3b.png)
46
78
 
47
79
 
48
80
 
@@ -50,23 +82,27 @@
50
82
 
51
83
 
52
84
 
53
- サイトの構文（原文）
85
+ サイトより一部修正しております。
86
+
87
+
54
88
 
55
89
  ```ここに言語名を入力
56
90
 
57
91
  Enum col '1以降の数値を省略した場合は+1される
58
92
 
59
- 宛先 = 1
93
+ 送信 = 1
60
-
94
+
61
- 複写
95
+ 添付
62
-
96
+
63
- 氏名
97
+ 宛名
98
+
64
-
99
+ アドレス1
100
+
101
+ アドレス2
102
+
65
- 使用日
103
+ 　　担当者
66
-
104
+
67
- 金額
105
+ 摘要
68
-
69
- 添付キーワード
70
106
 
71
107
  End Enum
72
108
 
@@ -86,7 +122,7 @@
86
122
 
87
123
  Dim r As Long
88
124
 
89
- For r = 2 To Cells(1, 1).End(xlDown).Row
125
+ For r = 2 To Cells(1, 4).End(xlDown).Row
90
126
 
91
127
 
92
128
 
@@ -116,6 +152,12 @@
116
152
 
117
153
  If FileAttach(attachObj, keyword) = True Then
118
154
 
155
+ 　　　　
156
+
157
+ 　　　　If Cells(r, 1).Value = 1 Then
158
+
159
+ 　　If Cells(r, 2).Value = "添付" Then
160
+
119
161
 
120
162
 
121
163
  'メール本文作成
@@ -130,16 +172,20 @@
130
172
 
131
173
  With mailItemObj
132
174
 
133
- .To = Cells(r, col.宛先).Value
175
+ .To = Cells(r, col.アドレス1).Value
134
-
176
+
135
- .CC = Cells(r, col.複写).Value
177
+ .CC = Cells(r, col.アドレス2).Value
136
-
178
+
137
- .Subject = Cells(1, "J").Value '件名
179
+ .Subject = Cells(1, "K").Value '件名
138
180
 
139
181
  .Body = mailBody '本文
140
182
 
141
183
  End With
142
184
 
185
+ 　　　　　End　If
186
+
187
+ 　　　　End　If
188
+
143
189
 
144
190
 
145
191
  mailItemObj.Display '下書きを表示
@@ -174,15 +220,15 @@
174
220
 
175
221
  sName = Cells(r, col.氏名).Value
176
222
 
177
- DayOfUse = Cells(r, col.使用日).Value
223
+ Personnel = Cells(r, col.担当者).Value
178
-
224
+
179
- price = Cells(r, col.金額).Value
225
+ Summary = Cells(r, col.摘要).Value
180
226
 
181
227
 
182
228
 
183
229
  Dim sign As String '署名
184
230
 
185
- sign = Cells(12, "J").Value
231
+ sign = Cells(12, "K").Value
186
232
 
187
233
 
188
234
 
@@ -192,9 +238,9 @@
192
238
 
193
239
  mBody = Replace(mBody, "（氏名）", sName)
194
240
 
195
- mBody = Replace(mBody, "（使用日）", DayOfUse)
241
+ mBody = Replace(mBody, "（担当者）", Personnel)
196
-
242
+
197
- mBody = Replace(mBody, "（金額）", price)
243
+ mBody = Replace(mBody, "（適用）", Summary)
198
244
 
199
245
  mBody = mBody & vbCrLf & vbCrLf & sign '末尾に署名を付与
200
246
 
@@ -288,155 +334,29 @@
288
334
 
289
335
 
290
336
 
291
- If Cells(r, 2).Value = 1 Then
337
+ If Cells(r, 1).Value = 1 Then
292
338
 
293
339
  End　If　を使用
294
340
 
295
341
 
296
342
 
343
+ 2）デスクトップにファイルを作成できましたが開いたままとなってしまいました
344
+
297
345
 
298
346
 
299
347
  ```ここに言語を入力
300
348
 
301
- Sub main()
302
-
303
-
304
-
305
- 'Outlookオブジェクトの作成
306
-
307
- Dim OutlookObj As Outlook.Application
308
-
309
- Set OutlookObj = New Outlook.Application
310
-
311
-
312
-
313
- Dim r As Long
314
-
315
- For r = 2 To Cells(1, 1).End(xlDown).Row
316
-
317
-
318
-
319
- If Cells(r, 2).Value = 1 Then
320
-
321
-
322
-
323
- 'メールアイテムオブジェクト作成
324
-
325
- Dim mailItemObj As Outlook.MailItem
326
-
327
- Set mailItemObj = OutlookObj.CreateItem(olMailItem)
328
-
329
-
330
-
331
- '添付ファイルオブジェクトの生成
332
-
333
- Dim attachObj As Outlook.Attachments
334
-
335
- Set attachObj = mailItemObj.Attachments
336
-
337
-
338
-
339
- 'メール本文作成
340
-
341
- Dim mailBody As String
342
-
343
- mailBody = CreateMailBody(r)
344
-
345
-
346
-
347
- 'メールアイテム作成
348
-
349
- With mailItemObj
350
-
351
- .To = Cells(r, col.アドレス1).Value
352
-
353
- .CC = Cells(r, col.アドレス2).Value
354
-
355
- .Subject = Cells(1, "K").Value '件名
356
-
357
- .Body = mailBody '本文
358
-
359
- End With
360
-
361
-
362
-
363
- End If
364
-
365
-
366
-
367
- Dim keyword As String
368
-
369
- keyword = Cells(r, col.添付キーワード)
370
-
371
-
372
-
373
- Call FileAttach(attachObj, keyword) 'ファイルを添付する
374
-
375
-
376
-
377
- mailItemObj.Display '下書きを表示
378
-
379
-
380
-
381
- '次のメールアイテムを作成するためいったん破棄
382
-
383
- Set mailItemObj = Nothing
384
-
385
-
386
-
387
- Next r
388
-
389
-
390
-
391
- End Sub
392
-
393
-
394
-
395
-
396
-
397
- ' 【機能】Excelシート上の指定行番号のメール本文を作成する
398
-
399
- Function CreateMailBody(r As Long) As String
400
-
401
-
402
-
403
- Dim sName As String, DayOfUse As String, price As Long
404
-
405
- sName = Cells(r, col.氏名).Value
406
-
407
- Personnel = Cells(r, col.担当者).Value
408
-
409
- Summary = Cells(r, col.摘要).Value
410
-
411
-
412
-
413
- Dim sign As String '署名
414
-
415
- sign = Cells(12, "J").Value
349
+ Sheets("添付").Copy
416
-
417
-
418
-
350
+
351
+
352
+
419
- Dim mBody As String 'メール本文
353
+ ActiveWorkbook.SaveAs _
420
-
354
+
421
- mBody = Cells(2, "J").Value '初期値を設定
355
+ FileName:=Ps & "\" & "添付", _
422
-
423
- mBody = Replace(mBody, "（氏名）", sName)
356
+
424
-
425
- mBody = Replace(mBody, "（担当者）", Personnel)
426
-
427
- mBody = Replace(mBody, "（摘要）", Summary)
428
-
429
- mBody = mBody & vbCrLf & vbCrLf & sign '末尾に署名を付与
430
-
431
-
432
-
433
- CreateMailBody = mBody
357
+ FileFormat:=xlOpenXMLWorkbook
434
-
435
-
436
-
358
+
437
- End Function```
359
+ ```
438
-
439
-
440
360
 
441
361
 
442
362