18.01.2016

Outlook - Ordner im Postein- und Postausgang erstellen...

Outlook - Ordner im Posteingang und Postausgang erstellen. Wie geht das?

Create a folder in your Inbox and Outbox - Outlook. How does it work?

Option Explicit
'--------------------------------------------------------------------------
' Module    : Modul1
' Procedure : Main
' Author    : Case (Ralf Stolzenburg)
' Date      : 18.01.2016
' Purpose   : Outlook - Ordner unter Postein- und Postausgang erstellen...
'--------------------------------------------------------------------------
Sub Main()
    Dim objNewFolder As Object
    Dim varFolder As Variant
    Dim objFolder As Object
    Dim objOutApp As Object
    Dim objName As Object
    Dim blnTMP As Boolean
    On Error GoTo Fin
    varFolder = Application.InputBox("Ordnername?", Type:=2)
    If Not varFolder = False And Trim(varFolder) <> "" Then
        Set objOutApp = CreateObject("Outlook.Application")
        Set objName = objOutApp.GetNamespace("MAPI")
        ' 6 = olFolderInbox
        ' 4 = olFolderOutbox
        On Error Resume Next
        Set objFolder = objName.GetDefaultFolder(6)
        Set objNewFolder = objFolder.Folders.Add(varFolder)
        If Err.Number = 440 Then blnTMP = True
        Err.Clear
        On Error GoTo Fin
        Set objFolder = objName.GetDefaultFolder(4)
        Set objNewFolder = objFolder.Folders.Add(varFolder)
    End If
Fin:
    Select Case Err.Number
        Case 440
            MsgBox "Ordner bereits vorhanden!"
        Case 0
        Case Else
            MsgBox "Fehler: " & Err.Number & " " & Err.Description
    End Select
    Set objNewFolder = Nothing
    Set objFolder = Nothing
    Set objName = Nothing
    Set objOutApp = Nothing
End Sub
' Nachfolgend die Elemente bzw. Konstanten von "OlDefaultFolders"
' Entnommen aus Objektkatalog (F2 im VBA-Editor) in Outlook 2010
'Const olFolderCalendar = 9
'Const olFolderConflicts = 19 (&H13)
'Const olFolderContacts = 10
'Const olFolderDeletedItems = 3
'Const olFolderDrafts = 16 (&H10)
'Const olFolderInbox = 6
'Const olFolderJournal = 11
'Const olFolderJunk = 23 (&H17)
'Const olFolderLocalFailures = 21 (&H15)
'Const olFolderManagedEmail = 29 (&H1D)
'Const olFolderNotes = 12
'Const olFolderOutbox = 4
'Const olFolderRssFeeds = 25 (&H19)
'Const olFolderSentMail = 5
'Const olFolderServerFailures = 22 (&H16)
'Const olFolderSuggestedContacts = 30 (&H1E)
'Const olFolderSyncIssues = 20 (&H14)
'Const olFolderTasks = 13
'Const olFolderToDo = 28 (&H1C)
'Const olPublicFoldersAllPublicFolders = 18 (&H12)

04.01.2016

UserForm - Datum - Filtern - als PDF speichern...

In Spalte A steht fortlaufend das Datum. Dies soll über eine UserForm gefiltert und als PDF gespeichert werden.

In column A continuously is the date. This should be filtered through a UserForm and saved as a PDF.

Hier noch eine Beispieldatei / Here's a sample file:
UserForm - Datum - Filtern - als PDF speichern...[XLSM 60 KB]

' Variablendeklaration erforderlich
Option Explicit
'--------------------------------------------------------------------------
' Module    : UserForm1
' Procedure : UserForm_Activate
' Author    : © Case (Ralf Stolzenburg)
' Date      : 04.01.2016
' Purpose   : Bereich - Datum - Filtern - PDF speichern...
'--------------------------------------------------------------------------
Private Sub UserForm_Activate()
    ' Tabelle1 Spalte A in Combobox schreiben
    ComboBox1.List = Tabelle1.Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row).Value
    ' Inhalt ComboBox2 = ComboBox1
    ComboBox2.List = ComboBox1.List
    ' Eintrag in ComboBox1 komplett markieren - ersten Eintrag anzeigen
    With ComboBox1
        .ListIndex = 0
        .SetFocus
        .SelStart = 0
        .SelLength = Len(ComboBox1)
    End With
    ' 16ten Eintrag von ComboBox2 anzeigen (Zählung beginnt bei 0)
    ComboBox2.ListIndex = 15
End Sub
Private Sub CommandButton1_Click()
    ' Variablendeklaration
    Dim lngCalc As Long
    ' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke
    On Error GoTo Fin
    ' Die Excelapplikation wird ruhig gestellt - UNBEDINGT wieder einschalten
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        lngCalc = .Calculation
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
    End With
    ' Wenn ComboBox1 oder 2 leer ist - Meldung ausgeben
    If Me.ComboBox1.Text = "" Or Me.ComboBox2.Text = "" Then
        If Me.ComboBox1.Text = "" Then
            MsgBox "Startdatum angeben!"
            Me.ComboBox1.SetFocus
        Else
            MsgBox "Enddatum angeben!"
            ComboBox2.SetFocus
        End If
    Else
        ' Der Code bezieht sich auf ein bestimmtes Objekt
        ' Hier Tabelle1 = der CodeName der Tabelle
        ' Im VBA-Editor der Name VOR der Klammer - Tabelle1 (Tabelle1)
        ' im englischen Excel in der Regel Sheet1
        ' Alles was sich auf dieses "With" bezieht
        ' MUSS mit einem Punkt beginnen
        With Tabelle1
            ' Filtern und als PDF auf dem Desktop speichern
            .Range("A1").AutoFilter Field:=1, _
            Criteria1:=">=" & CDbl(DateValue(ComboBox1)), _
            Operator:=xlAnd, Criteria2:="<=" & CDbl(DateValue(ComboBox2))
            .ExportAsFixedFormat 0, Environ("UserProfile") & _
                "\Desktop\" & Left(ThisWorkbook.Name, _
                (InStrRev(ThisWorkbook.Name, ".") - 1)) & _
                Format(Now, "_DD.MM.YYYY"), , , , , , False
            ' Wenn Autofilter und gefiltert dann alle Daten zeigen
            If .AutoFilterMode And .FilterMode Then .ShowAllData
            ' Autofilter löschen
            .Rows.AutoFilter
            ' Seitenumbruchlinien ausblenden
            .DisplayAutomaticPageBreaks = False
        End With
    End If
Fin:
    ' Die Applikation aufwecken
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = lngCalc
        .DisplayAlerts = True
    End With
    ' Wenn die Fehlernummer NICHT 0 ist, dann gib die Fehlernummer
    ' und die Fehlerbeschreibung aus
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub
Private Sub ComboBox2_DropButtonClick()
    ' Eintrag in ComboBox2 komplett markieren
    With ComboBox2
        .SetFocus
        .SelStart = 0
        .SelLength = Len(ComboBox2)
    End With
End Sub
Private Sub CommandButton2_Click()
    ' UserForm entladen
    Unload Me
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    ' Schliessen über das "x" unterbinden
    If CloseMode = 0 Then Cancel = True
End Sub

Word - Kontrollkästchen (Formularsteuerelement) auslesen...

Aus allen Worddateien sollen die Kontrollkästchen (Formularsteuerelement) ausgelesen werden - Haken gesetzt oder nicht. Auch ein Textfeld (F...