VBAによる週報の自動化

10144 ワード
VBA Outlook VBA テキストリンク

初投稿

初めて記事を書きます。
制御系のソフトウェアエンジニアをしています。
普段はVisual C#でプログラミングをしていますが、仕事以外でもOutputを出したいと思い投稿してみました。

週報集計の自動化

私の職場では毎週、Team Memberから上司へMail(Outlook 2016)で週報を提出していましたが、上司が確認しておらず形骸化していました。意味が無いなと感じたのでどうすれば活用されるのか考えました。

上司が確認できない理由は
* Memberが10名強と多く、各人のMailを確認する時間がない。
* 週報のFormatがpptで、Mailに添付しているためFileを開くのが面倒。
というものでした。
そこでMemberから送付される週報Mailを1つのまとめMailにすれば見やすくなるのではと考えました。

週報

職場での週報は以下のようなものでした。
* Outlook Mail
* ppt のFormatをMailに添付

改善方法

Excel VBAを使用してOutlookを操作し、各人のMailを1つのMailとして再送信できないか検討しました。
そこで
- ppt Formatを止めてMail本文に週報内容を記載
- 各人の週報Mailをまとめて一つのMailとして上司に送信
というものを思いつきました。
Memberからの週報Mailを以下のようなFormatにしました。

マクロ

実装するうえで以下のWebPageを参考にさせて頂きました。
VBAでメールを自動送信！エクセルマクロでoutlook操作する方法｜事例&コード付

下図のようなInterfaceをSheetに作成しました。

Buttonを押すとOutlookの週報フォルダからMail内容を読み、1つのExcel Fileとしてまとめ、そのFileを添付した
Mailを送信します。

'まとめMailの送信
Sub SendWeeklyReportMatome()
    On Error GoTo Err:
    Dim olAPP As Object
    Dim ns As Object
    Dim mf As Object
    Dim mailCount As Integer
    Dim accessCount As Integer
    Dim maxAccessCount As Integer
    Dim startString_Main As String
    Dim endString_Main As String
    Dim oneMail As Object
    Dim mailItems As Object
    Dim subject As String
    Dim from As String
    Dim body As String
    Dim targetBody_Main As String
    Dim startPoint_Main As Integer
    Dim endPoint_Main As Integer
    Dim targetBody_Note As String
    Dim startPoint_Note As Integer
    Dim endPoint_Note As Integer
    Dim nYLINE  As Integer
    Dim workNew As Workbook

    Dim sheet As Worksheet
    Dim filePath As String
    Dim t As Integer
    Dim delimiter As String
    Dim tempnames As String

    '表示更新しない
    With Application
        .ScreenUpdating = False
        .EnableEvents 　= False
        .DisplayAlerts  = False
    End With

    Set workNew = Workbooks.Add   '新規book作成
    Set olAPP = CreateObject("Outlook.Application")
    Set ns = olAPP.GetNamespace("MAPI") ' Namespaceオブジェクト
    Set sheet = Workbooks(1).Sheets(1)

    '週報フォルダの設定
    Set mf = ns.GetDefaultFolder(6).Folders("週報")

    '文字列抽出
    delimiter = "◆"　'"◆"を本文の区切り文字とする
    startString_Main = delimiter & "週報"
    endString_Main = delimiter

    '読み込みMailの最大数
    maxAccessCount = 30
    'Matome Fileの見出し作成
    nYLINE = 1
    With workNew.Sheets(1)
        .Cells(nYLINE, 1) = "番号"
        .Cells(nYLINE, 2) = "差出人"
        .Cells(nYLINE, 3) = "週報"
        .Cells(nYLINE, 4) = "連絡"
    End With

    nYLINE = nYLINE + 1

    accessCount = 0 '読み込みMail数最大値
    mailCount = 0 
    For Each oneMail In mf.Items
        accessCount = accessCount + 1
        '読み込んだMail数が最大値を超えたら終了
        If accessCount > maxAccessCount Then
            GoTo outLoop
        End If
        '返信MailはSkip
        subject = oneMail.subject
        If InStr(subject, "RE:") = 1 Then
            GoTo NextLoop
        End If
        body = oneMail.body
        from = oneMail.SenderName
        targetBody_Main = ""
　　　　 targetBody_Note = ""

        '抜き出し開始箇所のIndex取得
        startPoint_Main = InStr(body, startString_Main)
        startPoint_Note = InStr(body, startString_Note)

        '週報の開始位置が無い場合はSkip
        If startPoint_Main = 0 Then
            GoTo NextLoop
        End If
        startPoint_Main = startPoint_Main + Len(startString_Main)
        startPoint_Note = startPoint_Note + Len(startString_Note)
        '抜き出し最終Index
        endPoint_Main = InStr(startPoint_Main, body, endString_Main, 1)
        endPoint_Note = InStr(startPoint_Note, body, endString_Note, 1)
        '週報部分の文字列取得
        targetBody_Main = Mid(body, startPoint_Main, endPoint_Main - startPoint_Main)
        targetBody_Note = Mid(body, startPoint_Note, endPoint_Note - startPoint_Note)

        t = InStr(subject, "_") '"_"以降に差出人名を書く
        '同名の人はskip
        If InStr(tempnames, Mid(subject, t + 1)) Then
            GoTo NextLoop
        End If

        With workNew.Sheets(1)
            .Cells(nYLINE, 1) = mailCount + 1
            .Cells(nYLINE, 2) = Mid(subject, t + 1)
            .Cells(nYLINE, 3).Value = NTRIM(targetBody_Main)
            .Cells(nYLINE, 4).Value = targetBody_Note
        End With

        tempnames = tempnames & (Mid(subject, t + 1))
        mailCount = mailCount + 1
        nYLINE = nYLINE + 1
NextLoop:
        Next oneMail
outLoop:

    With workNew.Sheets(1)
        .Rows("1:" & .Range("A" & .Rows.Count).End(xlUp).Row).EntireRow.AutoFit
        .Range(.Cells(1, 1), .Cells(1, .Cells(2, .Columns.Count).End(xlToLeft).Column)).AutoFilter
    End With

    '作成Fileの保存
    Dim saveDir As String
    Dim leng As Integer
    saveDir = sheet.Range("B10").Value　'保存先Directory
    leng = Len(saveDir)
    If (Mid(saveDir, leng, 1) = "\") Then
        saveDir = Left(saveDir, leng - 1)
    End If

    If Dir(saveDir, vbDirectory) = "" Then
        MkDir (saveDir)
    End If
    Dim savePath As String
    savePath = saveDir + "\" + "matome_" + Format(Date, "yyyymmdd") + ".xlsx"
    workNew.SaveAs (savePath)
    workNew.Close

   '表示更新する
    With Application
        .ScreenUpdating = True
        .EnableEvents   = True
        .DisplayAlerts  = True
    End With

    'Mail送信
    Dim mails() As Variant
    ReDim mails(0)
    With sheet
        mails(0) = Array(savePath, .Range("B5").Value, .Range("B6").Value, .Range("B7").Value, .Range("B8").Value, .Range("B9").Value, true)
    End With
    Call SendMail(mails) 'Mail送信
    ' 作成File削除
    Dim fso As FileSystemObject
    Set fso = New FileSystemObject
    Call fso.DeleteFile(savePath, False)
    Set fso = Nothing

    olAPP.Quit 
    Exit Sub
Err:
    olAPP.Quit
End Sub

Mail要素の配列を引数とするMail送信プロシージャ。

Sub SendMail(mails() As Variant)
    'outlook起動
    Dim toaddress, ccaddress, bccaddress As String
    Dim subject, mailBody As String
    Dim outlookObj As Outlook.Application           
    Dim mailItemObj As Outlook.mailItem             

    Dim work As Workbook
    Dim sheet As Worksheet
    Dim i As Integer
    Set work = Workbooks(1) 'マクロbookだけ開いている前提
    Set sheet = work.Sheets(1)
    Set outlookObj = CreateObject("Outlook.Application")

    For i = 0 To UBound(mails, 1)
      Set mailItemObj = outlookObj.CreateItem(olMailItem)
      '変数のset
        With sheet
            toaddress  = mails(i)(1) '宛先  
            ccaddress  = mails(i)(2) 'CC
            bccaddress = mails(i)(3) 'BCC
            subject    = mails(i)(4) '件名
            mailBody   = mails(i)(5) '本文
        End With
        mailItemObj.BodyFormat = 3
        mailItemObj.To = toaddress   
        mailItemObj.cc = ccaddress   
        mailItemObj.bcc = bccaddress 
        mailItemObj.subject = subject
        mailItemObj.body = mailBody

        '添付ファイル
        Dim attached As String
        Dim myattachments As Outlook.Attachments 
        Set myattachments = mailItemObj.Attachments

        Dim attachPath As String
        Dim isDisplay As Boolean
        attachPath = mails(i)(0) '添付FilePath
        isDisplay  = mails(i)(6) '送信前に表示するFlag
        If Not (IsEmpty(attachPath) Or IsError(attachPath) Or attachPath = "") Then
            attached = attachPath
            If (Dir(attached) <> "") Then
                myattachments.Add attached
            End If
        End If

        If (isDisplay) Then
            mailItemObj.Display  
        Else
            mailItemObj.Send
        End If

        Set mailItemObj = Nothing
    Next i
    Set outlookObj = Nothing 'Outlook終了
End Sub

以上のようなマクロを実行するとまとめMailが作成できました。

添付Excel中身もMail本文が書かれています。

自動化

社内PCを宛先として設定してもらい、Windowsのタスクスケジューラを使用してExcelマクロを自動実行する仕組みにしました。ボタン操作ではなく、マクロのThisWorkbookにOpen Eventで上の処理が実行されるようにします。

Private Sub Workbook_Open()
 Call SendWeeklyReportMatome
End Sub

タスクスケジューラに日時指定でexecute.batを実行するタスクを作成し、
Excel VBAをbat → VB script → マクロの順で実行します。

execute.bat
cscript (path)\execute.vbs
execute.vbs
'Excel起動
Set oxlsApp = CreateObject("Excel.Application")
oxlsApp.Application.Visible = false
oxlsApp.Application.Workbooks.Open("マクロFilePath")
oxlsApp.Quit

スケジューラから自動実行されるようになりました。

終わりに

この改善によって週報は多少活用してもらえるようになりました。
作成したものが使われたので嬉しかったです。

普段ブログもほとんど書かないので、書くのに半日程度要してしまいました。
またコードもほとんど公開したことが無いので稚拙かもしれません。
でもいい勉強になりました。今後も何か書きたいと思います。