Excel VBAからOutlookを操作して、本文内に表を張り付ける
質問
2013年5月30日木曜日 8:31
どなたかご教授お願いいたします。
ExcelマクロからOutlookを操作して、メールを自動作成して、メール本文内に表を張り付けるというマクロを作成し、2007では問題無く使用していたのですが、Officeを2010にバージョンアップしたところ、エラーで張り付けができなくなってしまいました。
使用しているマクロは下記の通りです。
Dim oApp As Object
Dim myNameSpace As Object
Dim myFolder As Object
Dim objMAIL As Object 'メールのオブジェクト
'outlook 起動
Set oApp = CreateObject("Outlook.Application")
Set myNameSpace = oApp.GetNamespace("MAPI")
Set myFolder = myNameSpace.GetDefaultFolder(6) '規定のフォルダーを指定
myFolder.Display
'メールアイテムの作成
Set objMAIL = oApp.CreateItem(0)
objMAIL.BodyFormat = 3
'宛先・件名・本文 などのデータを代入する
objMAIL.To = Range("B3") '宛先 .TO セルB3から代入
objMAIL.CC = Range("B4") '宛先 .CC セルB4から代入
objMAIL.Subject = Range("B6") '.Subjectで件名 セルB6から代入
DoEvents
objMAIL.Body = "" '本文の初期化
DoEvents
objMAIL.Display '画面表示(Mail入力、編集画面を表示)
DoEvents
'Outlook貼り付けのコマンドをコマンドバーから探す
Dim oCBs As Object
Dim oCtl As Object
'今起動中のobjMAIL(メール作成中)のコマンドバーを取り出す
Set oCBs = objMAIL.GetInspector.CommandBars
'ループで貼り付けの文字を探す、、、
Dim I As Long 'カウンター
For I = 1 To 35000
'コントロール I 番目を取り出す
Set oCtl = oCBs.FindControl(, I)
If Not (oCtl Is Nothing) Then 'オブジェクトが空じゃなければ
'文字列でコマンド名を比較する
If right(oCtl.Caption,4) = "(&P)" Then
' ↑で見つけたら oCtlはそのままで、ループを抜ける。
Exit For
End If
End If
Next
'コピー(Excelから)と貼り付け(Outlookへ)処理
Range("A10:F14").Select 'Excel
Selection.Copy
DoEvents
oCtl.Execute '↑で見つけたoCtl 貼り付けコマンド(outlook)を実行←ここでエラー
DoEvents
ActiveSheet.ChartObjects("グラフ 1").Activate
ActiveChart.ChartArea.Select
Application.CutCopyMode = False
ActiveChart.ChartArea.Copy
DoEvents
oCtl.Execute '↑で見つけた oCtl 貼り付けコマンド(outlook)を実行
DoEvents
Range("A32:G42").Select
Selection.Copy
DoEvents
oCtl.Execute '↑で見つけた oCtl 貼り付けコマンド(outlook)を実行
DoEvents
'objMAIL.Save
'objMAIL.Close 2
'objMAIL.Send
Set oCtl = Nothing
Set oCBs = Nothing
End Sub
「oCtl.Execute」の部分で、下記エラーが発生します。
実行時エラー'-2147467259(80004005)':
'Execute'メソッドは失敗しました: '_CommandBarButton'オブジェクト
どこを修正すれば2007の時のように貼り付けができるようになるか、ご教授頂けると助かります。
どうぞよろしくお願いいたします。
すべての返信 (1)
2013年5月31日金曜日 22:00
こちらで回答しているので、ご覧になって下さい。