More efficient version.

! 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 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, AdvHead, IsHtmlDef
Arg = Mid(This.commandline, Len(document.urlunencoded) + 4)
Set WS = CreateObject("WScript.Shell")
WS.SendKeys "%"
If Arg = "" Then
Reg_UnReg
ElseIf Instr(Arg, "Temporary Internet Files") Then
WS.PopUp "Processing aborted because the file is in unsafe folder.", _
2, "Abort"
window.close
End If
'
Sub Main
Dim Buf, Header, Body, SendTo, CC, BCC, Subject, Command
With CreateObject("Scripting.FileSystemObject")
With .OpenTextFile(Arg, 1): Buf = .ReadAll: .Close: End With
End With
If Instr(1, Buf, "X-UNSENT: 1", 1) 0 Then
CheckSetting: If LUID = "" Then window.close: Exit Sub
Decode Buf, Header, Body
SetBody Body: If Body = "" Then window.close: Exit Sub
GetHeaderData Header, SendTo, CC, BCC, Subject
Command = "mailto:" & SendTo & "?"
If CC "" Then Command = Command & "cc=" & CC & "&"
If BCC "" Then Command = Command & "bcc=" & BCC & "&"
Command = Replace(Command, """", "")
Title = "Compose Message"
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 CheckSetting
LUID = WS.RegRead(RKey & SKey)
Select Case LUID
Case "", "{00000000-0000-0000-0000-000000000000}"
WS.PopUp "Can't specify the user ID !!", 1, "Abort"
LUID = "": Exit Sub
End Select
AdvHead = WS.RegRead(RKey & LUID & SSKey & TValue1)
IsHtmlDef = WS.RegRead(RKey & LUID & SSKey & TValue2)
End Sub
'
Sub Decode(Src, Header, Body)
Dim Pos
Pos = Instr(Src, vbCrLf & vbCrLf) + 1
Header = Left(Src, Pos): Body = Mid(Src, Pos + 3)
Header = Replace(Header, vbCrLf & vbTab, "")
If Instr(1, Body, "quoted-printable", 1) 0 Then
With New RegExp
.Global = True: .IgnoreCase = True
Body = Replace(Body, "=" & vbCrLf, "")
.Pattern = "=[\da-f]{2}"
Body = .Replace(Body, GetRef("QDecode"))
End With
End If
End Sub
'
Function QDecode(Match, Pos, Src)
QDecode = Chr("&h" & Mid(Match, 2))
End Function
'
Sub SetBody(Body)
Const HtmlPat = "HTML[\s\S]+/HTML"
Const ExSrcPat = "src(\s)?=(\s)?(\x22)?(http|/)"
Dim cRes, aRes
With New RegExp
.IgnoreCase = True: .Global = True
.Pattern = HtmlPat: Set cRes = .Execute(Body)
If cRes.Count 0 Then
Body = cRes(0)
.Pattern = ExSrcPat: Set cRes = .Execute(Body)
If cRes.Count 0 Then
WS.PopUp _
"Processing aborted because the file contains external reference.", _
2, "Abort": Body = "": Exit Sub
Else
document.body.innerhtml = Body
document.execCommand "SelectAll"
document.execCommand "Copy"
WS.RegWrite RKey & LUID & SSKey & TValue2, 1, "REG_DWORD"
End If
Else
window.clipboarddata.setdata "text", Body
WS.RegWrite RKey & LUID & SSKey & TValue2, 0, "REG_DWORD"
End If
End With
End Sub
'
Sub GetHeaderData(Header, SendTo, CC, BCC, Subject)
Const HeaderPat = "^(?:TO|(?:B)?CC|SUBJECT): ([^\r]*)"
Dim cRes, aRes
With New RegExp
.IgnoreCase = True: .Global = True: .MultiLine = True
.Pattern = HeaderPat
Set cRes = .Execute(Header)
For Each aRes In cRes
Select Case UCase(Split(aRes.Value, ":")(0))
Case "TO": SendTo = aRes.SubMatches(0)
Case "CC": CC = aRes.SubMatches(0)
Case "BCC": BCC = aRes.SubMatches(0): AdvHead = True
Case "SUBJECT": Subject = aRes.SubMatches(0)
End Select
Next
End With
End Sub
'
Sub PasteBody
If WS.AppActivate(Title) Then
WS.SendKeys Keys
WS.RegWrite RKey & LUID & SSKey & TValue2, IsHtmlDef, _
"REG_DWORD"
window.close
End If
End Sub
'
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,"Registered"
Else
.RegDelete Tkey & SKey & "\command\"
.RegDelete Tkey & SKey & "\"
.RegWrite TKey, ""
.PopUp "Deleted from context menu.", 1,"Deregistered"
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)
https://mvp.support.microsoft.com/pr...4-83d372c269b4