Constraints
Format : both of plain text , html
Charset : Windows-1252 (iso-8859-1 is not tested)
MIME-encoding : none
Attachment files : none
OE : should not be executing

! 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 B64Tbl = _
"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvw xyz0123456789+/"
Const RKey = "HKCU\Identities\", SKey = "Last User ID"
Const SSKey = "\Software\Microsoft\Outlook Express\5.0\Mail\"
Const TValue1 = "Show Adv Mail Send", TValue2 = "Message Send HTML"
Dim Arg, WS, tId, Title, Keys, LUID, IsHtmlDefault
Arg = Mid(This.commandline, Len(document.urlunencoded) + 4)
Set WS = CreateObject("WScript.Shell")
WS.SendKeys "%"
If Arg = "" Then Reg_UnReg
'
Sub Main
Const HtmlPat = "HTML[\s\S]+/HTML"
Dim Buf, Pos, Header, Body, SendTo, CC, BCC, Subject, Command
Dim AdvHead, Unsent
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 & SSKey & TValue1)
IsHtmlDefault = WS.RegRead(RKey & LUID & SSKey & TValue2)
With CreateObject("Scripting.FileSystemObject")
With .OpenTextFile(Arg, 1): Buf = .ReadAll: .Close: End With
End With
Pos = Instr(Buf, vbCrLf & vbCrLf) + 1
Header = Replace(Left(Buf, Pos), vbCrLf & vbTab, "")
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
With New RegExp
.IgnoreCase = True: .Pattern = HtmlPat
If .Test(Body) Then
Body = Decode(.Execute(Body)(0))
With document
.body.innerhtml = Body
.execCommand "SelectAll": .execCommand "Copy"
End With
WS.RegWrite RKey & LUID & SSKey & TValue2, 1, "REG_DWORD"
Else
window.clipboarddata.setdata "text", Body
WS.RegWrite RKey & LUID & SSKey & TValue2, 0, "REG_DWORD"
End If
End With
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", 100)
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
WS.RegWrite RKey & LUID & SSKey & TValue2, IsHtmlDefault, "REG_DWORD"
window.close
End If
End Sub
'
Function Decode(Src) ' Decode function for 'quoted-printable'
Const P0 = "([\s\S]*?)"
Dim RE, cResult, aResult
Set RE = New RegExp: RE.Global = True: RE.IgnoreCase = True
Src = Replace(Src, "=" & vbCrLf, "")
RE.Pattern =P0 & "(?:=)([\da-f]{2})" & P0 & "(?==|$)"
Set cResult = RE.Execute(Src)
If cResult.Count = 0 Then Decode = Src: Exit Function
For Each aResult In cResult
With aResult.SubMatches
Decode = Decode & .Item(0) & Chr("&h" & .Item(1)) & .Item(2)
End With
Next
End Function
'
Sub Reg_UnReg
Const TKey = "HKCR\Microsoft Internet Mail Message\shell\"
Const SKey = "MakeMail", sMenu = "&MakeMail"
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)