VBAでOutlook操作

Question

前提

マクロを使って一斉送信できるようにしたいです。
以前、他のサイトの構文を参照しておりましたが残念ながらWindows10では非対応との
ことで下記のサイトを今回参照しております。

https://moripro.net/vba-outlook-attach/

実現したいこと

1.Excelに情報を入力
2.マクロを実行する
3.Excelの情報を基にメールを作成

###サイトからの変更事項

1）A列が"1"なら送信メールを作成する
2）B列に"添付"があれば、同ファイルの添付（シート名）をデスクトップに保存する
3）B列が"添付"のものは、2）で作成したファイルを添付する

**※**サイトではキーワードが一致した場合だけフォルダよりファイルを探して
メールに添付しております。

発生している問題・エラーメッセージ

a）コンパイルエラー：名前が適切でありません（col）
となります。

b）3）の変更で

問題点①：B列に"添付"がひとつでもあったらという構文（IF？）の作り方、挿入場所が分かりません

問題点②：ユーザー名やWindowsのバージョンにかかわらずデスクトップにあるファイルのパスをどのように書いてよいのか分かりません

問題点③：送信メールへの添付の構文の書き方が分かりません

ファイル様式

該当のソースコード

サイトより一部修正しております。

Enum col '1以降の数値を省略した場合は+1される
    送信 = 1
    添付
    宛名
    アドレス1
    アドレス2
　　担当者
    摘要
End Enum
 
Sub main()
 
    'Outlookオブジェクトの作成
    Dim OutlookObj As Outlook.Application
    Set OutlookObj = New Outlook.Application
    
    Dim r As Long
    For r = 2 To Cells(1, 4).End(xlDown).Row
    
        'メールアイテムオブジェクト作成
        Dim mailItemObj As Outlook.MailItem
        Set mailItemObj = OutlookObj.CreateItem(olMailItem)
        
        '添付ファイルオブジェクトの生成
        Dim attachObj As Outlook.Attachments
        Set attachObj = mailItemObj.Attachments
        
        Dim keyword As String
        keyword = Cells(r, col.添付キーワード)
        
        '★添付ファイルが存在する場合のみ、メールアイテムを作成する
        If FileAttach(attachObj, keyword) = True Then
　　　　
　　　　If Cells(r, 1).Value = 1 Then
     　　If Cells(r, 2).Value = "添付" Then
        
            'メール本文作成
            Dim mailBody As String
            mailBody = CreateMailBody(r)
            
            'メールアイテム作成
            With mailItemObj
                .To = Cells(r, col.アドレス1).Value
                .CC = Cells(r, col.アドレス2).Value
                .Subject = Cells(1, "K").Value '件名
                .Body = mailBody '本文
            End With
　　　　　End　If
　　　　End　If
            
            mailItemObj.Display '下書きを表示
            
            '次のメールアイテムを作成するためいったん破棄
            Set mailItemObj = Nothing
            
        End If
            
    Next r
 
End Sub
 
' 【機能】Excelシート上の指定行番号のメール本文を作成する
Function CreateMailBody(r As Long) As String
 
    Dim sName As String, DayOfUse As String, price As Long
    sName = Cells(r, col.氏名).Value
    Personnel = Cells(r, col.担当者).Value
    Summary = Cells(r, col.摘要).Value
    
    Dim sign As String '署名
    sign = Cells(12, "K").Value
    
    Dim mBody As String 'メール本文
    mBody = Cells(2, "J").Value '初期値を設定
    mBody = Replace(mBody, "（氏名）", sName)
    mBody = Replace(mBody, "（担当者）", Personnel)
    mBody = Replace(mBody, "（適用）", Summary)
    mBody = mBody & vbCrLf & vbCrLf & sign '末尾に署名を付与
    
    CreateMailBody = mBody
 
End Function
 
' 処理① キーワードに合致するファイルを添付する
' 処理② 1つ以上のファイルが見つかった場合、Trueを返す
Function FileAttach(attachObj As Object, keyword As String) As Boolean
    
    Dim fileCnt As Long '★添付したファイル数をカウントする
    
    Dim FileStorePath As String 'ファイル格納パス
    FileStorePath = "C:\Outlookテスト\file"
 
    Dim FileName As String
    FileName = Dir(FileStorePath & "\" & "*")
    
    'フォルダ内のファイル数、検索を繰り返す&"
    Do While FileName <> ""
        
        'キーワードを含むファイルが見つかったら、下書きアイテムに添付する
        If InStr(FileName, keyword) > 0 Then
            attachObj.Add FileStorePath & "\" & FileName
            fileCnt = fileCnt + 1 '★添付したファイル数
        End If
        
        FileName = Dir()
    
    Loop
    
    Set attachObj = Nothing
    
    '★1以上のファイルを添付した場合Trueを返す
    '（Boolean型の初期値はFalse）
    If fileCnt > 0 Then FileAttach = True
 
End Function

試したこと

1）A列が"1"なら送信メールを作成する

If Cells(r, 1).Value = 1 Then
End　If　を使用

2）デスクトップにファイルを作成できましたが開いたままとなってしまいました

 Sheets("添付").Copy 
 
   ActiveWorkbook.SaveAs _
   FileName:=Ps & "\" & "添付", _
   FileFormat:=xlOpenXMLWorkbook

補足情報（FW/ツールのバージョンなど）

ここにより詳細な情報を記載してください。

Answer 1

今夜もこんばんは。よろしくおねがいいたします。

mailBody = CreateMailBody(r)を入れるとしたらどのあたりに入れるのがよいのでしょうか。

コードをちょっと書き直しましたので、見てみてください。

Option Explicit


Sub SendMailWithAttachment()
'Microsoft Outlook 16.0 libraryを 参照設定しています

  'Outlookオブジェクトの作成
  Dim OutlookObj As Outlook.Application
  Set OutlookObj = New Outlook.Application
  
  Dim olEmail As Outlook.MailItem
  Set olEmail = OutlookObj.CreateItem(olMailItem)
  
  Dim mailItemObj As Outlook.MailItem
  Dim attachObj As Outlook.Attachments
  Dim mailBody As String
  
  Dim FilePath As String
  FilePath = Environ("UserProfile") & "\desktop\"
  
  Dim r As Range
  For Each r In Range("A2", Range("A1").End(xlDown))
  
    'H列（送信）のフラグが"1"の対象のみメールを作成する
    If r.Offset(0, 7).Value = 1 Then
    
      'メールアイテムオブジェクト作成
      Set mailItemObj = OutlookObj.CreateItem(olMailItem)
      
      'メールアイテム作成
      With mailItemObj
        .To = r.Offset(0, 1).Value
        .CC = r.Offset(0, 2).Value
        .Subject = Range("K1").Value

　　　　　’ここでCreateMailBody(r)を呼んでいます
        .Body = CreateMailBody(r)

        .Attachments.Add Source:=FilePath & r.Offset(0, 6).Value
      End With
      mailItemObj.Save
      '次のメールアイテムを作成するためいったん破棄
      Set mailItemObj = Nothing
    End If
  
  Next r

End Sub


' 【機能】Excelシート上の指定行番号のメール本文を作成する
Function CreateMailBody(r As Range) As String

Dim sName As String
Dim Personnel As String
Dim Summary As String
Dim sign As String '署名
Dim mBody As String 'メール本文

sName = r.Offset(0, 3).Value
Personnel = r.Offset(0, 4).Value
Summary = r.Offset(0, 5).Value
sign = Range("K12").Value

mBody = Range("K2").Value '初期値を設定
mBody = Replace(mBody, "（氏名）", sName)
mBody = Replace(mBody, "（担当者）", Personnel)
mBody = Replace(mBody, "（摘要）", Summary)
mBody = mBody & vbCrLf & vbCrLf & sign '末尾に署名を付与

CreateMailBody = mBody

End Function

なお、これを制御するシートは、以下のようにしました。

”送信”フラグを立てる列は、H列にしました。

②添付ファイルを作成するという構文はどのあたりに入れたらよいのでしょうか？

これのおっしゃってる意味がわからないんですよ。
「添付ファイルを作成する」って...どういう意味？
ファイルを添付してメールを送信するマクロですよ？どぉして”ファイルを作成”するの？？

Comments

[ichigo15]

ありがとうございます。

ご提示頂いた様式と構文で試してみました。

-------
実行時エラー：2147024894（80070002）
ファイルが見つかりません。パスとファイル名が正しいかどうかを確認して下さい。

.Attachments.Add Source:=FilePath & r.Offset(0, 6).Value
---------
となりました。
↓こちらでデスクトップパスを取得したところC:\Users\●●●\Desktop

Sub Sample1()

Cells(9, 2).Value = Environ("UserProfile") & "\Desktop"

End Sub

ファイルパスはC:\Users\●●●\Desktop\添付.xlsx
Ｇ列には添付.xlsxと入力してます。
ファイルもパスも問題なく見えるのになぜなのでしょうか？？

それと②ですが、
ご提示のシートのＧ列に入力がある場合、同じブックのシート"添付"をデスクトップに保存
しようと思います。
そちらの構文をどのあたりに入れたらよいのでしょうか？

ご教示よろしくお願いいたします。

[AkiSaito]

１："\"マークを落としてないか、再度確認してみていただけますか？　"\Desktop"ではなく"\Desktop\"ではないかな？

２：＞Ｇ列に入力がある場合、同じブックのシート"添付"をデスクトップに保存しようと思います。
＞そちらの構文をどのあたりに入れたらよいのでしょうか？

あなたはこの部分、どんな構文をお考えになりましたか？

[ichigo15]

ありがとうございます。

1.私のデスクトップパスを取得します構文が"\"マークを落としておりましたので申し訳ございません
Cells(9, 2).Value = Environ("UserProfile") & "\Desktop￥"￥と修正し直しまして
取得しましたらC:\Users\●●●\Desktop\でした

構文にマウスをかざしますと、
.Attachments.Add Source:=FilePath & r.Offset(0, 6).Value
　　　　　　　　　　　　　　　↓　　　　↓
　　　C:\Users\●●●\Desktop\　　　　添付.xlsｘ

と表示されました。

2.構文考えておりましたがエラーが発生するようになってしまいました
しばらくお時間を頂けないでしょうか

お手数をおかけしますがよろしくお願いいたします。

[ichigo15]

おはようございます。

2.の構文です。
おかしい箇所がたくさんあるかもしれませんがご了承下さい。

Sub 添付()

Dim Ps As String
Dim Sh As Worksheet
Dim r As Range

For Each r In Range("A2", Range("A1").End(xlDown))

If r.Offset(0, 6).Value <> "" Then

Ps = CreateObject("wscript.shell").SpecialFolders("Desktop")

Set Sh = Worksheets("添付")

Sh.Copy

ActiveWorkbook.SaveAs _
Filename:=Ps & "\" & "?Y?t", _
FileFormat:=xlOpenXMLWorkbook

Exit For
End If
Next

End Sub

[AkiSaito]

この
"?Y?t"
って、何ですか？

[ichigo15]

文字化けしておりました申し訳ございません
"?Y?t"　⇒　"添付"

1.ですがデスクトップのファイルのパスと構文のパスは同じように見えますが
どうしてエラーになってしまうのでしょうか？

[ichigo15]

デスクトップファイルのパスをコピーしまして再度添付の箇所に貼り付けてみました。
すると今度は

.Attachments.Add Source:=FilePath & r.Offset(0, 6).Value
　　　　　　　　　　　　　　　　　　　　　　↑
　　　　　　　　　　　　　　　　　　　　　Empty値
となっておりました。

ご報告までに！

[AkiSaito]

まだ全部を見きれてないんですが、
とりあえず気になったのは、

Set Sh = Worksheets("添付")

ということは、
このマクロがあるブックに、"添付"というシートが最初からある、ということになるんですが……それで正しいですか？

その"添付"シートを、Sh.Copyでコピーしているようですが、そのコピーを　どこにも持っていってないようなんですが……それは何故ですか？

そして、
ActiveWorkbook.SaveAs _
Filename:=Ps & "\" & "?Y?t", _　
しているということは、
このマクロの入ったファイルをメールで送信することになりそうなんですが……それがあなたの意図するところですか？

[ichigo15]

コメントありがとうございます。

マクロがあるブックに"添付"というシートが存在します
このシートをデスクトップに保存して、保存したファイルをメールで送信します

なんですが、もう少しファイルの作成を考えさせて頂けないでしょうか。
不慣れなのでお時間を頂戴して申し訳ございません。

[ichigo15]

こんにちは　お世話になっております。

メールの件ですが
mailItemObj.Save　→　mailItemObj.Display
で作成（添付も）されるようになりました。

ただ、添付をしない場合エラーとなってしまいました
添付をしなくてもメールを作成できるようにしたいです
ご教授のほどよろしくお願いいたします。

[ichigo15]

色々とご教授ありがとうございます。
添付ファイルの作成は不細工ですが希望することができるようになりました。

丁寧に教えて頂き感謝いたします。

Answer 2

こんにちはこんばんは。よろしくおねがいいたします。
ちょうど先日、似たようなものを作っていましたので、よかったら参考になさってください。
まず、以下のような”メール送信設定シート”を考えました。

ここで、A列にTOの送信先、B列にCCの送信先、C列に添付ファイルのファイル名、D列に”添付するかしないか”のフラグ、E列に”送信するかしないか”のフラグ、とします。

とりあえず件名はB8セルに、本文はB10セル、ということにしました。

これで、"E列に1が立っている送信先は、メール送信する。そのうちD列に"添付”と立っているものは、C列にあるファイルを添付する、という制御になります。

そしてOutlookをコントロールするVBAは、以下のようなものです。

Option Explicit

Sub SendMailWithAttachment()
'Microsoft Outlook 16.0 libraryを 参照設定しています

'Outlookオブジェクトの作成
Dim OutlookObj As Outlook.Application
Set OutlookObj = New Outlook.Application

Dim olEmail As Outlook.MailItem
Set olEmail = OutlookObj.CreateItem(olMailItem)

Dim mailItemObj As Outlook.MailItem
Dim attachObj As Outlook.Attachments
Dim mailBody As String

Dim FilePath As String
FilePath = Environ("UserProfile") & "\desktop\"

Dim r As Range

For Each r In Range("A2", Range("A1").End(xlDown))

  'E列のフラグが"1"の対象のみメールを作成する
  If r.Offset(0, 4).Value = 1 Then
        
    'メールアイテムオブジェクト作成
    Set mailItemObj = OutlookObj.CreateItem(olMailItem)
                                
    'メールアイテム作成
    With mailItemObj
      .To = r.Value
      .CC = r.Offset(0, 1).Value
      .Subject = Range("B8").Value
      .Body = Range("B10").Value

      'D列のフラグが"添付"の対象のみ、所定のファイルを添付する
      If r.Offset(0, 3).Value = "添付" Then
        .Attachments.Add Source:=FilePath & r.Offset(0, 2).Value
      End If

    End With

    mailItemObj.Save

    '次のメールアイテムを作成するためいったん破棄
    Set mailItemObj = Nothing

  End If

Next r

End Sub

このVBAを使う各ユーザーのデスクトップのパスは

Environ("UserProfile") & "\desktop\"

でいいはずです。

これ、僕はmoripro.netさんのサイトを見ないでお話しているので、あなたの期待していることと違ってるかもしれませんが・・お許しを。
なので、まずはFunctionなどは取っ払って、シンプルなのを作って実験してみました。

このコードで私のほうのWindows 10 / Office365 (Excel2016, Outlook2016）で動作確認できました。

で、あなたの”試したこと”を拝見していて気付いたのは、
・if cells(r,2).value...の部分。判定に使うセルの位置が違うような気がします。
・for-nextのループの中で何回もDimしているのは、間違いでしょうね。

以上、ご参考になればなによりです。

Comments

[ichigo15]

ありがとうございます。
ぜひ参考にさせて頂きたいと思います。

それで少し教えて頂けないでしょうか。
基の様式をいかしていこうと思います。

①本文について
mailBody = CreateMailBody(r)を入れるとしたらどのあたりに入れるのがよいのでしょうか。
色々試してみましたがエラーが出てしまいます。

②添付ファイルを作成するという構文はどのあたりに入れたらよいのでしょうか？

マクロは不慣れなため申し訳ございません。
宜しくお願いいたします。

[AkiSaito]

こんばんは。ここにはソースコードが書けないので、別で回答を書きますね。

Answer 3

こんな感じですか？

Sub tes2()
Dim r As Long

'A列に１がありB列に添付のある行は
For r = 2 To Cells(1, "A").End(xlDown).Row
    If Cells(r, "A").Value = 1 Then
        If Cells(r, "B").Value = "添付" Then
            MsgBox r
        End If
    End If
Next r
End Sub

Comments

[dodox86]

複数回答は止めませんか。一般的には最初の回答に修正・追記のかたちでするものだと思います。

[sinzou]

次から、注意します。

Answer 4

気になったとこですが

 .Subject = Cells(1, "K").Value '件名   

がわかりやすければ統一したほうがよいですね。

　　　'1）A列が"1"なら送信メールを作成する
If Cells(r, 2).Value = 1 Then

2ですけど"A"ですかね

あと、
列挙型変数　Colつかわず上と同じく列記号を直接でよいと思います。

Answer 5

問題点①　　B列の"添付"がある行

Sub tes()
For r = 2 To Cells(1, 1).End(xlDown).Row
    If Cells(r, 2).Value = "添付" Then MsgBox r
Next r
End Sub

問題点②　　デスクトップのパス

Set WSH = CreateObject("WScript.Shell")
Path = WSH.SpecialFolders("Desktop") & "\"   '("MyDocuments") & "\"
MsgBox Path

問題点③
https://moripro.net/vba-outlook-attach/
に書かれています。アレンジ必要ですが。

ヒントになりますか？

Comments

[ichigo15]

説明が下手で申し訳ございません。

問題点①ですが、1）と一緒の構文は分かります。
2）を追加した場合の構文の書か方が分からないのです。
ようするに、
「A列が"1"の場合はメール作成します。
そのうちB列に"添付"があるものはメールを添付します。」
という、「そのうち」の書き方が分からないのです。