VBAでOutlookのメールを作成する際に署名を表示させる方法

スポンサーリンク

Outlookの署名をVBAで自動追加する方法が案外難しい

以前OutlookでメールをExcelVBAで大量に作成するコードをこちらの記事でご紹介しました。

これは私が現在業務で最も使用しているコードの1つですが、使用した際に署名が反映されないという課題がありました。

この部分は手で付け足したり、もしくは本文に署名も付け加えていたりしたのですが、手で付け加えるのはそもそも面倒、本文に署名を付け加える場合、HTMLの仕様の問題だと思いますが、スペースの幅・数がずれることがありました。

そこで現在使用している署名を本文の下に追加した状態でメールを作成できるコードに改良してみました。

署名の内容の呼び出しと取り込み方法について

署名はC:\ユーザー\[ユーザー名]\AppData\Roaming\Microsoft\Signaturesというフォルダにテキスト形式で保存されています。
(AppDataが表示されない場合、隠しファイルを表示にチェックをして探してみてください。)

このファイルを読み込んで、内容を本文の下に追加するフローで署名を追加するコードを考えました。

スポンサーリンク

署名を追加した状態でOutlookメールを作成するExcelVBA

今回署名つきのコードを作成するにあたり、こちらのページを参考にさせていただきました。

もしかしたら外国の方が作成されているのかもしれません。
少し日本語が変な気がするのでちょっと心配していましたが、きちんとした情報を提供してくださっていました。
(疑ってスミマセン…)

メールを作成する部分のコードは以前ご紹介したOutlookの差し込みメールを作成するExcelVBAを用いています。

Sub Outlook起動して署名つきメール作成する()

Dim oApp As New Outlook.Application
Dim oItem As Outlook.MailItem

Dim WSH As Object
Set WSH = CreateObject(“Wscript.Shell”)

Dim DesktopPath As String
DesktopPath = WSH.SpecialFolders(“Desktop”)

Dim 本文 As String, 件名 As String
Dim 宛先列番号 As Long
Dim i, k, x

i = 7

Do Until Cells(i, 2) = “”
If Cells(i, 21) = “” Then
件名 = Cells(2, 2).Text
本文 = Cells(3, 2).Text
k = 5
Do Until Cells(6, k) = “”
件名 = Replace(件名, “<" & Cells(6, k) & ">“, Cells(i, k))
本文 = Replace(本文, “<" & Cells(6, k) & ">“, Cells(i, k))
k = k + 1
Loop

本文 = 本文 & vbLf & vbLf & 署名(“署名1.txt”)
本文 = Replace(本文, vbLf, “<br />”)

Set oItem = oApp.CreateItem(olMailItem)
’oItem.SendUsingAccount = Session.Accounts(“指定する場合アカウント名を設定”)

oItem.To = Replace(Cells(i, 2), vbLf, “;”)
oItem.Subject = 件名
oItem.HTMLBody = “” & 本文 & “”

oItem.CC = Replace(Cells(i, 3), vbLf, “;”)
oItem.BCC = Replace(Cells(i, 4), vbLf, “;”)
’oItem.Importance = olImportanceHigh

Dim 添付()
x = 0
ReDim Preserve 添付(x)
添付(x) = Cells(i, 20).Text

If 添付(x) <> “” Then
Select Case InStr(添付(x), vbLf)
Case Is = 0
oItem.Attachments.Add DesktopPath & “\” & 添付(x)
Case Else
Do Until InStr(添付(x), vbLf) = 0
x = x + 1
ReDim Preserve 添付(x)
添付(x) = Mid(添付(x - 1), InStr(添付(x - 1), vbLf) + 1)
添付(x - 1) = Left(添付(x - 1), InStr(添付(x - 1), vbLf) - 1)

If 添付(x - 1) <> “” Then
oItem.Attachments.Add DesktopPath & “\” & 添付(x - 1)
End If
Loop

If 添付(x) <> “” Then
oItem.Attachments.Add DesktopPath & “\” & 添付(x)
End If
End Select

End If

oItem.Display ’送信せずに画面を表示する
’oItem.Save ’下書き保存
’oItem.Close 0 ’閉じる
’oItem.Send ’送る場合

End If

i = i + 1
Loop

End Sub

Function 署名(ByVal 署名ファイル As String) As String

Dim FSO As Object
Set FSO = CreateObject(“Scripting.FileSystemObject”)

Dim WSH As Object
Set WSH = CreateObject(“Wscript.Shell”)

Dim 署名フォルダ As String
署名フォルダ = WSH.SpecialFolders(“AppData”) & “\Microsoft\Signatures”

Dim ts As Object
Set ts = FSO.GetFile(署名フォルダ & “\” & 署名ファイル).OpenAsTextStream(1, -2)

署名 = ts.readall
ts.Close

Set WSH = Nothing
Set FSO = Nothing
Set ts = Nothing

End Function

テキストの内容を取得するためにはOpenAsTextStreamメソッドを使用しました。

引数の1つ目は「1」とすると読み取り専用で開きます。(2 = 書き込み用、8 = ファイルの末尾に書き込み用)
引数の1つ目は「-2」とするとシステムの規定の設定でファイルを開きます。(-1 = Unicode形式、0 = Ascii形式)

どちらも意識せずに、OpenAsTextStream(1 , -2)で入力して良い気がします。

上記のコードを実行するとメールが作成され、署名が追加されていることを確認できました。
下記に動作をキャプチャした動画を記載します。

コメント