[[20200519224724]]　『アウトルック？』（エクセル博士）　ページの最後に飛ぶ

『アウトルック？』（エクセル博士）

以下はどのように使えますか？

Enum col '1以降の数値を省略した場合は+1される

    宛先 = 1
    複写
    氏名
    期日
    金額
    添付キーワード
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, 1).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

            'メール本文作成
            Dim mailBody As String
            mailBody = CreateMailBody(r)

            'メールアイテム作成
            With mailItemObj
                .To = Cells(r, col.宛先).Value
                .CC = Cells(r, col.複写).Value
                .Subject = Cells(1, "J").Value '件名
                .Body = mailBody '本文
            End With

            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
    DayOfUse = Cells(r, col.期日).Value
    price = Cells(r, col.金額).Value

    Dim sign As String '署名
    sign = Cells(12, "J").Value

    Dim mBody As String 'メール本文
    mBody = Cells(2, "J").Value '初期値を設定
    mBody = Replace(mBody, "（氏名）", sName)
    mBody = Replace(mBody, "（期日）", DayOfUse)
    mBody = Replace(mBody, "（金額）", price)
    mBody = mBody & vbCrLf & vbCrLf & sign '末尾に署名を付与

    CreateMailBody = mBody

End Function

' 処理?@ キーワードに合致するファイルを添付する
' 処理?A 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

＜使用 Excel：Office365、使用 OS：unknown ＞

＞以下はどのように使えますか？
質問の意味がわかりませんが、エクセルからoutlookを操作して、メールを作成するのに使えますね。

（もこな２） 2020/05/19(火) 23:02

コメント返信：

[ 一覧(最新更新順) ]

[[20200519224724]] 『アウトルック？』（エクセル博士） ページの最後に飛ぶ

[[20200519224724]]　『アウトルック？』（エクセル博士）　ページの最後に飛ぶ