うぃっきうぃき

--- 以下が修整したOutlook2003のVBA ---

Sub RunEditor()

Dim objShell As Object
Dim objFso As Object
Dim strSubject As String
Dim strFileName As String
Dim stmFile As Object
Set objShell = CreateObject("WScript.Shell")
Set objFso = CreateObject("Scripting.FileSystemObject")

' タイトルの取得
If ActiveInspector.CurrentItem.Subject <> "" Then
strSubject = ActiveInspector.CurrentItem.Subject
Else
strSubject = "(無題)"
End If

' タイトルと日時から一時ファイル名を生成
strFileName = objShell.ExpandEnvironmentStrings("%temp%") & strSubject & Year(Date) & Month(Date) & Day(Date) & Hour(Time) & Minute(Time) & Second(Time) & ".txt"

' 一時ファイルの作成とメッセージの本文の書き出し
Set stmFile = objFso.CreateTextFile(strFileName, True)
stmFile.WriteLine ActiveInspector.CurrentItem.Body
stmFile.Close

' 秀丸ｴﾃﾞｨﾀの起動
objShell.Run "C:Progra~1HidemaruHidemaru.exe " & strFileName, , True

' 編集済みの一時ファイルからの読み出し
Set stmFile = objFso.OpenTextFile(strFileName, 1)
ActiveInspector.CurrentItem.Body = stmFile.ReadAll
stmFile.Close

objFso.DeleteFile strFileName
End Sub

'#####################################################
' Outlook2003のメール作成ウィンドウからエディタを起動
' copyright 2007 by 甘党のプログラマ
'#####################################################
' 【機能】
' Outlook2003のメール作成ウィンドウからエディタを起動して、そのエディタ上で編集をして、エディタの編集結果を取り込みます。
' (現状、"C:Progra~1HidemaruHidemaru.exe"で決めうち)

' 【参考】
'millefeuille氏の「マイクロソフト・インサイド・アウト」
'「Outlook Tips | HTML メールのソース編集をするマクロ」
'http://ameblo.jp/millefeuille/theme12-10000018720.html
'
'【準備】
' 1. [ツール]-[マクロ]-[Visual Basic Editor] をクリックします。
' 2. [VbaProject.OTM - ThisOutlookSession (コード)] ウィンドウに下記の VBA コードをコピーします。
' 3. CTRL+S で保存します。
' 4. Visual Basic Editor を終了します。
' 5. [ファイル]-[新規作成]-[メッセージ] をクリックし、新規メッセージの作成画面を表示します。
' 6. メッセージ作成ウィンドウのツールバーを右クリックし、[ユーザー設定] をクリックします。
' 7. [コマンド] タブをクリックし、[分類] のリストの [マクロ] をクリックします。
' 8. [コマンド] のリストの "Project1.ThisOutlookSession.HTMLEdit" をツールバーの適当なところにドラッグアンドドロップします。
' 9. ドラッグアンドドロップしたアイコンを右クリックし、名前やボタン イメージを好きなように変更します。
'
'Tatsu's room on the Web
'2005/01/14(金) Outlookのメール作成をエディタとマクロで強化し損ねる
'http://homepage3.nifty.com/Tatsu_syo/Nikki/200501.html
'
' 【履歴】
' v0.01 2007/4/12 初版 : タイトルと日時から一時ファイル名を生成、秀丸ｴﾃﾞｨﾀの起動、編集済みの一時ファイルからの読み出しを一気に行う
' v0.02 2007/4/17 v.0.01が、原因不明の調子が悪さがあるために、RunEditorは、タイトルと.CreationTimeから一時ファイル名を生成、秀丸ｴﾃﾞｨﾀの起動のみ。
' v0.03 2007/4/18 エディタを起動して戻ってきたら、オートリロードする機能を追加。秀丸エディタから戻ってきたら、1行目を、メールのタイトルに設定。
' v0.04 2007/4/19 秀丸エディタを起動したときに、2行目にカーソルを設定。リロードのときのMsgBoxをvbYesNoCancelに変更して、Cancelの場合には、もう一度、Activateしたときに、再ロードできるようにした。
' v0.05 2007/5/4 HMLメールに対応。呼び出し時のメッセージボックスをvbYesNoCancelに変更。参照時には、タイトルの他に、差出人、宛先、送信日時の情報を追加。
'
' 【TODO】
' ・重複起動は、後の方が、参照だけで、戻ってきたときのオートリロードができない状態にしようとしたが、どうも、最初のオートリロードの機能が間違ったところにロードしてしまう不具合があったため、重複起動機能をつぶしている。
' ・本当は、同時に複数のメールをエディタで編集できるようにしたい。
' ・Outlook側にフォーカスがあたったら、一時ファイルの存在の有無とタイムスタンプ更新をチェックして、取り込むようにしたい。
' ・もう少し、ソースコードの綺麗にしたい。(文字列が散らばっていたり、決めウチの文字列が、直接、埋まっていたり、知性がないコードになってしまっている。)
Public WithEvents myOlInspector As Inspector
Public myOlMailItem As MailItem
Public strFileName As String
Public strRunEditorTitle As String

Sub RunEditor()
strRunEditorTitle = "RunEditor v0.05"
Dim objShell As Object
Dim objFso As Object
Dim strTempFileName As String
Dim stmFile As Object

Set objShell = CreateObject("WScript.Shell")
Set objFso = CreateObject("Scripting.FileSystemObject")
Set myOlMailItem = ActiveInspector.CurrentItem
With myOlMailItem

' 一時ファイル名を生成
MakeTempFileNameForEditor strTempFileName, objShell

If .Sent = False Then
' 編集中のウィンドウから呼び出された場合
If myOlInspector Is Nothing Then
btn = MsgBox("このウィンドウに戻ってきたときに、呼び出すエディタの編集結果をオートロードしますか?" & Chr(13) & Chr(10) & "(呼び出したエディタ上のテキストの1行目は、メールのタイトルです。)", vbYesNoCancel, "RunEditor v0.05")
If btn = vbYes Then
Set myOlInspector = ActiveInspector
ElseIf btn = vbCancel Then
GoTo finish
End If
' メールを一旦保存する
.Save
strFileName = strTempFileName
Else
'[todo]
' If MsgBox("未リロードのメール編集画面が立ち上がっているため、これで起動するエディタから戻ってきてもオートリロードできませんが、エディタを呼び出しますか?", vbYesNo, "RunEditor") = vbNo Then GoTo Finish
MsgBox ("未リロードのメール編集画面が立ち上がっているときには、RunEditorを起動しないでください。以前、起動したエディタから復帰もできなくなりました。")
Set myOlInspector = Nothing
strFileName = ""
GoTo finish
End If
Else
' 単に参照するだけの場合
If MsgBox("参照のためにエディタを呼び出しますか?", vbOKCancel, "RunEditor v0.05") <> vbOK Then GoTo finish
End If


' 一時ファイルの作成とメッセージの本文の書き出し
Set stmFile = objFso.CreateTextFile(strTempFileName, True)
stmFile.WriteLine "[タイトル] : " & .Subject

If .Sent = True Then
' 単に参照するだけの場合
stmFile.WriteLine "[送信日時] : " & .SentOn
stmFile.WriteLine "[差出人] : " & .SenderName & "(" & .SenderEmailAddress & ")"
stmFile.WriteLine "[宛先] : " & .ReceivedByName & "(" & .To & ")"
End If

' HTML形式の場合の対応
If .BodyFormat = olFormatHTML Then
stmFile.WriteLine .HTMLBody
Else
stmFile.WriteLine .Body
End If
stmFile.Close

' 秀丸ｴﾃﾞｨﾀの起動
objShell.Run "C:Progra~1HidemaruHidemaru.exe /j2 " & strTempFileName, , False

End With
finish:
End Sub


Private Sub MakeTempFileNameForEditor(ByRef strFileName As String, objShell As Object)
Dim strSubject As String
With ActiveInspector.CurrentItem
' タイトルの取得
If .Subject <> "" Then
strSubject = .Subject
Else
strSubject = "(無題)"
End If

' タイトルと.CreationTimeから一時ファイル名を生成
strFileName = strSubject & "(" & Year(.CreationTime) & "-" & Month(.CreationTime) & "-" & Day(.CreationTime) & "-" & Hour(.CreationTime) & "-" & Minute(.CreationTime) & "-" & Second(.CreationTime) & ")" & ".txt"
strFileName = Replace(strFileName, ":", "：")
strFileName = Replace(strFileName, "<", "＜")
strFileName = Replace(strFileName, ">", "＞")
strFileName = Replace(strFileName, "?", "？")
strFileName = Replace(strFileName, "/", "／")
strFileName = Replace(strFileName, "", "￥")
strFileName = Replace(strFileName, "*", "＊")
strFileName = objShell.ExpandEnvironmentStrings("%temp%") & strFileName
End With
End Sub


Private Sub myOlInspector_Activate()
Dim objFso As Object
Dim stmFile As Object

Set objFso = CreateObject("Scripting.FileSystemObject")

If myOlInspector Is Nothing Then
MsgBox ("RunEditorの2重起動の不具合が直っていません。リロードできません。")
Else
With myOlMailItem
btn = MsgBox("エディタで編集したテキストを取り込みますか?", vbYesNoCancel, "RunEditor v0.05")
If btn = vbYes Then
' 編集済みの一時ファイルからの読み出し
Set stmFile = objFso.OpenTextFile(strFileName, 1)
.Subject = Mid(stmFile.ReadLine, Len("[タイトル] : ") + 1, 1024)
.Body = stmFile.ReadAll
stmFile.Close

' 最悪、このファイルから作成したテキストを復帰できるように、一時ファイルは削除しない。
'objFso.DeleteFile strFileName

Set myOlInspector = Nothing
strFileName = ""
ElseIf btn = vbNo Then
Set myOlInspector = Nothing
strFileName = ""
End If
End With
End If
End Sub