Prev: Error: 80072030, Facility: LDAP Provider, "There is no such object on the server."
Next: HTA Application problem - mshta.exe will not terminate
From: Ed_P. on 23 Feb 2005 19:34
Hello,

I thought I'd put out this question out on this newsgroup to see if what
I am trying to do can be done with vbsctipt. Basically what I am trying
to do set up outlook express to insert a pre-defined e-mail address in
the bcc: line of the message whenever I respond to a message in my
outlook express inbox.

I was thinking of doing this thru vbscripting but have not found any
info. on how to do so on the net. Is this possible? if so, can you
point me to some examples or resources that I can use to do this. If it
can't be done thru vbscripts can you point tell me what I can use to try
to automate this.

Thanks in Advance

Ed_P.
From: Miyahn on 24 Feb 2005 07:24
"Ed_P." wrote in message news:Oczu9ggGFHA.616(a)TK2MSFTNGP10.phx.gbl
> I thought I'd put out this question out on this newsgroup to see if what
> I am trying to do can be done with vbsctipt. Basically what I am trying
> to do set up outlook express to insert a pre-defined e-mail address in
> the bcc: line of the message whenever I respond to a message in my
> outlook express inbox.

This is a tricky way.
Replace the string value "SMTP Email Address" in registry with
the binary value of the same name and add Bcc header item.

Try the following HTA at your own risk.
This will work on Win2K or later (and probably on WinMe).

<!-- FileName : AddBccOE.hta -->
<html><head><title>Add Bcc For OE Mail Account</title>
<hta:application scroll="no"/>
<script language=vbs>
Const AccName = "Account Name", AdrName = "SMTP Email Address"
Const IdKey = "Identities", LUIDName = "Last User ID"
Const TKey ="Software\Microsoft\Internet Account Manager\Accounts"
Const HKCU = &H80000001, aPat = "\w+@\w+\.\w+", bPat = ">\r\nBcc: .+"
Dim MainKey: window.resizeto 300,220
'
Sub Init()
Dim LUID, SubKeys, aSubKey, Account, Address, aOption
With GetObject("winmgmts:\root\default:StdRegProv")
.GetStringValue HKCU, IdKey, LUIDName, LUID
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(HKCU, MainKey, SubKeys) <> 0 Then
MainKey = TKey
If .EnumKey(HKCU, MainKey, SubKeys) <> 0 Then _
Alert "Can't Read Accounts List !!": window.close: Exit Sub
End If
For Each aSubKey In SubKeys
If .GetStringValue(HKCU, MainKey & "\" & aSubKey, _
AdrName, Address) = 0 Then
GetAccount aSubKey
ElseIf .GetBinaryValue(HKCU, MainKey & "\" & aSubKey, _
AdrName, Address) = 0 Then
GetAccount aSubKey
End If
Next
SelChange
End With
End Sub
'
Sub GetAccount(aSubKey)
Dim aOption
With GetObject("winmgmts:\root\default:StdRegProv")
.GetStringValue HKCU, MainKey & "\" & aSubKey, AccName, Account
End With
Set aOption = document.createElement("option")
document.all.Accounts.options.add(aOption)
aOption.innertext = Account: aOption.Value = CStr(aSubKey)
End Sub
'
Sub SelChange
Dim aSubKey, Address, Buf, I
aSubKey = document.all.Accounts.Value
With GetObject("winmgmts:\root\default:StdRegProv")
If .GetStringValue( _
HKCU, MainKey & "\" & aSubKey, AdrName, Address) = 0 Then
MailAdr.innertext = Address: Exit Sub
End If
If .GetBinaryValue( _
HKCU, MainKey & "\" & aSubKey, AdrName, Address) = 0 Then
For I = 0 To UBound(Address): Buf = Buf & Chr(Address(I)): Next
MailAdr.innertext = Buf
End If
End With
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) = CByte(Asc(Mid(Buf, I))): Next
With GetObject("winmgmts:\root\default:StdRegProv")
.DeleteValue HKCU, MainKey & "\" & aSubKey, AdrName
.SetBinaryValue _
HKCU, MainKey & "\" & aSubKey, AdrName, BinAddr
End With
SelChange
End Sub
'
Sub DelBcc()
Dim aSubKey, Address
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
With GetObject("winmgmts:\root\default:StdRegProv")
.DeleteValue HKCU, MainKey & "\" & aSubKey, AdrName
.SetStringValue HKCU, MainKey & "\" & aSubKey, AdrName, Address
End With
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><head><body onload="Init"><form>
<p>Account : <select id="Accounts" onchange="SelChange">
</select></p>
<p>Email Address: <span id="MailAdr"></span></p>
<p>Bcc Address : <input type=text id="BccAdr"></p>
<p align=center>
<input type=button value=" Copy " onclick="Adr2Bcc">
&nbsp;&nbsp;&nbsp;&nbsp;
<input type=button value=" Add " onclick="AddBcc">
&nbsp;&nbsp;&nbsp;&nbsp;
<input type=button value=" Del " onclick="DelBcc"></p>
</form></body><html>

--
Miyahn (Masataka Miyashita) JPN
Microsoft MVP for Microsoft Office - Excel(Jan 2005 - Dec 2005)
HQF03250(a)nifty.ne.jp

From: Miyahn on 24 Feb 2005 08:32
There are some mistakes in the variable declaration.

"Miyahn" wrote in message news:eVKwevmGFHA.2616(a)tk2msftngp13.phx.gb
> Sub Init()
> Dim LUID, SubKeys, aSubKey, Account, Address, aOption

Dim LUID, SubKeys, aSubKey, Address

> Sub GetAccount(aSubKey)
> Dim aOption

Dim Account, aOption

--
Miyahn (Masataka Miyashita) JPN
Microsoft MVP for Microsoft Office - Excel(Jan 2005 - Dec 2005)
HQF03250(a)nifty.ne.jp

From: Ed_P. on 24 Feb 2005 13:40
Thanks Miyahn, I'll give it a try!

Ed_P. wrote:
> Hello,
>
> I thought I'd put out this question out on this newsgroup to see if what
> I am trying to do can be done with vbsctipt. Basically what I am trying
> to do set up outlook express to insert a pre-defined e-mail address in
> the bcc: line of the message whenever I respond to a message in my
> outlook express inbox.
>
> I was thinking of doing this thru vbscripting but have not found any
> info. on how to do so on the net. Is this possible? if so, can you
> point me to some examples or resources that I can use to do this. If it
> can't be done thru vbscripts can you point tell me what I can use to try
> to automate this.
>
> Thanks in Advance
>
> Ed_P.
From: Miyahn on 25 Feb 2005 10:23
Faster version using wscript.shell's method.

<!-- FileName : AddBccOE.hta -->
<html><head><title>Add Bcc For OE Mail Account</title>
<hta:application scroll="no"/>
<script language=vbs>
Option Explicit
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 HKCU = &H80000001, aPat = "\w+@\w+\.\w+", bPat = ">\r\nBcc: .+"
Dim WS, MainKey: window.resizeto 300,220
'
Sub Init()
Dim LUID, SubKeys, aSubKey, Key, Address, Account, aOption, EN
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
With GetObject("winmgmts:\root\default:StdRegProv")
If .EnumKey(HKCU, MainKey, SubKeys) <> 0 Then
MainKey = TKey
If .EnumKey(HKCU, MainKey, SubKeys) <> 0 Then _
alert "Can't Read Accounts List !!": window.close: Exit Sub
End If
End With
For Each aSubKey In SubKeys
Key = Root & MainKey & "\" & aSubKey & "\"
On Error Resume Next
Address = WS.RegRead(Key & "\" & AdrName)
EN = Err.Number
On Error GoTo 0
If EN = 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
'
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) = CByte(Asc(Mid(Buf, I))): Next
WS.RegDelete Root & MainKey & "\" & aSubKey & "\" & AdrName
With GetObject("winmgmts:\root\default:StdRegProv")
.SetBinaryValue HKCU, MainKey & "\" & aSubKey, AdrName, BinAddr
End With
SelChange
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><head><body onload="Init"><form>
<p>Account : <select id="Accounts" onchange="SelChange">
</select></p>
<p>Email Address: <span id="MailAdr"></span></p>
<p>Bcc Address : <input type=text id="BccAdr"></p>
<p align=center>
<input type=button value=" Copy " onclick="Adr2Bcc">
&nbsp;&nbsp;&nbsp;&nbsp;
<input type=button value=" Add " onclick="AddBcc">
&nbsp;&nbsp;&nbsp;&nbsp;
<input type=button value=" Del " onclick="DelBcc"></p>
</form></body><html>

--
Miyahn (Masataka Miyashita) JPN
Microsoft MVP for Microsoft Office - Excel(Jan 2005 - Dec 2005)
HQF03250(a)nifty.ne.jp

 | 
Pages: 1
Prev: Error: 80072030, Facility: LDAP Provider, "There is no such object on the server."
Next: HTA Application problem - mshta.exe will not terminate