Sub MAKE_MAIL_ITEM222()
Dim oApp As Object
Dim myNameSpace As Object
Dim myFolder As Object
Dim objMAIL As Object 'メールのオブジェクト
Dim strMOJI As String '本文
'outlook 起動
Set oApp = CreateObject("Outlook.Application")
Set myNameSpace = oApp.GetNamespace("MAPI")
Set myFolder = myNameSpace.GetDefaultFolder(6) '規定のフォルダーを指定
myFolder.Display '表示 いつものクセで .Visible = True とやりがちだけど
'メールアイテムの作成
Set objMAIL = oApp.CreateItem(0) 'olMailItem=0 直値はいけないと思いつつ、
'宛先・件名・本文 などのデータを代入する
objMAIL.To = "test@ken3.org" '宛先 ほかに.cc や.Bccも可能です
objMAIL.Subject = "テスト メールの件名です " '.Subjectに文字列設定で件名
'本文を作る、(vbCrLfで改行されます)
strMOJI = "こんにちは(このメールtestアドレスなので質問は別便で)" & vbCrLf _
& " ここで 文字列を作って .Bodyに代入する" & vbCrLf _
& " メールアイテムが作成されたらその後、 " & vbCrLf _
& " .save 下書きへ保存 や .sendで送信(確認が出る)" & vbCrLf _
& " 今回は、.Display で メール作成画面を表示" & vbCrLf _
& Now() & "作成"
objMAIL.Body = strMOJI '本文の代入
DoEvents
objMAIL.Display '途中で編集したい時（メール編集画面を表示してみた)
DoEvents
'署名を入れる
'署名のコマンドバーを探し、実行する
Dim oCBs As Object '上級者に怒られるけど object型 正解はAs Office.CommandBarsだけど
Dim oCtl As Object '正解は Office.CommandBarControl かな
'今起動中の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 'オブジェクトが空じゃなければ
'文字列でコマンド名を比較する
Debug.Print ".Caption " & oCtl.Caption
If oCtl.Caption = "署名(&S)" Then
'ここで、octlを実行したいなぁ。ってことで
'っと、その前に、どの署名か？判断が必要なのかなぁ。
Dim oCtlSUB As Object 'その下を探るので勝手にSUBを作った。
For Each oCtlSUB In oCtl.Controls '署名の下でまわす
Debug.Print "sub .Caption" & oCtlSUB.Caption
If oCtlSUB.Caption = "TESTです。" Then
oCtlSUB.Execute ' ↑で見つけた署名を実行
Exit For 'もう実行したので 抜ける、これ以上はループしないでいいので。
End If
Next
Exit For 'もう実行したので 抜ける、これ以上はループしないでいいので。
End If
End If
Next
'↑が見つからなかった時の処理や、エラー処理が無いなぁ
'※、オイオイ、オブジェクトの後始末もしないのかよ。
'サンプルだからって、手を抜きすぎ、、、
'ここで、普通はオブジェクトの開放など、後始末をする。
End Sub
↑これ(コマンドバー)を利用して、
貼り付け 処理のコマンドを実行させてみたいと思います
'リッチテキストのメールにグラフを貼って作成する。
Sub MAKE_MAIL_ITEM_RichText_Gra()
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 '表示 いつものクセで .Visible = True とやりがちだけど
'メールアイテムの作成
Set objMAIL = oApp.CreateItem(0) 'olMailItem=0 直値はいけないと思いつつ、
objMAIL.BodyFormat = 3 'olFormatRichText=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 '上級者に怒られるけど object型 正解はAs Office.CommandBarsだけど
Dim oCtl As Object '正解は Office.CommandBarControl かな
'[OL] Outlook ソリューションで CommandBars を使用する方法
' http://support.microsoft.com/kb/201095/ja
'の Excel ユーティリティを使用して Outlook CommandBar が 参考になると思います。
'今起動中の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 'オブジェクトが空じゃなければ
'文字列でコマンド名を比較する
Debug.Print ".Caption " & oCtl.Caption
If oCtl.Caption = "貼り付け(&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 '保存、下書きへ 保存後、用が無かったら.Closeで閉じるのがいいのかなぁ。。。
'objMAIL.Close 2 '閉じる Mailの編集画面を閉じる
'objMAIL.Send '送信箱へ ※セキュリティの警告メッセージが出るよ
'ここで、普通はオブジェクトの開放など、後始末をする。
Set oCtl = Nothing
Set oCBs = Nothing
End Sub
05/07 Outlook olFormatRichText リッチテキストのメールを作るには？ :
http://www.youtube.com/watch?v=v7Ein7x7j3k
05/07 Outlook の 編集・貼り付け コマンドを実行したい :
http://www.youtube.com/watch?v=XvE5JuzxE5k