Getting WAB Email Addresses: a lame hack

[Lyle Fairfield]

Option Explicit

' requires VBScript to be installed
' (maybe don't give this to your sugnificant other as
' it gets deleted addresses as well as current)
' obvious fixups needed
'1. how get wab file location
' further development
'1. get names too?
' maybe some WABs are encrypted
' mine isn't

Dim RE As Object
Dim Match As Variant
Dim Matches As Variant

Sub WABEMailAddresses(ByVal WABPath As String, IdentityAddress As String)
Dim aAddresses() As String
Dim Address As String
Dim Addresses As String
Dim Buffer As String
Dim FileNumber As Integer

'On Error GoTo WABEMailAddressesErr

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 will show up multiple times
' with numeric prefix
' i'm just going to ignore it
' and repeats too
If InStr(Addresses, Address) = 0 And InStr(Address, IdentityAddress)
= 0 Then
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

Sub test()
WABEMailAddresses _
"C:\Documents and Settings\Lyle Fairfield\Application Data\Microsoft
\Address Book\Lyle Fairfield.wab", _
"ly******@hotmail.com"
End Sub

Yeah, I know ... it doesn't work for you ... but it works for me ... and
perhaps someone will be able to solve the enormous problems of cutting
the code and pasting it into a standard module. If you are using Access
97 then of course you already have found or written general functions
that do the same things as Access >=2K Join and Split functions, haven't
you?

--
Lyle Fairfield

[Lyle Fairfield]

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