回答編集履歴
1
全コード
answer
CHANGED
|
@@ -34,4 +34,74 @@
|
|
|
34
34
|
End With
|
|
35
35
|
```
|
|
36
36
|
余談ですが折角With使っているのにその中でObjMailを書いていたので修正してます。
|
|
37
|
-
あと動作確認はしていませんのであしからず。
|
|
37
|
+
あと動作確認はしていませんのであしからず。
|
|
38
|
+
|
|
39
|
+
修正版全コード
|
|
40
|
+
```VBA
|
|
41
|
+
Sub ovba()
|
|
42
|
+
|
|
43
|
+
'ファイルの選択ダイアログを表示して
|
|
44
|
+
'ファイルのパスを取得します
|
|
45
|
+
|
|
46
|
+
Dim fType, prompt As String
|
|
47
|
+
Dim fPath As Variant
|
|
48
|
+
Dim ws As Worksheet
|
|
49
|
+
Dim ObjMail As Object
|
|
50
|
+
|
|
51
|
+
|
|
52
|
+
Dim objOutlook As Outlook.Application
|
|
53
|
+
Dim i As Long
|
|
54
|
+
Dim rowMax As Long
|
|
55
|
+
Dim wsList As Worksheet
|
|
56
|
+
|
|
57
|
+
' Set ObjMail = CreateObject("Outlook.Application") ★この行削除
|
|
58
|
+
|
|
59
|
+
Set objOutlook = New Outlook.Application
|
|
60
|
+
Set wsList = ThisWorkbook.Sheets("送信先")
|
|
61
|
+
Set wsMail = ThisWorkbook.Sheets("メール内容")
|
|
62
|
+
|
|
63
|
+
'選択できるファイルの種類はすべてのファイル
|
|
64
|
+
fType = ""
|
|
65
|
+
|
|
66
|
+
|
|
67
|
+
'ダイアログのタイトルを指定
|
|
68
|
+
prompt = "Excelファイルを選択して下さい"
|
|
69
|
+
'ファイル参照ダイアログの表示
|
|
70
|
+
fPath = Application.GetOpenFilename(fType, , prompt)
|
|
71
|
+
|
|
72
|
+
If fPath = False Then
|
|
73
|
+
'ダイアログでキャンセルボタンが押された場合は処理を終了します
|
|
74
|
+
End
|
|
75
|
+
End If
|
|
76
|
+
|
|
77
|
+
'B2セルにファイル名をセット
|
|
78
|
+
wsMail.Cells(10, 3).Value = fPath
|
|
79
|
+
|
|
80
|
+
'--- 添付ファイルのパス ---'
|
|
81
|
+
Dim attachmentPath As String
|
|
82
|
+
attachmentPath = fPath
|
|
83
|
+
|
|
84
|
+
'--- 添付ファイルを設定 ---'
|
|
85
|
+
' Call ObjMail.Attachments.Add(attachmentPath) ★この行削除
|
|
86
|
+
|
|
87
|
+
With wsList
|
|
88
|
+
|
|
89
|
+
'送信先の件数
|
|
90
|
+
rowMax = .Cells(Rows.Count, 1).End(xlUp).Row
|
|
91
|
+
|
|
92
|
+
'送信先の件数分繰り返す
|
|
93
|
+
For i = 2 To rowMax
|
|
94
|
+
Set ObjMail = objOutlook.CreateItem(olMailItem)
|
|
95
|
+
With ObjMail
|
|
96
|
+
.To = wsList.Cells(i, 4).Value 'メール宛先
|
|
97
|
+
.Subject = wsMail.Range("B1").Value 'メール件名
|
|
98
|
+
.BodyFormat = olFormatPlain 'メールの形式
|
|
99
|
+
.Body = wsMail.Range("B2").Value 'メール本文
|
|
100
|
+
.Attachments.Add attachmentPath ' ★この行追加
|
|
101
|
+
.Display 'Outlookの下書きをDisplayする
|
|
102
|
+
End With
|
|
103
|
+
Next i
|
|
104
|
+
|
|
105
|
+
End With
|
|
106
|
+
End Sub
|
|
107
|
+
```
|