Attribute VB_Name = "OL_OOBrief"
Option Explicit


'Erfordert:
'- Deutsches Outlook XP/2003
'- Deutsches OpenOffice 2.0
'- Installiertes ActiveX-Control UniversalTools.ocx
'- Aktiven Windows Scripting Host

'Konstanten
Public Const APPNAME As String = "OpenOffice-Briefe"
Public Const VORLAGE As String = "OoVorlage.ott"
Public Const EXPORTDATEI As String = "OoKontakte.ods"

'**********************************************************************
'Makros
'**********************************************************************

Public Sub OoBrief_Anlegen()
    Dim strPfadname As String
    Dim objUniversalTools As Object
    Dim blnAbbruch As Boolean
    Dim objOoSM As Object
    Dim objOoDesktop As Object
    Dim objElement As Object
    Dim objOoDoc As Object
    Dim vntOoArg() As Variant
    
    'Fehlerverfolgung ausschalten
    On Error Resume Next
    
    'Wenn immer dieselbe Vorlage verwendet werden soll, dann...
    If CBool(GetSetting(APPNAME, "Einstellungen", "chkVorlageFix", True)) = True Then
        '... deren Pfadnamen aus Registry lesen
        strPfadname = GetSetting(APPNAME, "Einstellungen", "txtVorlage", HolPfadEigeneDateien & "\" & VORLAGE)
        
    'Ansonsten...
    Else
        '... Verweis auf ActiveX-Control UniversalTools.ocx holen
        Set objUniversalTools = CreateObject("UniversalTools.Control1")
        
        'Pfadnamen der Vorlage per FileOpen-Dialog abfragen
        strPfadname = objUniversalTools.FileOpen("Writer-Dokumentvorlagen", "*.ott", , , APPNAME & " - Dokumentvorlage wählen")
        'Wenn Dialog abgebrochen, dann...
        If strPfadname = "" Then
            '... Makro verlassen
            Exit Sub
        End If
    End If
    
    'Wenn Pfadname bekannt und Datei vorhanden, dann...
    If strPfadname <> "" And Dir(strPfadname) <> "" Then
        '... Verweis auf OO-ServiceManager einrichten
        Set objOoSM = CreateObject("com.sun.star.ServiceManager")
        'Desktop-Service starten
        Set objOoDesktop = objOoSM.createInstance("com.sun.star.frame.Desktop")

        'Alle ausgewählten Elemente im Kontakte-Ordner durchlaufen
        For Each objElement In ActiveExplorer.Selection
            'Wenn Element ein Kontakt ist (und keine Verteilerliste), dann...
            If TypeName(objElement) = "ContactItem" Then
                '... neues Writer-Dokument auf der Grundlage der gewählten Vorlage öffnen
                Set objOoDoc = objOoDesktop.loadComponentFromURL(Pfadname2Url(strPfadname), "_blank", 0, vntOoArg())
                'Wenn Anlegen des Dokuments erfolgreich war, dann...
                If Not objOoDoc Is Nothing Then
                    '... Platzhalter durch Daten des aktuellen Kontakts ersetzen
                    TextErsetzen objOoDoc, "[Kontaktname]", objElement.Subject
                    TextErsetzen objOoDoc, "[Adresse]", objElement.MailingAddress
                    TextErsetzen objOoDoc, "[Anrede]", objElement.Title
                    TextErsetzen objOoDoc, "[Vorname]", objElement.FirstName
                    TextErsetzen objOoDoc, "[Nachname]", objElement.LastName
                    TextErsetzen objOoDoc, "[Firmenname]", objElement.CompanyName
                    TextErsetzen objOoDoc, "[Straße]", objElement.MailingAddressStreet
                    TextErsetzen objOoDoc, "[Stadt]", objElement.MailingAddressCity
                    TextErsetzen objOoDoc, "[Bundesland]", objElement.MailingAddressState
                    TextErsetzen objOoDoc, "[Postleitzahl]", objElement.MailingAddressPostalCode
                    TextErsetzen objOoDoc, "[Land]", objElement.MailingAddressCountry
                    TextErsetzen objOoDoc, "[Telefon privat]", objElement.HomeTelephoneNumber
                    TextErsetzen objOoDoc, "[Telefon geschäftlich]", objElement.BusinessTelephoneNumber
                    TextErsetzen objOoDoc, "[E-Mail-Adresse]", objElement.Email1Address
                    TextErsetzen objOoDoc, "[Geschlecht]", objElement.Gender
                    
                    'Individuelle Anrede generieren und einfügen
                    TextErsetzen objOoDoc, "[IndividuelleAnrede]", HolAnrede(objElement)

                    'Verweis auf Dokument löschen (und Speicher freigeben)
                    Set objOoDoc = Nothing
                End If
            End If
        Next
        
        'Verweise auf auf OO-ServiceManager und Desktop-Service löschen
        Set objOoSM = Nothing
        Set objOoDesktop = Nothing
    
    'Wenn Vorlagendatei nicht vorhanden, dann...
    Else
        '... Fehler melden
        MsgBox "Die Vorlagendatei " & strPfadname & " ist nicht zu finden." & vbCr & "Bitte wählen Sie im Einstellungen-Dialog eine gültige Vorlagendatei.", vbInformation, APPNAME
    End If
End Sub

Public Sub OoBrief_Export()
    Dim intButton As Integer
    Dim objElementPool As Object
    Dim objOoSM As Object
    Dim objOoDesktop As Object
    Dim objOoDoc As Object
    Dim vntOoArg() As Variant
    Dim objOoTabelle As Object
    Dim intZeile As Integer
    Dim objElement As Object
    Dim strPfadname As String
    
    'Fehlerverfolgung ausschalten
    On Error Resume Next
    
    'Wenn nur ein Element im Kontaktordner markiert ist, dann...
    If ActiveExplorer.Selection.Count = 1 Then
        '... nachfragen, ob Auswahl korrekt ist
        intButton = MsgBox("Sind Sie sicher, dass Sie nur einen Kontakt exportieren möchten?" & vbCr & "Klicken Sie auf 'Nein', um alle Kontakte zu exportieren.", vbQuestion + vbYesNoCancel, APPNAME & " - Kontakte exportieren")
        'Wenn Antwort 'Ja' lautet, dann...
        If intButton = vbYes Then
            '... nur markierte Elemente exportieren
            Set objElementPool = ActiveExplorer.Selection
        
        'Wenn Antwort 'Nein' lautet, dann...
        ElseIf intButton = vbNo Then
            '... alle Elemente im Kontaktordner exportieren
            Set objElementPool = ActiveExplorer.CurrentFolder.Items
        
        'Wenn Antwort 'Abbrechen' lautet, dann...
        Else
            '... Makro verlassen
            Exit Sub
        End If
    
    'Falls mehr als ein Element im Kontaktordner markiert ist, dann...
    Else
        '... markierte Elemente exportieren
        Set objElementPool = ActiveExplorer.Selection
    End If
    
    'Verweis auf OO-ServiceManager einrichten
    Set objOoSM = CreateObject("com.sun.star.ServiceManager")
    'Desktop-Service starten
    Set objOoDesktop = objOoSM.createInstance("com.sun.star.frame.Desktop")
  
    'Neues Calc-Dokument anlegen
    Set objOoDoc = objOoDesktop.loadComponentFromURL("private:factory/scalc", "_blank", 0, vntOoArg())
    'Wenn Anlegen des Dokuments erfolgreich war, dann...
    If Not objOoDoc Is Nothing Then
        '... prüfen, ob "Tabelle1" existiert. Falls ja, dann...
        If objOoDoc.Sheets.hasByName("Tabelle1") Then
            '... Verweis auf Tabelle einrichten
            Set objOoTabelle = objOoDoc.Sheets.getByName("Tabelle1")
            'Zeilenzählung beginnen
            intZeile = 0
            
            'Referenzdatensatz für die automatische Feldzuordnung in erste
            'Tabellenzeile schreiben und dabei die gleichen, teilweise
            'falsch geschriebenen Datenfeldnamen verwenden
            With objOoTabelle
                .getCellByPosition(0, intZeile).String = "Anrede"
                .getCellByPosition(1, intZeile).String = "Vorname"
                .getCellByPosition(2, intZeile).String = "Name"
                .getCellByPosition(3, intZeile).String = "Firmenname"
                .getCellByPosition(4, intZeile).String = "Addresszeile 1"
                .getCellByPosition(5, intZeile).String = "Addresszeile 2"
                .getCellByPosition(6, intZeile).String = "Stadt"
                .getCellByPosition(7, intZeile).String = "Bundesland"
                .getCellByPosition(8, intZeile).String = "Postleitzahl"
                .getCellByPosition(9, intZeile).String = "Land"
                .getCellByPosition(10, intZeile).String = "Telefon privat"
                .getCellByPosition(11, intZeile).String = "Telefon geschäftlich"
                .getCellByPosition(12, intZeile).String = "E-Mail Addresse"
                .getCellByPosition(13, intZeile).String = "Geschlecht"
            End With
            
            'Alle Elemente in objElementPool durchlaufen
            For Each objElement In objElementPool
                'Wenn Element ein Kontakt ist (und keine Verteilerliste), dann...
                If TypeName(objElement) = "ContactItem" Then
                    '... Zeilenzähler erhöhen
                    intZeile = intZeile + 1
                    'Kontaktdaten in aktuelle Tabellenzeile schreiben
                    With objOoTabelle
                        .getCellByPosition(0, intZeile).String = objElement.Title
                        .getCellByPosition(1, intZeile).String = objElement.FirstName
                        .getCellByPosition(2, intZeile).String = objElement.LastName
                        .getCellByPosition(3, intZeile).String = objElement.CompanyName
                        .getCellByPosition(4, intZeile).String = objElement.MailingAddressStreet
                        .getCellByPosition(5, intZeile).String = ""
                        .getCellByPosition(6, intZeile).String = objElement.MailingAddressCity
                        .getCellByPosition(7, intZeile).String = objElement.MailingAddressState
                        .getCellByPosition(8, intZeile).String = objElement.MailingAddressPostalCode
                        .getCellByPosition(9, intZeile).String = objElement.MailingAddressCountry
                        .getCellByPosition(10, intZeile).String = objElement.HomeTelephoneNumber
                        .getCellByPosition(11, intZeile).String = objElement.BusinessTelephoneNumber
                        .getCellByPosition(12, intZeile).String = objElement.Email1Address
                        .getCellByPosition(13, intZeile).String = objElement.Gender
                    End With
                End If
            Next
        End If
    
        'Pfadname der Exportdatei aus Registry lesen
        strPfadname = GetSetting(OL_OOBrief.APPNAME, "Einstellungen", "txtExportdatei", OL_OOBrief.HolPfadEigeneDateien & "\" & EXPORTDATEI)
        With objOoDoc
            'Calc-Dokument unter diesem Pfadnamen abspeichern und...
            .storeAsURL Pfadname2Url(strPfadname), vntOoArg()
            '... dann schließen (einschließlich OpenOffice)
            .Close True
        End With
        
        'Erfolgsmeldung ausgeben
        MsgBox CStr(intZeile) & " Kontakt(e) nach " & strPfadname & " exportiert.", vbInformation, APPNAME & " - Kontakte exportieren"
        
        'Verweis auf Dokument löschen (und Speicher freigeben)
        Set objOoDoc = Nothing
    End If
    
    'Verweise auf auf OO-ServiceManager und Desktop-Service löschen
    Set objOoSM = Nothing
    Set objOoDesktop = Nothing
End Sub

Public Sub OoBrief_Optionen()
    With frmOoBriefOptionen
        'Titel der Userform festlegen
        .Caption = APPNAME & " - © 2005, c't + Ralf Nebelo"
        'Userform anzeigen
        .Show
    End With
End Sub

'**********************************************************************
'Routinen
'**********************************************************************

Public Function SchaltflächeAnlegen(objCB As CommandBar, strCaption As String, intFaceID As Integer, strMakro As String, blnGruppe As Boolean) As CommandBarButton
    Dim objCTL As CommandBarButton
            
    'Schaltfläche suchen
    Set objCTL = objCB.FindControl(Tag:=strCaption)
    'Wenn diese bereits existiert, dann...
    If Not objCTL Is Nothing Then
        '... löschen
        objCTL.Delete
    End If
    
    'Schaltfläche temporär anlegen
    Set objCTL = objCB.Controls.Add(Type:=msoControlButton, Temporary:=True)
    With objCTL
        'Gruppierung beginnen oder nicht
        .BeginGroup = blnGruppe
        'Beschriftung festlegen
        .Caption = strCaption
        'Tag-Wert festlegen
        .Tag = strCaption
        'Grafisches Symbol festlegen
        .FaceId = intFaceID
        'Stil festlegen
        .Style = msoButtonIconAndCaption
        'Makro zuweisen
        .OnAction = strMakro
    End With
    
    'Verweis auf Schaltfläche zurückgeben
    Set SchaltflächeAnlegen = objCTL
End Function

Private Function Pfadname2Url(strPfadname) As String
    Dim strTmp As String
    
    'Jeden Backslash durch Slash ersetzen
    strTmp = Replace(strPfadname, "\", "/")
    'Doppelpunkt durch Alt-124 ersetzen
    strTmp = Replace(strTmp, ":", "|")
    'Leerzeichen durch "%20" ersetzen
    strTmp = Replace(strTmp, " ", "%20")
    'File-Präfix hinzufügen
    strTmp = "file:///" + strTmp
    
    'URL zurückgeben
    Pfadname2Url = strTmp
End Function

Private Function TextErsetzen(objOoDoc As Object, strSuchtext As String, strErsatztext As String) As Integer
    Dim objErsetzen As Object
    
    'Wenn kein Ersatztext vorhanden ist (weil das jeweilige Datenfeld leer ist)
    'und Platzhalter NICHT gelöscht werden sollen, dann...
    If strErsatztext = "" And CBool(GetSetting(OL_OOBrief.APPNAME, "Einstellungen", "chkPlatzhalterLöschen", True)) = False Then
        '... gesuchten Text durch gesuchten Text ersetzen
        '(und somit Platzhalter erhalten)
        strErsatztext = strSuchtext
    End If
    
    'ReplaceDescriptor anlegen
    Set objErsetzen = objOoDoc.createReplaceDescriptor
    With objErsetzen
        'Groß-/Kleinschreibung nicht beachten
        .SearchCaseSensitive = False
        'Suchtext definieren
        .SearchString = strSuchtext
        'Ersatztext definieren
        .ReplaceString = strErsatztext
    End With
    
    'Alle Fundstellen ersetzen und Anzahl zurückgeben
    TextErsetzen = objOoDoc.replaceAll(objErsetzen)
End Function

Private Function HolAnrede(objKontakt As ContactItem) As String
    Dim strAnrede As String
    
    'Wenn Title-Wert "Frau" lautet, dann...
    If LCase(Trim(objKontakt.Title)) = "frau" Then
        '... Anrede zusammenbauen
        strAnrede = "Sehr geehrte Frau " & objKontakt.LastName
    'Wenn Title-Wert "Herr" lautet, dann...
    ElseIf LCase(Trim(objKontakt.Title)) = "herr" Then
        '... Anrede zusammenbauen
        strAnrede = "Sehr geehrter Herr " & objKontakt.LastName
    'Ansonsten...
    Else
        '... unpersönliche Anrede zusammenbauen
        strAnrede = "Sehr geehrte Damen und Herren"
    End If
    
    'Anrede zurückgeben
    HolAnrede = strAnrede
End Function

Public Function HolPfadEigeneDateien() As String
    Dim objWS As Object
    
    'Verweis auf Windows Scripting Host einrichten
    Set objWS = CreateObject("WScript.Shell")

    'Pfad des Ordners "Eigene Dateien" zurückgeben
    HolPfadEigeneDateien = objWS.SpecialFolders("MyDocuments")
End Function

