添付ファイル付きで署名入れてメールする

前回エクセル表をPDFにしました。

このPDFは、客先に送付しなきゃいけないものなんです。

これがまた面倒・・・

もう本文は定形だし、宛先も固定なんでいっそVBAでやっちまおうと。

Outlookの挙動は

jus7733.hatenablog.com

 ほぼ同じです。

ただ、署名を入れるのに若干苦労しました。

署名を

SendKeys "%N"
SendKeys "^AS"
SendKeys "{ENTER}"
で入れようとしたら、本文よりも上に署名されたのでかなり困りました。

それで検索したところ、

VBAでOutlookの署名を本文に挿入 - ClockAhead 開発Blog

こちらからご教授頂きましたぁ

で、出来たのが以下。

'//
Private Declare Function SetForegroundWindow Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long

 '署名のテキスト全文の読み出し

Public Function ReadAllText(fileName As String)
Dim fso As Object, buf As String
Set fso = CreateObject("Scripting.FileSystemObject")
With fso.GetFile(fileName).OpenAsTextStream(1, -2)
buf = .ReadAll
.Close
End With
Set fso = Nothing

ReadAllText = buf
End Function

Private Sub CommandButton1_Click()
Dim oApp As Object
Dim myNameSpace As Object
Dim myFolder As Object
Dim objWShell As Object
Dim flg As Boolean
Dim hwnd As Long

Const FCLASSNAME As String = "rctrl_renwnd32"

On Error Resume Next
Set oApp = GetObject(, "Outlook.Application")
If Err.Number <> 0 Then
Set oApp = CreateObject("Outlook.Application")
flg = True
End If

On Error GoTo 0

If flg Then
Set myNameSpace = oApp.GetNamespace("MAPI")
Set myFolder = myNameSpace.GetDefaultFolder(6)
myFolder.Display
oApp.ActiveWindow.WindowState = 2

Else
Set objWShell = CreateObject("WScript.Shell")
objWShell.AppActivate oApp.ActiveWindow.Caption
hwnd = FindWindow(FCLASSNAME, vbNullString)
SetForegroundWindow hwnd

End If

'ここからメールの作成
Dim myItem
Dim Ffldr As String
Dim Fname As String
Dim sin As String

Ffldr = "C:\Users\ユーザ名\Documents\検査成績書\PDF\"
Fname = Ffldr & Range("A11") & Format(Range("B6"), "【yymmdd】") '添付ファイルの用意

sin = ReadAllText("C:\Users\ユーザ名\AppData\Roaming\Microsoft\Signatures\署名.txt")　'署名の用意

Set myItem = oApp.CreateItem(0)

myItem.Display

myItem.Subject = "検査表を送付いたします"
myItem.To = "atesakiA@ex.com ;atesakiB@ex.com" '宛先は;で区切り
myItem.Body = "株式会社○○　御中" & vbCrLf & "" & vbCrLf & "お世話になっております｡" & vbCrLf & "検査表を送付いたします｡" & vbCrLf & vbCrLf & sin

myItem.Attachments.Add Fname & ".pdf"　'PDFを添付します

'追加動作
'myItem.Save '.Saveで保存下書きへ
'myItem.Send '.Sendで送信

End Sub

 エラー処理は全部やってないです。

しくじっても.SendはOFFしてるんで怪我しませんし(^_^;)

よくわからないこともあるけど動くからいいか！

SLAMMING HIS SEXY SEND-OFF (Taboo Forbidden Romance) (English Edition)