Sub MyXlMailAutoAtt()
Rem *----*----* *----*----* *----*----* *----*----*
Rem Excelブック個別宛て添付ファイルOutlook電子メール送信処理
Rem 作譜：Hitrock Camellia Shinopy
Rem 言語：Excel VBA
Rem 機能...
Rem シート上の送信先名・送信先メールアドレスを基にメール送信。
Rem 指定した保存先フォルダのJPEGファイルを、電子メールの添付ファイルとする。
Rem 送信先名の付いた添付ファイルをメールに追加する。
Rem 注記...
Rem 01. この処理は、ブックを一度以上保存した場合に有効。
Rem （新規作成して保存を一度もしていない場合は、使用不可。）
Rem 02. 指定したフォルダの「*.jpg」ファイルを検索し、ハイパーリンクのアドレスに設定する。
Rem 03. 指定するフォルダは、ブックと同一か下位のフォルダであること。
Rem 04. 検索するファイルは、次のようなファイル名の場合に有効：
Rem 検索する文字列（＝ハイパーリンクの表示文字列）と任意の文字列が、
Rem つながっている場合は検索不可。
Rem （「ああ」は、検索する文字列（＝ハイパーリンクの表示文字列）、
Rem 「いい」は、内容・長さとも任意の文字列、
Rem 「00」「01」は、内容・長さとも任意の数字）
Rem ああ.jpg 00ああ.jpg ああ01.jpg 00ああ01.jpg
Rem ああ01いい.jpg 00ああ01いい.jpg
Rem 05. 検索したファイルが全くない場合も、ダイアログボックスが表示されるので、
Rem 縮小版表示されたファイルを直にクリックして選択すること。
Rem [キャンセル]ボタンを押すと、処理を中止する。
Rem 06. 検索したファイルが複数ある場合は、ダイアログボックスが表示されるので、
Rem 縮小版表示されたファイルを直にクリックして選択すること。
Rem この際、[ファイル名]は、検索したファイルの名前が総て表示されたままになっているので注意。
Rem [キャンセル]ボタンを押すと、処理を中止する。
Rem [ファイル名]・[空白ボタン]は、使用不可。
Rem 07. Microsoft Outlook上で、下記の手作業による事前設定が必要。
Rem Microsoft Outlookのメニューバーの[ツール]から[オプション...]をクリックし、
Rem [メール形式]タブの[電子メールの編集にMicrosoft Wordを使用する]チェックボックスを
Rem オンにする。
Rem 08. Microsoft Outlookが起動済みの状態である場合、すぐに電子メールが送信される。
Rem 起動してない場合は、これを起動して[送受信]ボタンを押して送信する必要がある。
Rem 09. [電子メールの編集にMicrosoft Wordを使用する]オフの場合、処理を中止する。
Rem 10. シートの1行目は、見出し行とする。
Rem 11. この処理では、[送信先名]列・[送信先メールアドレス]列・[送信済みフラグ]列を使用する。
Rem 12. この処理では、送信の繰り返しを3回に制限している。（処理を続けたい場合は再実行）
Rem 履歴...
Rem 第01版：2007/04/20：作成。
Rem 第02版：2008/08/12：Microsoft Outlookのバージョンにより送信する処理方法を分けた。
Rem *----*----* *----*----* *----*----* *----*----*
Rem 参照設定する場合...
Rem Microsoft Shell Controls And Automation
Rem Microsoft Scripting RunTime
Rem Microsoft VBScript Regular Expressions 5.5
Rem Microsoft Outlook 10.0 Object Library
Rem Microsoft Word 10.0 Object Library
Rem *----*----* *----*----* *----*----* *----*----*
Dim myFolder As String
Dim myFiles As String
Dim myString As String
Dim myAtt As String
'
Dim myRegExp As Variant ' VBScript_RegExp_55.RegExp
Dim myMatches As Variant ' MatchCollection
Dim myMatch As Variant ' Match
Dim myPttn As String
'
Dim myDialog As FileDialog
Dim myInitialFileName As String
Dim myText As String
Dim myHref As String
Dim myBody As String
Dim i As Long
Dim j As Long
Dim myMax As Long
'
Dim myOutlook As Variant ' Outlook.Application
Dim myMail As Variant ' MailItem
Dim myWord As Variant ' Word.Application
Dim myCmmdBar As CommandBar
Dim myCtrl As CommandBarControl
'
Dim a As Long
Dim b As Long
Dim c As Long
Rem *----*----* *----*----* *----*----* *----*----*
'
a = 1 ' [送信先名]列
b = 2 ' [送信先メールアドレス]列
c = 3 ' [送信済みフラグ]列
'
Range("A1").Select
ActiveCell.SpecialCells(xlLastCell).Select
myMax = ActiveCell.Row
'
myFiles = ""
Call MyXlMailAutoAttFiles(myFolder, myFiles)
Select Case myFiles
Case ""
Rem 処理キャンセル
Exit Sub
Case vbCrLf
MsgBox "JPEGファイル（*.jpg）がありません。"
Exit Sub
End Select
'
Set myRegExp = CreateObject("VBScript.RegExp") ' New VBScript_RegExp_55.RegExp
Rem *----*----* *----*----* *----*----* *----*----*
'
On Error Resume Next
Set myOutlook = GetObject(, "Outlook.Application")
If Err.Number <> 0 Then
Set myOutlook = CreateObject("Outlook.Application")
End If
On Error GoTo 0
'
j = 0
For i = 2 To myMax
If Len(Cells(i, a).Value) <> 0 And Len(Cells(i, b).Value) <> 0 Then
If Len(Cells(i, c).Value) = 0 Then
myText = i * 100 \ myMax & "% " & i & "/" & myMax & "行"
Application.StatusBar = "MyXlMailAutoAtt" & "：" & myText
Rem *----*----* *----*----* *----*----* *----*----*
'
myPttn = "(\r\n){1}(\d*?)(" & Cells(i, a).Text & ")(\d*?|\d+?.*?)\.jpg"
With myRegExp
.Pattern = myPttn ' パターンを指定
.IgnoreCase = False ' 大文字小文字を区別する。
.Global = True ' 文字列全体を検索
End With
Set myMatches = myRegExp.Execute(myFiles)
'
Cells(i, a).Select
Select Case myMatches.Count
Case 1
myHref = Replace(myMatches(0).Value, vbCrLf, "")
myAtt = myFolder & "\" & myHref
Case 0
Beep
' MsgBox "該当するJPEGファイル（*.jpg）がありません。"
Set myDialog = Application.FileDialog(msoFileDialogFilePicker)
With myDialog
.InitialView = msoFileDialogViewThumbnail
.ButtonName = " "
.Filters.Add "画像", "*.jpg", 1
.InitialFileName = ""
myText = " ( " & i & "/" & myMax & "行目" & " )"
myText = myText & "：画像を一つ選択し、クリックして下さい。"
myText = myText & "（ファイル名・空白ボタンは無効）"
.Title = Cells(i, a).Text & myText
.AllowMultiSelect = False
If .Show = 0 Then
Rem [キャンセル]
Set myDialog = Nothing
Exit Sub
End If
myAtt = .SelectedItems(1)
End With
Case Else
Beep
' MsgBox "該当するJPEGファイル（*.jpg）が複数あります。"
myInitialFileName = ""
For Each myMatch In myMatches
myInitialFileName = myInitialFileName & Replace(myMatch.Value, vbCrLf, "") & ";"
Next ' myMatch
'
Set myDialog = Application.FileDialog(msoFileDialogFilePicker)
With myDialog
.InitialView = msoFileDialogViewThumbnail
.ButtonName = " "
.Filters.Add "画像", "*.jpg", 1
' InitialFileNameプロパティに 256 文字より長い文字列を指定すると、実行時エラーになります。
.InitialFileName = Left(myFolder & "\" & myInitialFileName, 256)
myText = " ( " & i & "/" & myMax & "行目" & " )"
myText = myText & "：画像を一つ選択し、クリックして下さい。"
myText = myText & "（ファイル名・空白ボタンは無効）"
.Title = Cells(i, a).Text & myText
.AllowMultiSelect = False
If .Show = 0 Then
Rem [キャンセル]
Set myDialog = Nothing
Exit Sub
End If
myAtt = .SelectedItems(1)
End With
End Select
Rem *----*----* *----*----* *----*----* *----*----*
'
Set myMail = myOutlook.CreateItem(0) ' = myOutlook.CreateItem(olMailItem)
With myMail
.Subject = "このメールはテストです。"
.To = Cells(i, b).Value
.BCC = "xxxxxx@xxxx.ne.jp"
.FlagRequest = "凄い！"
.Importance = 2 ' = olImportanceHigh
Rem 0 = olImportanceLow / 1 = olImportanceNormal
Rem メッセージ形式...
Rem テキスト形式の場合、書式設定（文字色・蛍光ペン書式など）は無効になる。
.BodyFormat = 1 ' = olFormatPlain / 2 = olFormatHTML
.Attachments.Add myAtt
.VotingOptions "はい！;いいえ！"
'
myBody = Cells(i, a).Text & " 御中" & vbCrLf
myBody = myBody & "添付ファイルを送付します。" & vbCrLf
.body = myBody
.Display
End With
Rem *----*----* *----*----* *----*----* *----*----*
'
On Error Resume Next
Set myWord = GetObject(, "Word.Application")
If Err.Number <> 0 Then
Rem [電子メールの編集にMicrosoft Wordを使用する]でない場合
Rem MsgBox表示のため、開いているシートをアクティブ状態にする。（苦肉の策）
AppActivate Application.Caption
myText = "[電子メールの編集にMicrosoft Wordを使用する]を指定して下さい。"
MsgBox myText, vbMsgBoxSetForeground, "MyXlMailAutoAtt"
myOutlook.ActiveInspector.Activate
Exit Sub
End If
On Error GoTo 0
'
myWord.WindowState = 2 ' wdWindowStateMinimize ' 最小表示
'
If Val(myOutlook.Version) >= 12 Then
myMail.Send
Else
On Error Resume Next
myWord.CommandBars("Zzz").Delete
On Error GoTo 0
'
Set myCmmdBar = myWord.CommandBars.Add(Name:="Zzz", Position:=msoBarPopup, Temporary:=True)
With myCmmdBar.Controls
Set myCtrl = .Add(Type:=msoControlButton, ID:=3708)
With myCtrl
.Visible = True
.Caption = "送信"
.DescriptionText = "電子メールの送信コマンドを実行します。"
' .Execute
End With
End With
'
On Error Resume Next
myWord.CommandBars("Zzz").Delete
On Error GoTo 0
End If
'
Set myMail = Nothing
Set myWord = Nothing
Set myCmmdBar = Nothing
'
Cells(i, c).Value = "済 " & Now()
'
Rem 一括送信数制限：3件ずつ送信する。
j = j + 1
If j >= 3 Then Exit For
End If
End If
DoEvents
Next ' i
Rem *----*----* *----*----* *----*----* *----*----*
'
Set myDialog = Nothing
Set myRegExp = Nothing
Set myMatches = Nothing
Set myOutlook = Nothing
Set myMail = Nothing
Set myWord = Nothing
Set myCmmdBar = Nothing
Set myCtrl = Nothing
'
myText = "処理が終了しました。"
Application.StatusBar = "MyXlMailAutoAtt" & "：" & myText
Application.Speech.Speak myText, False
End Sub ' MyXlMailAutoAtt *----*----* *----*----* *----*----* *----*----*
Sub MyXlMailAutoAttFiles(myFolder As String, myFiles As String)
Dim myShell As Variant ' Shell32.Shell
Dim myBrowseFolder As Variant ' Shell32.Folder
'
Dim myFso As Variant ' Scripting.FileSystemObject
Dim myScriptingFiles As Variant ' Scripting.Files
Dim myScriptingFile As Variant ' Scripting.File
Rem *----*----* *----*----* *----*----* *----*----*
'
Set myShell = CreateObject("Shell.Application")
Rem [フォルダの参照]ダイアログボックス表示
Set myBrowseFolder = myShell.BrowseForFolder(0, "添付ファイルの保存先フォルダを指定してください", 1 + 16, ActiveWorkbook.Path)
If myBrowseFolder Is Nothing Then
Exit Sub
Else
myFolder = myBrowseFolder.Items.Item.Path
End If
'
Set myFso = CreateObject("Scripting.FileSystemObject")
Rem ファイルを名を取り込む
Set myScriptingFiles = myFso.GetFolder(myFolder).Files
myFiles = vbCrLf
For Each myScriptingFile In myScriptingFiles
If Right(myScriptingFile, 4) = ".jpg" Then
myFiles = myFiles & myScriptingFile.Name & vbCrLf
End If
Next ' myScriptingFile
Rem *----*----* *----*----* *----*----* *----*----*
'
Set myShell = Nothing
Set myBrowseFolder = Nothing
Set myFso = Nothing
Set myScriptingFiles = Nothing
Set myScriptingFile = Nothing
End Sub ' MyXlMailAutoAttFiles *----*----* *----*----* *----*----* *----*----*
