Как импортировать адреса из WAB файлов?

[MagicMan]

Всем при!

Может кто знает как импортировать адреса из WAB файлов? Пробовал через cdo.dll - там можно вызвать диалоговое окно через mapmess.show со списком адресов, но как потом их программно запулучить так и не смог понять.

Был бы очень признателен. Нужно это для улучшения моей программы против спама - Anti-Spammer. (http://www.anti-spammer.ru)

Надеюсь на помощь,
Юрий.

[alibek]

Зачем антиспаму доступ к адресной книжке?
Это нужно скорее массмайлерам или вирусам.

[MagicMan]

Это нужно для импорта всех адресов в антиспаммер, так как он работает со списками (белыми и черными).

[Demonx]

Вот написал модуль для выдирания емэйлов с вабов:

Код: Выделить всё


Private WABData As String, WABEmail() As String

Public Sub WABLoad(wabFile As String)
WABData = Space(FileLen(wabFile))
Open wabFile For Binary As #1
    Get #1, , WABData
Close #1
End Sub

Public Function WABGetEmail() As String()
Dim Pos As Long, I As Long
Erase WABEmail
Pos = 1
Do
    Pos = WABFindEmail(Pos)
Loop Until Pos = 0
For I = 0 To UBound(WABEmail)
    MsgBox WABEmail(I)
Next I
End Function

Private Sub WABAddEmail(wabMail As String)
If WABExtArr = True Then
    ReDim Preserve WABEmail(UBound(WABEmail) + 1) As String
Else
    ReDim WABEmail(0) As String
End If
WABEmail(UBound(WABEmail)) = wabMail
End Sub

Private Function WABExtArr() As Boolean
On Error Resume Next
Dim Temp As String
Temp = WABEmail(0)
If Err.Number = 9 Then
    WABExtArr = False
Else
    WABExtArr = True
End If
End Function

Private Function WABFindEmail(Optional wabPos As Long = 1) As Long
On Error GoTo Error
Dim WABDog As Long, WABLeft As Long, WABRight As Long
Dim WABTemp As String
WABDog = InStr(wabPos, WABData, Chr(0) & Chr(64) & Chr(0))
WABLeft = InStrRev(WABData, Chr(0) & Chr(0), WABDog)
WABRight = InStr(WABDog, WABData, Chr(0) & Chr(0))
WABTemp = Replace(Mid$(WABData, WABLeft, WABRight - WABLeft), Chr(0), vbNullString)
If (WABCheckEmail(WABTemp) = True) And (WABExtEmail(WABTemp) = False) Then
    Call WABAddEmail(WABTemp)
End If
WABFindEmail = WABRight
Exit Function
Error:
WABFindEmail = 0
End Function

Private Function WABExtEmail(wabMail As String) As Boolean
Dim I As Long
If WABExtArr = True Then
    For I = 0 To UBound(WABEmail)
        If WABEmail(I) = wabMail Then
            WABExtEmail = True
            Exit Function
        End If
    Next I
    WABExtEmail = False
Else
    WABExtEmail = False
End If
End Function

Private Function WABCheckEmail(wabMail As String) As Boolean
Dim I As Integer
Dim Char As String
Dim C() As String
If Not wabMail Like "*@*.*" Then
    WABCheckEmail = False
    Exit Function
End If
C = Split(wabMail, ".", -1, vbBinaryCompare)
If Not Len(C(UBound(C))) = 3 And Not Len(C(UBound(C))) = 2 Then
    WABCheckEmail = False
    Exit Function
End If
For I = 1 To Len(C(UBound(C))) Step 1
    Char = Mid(C(UBound(C)), I, 1)
    If Not (LCase(Char) <= Chr(122)) Or Not (LCase(Char) >= Chr(97)) Then
        WABCheckEmail = False
        Exit Function
    End If
Next I
For I = 1 To Len(wabMail) Step 1
    Char = Mid(wabMail, I, 1)
    If (LCase(Char) <= Chr(122) And LCase(Char) >= Chr(97)) _
    Or (Char >= Chr(48) And Char <= Chr(57)) _
    Or (Char = ".") _
    Or (Char = "@") _
    Or (Char = "-") _
    Or (Char = "_") Then
        WABCheckEmail = True
    Else
        WABCheckEmail = False
        Exit Function
    End If
Next I
End Function


Использовать:

Код: Выделить всё


WABLoad "C:\Documents and Settings\xxx\Application Data\Microsoft\Address Book\xxx.wab"
WABGetEmail


[MagicMan]

СПАСИБО!

А из бата никто не знает как выдрать?

Надеюсь на помощь,
Юрий.