Re: Getting WAB Email Addresses: a lame hack
In response to the overwhelming interest I post a revised version which
finds the location of the WAB file and the names which match the
addresses:
Option Explicit
Private Type MAPIRecip
Reserved As Long
RecipClass As Long
Name As String
Address As String
EIDSize As Long
EntryID As String
End Type
Private Declare Function MAPIResolveName _
Lib "c:\program files\outlook express\msoe.dll" _
Alias "BMAPIResolveName" ( _
ByVal Session As Long, _
ByVal UIParam As Long, _
ByVal UserName As String, _
ByVal Flags As Long, _
ByVal Reserved As Long, _
ByVal Recipient As Long) As Long
Private Declare Function RegOpenKey Lib "advapi32.dll" _
Alias "RegOpenKeyA" _
(ByVal Key As Long, _
ByVal SubKey As String, _
result As Long) _
As Long
Private Declare Function RegQueryValueEx Lib "advapi32.dll" _
Alias "RegQueryValueExA" (ByVal Key As Long, _
ByVal ValueName As String, _
ByVal Reserved As Long, _
ByVal TypeIsAReservedWord As Long, _
Data As String, _
DataLength As Long) _
As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" _
(ByVal Key As Long) _
As Long
Private Const HKEY_LOCAL_MACHINE As Long = &H80000002
Private Const HKEY_CURRENT_USER As Long = &H80000001
' requires VBScript to be installed
' (maybe don't give this to your sugnificant other as
' it gets deleted addresses as well as current)
' further development
'1. get names too?
' maybe some WABs are encrypted
' Win XP has this as registry location of wab file
' may be different in other Win versions
' HKEY_CURRENT_USER\Software\Microsoft\WAB\WAB4\Wab File Name
' mine isn't
' Excludes are list of key words to be excluded from
' list of addresses
Dim RE As Object
Dim Match As Variant
Dim Matches As Variant
' store value for this
' if you want to specify location of WAB file
Dim WabPath As String
Sub WABEMailAddresses(ParamArray Excludes() As Variant)
Dim aAddresses() As String
Dim Address As String
Dim Addresses As String
Dim Buffer As String
Dim FileNumber As Integer
Dim Name As String
Dim Include As Boolean
Dim Iterator As Long
On Error GoTo WABEMailAddressesErr
If Len(WabPath) = 0 Then WabPath = WABLocation
FileNumber = FreeFile
Open WabPath For Binary As #FileNumber
Buffer = String(LOF(FileNumber), vbNullChar)
Get #FileNumber, , Buffer
Close #FileNumber
Buffer = StrConv(Buffer, vbFromUnicode)
InitializeRegExp
("[\w-\.]{1,}\@([\da-zA-Z-]{1,}\.){1,}[\da-zA-Z-]{2,3}")
Set Matches = RE.Execute(Buffer)
For Each Match In Matches
Address = Match.Value
' identity address probably should be include in Excludes
Include = InStr(Addresses, Address) = 0
If Include Then
For Iterator = LBound(Excludes) To UBound(Excludes)
If InStr(Address, Excludes(Iterator)) <> 0 Then
Include = False
Exit For
End If
Next Iterator
End If
If Include Then
Name = GetNameFromWABAddress(Address)
If Name <> Address Then
Address = "<" & GetNameFromWABAddress(Address) & "> " &
Address
End If
Addresses = Addresses & ";" & Address
End If
Next
If Len(Addresses) > 0 Then
Addresses = Mid$(Addresses, 2)
aAddresses = Split(Addresses, ";")
End If
' this part requires Access >=2k
' but it can be omitted
On Error Resume Next
With WizHook
.Key = 51488399
.SortStringArray aAddresses
End With
On Error GoTo WABEMailAddressesErr
' we now have an sorted (maybe) string of addresses
' delimited with ";"
' we can do whatever we want with them
' I am displaying them in the Immediate window
Addresses = Join(aAddresses, vbNewLine)
Debug.Print Addresses
WABEMailAddressesExit:
ReleaseRegExp
Close
Exit Sub
WABEMailAddressesErr:
With Err
MsgBox .Description, vbCritical, "Error " & .Number
End With
Resume WABEMailAddressesExit
End Sub
Public Sub InitializeRegExp( _
ByRef MaskPattern As String, _
Optional ByRef Globally As Boolean = True, _
Optional ByRef IgnoreCase As Boolean = True)
Set RE = CreateObject("VBScript.RegExp") 'late binding ... Dev
would squirm
With RE
.Global = Globally
.IgnoreCase = IgnoreCase
.Pattern = MaskPattern
End With
End Sub
Public Sub ReleaseRegExp()
Set Matches = Nothing
Set RE = Nothing
End Sub
Public Function WABLocation() As String
Dim Key As Long
Dim KeyName As String
Dim Length As Long
Dim ReturnValue As Long
On Error GoTo WABLocationErr
KeyName = "Software\Microsoft\WAB\WAB4\Wab File Name"
Length = 255
WABLocation = String(255, vbNullChar)
ReturnValue = RegOpenKey(HKEY_CURRENT_USER, KeyName, Key)
If ReturnValue = 0 Then
ReturnValue = RegQueryValueEx(Key, _
"", _
0, _
0, _
ByVal WABLocation, _
Length)
End If
If ReturnValue <> 0 Then Resume WABLocationErr
WABLocationExit:
On Error Resume Next
RegCloseKey Key
Exit Function
WABLocationErr:
MsgBox "WABLocation not retrieved!", vbCritical, "Error!"
WABLocation = 0
Resume WABLocationExit
End Function
Public Function GetNameFromWABAddress(ByVal strAddress As String) As
String
Dim r As MAPIRecip
MAPIResolveName 0, 0, strAddress, 0, 0, VarPtr(r)
GetNameFromWABAddress = StrConv(r.Name, vbUnicode)
End Function
Sub test()
' excludes addresses which include
' lylefair
WABEMailAddresses "lylefair"
End Sub
|
