I'll just post his reply in toto:
=======================
I use the following HTA to add bcc address to mail account on Japanese
WinXP + Japanese OE6.0
The HTA change registry value type of "SMTP Email Address" from "REG_SZ"
to "REG_Binary", and add bcc address.
# Note:This is a tricky way. Try first on new account.
Select target account on "Account" dropdown listbox.
Type Bcc Address in "Bcc Address" textbox.
If you click [Copy] button, original email address is copied to "Bcc
Address"
textbox.
Click [Add] button to change registry.
!-- FileName : AddBccOE.hta --
htmlheadtitleAdd Bcc For OE Mail Account/title
hta:application scroll="no"/
script language=vbs
Const AccName = "Account Name", AdrName = "SMTP Email Address"
Const Root = "HKCU\", IdKey = "Identities", LUIDName = "Last User ID"
Const TKey ="Software\Microsoft\Internet Account Manager\Accounts"
Const aPat = "\w+@\w+\.\w+", bPat = "\r\nBcc: .+"
Dim WS, MainKey: window.resizeto 300,220
'
Sub Init()
Dim LUID, SubKeys, aSubKey, Key, Address, Account, aOption, E
Set WS = CreateObject("WScript.Shell")
LUID = WS.RegRead(Root & IdKey & "\" & LUIDName)
If LUID = "" Or _
LUID = "{00000000-0000-0000-0000-000000000000}" Then _
alert "Can't Specify User ID !!": window.close: Exit Sub
MainKey = IdKey & "\" & LUID & "\" & TKey
If EnumKey(Root & MainKey, SubKeys) 0 Then
MainKey = TKey
If EnumKey(Root & MainKey, SubKeys) 0 Then _
alert "Can't Read Accounts List !!": window.close: Exit Sub
End If
For Each aSubKey In SubKeys
Key = Root & MainKey & "\" & aSubKey & "\"
On Error Resume Next
Address = WS.RegRead(Key & "\" & AdrName)
E = Err.Number
On Error GoTo 0
If E = 0 Then
Account = WS.RegRead(Key & "\" & AccName)
Set aOption = document.createElement("option")
document.all.Accounts.options.add(aOption)
aOption.innertext = Account: aOption.Value = CStr(aSubKey)
End If
Next
SelChange
End Sub
'
Function EnumKey(ByVal MainKey, SubKeys)
Const Tmp = "Temp.reg"
Dim Buf, Pat, cRes, I, Keys()
Select Case Left(MainKey, 4)
Case "HKCR": MainKey = "HKEY_CLASSES_ROOT" & Mid(Mainkey, 5)
Case "HKCU": MainKey = "HKEY_CURRENT_USER" & Mid(Mainkey, 5)
Case "HKLM": MainKey = "HKEY_LOCAL_MACHINE" & Mid(Mainkey, 5)
End Select
With CreateObject("WScript.Shell")
.Run "Regedit /e " & Tmp & " """ & MainKey & """", 0, True
End With
With CreateObject("Scripting.FileSystemObject")
If .FileExists(Tmp) Then EnumKey = 0 Else EnumKey = 1: _
Exit Function
With .OpenTextFile(Tmp, 1, False, -2): Buf = .ReadAll: _
.Close: End With
.DeleteFile Tmp
End With
Pat = "\[" & Replace(MainKey, "\", "\\") & "\\([^\\\]]+)"
With New RegExp
.IgnoreCase = True: .Global = True: .Pattern = Pat
Set cRes = .Execute(Buf): ReDim Keys(cRes.Count - 1)
For I = 0 To cRes.Count - 1: Keys(I) = cRes(I).SubMatches(0): Next
End With
SubKeys = Keys: EnumKey = 0
End Function
'
Sub SelChange
Dim aSubKey, Address, Buf, I
aSubKey = document.all.Accounts.Value
Address = WS.RegRead(Root & MainKey & "\" & aSubKey & "\" & AdrName)
If TypeName(Address) = "String" Then
MailAdr.innertext = Address
Else
For I = 0 To UBound(Address): Buf = Buf & Chr(Address(I)): Next
MailAdr.innertext = Buf
End If
End Sub
'
Sub AddBcc()
Dim aSubKey, Address, BccAddress, Buf, I, L, BinAddr()
aSubKey = document.all.Accounts.Value
Address = MailAdr.innertext
BccAddress = document.all.BccAdr.Value
With New RegExp
.Pattern = aPat
If Not .Test(BccAddress) Then _
alert "Invalid Bcc Address !!": Exit Sub
.Pattern = bPat
If .Test(Address) Then _
alert "Bcc Already Exists !!": Exit Sub
End With
Buf = Address & "" & vbCrLf & "Bcc: " & BccAddress & Chr(0)
L = Len(Buf): ReDim BinAddr(L - 1)
For I = 1 To L: BinAddr(I - 1) = Asc(Mid(Buf, I)): Next
WS.RegDelete Root & MainKey & "\" & aSubKey & "\" & AdrName
RegWriteB Root & MainKey & "\" & aSubKey, AdrName, BinAddr
SelChange
End Sub
'
Sub RegWriteB(MainKey, Name, Data)
Const Tmp = "Temp.reg": Dim Buf, sData(), I
Select Case Left(MainKey, 4)
Case "HKCR": MainKey = "HKEY_CLASSES_ROOT" & Mid(Mainkey, 5)
Case "HKCU": MainKey = "HKEY_CURRENT_USER" & Mid(Mainkey, 5)
Case "HKLM": MainKey = "HKEY_LOCAL_MACHINE" & Mid(Mainkey, 5)
End Select
ReDim sData(UBound(Data))
For I = 0 To UBound(Data): sData(I) = Hex(Data(I)): Next
Buf = Buf & "REGEDIT4" & vbCrLf
Buf = Buf & "[" & MainKey & "]" & vbCrLf
Buf = Buf & """" & Name & """=hex:" & Join(sData, ",")
With CreateObject("Scripting.FileSystemObject")
With .OpenTextFile(Tmp, 2, True, 0): .Write Buf: .Close: End With
With CreateObject("WScript.Shell")
.Run "Regedit /s " & Tmp, 0, True
End With
.DeleteFile Tmp
End With
End Sub
'
Sub DelBcc()
Dim aSubKey, Address, Key
aSubKey = document.all.Accounts.Value: Address = MailAdr.innertext
With New RegExp
.Pattern = bPat: If Not .Test(Address) Then Exit Sub
Address = .Replace(Address, "")
End With
Key = Root & MainKey & "\" & aSubKey & "\" & AdrName
WS.RegDelete Key: WS.RegWrite Key, Address, "REG_SZ": SelChange
End Sub
'
Sub Adr2Bcc
Dim Address: Address = MailAdr.innertext
With New RegExp
.Pattern = bPat: If .Test(Address) Then Exit Sub
End With
document.all.BccAdr.innertext = Address
End Sub
/script/headbody onload="Init"form
pAccount : select id="Accounts" onchange="SelChange"
/select/p
pEmail Address: span id="MailAdr"/span/p
pBcc Address : input type=text id="BccAdr"/p
p align=center
input type=button value=" Copy " onclick="Adr2Bcc"
input type=button value=" Add " onclick="AddBcc"
input type=button value=" Del " onclick="DelBcc"/p
/form/bodyhtml
--
Miyahn (Masataka Miya****a) JPN
Microsoft MVP for Microsoft Office - Excel(Jan 2006 - Dec 2006)
=========================
--
Jim Pickering, MVP, Outlook Express
https://mvp.support.microsoft.com/pr...8-1171988A62D6
Please deliver feedback to the newsgroup, so that others can be helped.
Customers in the U.S. and Canada can receive technical support from
Microsoft Product Support Services at 1-866-PCSAFETY. There is no charge for
support calls that are associated with security updates
"badgolferman" wrote in message
...
Jim Pickering, 4/18/2006, 1:42:26 PM,
wrote:
All that you need to do to his link is add the server, i.e., take his
link
and convert it to the following by adding "//msnews.microsoft.com/"
news://msnews.microsoft.com/#Z9AdNoO...TNGP11.phx.gbl
Sorry, it's not working for me. Perhaps if you tell me which newsgroup
and what subject I may find it manually.
"Outlook Express could not download the requested message. It is
likely the message was removed or expired or expired from the server."