"Stan" wrote in message oups.com
I'm having eml issues and looking for some suggestions. I have new and
a bunch of previously saved eml files that when launched from IE will
only open in OE in read-only mode. None of the eml files have
read-only properties and when I create and save new eml files using OE
they also only open read-only. I'm open to any suggestions? It's me
against the computer and I seem to be losing....
I created a HTA tool to use eml file as template in Japanese environment.
If you run the HTA by double clicking, the HTA register itself to the context
menu of eml files.
After that, if you double click the eml file which contains 'X-Unsent: 1',
new mail window will open.
The body content of eml file is copied to the clipboard by HTA, you can paste
it to the body area.
The HTA is for text format only, and does not support attachment file also.
Since I make this HTA for Japanese, decode function's are complicated.
! 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 P0 = "([\s\S]*?)", P1 = "\?b\?([a-z0-9\+/=]+)\?=", P2 = "(?==\?|$)"
Dim Arg, H, B, RE, ST, CC, BCC, SB, CMD, US
Arg = Mid(This.commandline, Len(document.urlunencoded) + 4)
If Arg = "" Then
Reg_UnReg
Else
ToText Arg, H, B
With New RegExp
.IgnoreCase = True: .Global = True: .Multiline = True
.Pattern = "^TO: ([^\r]*)"
If .Test(H) Then ST = .Execute(H)(0).SubMatches(0)
.Pattern = "^CC: ([^\r]*)"
If .Test(H) Then CC = .Execute(H)(0).SubMatches(0)
.Pattern = "^BCC: ([^\r]*)"
If .Test(H) Then BCC = .Execute(H)(0).SubMatches(0)
.Pattern = "^SUBJECT: ([^\r]*)"
If .Test(H) Then SB = .Execute(H)(0).SubMatches(0)
.Pattern = "^X-UNSENT: 1\r": US = .Test(H)
End With
If US Then
Me.clipboarddata.setdata "text", Mid(B, 3)
CMD = "mailto:" & ST & "?"
If CC "" Then CMD = CMD & "cc=" & CC & "&"
If BCC "" Then CMD = CMD & "bcc=" & BCC & "&"
CMD = Replace(CMD, """", "")
If SB "" Then CMD = CMD & "subject=" & SB
With CreateObject("WScript.Shell"): .SendKeys "%": End With
window.open CMD
Else
With CreateObject("WScript.Shell")
.SendKeys "%": .Run Chr(34) & Arg & Chr(34)
End With
End If
End If
me.close
'
Sub ToText(inF, H, B)
Dim Bf, nH
With CreateObject("Scripting.FileSystemObject")
With .OpenTextFile(inF, 1): Bf = .ReadAll: .Close: End With
nH = Instr(Bf, vbCrLf & vbCrLf) + 1
If InstrRev(Bf, "charset=""utf-8""", nH, 1) 0 Then
With .OpenTextFile(inF, 1, , -1): Bf = .ReadAll: .Close: End With
Bf = U2S(Bf): nH = Instr(Bf, vbCrLf & vbCrLf) + 1
End If
End With
H = Left(Bf, nH): B = Mid(Bf, nH + 1)
H = DC(H, "I"): H = DC(H, "U"): H = Replace(H, vbCrLf & vbTab, "")
If Instr(1, H, "quoted-printable", 1) 0 Then B = DC(B, "Q")
If Instr(H, Chr(27)) 0 Then H = DC(H, "J")
If Instr(B, Chr(27)) 0 Then B = DC(B, "J")
End Sub
'
Function DC(S, M)
Dim RE, Rs, aR, T, PT
Set RE = New RegExp: RE.Global = True: RE.IgnoreCase = True
Select Case M
Case "I": PT = "=\?iso-2022-jp" & P1 & P0 & P2
Case "U": PT = "=\?utf-8" & P1 & P0 & P2
Case "J": RE.IgnoreCase = False: _
PT ="(?:\x1b\$[@B])" & P0 & "(?:\x1B\([BJ])" & P0 & "(?=\x1b|$)"
Case "Q": S = Replace(S, "=" & vbCrLf, ""): _
PT ="(?:=)([\da-f]{2})" & P0 & "(?==|$)"
End Select
RE.Pattern = P0 & PT: Set Rs = RE.Execute(S)
If Rs.Count = 0 Then DC = S: Exit Function
For Each aR In Rs
With aR.SubMatches
DC = DC & .Item(0)
Select Case M
Case "I": DC = DC & D64(.Item(1))
Case "U": DC = DC & U2S(D64(.Item(1)))
Case "J": DC = DC & J2S(.Item(1))
Case "Q": DC = DC & Chr("&h" & .Item(1))
End Select
DC = DC & .Item(2)
End With
Next
End Function
'
Function D64(S)
Dim I, T
For I = 1 To Len(S): T = T & S2B(Mid(S, I, 1)): Next
For I = 1 To Len(T) / 8: D64 = D64 & B2S(Mid(T, I * 8 - 7, 8)): Next
End Function
'
Function S2B(C)
Dim P, V, I
P = Instr(B64Tbl, C): If P = 0 Then Exit Function
P = P - 1: V = 1
For I = 0 To 5: S2B = (P And V) / V & S2B: V = V * 2: Next
End Function
'
Function B2S(B)
Dim V, I, T
V = 128
For I = 1 To 8: T = T + V * Mid(B, I, 1): V = V \ 2 : Next
If T 128 Then B2S = Chr(T) Else B2S = ChrB(T)
End Function
'
Function J2S(S)
Dim I, U, L
S = Replace(Replace(S, vbCrLf, ""), vbTab, "")
For I = 1 To Len(S) Step 2
U = Asc(Mid(S, I, 1)): L = Asc(Mid(S, I + 1, 1)) + 31
L = L - 94 * (U Mod 2 = 0): L = L - (L = 127)
U = (U - 33) \ 2 + 129: U = U - 64 * (U = 160)
J2S = J2S & Chr(U * 256 + L)
Next
End Function
'
Function U2S(S)
Dim I, U, M, L
For I = 1 To LenB(S)
U = AscB(MidB(S, I, 1))
If U = 0 Then
ElseIf U &h80 Then
If U = 10 And Right(U2S, 1) vbCr Then U2S = U2S & vbCr
U2S = U2S & Chr(U)
ElseIf U &hE0 And I LenB(S) Then
U = U And &h1F: L = AscB(MidB(S, I + 1, 1)) And &h3F: I = I + 1
U2S = U2S & ChrW((U \ 4) * 256 + (U Mod 4) * 64 + L)
ElseIf U &hF0 And I LenB(S) - 1 Then
U = U And &h0F: M = AscB(MidB(S, I + 1, 1)) And &h3F
L = AscB(MidB(S, I + 2, 1)) And &h3F: I = I + 2
U2S = U2S & ChrW((U * 16 + M \ 4) * 256 +(M Mod 4) * 64 + L)
End If
Next
End Function
'
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 CreateObject("WScript.Shell")
.SendKeys "%"
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
End Sub
/script/head/html
--
Miyahn (Masataka Miya****a) JPN
Microsoft MVP for Microsoft Office - Excel(Jan 2006 - Dec 2006)