はじめまして###
Qiita初投稿です。
元は組み込み系ソフトウェア開発やってましたが、最近書くコードと言えば専らPythonやVBAです。今は装置メーカーのテクニカルサポートエンジニアなので、そんな感じです。
最近、PowerPointからSharePoint上のExcelを読み込んでスライドに表示し、その内容をメール送信する為のVBAマクロを書けと言われました。実際はもっとふゎっとしたリクエストでしたけど。
取り敢えず、自PCで作ったテスト環境では問題なかったのですが、いざ本番環境に近い環境で試してみたらSharePointに置いたメールテンプレートを直接読み込めない事が判明しました。メールの送信先とかの変更が簡単になるようにOutlookのメールテンプレート(*.oftファイル)はSharePointに置けたらよかったのですけど、OutlookのCreateItemFromTemplateメソッドがURLは受け付けてくれないようです。
OLEオブジェクトとしてPowerPointに埋め込んだら行けそうかな？と試して取り敢えず動いてそうなのでシェアしてみます。何方かの参考になれば幸いです。
PowerPointスライドのイメージ###
↓のようなスライドをPowerPointで作成して、VBAはPowerPointで実装しました。Outlookメールテンプレート(*.oft)は実際には見えない場所に貼り付けました。
VBAコード###
貼り付けてあるOLEオブジェクトをCreateItemFromTemplateで使うには、一旦ファイルとして保存しないといけないんですけど、少し調べるとOLEObject.CopyやOLEObject.Duplicateを実行すると一時ファイルが作られることが分かりました。こちらにあるコードでは毎回一時ファイルが作られるOLEObject.Duplicateを使用し、且つ5秒以内に作成されたものが対象の一時ファイルだろうと判断しているようです。今回の場合はファイルを元に作られたOLEオブジェクトで、一時ファイル名は元のファイル名と同じか、それに番号が振られたものになるようでした。なので下記コードではOLEObject.Copyを使い、ファイル名が指定パターンにマッチする最新の一時ファイルを選択するようになっています。基本的に一時ファイルはPowerPointアプリが終了すると削除されるようです(たまに消されないまま残ってますが)。また、OLEオブジェクトを更新すると作られる一時ファイルも更新されるようです。
下記はPowerPointスライドのExcelテーブルをコピーして、メールテンプレートの指定位置に挿入する部分のコードで、冒頭に書いたリクエストのSharePointのExcelからデータを読み込む部分は含まれていません。
定数とMainルーチン#####
各定数についてはコード内のコメントを参照ください ^^;
Mainルーチンでは、スライド内のExcelワークシートにあるOLEObjectに対しOLEObject.Copyを実行して一時ファイルが存在する状態に。GetLatestTempFileをコールして該当する一時ファイルの中で最新のものを見つけ、ComposeEmailに渡すという流れです。
' -*- coding: utf-8 -*-
Option Explicit
Const SlideToSend = 1 ' The 1st slide
Const ShapeName = "ExcelTable" ' Shape name for the Excel Spreadsheet inserted in the slide
Const MySheet = "SheetToSend" ' Excel Worksheet name to be sent
Const MyRange = "A2:E6" ' The range to be copied and inserted to the email
Const OLEObjectName = "EmailTemplateOft" ' Object name of the Outlook email template file inserted to the Excel worksheet
Const OftFilePattern = "EmailTemplate*.oft" ' Temporary file name pattern for the template file
'The original file name was "EmailTemplate.oft", but the temporary file name can be like "EmailTemplate (2).oft".
Const SubjDateRepStr = "__DATE__" ' String to be replaced with the actual date
Const SubjDateFormat = "YYYY-MM-DD" ' Date format to be used
Const OftInsertPos = 93 ' Insert position in the template as number of characters
Sub Main()
Dim theSlide As Object
Dim oftPath As String, oftObj As Object, excelRange As Object
Set theSlide = ActivePresentation.Slides(SlideToSend)
With theSlide.Shapes(ShapeName).OLEFormat.Object.Worksheets(MySheet)
Set oftObj = .OLEObjects(OLEObjectName)
If Not oftObj Is Nothing Then
oftObj.Copy ' this will create a temporary oft file
oftPath = GetLatestTempFile(OftFilePattern)
If oftPath <> "" Then
Set excelRange = .Range(MyRange)
ComposeEmail excelRange, oftPath
End If
End If
End With
End Sub
ComposeEmail#####
ExcelのRangeオブジェクトとOutlookメールテンプレートのパスを受け取り、テンプレートのメールサブジェクト内の日付を更新し、受け取ったExcelのRangeオブジェクトで示される範囲のセルをメール本文の指定位置に挿入した後、メールのドラフトを表示します。
テンプレートのメールサブジェクトに現在の日付で置き換えられる為のSubjDateRepStr定数で示される文字列が含まれる事を前提としています。
Sub ComposeEmail(aExcelRange As Variant, aMailTemplate As String)
Dim objOL, objMail As Object
Dim objEdit As Object
Set objOL = CreateObject("Outlook.Application")
Set objMail = objOL.CreateItemFromTemplate(aMailTemplate)
With objMail
.Subject = Replace(.Subject, SubjDateRepStr, Format(Date, SubjDateFormat))
Set objEdit = .GetInspector().WordEditor
' copy & paste table into the mail body
aExcelRange.Copy
objEdit.Characters(OftInsertPos).Paste
.Display
End With
End Sub
GetLatstTempFileとGetLatestFile#####
GetLatestTempFileは、ファイル名パターンを受け取り、一時ファイル用フォルダのFolderオブジェクトを取得し、そのフォルダとサブフォルダについてGetLatestFileをコールし受け取ったファイル名パターンにマッチする最新の一時ファイルを探し、そのパスを返します。見つからなかった場合は空文字列を返します。
今回のケースでは一時ファイルは下記の様に%TMP%で示される一時ファイル用フォルダのひとつ下のサブフォルダに作成されていました。(下記'x'の部分は実際はGUIDの16進表記ぽいです)
%TMP%\{xxxxxxxx-xxxx-xxxx-xxxx-xxxxxxxxxxxx}\EmailTemplate.oft
GetLatestFileはFolderオブジェクトとファイル名パターンを受け取り、Folderオブジェクトで示されるフォルダ内でファイル名パターンにマッチする最新のファイルをFileオブジェクトとして返します。
' Finds the latest temporary file matching given file name pattern, then returns its path as String
Function GetLatestTempFile(aFilePattern As String) As String
Dim fsoObj As Object
Dim folderObj As Object, subfolderObj As Object
Dim fileObj As Object, latestFileObj As Object, timestamp As Date
Set latestFileObj = Nothing
timestamp = vbEmpty ' =0, same as #1899/12/30 0:00:00#
Set fsoObj = CreateObject("Scripting.FileSystemObject")
Set folderObj = fsoObj.GetFolder(fsoObj.GetSpecialFolder(2)) ' 2: Temporary folder (should be same as %TMP%)
For Each subfolderObj In folderObj.SubFolders
Set fileObj = GetLatestFile(subfolderObj, aFilePattern)
If Not fileObj Is Nothing Then
If fileObj.DateCreated > timestamp Then
Set latestFileObj = fileObj
timestamp = fileObj.DateCreated
End If
End If
Next subfolderObj
Set fileObj = GetLatestFile(folderObj, aFilePattern)
If Not fileObj Is Nothing Then
If fileObj.DateCreated > timestamp Then
Set latestFileObj = fileObj
End If
End If
If Not latestFileObj Is Nothing Then
GetLatestTempFile = latestFileObj.Path
Else
GetLatestTempFile = ""
End If
End Function
' Finds the latest file matching given file name pattern in given folder, then returns it as File object
Function GetLatestFile(aFolder As Object, aFilePattern As String) As Object
Dim fileObj As Object, foundFileObj As Object, timestamp As Date
Set foundFileObj = Nothing
timestamp = vbEmpty ' =0, same as #1899/12/30 0:00:00#
For Each fileObj In aFolder.Files
If fileObj.Name Like aFilePattern Then
If fileObj.DateCreated > timestamp Then
Set foundFileObj = fileObj
timestamp = fileObj.DateCreated
End If
End If
Next fileObj
Set GetLatestFile = foundFileObj
End Function
因みに上記コード中、最初下記のように書いてましたが、エラーしてしまいました。
VBAは、このようなIf文の左式が偽でも右式も評価するのでしょうか。
If Not fileObj Is Nothing And fileObj.DateCreated > timestamp Then
メールイメージ###
メールテンプレートの内容によりますが、元のスライドにあったテーブルが下記の様にメールボディにインサートされます。
以上です。
サンプルコードはエラー処理などが十分ではないと思われますが、ご了承ください。
VBAはいつまでたっても初心者な感じですが、間違いやおかしな点などあれば指摘いただけると嬉しいです。