첫 포스트

처음으로 기사를 씁니다.
제어계의 소프트웨어 엔지니어를 하고 있습니다.
평상시는 Visual C#로 프로그래밍을 하고 있습니다만, 일 이외에서도 Output을 내고 싶다고 투고해 보았습니다.

주보 집계 자동화

내 직장에서는 매주 Team Member에서 상사에게 Mail(Outlook 2016)에서 주보를 제출하고 있었지만, 상사가 확인하지 않고 형편화하고 있었습니다. 의미가 없다고 느꼈기 때문에 어떻게 하면 활용되는지 생각했습니다.

상사가 확인할 수 없는 이유는
* Member가 10명 강으로 많고, 각 사람의 Mail를 확인할 시간이 없다.
* 주보의 Format가 ppt로 Mail에 첨부하고 있기 때문에 File을 여는 것이 귀찮습니다.
라는 것이었습니다.
거기서 Member로부터 송부되는 주보 Mail을 1개의 정리 Mail로 하면 보기 쉬워진다고 생각했습니다.

주보

직장에서의 주보는 다음과 같습니다.
* Outlook Mail
* ppt 형식을 메일에 첨부

개선 방법

Excel VBA를 사용하여 Outlook을 조작하고 각 사람의 메일을 하나의 메일로 다시 제출할 수 없는지 고려했습니다.
거기서
- ppt Format을 멈추고 Mail 본문에 주보 내용을 기재
- 각 사람의 주보 메일을 모아서 하나의 메일로 상사에게 보내기
라는 것을 생각해 냈습니다.
Member로부터의 주보 Mail를 이하와 같은 Format으로 했습니다.

매크로

구현하기 위해 아래의 WebPage를 참고로 했습니다.
VBA로 이메일을 자동 전송! 엑셀 매크로로 outlook 조작하는 방법 | 사례 & 코드 첨부

아래 그림과 같은 Interface를 Sheet에 작성했습니다.

Button을 누르면 Outlook의 주보 폴더에서 Mail 내용을 읽고, 하나의 Excel File로 정리하고, 그 File을 첨부했다
메일을 보냅니다.

'まとめ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

위와 같은 매크로를 실행하면 정리 메일을 만들 수있었습니다.


첨부 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

스케줄러에서 자동 실행됩니다.

끝에

이 개선에 의해 주보는 다소 활용해 주게 되었습니다.
만든 것이 사용되었기 때문에 기뻤습니다.

평상시 블로그도 거의 쓰지 않기 때문에, 쓰는데 반나절 정도 요해 버렸습니다.
또 코드도 거의 공개한 적이 없기 때문에 치수일지도 모릅니다.
하지만 좋은 공부가 되었습니다. 앞으로도 뭔가 쓰고 싶습니다.