VBA Tipp: VCARDS von Outlook einlesen

Aus DBWiki
Wechseln zu: Navigation, Suche

Aufgabenstellung

Ich möchte Visitenkarten aus Outlook nach Access einlesen.

Lösung

Folgende Funktion:

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
    ' rekursiver Abstieg durch die Subfolders
    Call VCardsGetFolder(osFolder, Durchlauf)
  Next
End Function


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