28.02.2013

PowerPoint - Bilder nach Excel holen - the next level...

Frage: Zu dem Thema "Bilder aus PowerPoint nach Excel" gab es verschiedene Nachfragen. Die Bilder werden nicht permanent gespeichert. Ein Problem aus Excel 2010. Im Netz gibt es verschiedene Lösungen. Ich lade die Bilder in ein ActiveX Steuerelement (Image). Die Verzeichnisauswahl (temporäre Bilder) habe ich geändert. PowerPoint soll minimiert werden. Läuft nicht unter PowerPoint 2003. Codezeile löschen oder kommentieren. Getestet in Excel 2007 und 2010. Für andere Versionen muss gegebenenfalls angepasst werden.

On the topic of "images from PowerPoint to Excel" there were different demands. The images are not stored permanently. A problem of Excel 2010. On the web there are various solutions. I load the images in an ActiveX control (Image). The directory selection (temporary images) I have changed. PowerPoint should be minimized. Does not work in PowerPoint 2003. Line of code to delete or comment. Tested in Excel 2007 and 2010. For other versions may need to be adjusted.

Hier noch eine Beispieldatei / Here's a sample file:
PowerPoint - Bilder nach Excel holen - the next level...[ZIP 500 KB]

Option Explicit
Private Declare Function GetWindowText Lib "user32" _
    Alias "GetWindowTextA" (ByVal hwnd As Long, _
    ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function FindWindow Lib "user32" _
    Alias "FindWindowA" (ByVal lpClassName As String, _
    ByVal lpWindowName As String) As Long
Private Declare Function ShowWindow Lib "user32" (ByVal _
    hwnd As Long, ByVal nCmdShow As Long) As Long
Private Declare Function GetWindow Lib "user32" _
    (ByVal hwnd As Long, ByVal wCmd As Long) As Long
Private Declare Function GetParent Lib "user32" _
    (ByVal hwnd As Long) As Long
Private Declare Function PathFileExists Lib "shlwapi.dll" _
    Alias "PathFileExistsA" (ByVal pszPath As String) As Long
Private Declare Function MakeSureDirectoryPathExists _
    Lib "imagehlp.dll" (ByVal Pfad As String) As Long
Private Declare Function SafeArrayGetDim Lib "oleaut32.dll" _
    (ByRef pArray() As Any) As Long
Private strList() As String
Private lngCount As Long
Const GW_HWNDNEXT = 2
Const SW_MINIMIZE = 6
' TEMP Pfad - muss in der Regel nicht angepasst werden 
Const strPath As String = "C:\PicTMP"
' Konstanten 
Const strName As String = "tmp"
Const PpSaveAsHTML = 12
' Variablen 
Dim blnPPT As Boolean
Dim blnTMP As Boolean
Dim objPP As Object
'-------------------------------------------------------------------------- 
' Module    : Module1 
' Procedure : Main 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 28.02.2013 
' Purpose   : Bilder aus PowerPoint nach Excel holen... 
'-------------------------------------------------------------------------- 
Public Sub Main()
    ' Variablendeklaration 
    Dim intCount As Integer
    Dim lngRow As Long
    ' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke 
    On Error GoTo Fin
    ' Die PowerPointapplikation starten 
    Set objPP = OffApp("PowerPoint")
    If Not objPP Is Nothing Then
        ' Die Sub "PPPicture" mit Parameter aufrufen 
        PPPicture ThisWorkbook.Path & Application.PathSeparator & _
            "Picture.ppt"
        SearchFiles strPath, "*.jpg"
        ' In Zeile 2 mit dem Einfügen beginnen 
        lngRow = 2
        ' Wenn das Array dimensioniert, dann... 
        If SafeArrayGetDim(strList) <> 0 Then
            ' Schleife über alle Einträge 
            For intCount = Lbound(strList) To Ubound(strList)
                With ThisWorkbook.Worksheets(1)
                ' Einfügen und anpassen 
                    With .OLEObjects(intCount + 1)
                        .Object.PictureSizeMode = fmPictureSizeModeStretch
                        .Object.Picture = LoadPicture(strList(intCount))
                    End With
                    ' Nächstes Bild 2 Zeilen weiter unten einfügen 
                    lngRow = lngRow + 2
                End With
            Next intCount
            ' Array leeren 
            Erase strList
        End If
    Else
        MsgBox "Application is not installed!"
    End If
Fin:
    ' Aufräumen 
    If Not objPP Is Nothing Then
        If blnPPT = True Then
            objPP.Quit
            blnPPT = False
        End If
    End If
    ' Wenn der Pfad existiert, dann lösche den Ordner 
    If IsFilePath(strPath) Then Call FolDel
    ' Objektvariable zurücksetzen 
    Set objPP = Nothing
    ' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung 
    If Err.Number <> 0 Then MsgBox "Fehler: " & _
        Err.Number & " " & Err.Description
End Sub
'-------------------------------------------------------------------------- 
' Module    : Module1 
' Procedure : OffApp 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 28.02.2013 
' Purpose   : Application starten... 
'-------------------------------------------------------------------------- 
Private Function OffApp(ByVal strApp As String, _
    Optional blnVisible As Boolean = False) As Object
    On Error Resume Next
    Set objPP = GetObject(, strApp & ".Application")
    Select Case Err.Number
        Case 429
            Err.Clear
            Set objPP = CreateObject(strApp & ".Application")
            blnPPT = True
            If blnVisible = True Then
                On Error Resume Next
                objPP.Visible = True
                Err.Clear
            End If
    End Select
    On Error GoTo 0
    Set OffApp = objPP
    Set objPP = Nothing
End Function
'-------------------------------------------------------------------------- 
' Module    : Module1 
' Procedure : PPPicture 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 28.02.2013 
' Purpose   : PowerPoint - Datei als HTML spaichern... 
'-------------------------------------------------------------------------- 
Private Sub PPPicture(strFileName As String)
    Dim objPPT As Object
    ' Ordner erstellen - beste Methode 
    MakeSureDirectoryPathExists strPath & Application.PathSeparator
    ' PowerPointdatei öffnen bzw. an Objektvariable binden 
    Set objPPT = objPP.Presentations.Open(strFileName)
    ' PowerPoint per API ausblenden 
    ' WICHTIG! Wenn es Probleme gibt die nächste Zeile AUSKOMMENTIEREN!!! 
    Call PP_Klein
    ' Als HTML speichern 
    objPPT.SaveAs strPath & Application.PathSeparator & _
        strName, PpSaveAsHTML
    ' Schliessen 
    objPPT.Close
    Set objPPT = Nothing
End Sub
Private Sub FolDel()
    Dim objFSO As Object
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    ' Ordner löschen 
    objFSO.DeleteFolder strPath
    Set objFSO = Nothing
End Sub
Private Function IsFilePath(strPath As String) As Boolean
    IsFilePath = CBool(PathFileExists(strPath))
End Function
Private Sub PP_Klein()
    Dim hWindow As Long
    hWindow = SearchHndByWndName_Parent("Microsoft PowerPoint")
    Call ShowWindow(hWindow, SW_MINIMIZE)
End Sub
Private Function SearchHndByWndName_Parent(strSearch As String) As Long
    Dim strTMP As String * 100
    Dim nhWnd As Long
    nhWnd = FindWindow(vbNullString, vbNullString)
    Do While Not nhWnd = 0
        If GetParent(nhWnd) = 0 Then
            GetWindowText nhWnd, strTMP, 100
            If InStr(strTMP, strSearch) > 0 Then
                SearchHndByWndName_Parent = nhWnd
                Exit Do
            End If
        End If
        nhWnd = GetWindow(nhWnd, GW_HWNDNEXT)
    Loop
End Function
'-------------------------------------------------------------------------- 
' Module    : Module1 
' Procedure : SearchFiles 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 28.02.2013 
' Purpose   : Dateiliste erstellen... 
'-------------------------------------------------------------------------- 
Private Sub SearchFiles(strFolder As String, strFileName As String)
    Dim objFolder As Object
    Dim objFile As Object
    Dim objFSO As Object
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    For Each objFile In objFSO.GetFolder(strFolder).Files
        If objFile.Name Like strFileName Then
            Redim Preserve strList(lngCount)
            strList(lngCount) = objFile.Path
            lngCount = lngCount + 1
        End If
    Next
    For Each objFolder In objFSO.GetFolder(strFolder).Subfolders
        SearchFiles strFolder & "\" & objFolder.Name, strFileName
    Next
End Sub

26.02.2013

Summe - Tabellenblätter - Zelle - Zellen...

Frage: Für jeden Tag eines Jahres gibt es ein Tabellenblatt. Zusätzlich noch ein Summentabellenblatt. In diesem möchte ich die Summe von einer oder zwei Zellen aus allen Tabellenblättern. Die Tabellenblätter haben das Datum als Namen. Deshalb möchte ich auch über die Eingabe eines Start- bzw. Enddatums die Summe dieser beiden Zellen wissen. Ein Tabellenblatt für jeden Tag des Jahres erstellen - siehe "http://vbanet.blogspot.de/2012/10/ein-tabellenblatt-fur-jeden-tag-des.html".

For each day of the year, there is a worksheet. Additionally a total spreadsheet. In this I would like the sum of one or two cells from all worksheets. The spreadsheets have the date as the name. So I want to know by entering a start and end date, the sum of these two cells. A worksheet for each day of the year to create - see "http://vbanet.blogspot.de/2012/10/ein-tabellenblatt-fur-jeden-tag-des.html".

Hier noch eine Beispieldatei / Here's a sample file:
Summe - Tabellenblätter - Zelle - Zellen...[XLS 900 KB]

Option Explicit
'-------------------------------------------------------------------------- 
' Module    : Modul1 
' Procedure : Main 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 26.02.2013 
' Purpose   : Sum certain worksheets certain areas... 
'-------------------------------------------------------------------------- 
Sub Main()
    ThisWorkbook.Worksheets("Total").Range("A2").Formula = _
        "=SUM('01.01.2013:31.12.2013'!B4)"
End Sub
'-------------------------------------------------------------------------- 
' Module    : Modul1 
' Procedure : Main_1 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 26.02.2013 
' Purpose   : Sum certain worksheets certain areas... 
'-------------------------------------------------------------------------- 
Sub Main_1()
    ThisWorkbook.Worksheets("Total").Range("B2").Formula = _
        "=SUM('01.01.2013:31.12.2013'!C4)"
End Sub
'-------------------------------------------------------------------------- 
' Module    : Modul1 
' Procedure : Main_2 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 26.02.2013 
' Purpose   : Sum certain worksheets certain areas... 
'-------------------------------------------------------------------------- 
Sub Main_2()
    ThisWorkbook.Worksheets("Total").Range("C2").Formula = _
        "=SUM('01.01.2013:31.12.2013'!B4:C4)"
End Sub
'-------------------------------------------------------------------------- 
' Module    : Modul1 
' Procedure : Main_3 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 26.02.2013 
' Purpose   : Sum certain worksheets certain areas... 
'-------------------------------------------------------------------------- 
Sub Main_3()
    With ThisWorkbook.Worksheets("Total").Range("A2")
        .Formula = "=SUM('01.01.2013:31.12.2013'!B4)"
        .Value = .Value
    End With
End Sub
'-------------------------------------------------------------------------- 
' Module    : Modul1 
' Procedure : Main_4 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 26.02.2013 
' Purpose   : Sum certain worksheets certain areas... 
'-------------------------------------------------------------------------- 
Sub Main_4()
    With ThisWorkbook.Worksheets("Total").Range("B2")
        .Formula = "=SUM('01.01.2013:31.12.2013'!C4)"
        .Value = .Value
    End With
End Sub
'-------------------------------------------------------------------------- 
' Module    : Modul1 
' Procedure : Main_5 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 26.02.2013 
' Purpose   : Sum certain worksheets certain areas... 
'-------------------------------------------------------------------------- 
Sub Main_5()
    With ThisWorkbook.Worksheets("Total").Range("C2")
        .Formula = "=SUM('01.01.2013:31.12.2013'!B4:C4)"
        .Value = .Value
    End With
End Sub
'-------------------------------------------------------------------------- 
' Module    : Modul1 
' Procedure : Main_6 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 26.02.2013 
' Purpose   : Sum certain worksheets certain areas... 
'-------------------------------------------------------------------------- 
Sub Main_6()
    With ThisWorkbook.Worksheets("Total")
        .Range("A2").Formula = _
            "=SUM('" & .Range("B10").Text & ":" & .Range("C10").Text & "'!B4)"
        .Range("A2").Value = .Range("A2").Value
    End With
End Sub
'-------------------------------------------------------------------------- 
' Module    : Modul1 
' Procedure : Main_7 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 26.02.2013 
' Purpose   : Sum certain worksheets certain areas... 
'-------------------------------------------------------------------------- 
Sub Main_7()
    With ThisWorkbook.Worksheets("Total")
        .Range("B2").Formula = _
            "=SUM('" & .Range("B10").Text & ":" & .Range("C10").Text & "'!C4)"
        .Range("B2").Value = .Range("B2").Value
    End With
End Sub
'-------------------------------------------------------------------------- 
' Module    : Modul1 
' Procedure : Main_8 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 26.02.2013 
' Purpose   : Sum certain worksheets certain areas... 
'-------------------------------------------------------------------------- 
Sub Main_8()
    With ThisWorkbook.Worksheets("Total")
        .Range("C2").Formula = _
            "=SUM('" & .Range("B10").Text & ":" & .Range("C10").Text & "'!B4:C4)"
        .Range("C2").Value = .Range("C2").Value
    End With
End Sub

22.02.2013

UserForm, ComboBox, TextBox - variabel ansprechen...

Frage: Userformen, ComboBoxen und Textboxen variabel ansprechen. Ich habe mehrere UserFormen. Auf Grund von Usereingaben muss eine bestimmte UserForm geöffnet werden. Eine TextBox soll schon einen bestimmten Text enthalten. Eine ComboBox einen bestimmten Wert anzeigen. Wie geht das?

User forms, combo boxes and text boxes respond variably. I have several user forms. Based on user input, a certain UserForm to open. A TextBox is already contain specific text. A ComboBox show a certain value. How does it work?

Hier noch eine Beispieldatei / Here's a sample file:
UserForm, ComboBox, TextBox variabel ansprechen...[XLS 60 KB]

Option Explicit
'-------------------------------------------------------------------------- 
' Module    : Module1 
' Procedure : Main 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 22.02.2013 
' Purpose   : UserForms and TextBoxes to address variable... 
'-------------------------------------------------------------------------- 
Public Sub Main()
    Dim intCount2 As Integer
    Dim intCount1 As Integer
    Dim intCount As Integer
    On Error GoTo Fin
    intCount2 = 1
    intCount1 = 2
    intCount = 3
    Call myForm("Userform" & intCount, "TextBox" & intCount1, _
        "ComboBox" & intCount2)
Fin:
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub
'-------------------------------------------------------------------------- 
' Module    : Module1 
' Procedure : myForm 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 22.02.2013 
' Purpose   : UserForms and TextBoxes to address variable... 
'-------------------------------------------------------------------------- 
Private Sub myForm(strForm As String, strBox As String, strCombo As String)
    Dim blnCombo As Boolean
    Dim blnForm As Boolean
    Dim blnBox As Boolean
    Dim intTMP As Integer
    Dim objBox As Object
    With ThisWorkbook.VBProject
        For intTMP = 1 To .VBComponents.Count
            If .VBComponents.Item(intTMP).Type = 3 Then
                If UCase$(.VBComponents.Item(intTMP).Name) = _
                    UCase$(strForm) Then
                    blnForm = True
                    For Each objBox In .VBComponents(strForm). _
                        Designer.Controls
                        If objBox.Name = strBox Then
                            blnBox = True
                        ElseIf objBox.Name = strCombo Then
                            blnCombo = True
                        End If
                        If blnBox And blnCombo Then
                            .VBComponents(strForm). _
                                Designer.Controls(strBox).Text = "Test"
                            .VBComponents(strForm). _
                                Designer.Controls(strCombo).ListIndex = 3
                            UserForms.Add(strForm).Show
                            .VBComponents(strForm). _
                                Designer.Controls(strBox).Text = ""
                            Exit For
                        End If
                    Next objBox
                End If
            End If
        Next intTMP
    End With
    If Not blnForm Then blnBox = True: blnCombo = True: _
        MsgBox "UserForm does not exist!", vbCritical
    If Not blnBox Then MsgBox "TextBox does not exist!", vbCritical
    If Not blnCombo Then MsgBox "ComboBox does not exist!", vbCritical
End Sub

14.02.2013

PowerPoint - Bilder nach Excel holen...

Frage: Eine Powerpointdatei enthält einige Bilder. Diese Bilder brauche ich in Excel. Wie geht das?
Info: Funktioniert nicht mit PowerPoint 2013 (im Moment). Speichern als HTML ist dort wohl nicht vorgesehen.

A PowerPoint file contains a few pictures. These pictures I need in Excel. How does it work?
Info: Does not work with PowerPoint 2013 (at the moment). Save as HTML is not well provided there.

Link: PP 2010 and Save as HTML...

Achtung! / Attention! PowerPoint - Bilder nach Excel holen - the next level...

Hier noch eine Beispieldatei / Here's a sample file:
PowerPoint - Bilder nach Excel holen...[ZIP 450 KB]

Option Explicit
Private Declare Function PathFileExists Lib "shlwapi.dll" _
    Alias "PathFileExistsA" (ByVal pszPath As String) As Long
Private Declare Function MakeSureDirectoryPathExists _
    Lib "imagehlp.dll" (ByVal Pfad As String) As Long
' TEMP Pfad - muss in der Regel nicht angepasst werden 
Const strPath As String = "C:\PicTMP"
' Konstanten 
Const strName As String = "tmp"
Const PpSaveAsHTML = 12
' Variablen 
Dim blnPPT As Boolean
Dim blnTMP As Boolean
Dim objPP As Object
'-------------------------------------------------------------------------- 
' Module    : Module1 
' Procedure : Main 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 14.02.2013 
' Purpose   : Bilder aus PowerPoint nach Excel holen... 
'-------------------------------------------------------------------------- 
Public Sub Main()
    ' Variablendeklaration 
    Dim objPicture As Picture
    Dim strTMPPath As String
    Dim strFile As String
    Dim lngRow As Long
    ' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke 
    On Error GoTo Fin
    ' Die PowerPointapplikation starten 
    Set objPP = OffApp("PowerPoint")
    If Not objPP Is Nothing Then
        ' Die Sub "PPPicture" mit Parameter aufrufen 
        PPPicture ThisWorkbook.Path & Application.PathSeparator & _
            "Picture.ppt"
        ' TEMP - Pfad bilden - muss NUR angepasst werden, wenn ENGLISCHE 
        ' Excelversion - dann heisst es NICHT "-Dateien" sondern "_files" 
        strTMPPath = strPath & Application.PathSeparator & _
            strName & "-Dateien" & Application.PathSeparator
        ' Erste Grafikdatei in Variable holen 
        strFile = Dir$(strTMPPath & "*.jpg", vbDirectory)
        ' In Zeile 2 mit dem Einfügen beginnen 
        lngRow = 2
        ' Mach das solange bis keine JPG-Datei mehr im Ordner ist 
        Do While strFile <> ""
            With ThisWorkbook.Worksheets(1)
                ' Einfügen und anpassen 
                With .Cells(lngRow, 2)
                    Set objPicture = .Parent.Pictures.Insert _
                        (strTMPPath & strFile)
                    objPicture.Top = .Top
                    objPicture.Left = .Left
                    objPicture.Height = .Height
                    objPicture.Width = .Width
                End With
                ' Nächstes Bild 2 Zeilen weiter unten einfügen 
                lngRow = lngRow + 2
            End With
            ' Nächste Datei in die Variable holen 
            strFile = Dir$()
        Loop
        ' Wenn der Pfad existiert, dann lösche den Ordner 
        If IsFilePath(strPath) Then Call FolDel
    Else
        MsgBox "Application is not installed!"
    End If
Fin:
    ' Aufräumen 
    If Not objPP Is Nothing Then
        If blnPPT = True Then
            objPP.Quit
            blnPPT = False
        End If
    End If
    ' Objektvariable zurücksetzen 
    Set objPP = Nothing
    ' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung 
    If Err.Number <> 0 Then MsgBox "Fehler: " & _
        Err.Number & " " & Err.Description
End Sub
'-------------------------------------------------------------------------- 
' Module    : Module1 
' Procedure : OffApp 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 14.02.2013 
' Purpose   : Application starten... 
'-------------------------------------------------------------------------- 
Private Function OffApp(ByVal strApp As String, _
    Optional blnVisible As Boolean = False) As Object
    On Error Resume Next
    Set objPP = GetObject(, strApp & ".Application")
    Select Case Err.Number
        Case 429
            Err.Clear
            Set objPP = CreateObject(strApp & ".Application")
            blnPPT = True
            If blnVisible = True Then
                On Error Resume Next
                objPP.Visible = True
                Err.Clear
            End If
    End Select
    On Error GoTo 0
    Set OffApp = objPP
    Set objPP = Nothing
End Function
'-------------------------------------------------------------------------- 
' Module    : Module1 
' Procedure : PPPicture 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 14.02.2013 
' Purpose   : PowerPoint - Datei als HTML spaichern... 
'-------------------------------------------------------------------------- 
Private Sub PPPicture(strFileName As String)
    Dim objPPT As Object
    ' Ordner erstellen - beste Methode 
    MakeSureDirectoryPathExists strPath & Application.PathSeparator
    ' PowerPointdatei öffnen bzw. an Objektvariable binden 
    Set objPPT = objPP.Presentations.Open(strFileName)
    ' Als HTML speichern 
    objPPT.SaveAs strPath & Application.PathSeparator & _
        strName, PpSaveAsHTML
    ' Schliessen 
    objPPT.Close
    Set objPPT = Nothing
End Sub
Private Sub FolDel()
    Dim ObjFSO As Object
    Set ObjFSO = CreateObject("Scripting.FileSystemObject")
    ' Ordner löschen 
    ObjFSO.DeleteFolder strPath
    Set ObjFSO = Nothing
End Sub
Private Function IsFilePath(strPath As String) As Boolean
    IsFilePath = CBool(PathFileExists(strPath))
End Function

05.02.2013

Outlook - Entwürfe - Mails...

Frage: In Outlook im Ordner Entwürfe liegen einige Mails. Diese werden vor dem verschicken noch bearbeitet. Z. B. sollen Anhänge hinzugefügt werden. Das Beispiel unten funktioniert natürlich nur, wenn auch Mails im Ordner Entwürfe vorhanden sind!

In Outlook Drafts folder are some mails. These are still being processed before sending. E.G. attachments should be added. The example below only works if there are messages in the Drafts folder!

Hier noch eine Beispieldatei / Here's a sample file:
Outlook - Entwürfe - Mails...[XLS 40 KB]

Option Explicit
Dim blnTMP As Boolean
'-------------------------------------------------------------------------- 
' Module    : Module1 
' Procedure : Main 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 05.02.2013 
' Purpose   : Outlook Entwürfe auf Mails zugreifen... 
'-------------------------------------------------------------------------- 
Public Sub Main()
    Dim objNameSpace As Object
    Dim objFolder As Object
    Dim objItem As Object
    Dim objApp As Object
    On Error GoTo Fin
    'Set objApp = OffApp("Word") 
    'Set objApp = OffApp("Word", False) 
    Set objApp = OffApp("Outlook")
    'Set objApp = OffApp("Outlook", False) 
    'Set objApp = OffApp("PowerPoint") 
    'Set objApp = OffApp("PowerPoint, False") 
    'Set objApp = OffApp("ACCESS") 
    'Set objApp = OffApp("ACCESS", False) 
    If Not objApp Is Nothing Then
        Set objNameSpace = objApp.GetNamespace("MAPI")
        ' Nachfolgend die Elemente bzw. Konstanten von "OlDefaultFolders" 
        ' Entnommen aus Objektkatalog (F2 im VBA-Editor) in Outlook 2010 
        'Const olFolderCalendar = 9 
        'Const olFolderConflicts = 19 
        'Const olFolderContacts = 10 
        'Const olFolderDeletedItems = 3 
        Const olFolderDrafts = 16
        'Const olFolderInbox = 6 
        'Const olFolderJournal = 11 
        'Const olFolderJunk = 23 
        'Const olFolderLocalFailures = 21 
        'Const olFolderManagedEmail = 29 
        'Const olFolderNotes = 12 
        'Const olFolderOutbox = 4 
        'Const olFolderRssFeeds = 25 
        'Const olFolderSentMail = 5 
        'Const olFolderServerFailures = 22 
        'Const olFolderSuggestedContacts = 30 
        'Const olFolderSyncIssues = 20 
        'Const olFolderTasks = 13 
        'Const olFolderToDo = 28 
        'Const olPublicFoldersAllPublicFolders = 18 
        ' Hier ist jetzt der Ordner "Entwürfe" = "olFolderDrafts" = 16 
        Set objFolder = objNameSpace.GetDefaultFolder(olFolderDrafts)
        ' Ist überhaupt eine Mail in Entwürfe, dann... 
        If objFolder.Items.Count > 0 Then
            ' Schleife über alle Mails in Entwürfe 
            For Each objItem In objFolder.Items
                ' Ausgabe Anzahl der Anhänge 
                Debug.Print objItem.Attachments.Count
                ' Zwei Dateien anhängen 
                objItem.Attachments.Add "C:\Temp\Test.doc"
                objItem.Attachments.Add "C:\Temp\Test.txt"
                ' Ausgabe Anzahl der Anhänge 
                Debug.Print objItem.Attachments.Count
            Next objItem
        Else
            ' Hinweis - es ist keine Mail in Entwürfe 
            MsgBox "There are " & objFolder.Items.Count & " mail in draft."
        End If
    Else
        MsgBox "Application not installed!"
    End If
Fin:
    If Not objApp Is Nothing Then
        If blnTMP = True Then
            objApp.Quit
            blnTMP = False
        End If
    End If
    Set objFolder = Nothing
    Set objNameSpace = Nothing
    Set objApp = Nothing
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub
Private Function OffApp(ByVal strApp As String, _
    Optional blnVisible As Boolean = True) As Object
    Dim objApp As Object
    On Error Resume Next
    Set objApp = GetObject(, strApp & ".Application")
    Select Case Err.Number
        Case 429
            Err.Clear
            Set objApp = CreateObject(strApp & ".Application")
            blnTMP = True
            If blnVisible = True Then
                On Error Resume Next
                objApp.Visible = True
                Err.Clear
            End If
    End Select
    On Error GoTo 0
    Set OffApp = objApp
    Set objApp = Nothing
End Function

Wenn Sie weitere Informationen über die Mails im Ordner Entwürfe brauchen, dann klicken Sie einen Haltepunkt (oder F9) in folgender Codezeile "Debug.Print objItem.Attachments.Count". Verschiedene Informationen können im VBA Editor im Lokalfenster (z. B. Empfänger, Bodytext...) kontrolliert werden.

If you need more information about the messages in the Drafts folder, then click a breakpoint (or F9) in the following line of code "Debug.Print objItem.Attachments.Count". Various information in the VBA editor in the local window can be controlled (eg, recipient, body text ...).


Formeln auf einer UserForm in einer TextBox darstellen...

Formeln auf einer UserForm in einer TextBox anzeigen. Z. B. "Formula", "FormulaLocal"... und wie muss die Formel in VBA ...