More reliable version on Body-content pasting.
! FileName : MakeMail.hta
htmlhead
meta http-equiv=Content-Type content="text/html; charset=us-ascii"
hta:application applicationname="MakeMail" id="This"
windowstate="minimize" singleinstance="yes"
script language=vbs
Option Explicit
Const RKey = "HKCU\Identities\", SKey = "Last User ID"
Const TValue = "\Software\Microsoft\Outlook Express\5.0\Mail\Show Adv Mail Send"
Dim Arg, Buf, Pos, Header, Body, SendTo, CC, BCC, Subject, Command, Unsent
Dim WS, LUID, AdvHead, tId, Title, Keys
Arg = Mid(This.commandline, Len(document.urlunencoded) + 4)
Set WS = CreateObject("WScript.Shell")
WS.SendKeys "%"
If Arg = "" Then Reg_UnReg
'
Sub Main
LUID = WS.RegRead(RKey & SKey)
If LUID = "" Or LUID = "{00000000-0000-0000-0000-000000000000}" Then
WS.PopUp "Can't specify the user ID !!", 1, "Error"
window.close: Exit Sub
End If
AdvHead = WS.RegRead(RKey & LUID & TValue)
With CreateObject("Scripting.FileSystemObject")
With .OpenTextFile(Arg, 1): Buf = .ReadAll: .Close: End With
End With
Pos = Instr(Buf, vbCrLf & vbCrLf) + 1
Header = Left(Buf, Pos): Body = Mid(Buf, Pos + 3)
With New RegExp
.IgnoreCase = True: .Global = True: .Multiline = True
.Pattern = "^TO: ([^\r]*)"
If .Test(Header) Then SendTo = .Execute(Header)(0).SubMatches(0)
.Pattern = "^CC: ([^\r]*)"
If .Test(Header) Then CC = .Execute(Header)(0).SubMatches(0)
.Pattern = "^BCC: ([^\r]*)"
If .Test(Header) Then _
BCC = .Execute(Header)(0).SubMatches(0): AdvHead = True
.Pattern = "^SUBJECT: ([^\r]*)"
If .Test(Header) Then Subject = .Execute(Header)(0).SubMatches(0)
.Pattern = "^X-UNSENT: 1\r": Unsent = .Test(Header)
End With
If Unsent Then
Title = "Compose Message" ' I am not sure this title
Me.clipboarddata.setdata "text", Body
Command = "mailto:" & SendTo & "?"
If CC "" Then Command = Command & "cc=" & CC & "&"
If BCC "" Then Command = Command & "bcc=" & BCC & "&"
Command = Replace(Command, """", "")
If Subject "" Then _
Command = Command & "subject=" & Subject: Title = Subject
If AdvHead Then Keys = "{TAB 4}^v" Else Keys = "{TAB 3}^v"
tId = window.SetInterval("PasteBody", 500)
window.open Command
Else
WS.Run Chr(34) & Arg & Chr(34): window.close
End If
End Sub
'
Sub PasteBody
If WS.AppActivate(Title) Then WS.SendKeys Keys: window.close
End Sub
'
Sub Reg_UnReg
Const TKey = "HKCR\Microsoft Internet Mail Message\shell\"
Const SKey = "MakeMail", sMenu = "MakeMail(&M)"
Dim sCmd, EN
sCmd = "mshta """ & document.urlunencoded & """ %L"
With WS
On Error Resume Next
.RegRead TKey & SKey & "\": EN = Err.Number
On Error GoTo 0
If EN Then
.RegWrite TKey, SKey
.RegWrite Tkey & SKey & "\", sMenu
.RegWrite Tkey & SKey & "\command\", sCmd
.PopUp "Added to context menu.", 1,"Message"
Else
.RegDelete Tkey & SKey & "\command\"
.RegDelete Tkey & SKey & "\"
.RegWrite TKey, ""
.PopUp "Deleted from context menu.", 1,"Message"
End If
End With
window.close
End Sub
/script/headbody onload=Main/body/html
--
Miyahn (Masataka Miya****a) JPN
Microsoft MVP for Microsoft Office - Excel(Jan 2006 - Dec 2006)
