title image


Smiley Re: Outlook Visitenkarten (VCards) nach Access importieren...
Das geht so (ohne Prüfung auf doppelte VCards):



Private Flds As Collection, TempFileName As String, RS As DAO.Recordset



Function VCardsGetFolders()

Dim F, oSession As New MAPI.Session, oInfoStore As MAPI.InfoStore, oFolder As MAPI.Folder, _

Tmp As String, SQL As String



TempFileName = Environ("Temp") & "\ttt.vcf"

oSession.Logon

Set Flds = New Collection

For Each oInfoStore In oSession.InfoStores

Set oFolder = oInfoStore.RootFolder

Call VCardsGetFolder(oFolder, 1)

Next oInfoStore

Tmp = ""

For Each F In Flds

' Debug.Print "-->" & F

Tmp = Tmp & ",[" & F & "] Text(255)"

Next

On Error Resume Next

CurrentDb.Execute "DROP TABLE tblVCards"

On Error GoTo 0

SQL = "CREATE TABLE tblVCards (" & Mid(Tmp, 2) & ")"

Debug.Print SQL

CurrentDb.Execute SQL

Set RS = CurrentDb.OpenRecordset("tblVCards", dbOpenDynaset)

For Each oInfoStore In oSession.InfoStores

Set oFolder = oInfoStore.RootFolder

Call VCardsGetFolder(oFolder, 2)

Next oInfoStore

RS.Close

Set RS = Nothing

Kill TempFileName

End Function



Function VCardsGetFolder(oFolder As MAPI.Folder, Durchlauf As Long)

Dim osFolder As MAPI.Folder, oMsg As MAPI.Message, oAtt As MAPI.Attachment, _

FSO As New Scripting.FileSystemObject, Strm As Scripting.TextStream, _

T As Variant, Lines As Variant, I As Long, F As Variant, FName As String, FInhalt As String



For Each osFolder In oFolder.Folders

For Each oMsg In osFolder.Messages

For Each oAtt In oMsg.Attachments

If oAtt.Name Like "*.vcf" Then

If Durchlauf = 2 Then RS.AddNew

Debug.Print Durchlauf, oMsg.Subject, oAtt.Name

FSO.CreateTextFile TempFileName, True ' leere Datei anlegen

On Error Resume Next ' nicht alle Attachments sind lesbar

oAtt.WriteToFile TempFileName

On Error GoTo 0

Set Strm = FSO.OpenTextFile(TempFileName, ForReading)

If Not Strm.AtEndOfStream Then ' Datei ist nicht leer

Lines = Split(Strm.ReadAll, vbCrLf)

For I = LBound(Lines) To UBound(Lines)

T = InStr(Lines(I), ":")

If T > 0 Then

FName = Left(Left(Lines(I), T - 1), 50) ' Teil vor dem ":"

FInhalt = Mid(Lines(I), T + 1) ' Teil hinter dem ":"

If Durchlauf = 1 Then ' 1. Durchlauf - Feldnamen sammeln

F = ""

On Error Resume Next

F = Flds(FName)

On Error GoTo 0

If F = "" And FName "BEGIN" And FName "END" Then

Flds.Add FName, FName

End If

ElseIf Durchlauf = 2 Then ' 2. Durchlauf - Daten wegschreiben

If FInhalt "" And FName "BEGIN" And FName "END" Then RS(FName) = FInhalt

End If

End If

Next I

If Durchlauf = 2 Then RS.UpDate

End If

End If

Next oAtt

Next oMsg

Call VCardsGetFolder(osFolder, Durchlauf) ' rekursiver Abstieg durch die Subfolders

Next

End Function



Verweise auf die MS CDO Library (CDO.DLL - muss mit Outlook installiert werden) und auf die Scripting Runtime (SCRRUN.DLL) setzen!


Gruß aus dem Norden
Reinhard


Bitte immer die Access-Version angeben!
DB-Wiki


Wie man Fragen richtig stellt

YaccessAccess-FAQUnd ansonsten: Wikipedia




geschrieben von

Login

E-Mail:
  

Passwort:
  

Beitrag anfügen

Symbol:
 
 
 
 
 
 
 
 
 
 
 
 
 

Überschrift: