Attribute VB_Name = "WD_Makros"
Option Explicit

Sub XLDiagrammErstellen()
    'Erstellt ein Kreis- oder Säulendiagramm aus dem Inhalt
    'der markierten Word-Tabelle und kopiert es in die Zwischenablage.
    '© 2000, Ralf Nebelo
    
    Dim objXL As Object
    Dim intTyp As Integer
    Dim intPlot As Integer
    Const xl3DColumn = -4100
    Const xl3DPie = -4102
    Const xlRows = 1
    Const xlColumns = 2
    Const xlLocationAsNewSheet = 1
    
    With Selection
        If Not .Information(wdWithInTable) Then
            MsgBox "Keine Tabelle markiert"
            Exit Sub
        Else
            .Tables(1).Select
            .Copy
        End If
    End With

    With frmListenfeld
        .Caption = "Diagramm erstellen"
        With .lstListe
            .Clear
            .AddItem "3D-Kreisdiagramm"
            .AddItem "3D-Säulendiagramm"
        End With
        
        .Show
        If .lstListe.Value > "" Then
            If .lstListe.Value = "3D-Kreisdiagramm" Then
                intTyp = xl3DPie
                intPlot = xlColumns
            Else
                intTyp = xl3DColumn
                intPlot = xlRows
            End If
        
            Set objXL = CreateObject("Excel.Application")
            If objXL Is Nothing Then
                MsgBox "Excel kann nicht gestartet werden."
                Exit Sub
            End If
            
            With objXL
                .Workbooks.Add
                .ActiveSheet.Paste
                .Charts.Add
                With .ActiveChart
                    .ChartType = intTyp
                    .SetSourceData Source:=objXL.Sheets("Tabelle1").UsedRange, PlotBy:=intPlot
                    .Location Where:=xlLocationAsNewSheet
                    .ChartArea.Copy
                End With
                .ActiveWorkbook.Close SaveChanges:=False
                .Quit
            End With
        
            Set objXL = Nothing
        
            MsgBox "Diagramm in Zwischenablage kopiert."
        End If
    End With
    Unload frmListenfeld
End Sub

Sub XLWochentagErmitteln()
    'Ermittelt den Wochentag eines im Dialog abgefragten Datums
    'und kopiert das Ergebnis in die Zwischenablage.
    '© 2000, Ralf Nebelo
    
    Dim objXL As Object
    Dim strVorgabe As String
    Dim strDatum As String
    Dim vntTage As Variant
    Dim intWochentagNr As Integer
    Dim strWochentag As String
    Dim objZwischenablage As New DataObject

    Set objXL = CreateObject("Excel.Application")
    If objXL Is Nothing Then
        MsgBox "Excel kann nicht gestartet werden."
        Exit Sub
    End If
    
    If IsDate(Selection.Text) Then
        strVorgabe = CDate(Selection.Text)
    Else
        strVorgabe = Date
    End If
    
    strDatum = InputBox("Datum:", "Wochentag ermitteln", strVorgabe)
    If strDatum > "" Then
        vntTage = Array("Montag", "Dienstag", "Mittwoch", "Donnerstag", "Freitag", "Samstag", "Sonntag")
        intWochentagNr = objXL.WorksheetFunction.Weekday(DateValue(strDatum), vbMonday)
        strWochentag = vntTage(intWochentagNr - 1)
        MsgBox strWochentag
        
        With objZwischenablage
            .SetText strWochentag
            .PutInClipboard
        End With
    End If

    Set objXL = Nothing
End Sub

Sub ACAdresseEinfügen()
    'Sucht eine Adresse in der Access-Datei AC-Beispiele.mdb
    'und fügt sie in das aktuelle Word-Dokument ein.
    'Erfordert Verweis auf "Microsoft DAO 3.6 Object Library"
    '© 2000, Ralf Nebelo

    Dim objDB As Object
    Dim objRS As Object
    Dim strNachname As String
    
    strNachname = InputBox("Gesuchter Nachname:", "Adresse suchen", "Piepenbrink")
    If strNachname > "" Then
        Set objDB = DBEngine.OpenDatabase(ActiveDocument.Path & "\ac-beispiele.mdb")
        Set objRS = objDB.OpenRecordset("SELECT * FROM Adressen")
        With objRS
            .FindFirst "Nachname = '" & strNachname & "'"
            If Not .NoMatch Then
                Selection.TypeText .Fields("Vorname") & " " & .Fields("Nachname") & vbCr
                Selection.TypeText .Fields("Adresse") & vbCr
                Selection.TypeText .Fields("PLZ") & " " & .Fields("Ort") & vbCr
            Else
                MsgBox "Nachname nicht gefunden."
            End If
            .Close
        End With
        Set objRS = Nothing
        
        objDB.Close
        Set objDB = Nothing
    End If
End Sub

Sub OLAdresseEinfügen()
    'Ermöglicht die Auswahl einer Outlook-Adresse und fügt diese
    'einschließlich einer automatisch generierten Anredezeile in
    'das Word-Dokument ein.
    '© 2000, Ralf Nebelo
    
    Dim objOL As Object
    Dim objOLNameSpace As Object
    Dim objOLKontaktOrdner As Object
    Dim objOLKontakt As Object
    Dim strEintrag As String
    Const olFolderContacts = 10

    On Error Resume Next
    
    Set objOL = CreateObject("Outlook.Application")
    If objOL Is Nothing Then
        MsgBox "Outlook kann nicht gestartet werden."
        Exit Sub
    End If
    
    Set objOLNameSpace = objOL.GetNamespace("MAPI")
    Set objOLKontaktOrdner = objOLNameSpace.GetDefaultFolder(olFolderContacts)
    
    With frmListenfeld
        .Caption = "Adressat wählen"
        For Each objOLKontakt In objOLKontaktOrdner.Items
            .lstListe.AddItem objOLKontakt.Subject
        Next
        
        .Show
        If .lstListe.Value > "" Then
            For Each objOLKontakt In objOLKontaktOrdner.Items
                If objOLKontakt.Subject = .lstListe.Value Then
                    strEintrag = objOLKontakt.Subject & vbCr
                    strEintrag = strEintrag & objOLKontakt.MailingAddressStreet & vbCr & vbCr
                    strEintrag = strEintrag & objOLKontakt.MailingAddressPostalCode & " " & objOLKontakt.MailingAddressCity
                    strEintrag = strEintrag & vbCr & vbCr & vbCr
                    If objOLKontakt.Title = "Herr" Then
                        strEintrag = strEintrag & "Sehr geehrter Herr " & objOLKontakt.LastName & ","
                    ElseIf objOLKontakt.Title = "Frau" Then
                        strEintrag = strEintrag & "Sehr geehrte Frau " & objOLKontakt.LastName & ","
                    Else
                        strEintrag = strEintrag & "Sehr geehrte Damen und Herren,"
                    End If
                    Selection.TypeText strEintrag
                    Exit For
                End If
            Next
        End If
    End With
    Unload frmListenfeld
        
    Set objOLNameSpace = Nothing
    Set objOLKontaktOrdner = Nothing
    Set objOL = Nothing
End Sub

Sub OLWiedervorlage()
    'Erstellt eine neue Outlook-Aufgabe mit automatischer Erinnerung für
    'die erneute Bearbeitung (Wiedervorlage) des aktuellen Dokuments.
    '© 2000, Ralf Nebelo
    
    Dim objOL As Object
    Dim objAufgabe As Object
    Dim strDokPfadname As String
    Const olTaskItem = 3
    Const olByReference = 4
    
    Set objOL = CreateObject("Outlook.Application")
    If objOL Is Nothing Then
        MsgBox "Outlook kann nicht gestartet werden."
        Exit Sub
    End If

    strDokPfadname = ActiveDocument.FullName
    
    Set objAufgabe = objOL.CreateItem(olTaskItem)
    With objAufgabe
        .Subject = "Wiedervorlage: " & strDokPfadname
        .StartDate = CStr(Date + 1)
        .ReminderSet = True
        .ReminderTime = CStr(Date + 1) & " 8:00"
        .Body = "Dokument zur erneuten Bearbeitung öffnen." & vbCr & vbCr
        .Attachments.Add strDokPfadname, olByReference, Len(.Body) + 1
        .Display
    End With
    
    Set objOL = Nothing
End Sub



