Sub ObserveManners()
Dim ws As Worksheet
'全てのシートでA1セルを指定し、倍率を100%に変更。
For Each ws In Worksheets
ws.Select
ws.Range("A1").Select
ActiveWindow.Zoom = 100
Next
'1つ目のシートへ移動。
Sheets(1).Select
End Sub
④ 「Microsoft Visual Basic for Applications」にて以下のコードを記載
Sub CreateEmail()
Dim oApp As Object
Dim objMail As Object
Dim subjectBodyWorksheet As Object: Set subjectBodyWorksheet = ThisWorkbook.Worksheets("件名・本文")
Dim subject As String: subject = subjectBodyWorksheet.Cells(1, 2).Value
Dim body As String: body = subjectBodyWorksheet.Cells(2, 2).Value
Dim attachmentPath As String: attachmentPath = subjectBodyWorksheet.Cells(3, 2).Value
Dim firstRow As Long: firstRow = 2
Dim lastRow As Long: lastRow = ThisWorkbook.Worksheets("宛先リスト").Cells(Rows.Count, 1).End(xlUp).Row
Dim companyNameRow As Integer: companyNameRow = 1
Dim departmentNameRow As Integer: departmentNameRow = 2
Dim staffNameRow As Integer: staffNameRow = 3
Dim honorificTitleRow As Integer: honorificTitleRow = 4
Dim mailAddressRow As Integer: mailAddressRow = 5
For y = firstRow To lastRow
Dim addressListWorksheet As Object: Set addressListWorksheet = ThisWorkbook.Worksheets("宛先リスト")
Dim companyName As String: companyName = addressListWorksheet.Cells(y, companyNameRow).Value
Dim departmentName As String: departmentName = addressListWorksheet.Cells(y, departmentNameRow).Value
Dim staffName As String: staffName = addressListWorksheet.Cells(y, staffNameRow).Value
Dim honorificTitle As String: honorificTitle = addressListWorksheet.Cells(y, honorificTitleRow).Value
Dim mailAddress As String: mailAddress = addressListWorksheet.Cells(y, mailAddressRow).Value
'メールアドレス列がからの場合は飛ばす
If mailAddress = "" Then
GoTo Continue
End If
'メールオブジェクト生成
On Error Resume Next
Set oApp = GetObject(, "Outlook.Application")
On Error GoTo 0
If oApp Is Nothing Then
Set oApp = CreateObject("Outlook.Application")
oApp.GetNamespace("MAPI").GetDefaultFolder(6).display
End If
Set objMail = oApp.CreateItem(0)
'各変数の置換
Dim adjustBody As String: adjustBody = body
adjustBody = Replace(adjustBody, "&CompanyName", companyName)
adjustBody = Replace(adjustBody, "&DepartmentName", departmentName)
adjustBody = Replace(adjustBody, "&StaffName", staffName)
adjustBody = Replace(adjustBody, "&HonorificTitle", honorificTitle)
'各メールの要素をセット
With objMail
.To = mailAddress
.subject = subject
.body = adjustBody
.BodyFormat = 1
End With
'請求書添付
AttachFile objMail, attachmentPath, companyName
'メール表示
objMail.display
Continue:
Next y
Set objMail = Nothing
Set oApp = Nothing
End Sub
Sub AttachFile(ByVal objMail As Object, ByVal attachmentPath As String, ByVal companyName As String)
If attachmentPath = "" Then
Exit Sub
End If
Dim path, fso, file, files
'ファイル格納フォルダ
path = attachmentPath
Set fso = CreateObject("Scripting.FileSystemObject")
Set files = fso.GetFolder(path).files
'フォルダ内の全ファイルをループ
For Each file In files
'companyNameを含むファイルを特定
If InStr(file.Name, companyName) >= 1 Then
objMail.Attachments.Add (file.path)
End If
Next file
End Sub
④ 「Microsoft Visual Basic for Applications」にて以下のコードを記載
Sub CreateEmail()
Dim oApp As Object
Dim objMAIL As Object
Dim subjectBodyWorksheet As Object: Set subjectBodyWorksheet = ThisWorkbook.Worksheets("件名・本文")
Dim subject As String: subject = subjectBodyWorksheet.Cells(1, 2).Value
Dim body As String: body = subjectBodyWorksheet.Cells(2, 2).Value
Dim mailMagazinePath As String: mailMagazinePath = subjectBodyWorksheet.Cells(3, 2).Value
Dim firstRow As Long: firstRow = 2
Dim lastRow As Long: lastRow = ThisWorkbook.Worksheets("宛先リスト").Cells(Rows.Count, 1).End(xlUp).Row
Dim nameRow As Integer: nameRow = 1
Dim mailAddressRow As Integer: mailAddressRow = 2
'画像コピー
Dim picture As shape: Set picture = CopyPicture(mailMagazinePath)
'宛先分繰り返し
For y = firstRow To lastRow
Dim addressListWorksheet As Object: Set addressListWorksheet = ThisWorkbook.Worksheets("宛先リスト")
'氏名とメールアドレス取得
Dim name As String: name = addressListWorksheet.Cells(y, nameRow).Value
Dim mailAddress As String: mailAddress = addressListWorksheet.Cells(y, mailAddressRow).Value
'メールアドレス列がからの場合は飛ばす
If mailAddress = "" Then
GoTo Continue
End If
'メールオブジェクト生成
On Error Resume Next
Set oApp = GetObject(, "Outlook.Application")
On Error GoTo 0
If oApp Is Nothing Then
Set oApp = CreateObject("Outlook.Application")
oApp.GetNamespace("MAPI").GetDefaultFolder(6).display
End If
Set objMAIL = oApp.CreateItem(0)
'変数の置換
Dim adjustBody As String: adjustBody = body
adjustBody = Replace(adjustBody, "&Name", name)
'各メールの要素をセットして表示
With objMAIL
.To = mailAddress
.subject = subject
.body = adjustBody
.BodyFormat = 3
.display
End With
'最終位置を取得して画像を貼り付け
If Not (picture Is Nothing) Then
Dim endPosition As Integer: endPosition = objMAIL.GetInspector.WordEditor.Characters.Count - 1
oApp.ActiveInspector.WordEditor.Range(endPosition, endPosition).Paste
Application.CutCopyMode = True
End If
'★自動で送信したい場合は↓の「'」を外してください★
'objMail.Send
Continue:
Next y
'画像シートの画像を削除
If Not (picture Is Nothing) Then
picture.Delete
End If
Set objMAIL = Nothing
Set oApp = Nothing
End Sub
Function CopyPicture(ByVal mailMagazinePath As String) As shape
If mailMagazinePath = "" Then
Exit Function
End If
'画像を画像シートに配置
Dim picture As shape: Set picture = ThisWorkbook.Worksheets("画像").Shapes.AddPicture(Filename:=mailMagazinePath, _
LinkToFile:=True, _
SaveWithDocument:=False, _
Left:=Selection.Left, _
Top:=Selection.Top, _
Width:=0, _
Height:=0)
'画像を元のサイズにしてコピー
With picture
.ScaleHeight 1, msoTrue
.ScaleWidth 1, msoTrue
.Copy
End With
Set CopyPicture = picture
End Function