スナックelve 本店

バツイチ派遣40代女性の日記です

あばうとー  読者になる  follow us in feedly

Outlookで選択したメールの添付ファイル(エクセル)を印刷するマクロ(アラートなし)

えーっと、マクロを書く場所(?)は
www.lisz-works.com
こちらが詳しいのでご参照ください。

えーっと、選択したメールの添付ファイル(エクセル、ワード、PDF)を印刷するマクロってのは
Print Attachments Automatically - VBOfficeの下のほうにある。
このままだとATTACHMENT_DIRECTORYが空なのでCドライブに「Attachments」ってフォルダ作って置く(私はこのディレクトリがないと印刷できなかったが、なくても印刷できるっていう人もいた。試してくれ)

当方Outlook2010なり。

んで、コピったコードのままじゃ動かんかったので下記のように修正
意味わかってないので突っ込み歓迎(;´Д`)

Private Sub PrintAttachments(oMail As Outlook.MailItem)
  On Error Resume Next
  Dim colAtts As Outlook.Attachments
  Dim oAtt As Outlook.Attachment
  Dim sFile As String
  Dim sDirectory As String
  Dim sFileType As String
  
  'D:\->C:\
  sDirectory = "C:¥Attachments¥"

  Set colAtts = oMail.Attachments

  If colAtts.Count Then
    For Each oAtt In colAtts

      sFileType = LCase$(Right$(oAtt.FileName, 4))

      Select Case sFileType
      Case ".xls", ".doc", ".pdf"
        'ATTACHMENT_DIRECTORY-> sDirectory
        sFile = sDirectory & oAtt.FileName
        oAtt.SaveAsFile sFile
        ShellExecute 0, "print", sFile, vbNullString, vbNullString, 0
      End Select
    Next
  End If
End Sub

んで、このままだと

  • 新しい拡張子に対応してない(xlsxとかxlsm)
  • リンクとか含むエクセルだといちいちアラートが出る(保存しますか?ってやつ)

そこで、印刷するのはエクセルだけに特化することにする。

Private Sub PrintAttachments(oMail As Outlook.MailItem)
  On Error Resume Next
  Dim colAtts As Outlook.Attachments
  Dim oAtt As Outlook.Attachment
  Dim sFile As String
  Dim sDirectory As String
  Dim sFileType As String
  
  'D:\->C:\
  sDirectory = "C:\Attachments\"

  Set colAtts = oMail.Attachments

  If colAtts.Count Then
    For Each oAtt In colAtts

      sFileType = LCase$(Right$(oAtt.FileName, 4))

      Select Case sFileType
      Case ".xls", "xlsx", "xlsm"
        'ATTACHMENT_DIRECTORY->sDirectory
        sFile = sDirectory & oAtt.FileName
        oAtt.SaveAsFile sFile
        'ShellExecute 0, "print", sFile, vbNullString, vbNullString, 0
        
        'Excelでファイルを開いて印刷して保存しないで閉じる
        Set ExAp = CreateObject("Excel.Application")
        ExAp.displayalert = False
        Set book = ExAp.Workbooks.Open(sFile)
        book.activesheet.PrintOut
        book.Close (False)
        book = Nothing
        ExAp.Quit
        ExAp = Nothing
      End Select
    Next
  End If
End Sub

こんな感じで動いた(と思う)