16.05.2018

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 eingegeben werden.
Show formulas on a UserForm in a TextBox. For example, "Formula", "FormulaLocal" ... and how to enter the formula in VBA.

Hier noch eine Beispieldatei / Here's a sample file:
Formeln auf einer UserForm in einer TextBox darstellen...[ZIP 20 KB]

Code gehört in eine UserForm (UserForm1) / Code belongs in a UserForm (UserForm1):

Option Explicit
'--------------------------------------------------------------------------
' Module    : UserForm1
' Procedure : UserForm_Activate
' Author    : Case (Ralf Stolzenburg)
' Date      : 16.05.2018
' Purpose   : Aktives Control in UserForm andere Farbe...
'--------------------------------------------------------------------------
Private Sub UserForm_Activate()
    Dim lngTMP As Long
    CommandButton1.TabStop = False
    With ActiveCell
        If .HasFormula Then
            TextBox1.Text = .Formula
            TextBox2.Text = .FormulaArray
            TextBox3.Text = .FormulaHidden
            TextBox4.Text = .FormulaLocal
            TextBox5.Text = .FormulaR1C1
            TextBox6.Text = .FormulaR1C1Local
            TextBox7.Text = Replace(.Formula, """", """""")
        Else
            For lngTMP = 1 To 6
                Me.Controls("TextBox" & lngTMP).Text = ""
            Next lngTMP
        End If
    End With
    Call StartTimer
    AppActivate Application.Caption
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    If CloseMode = 0 Then Cancel = True
    Call StopTimer
End Sub
Private Sub CommandButton1_Click()
    Unload Me
End Sub

Code gehört in ein Modul (Modul2) / Code belongs in a module (Module2):

Option Explicit
Option Private Module
Private Declare Function KillTimer Lib "user32.dll" _
    (ByVal hWnd As Long, ByVal nIDEvent As Long) As Long
Private Declare Function SetTimer Lib "user32.dll" _
    (ByVal hWnd As Long, ByVal nIDEvent As Long, _
    ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function FindWindow Lib "user32.dll" _
    Alias "FindWindowA" (ByVal lpClassName As String, _
    ByVal lpWindowName As String) As Long
Private Const EXUSERFORM = "ThunderDFrame"
Private hWnd As Long
'--------------------------------------------------------------------------
' Module    : Modul2
' Procedure : StartTimer
' Author    : Case (Ralf Stolzenburg)
' Date      : 16.05.2018
' Purpose   : Aktives Control in UserForm andere Farbe - API - Timer...
'--------------------------------------------------------------------------
Public Sub StartTimer()
    hWnd = FindWindow(EXUSERFORM, UserForm1.Caption)
    SetTimer hWnd, 0&, 100&, AddressOf ControlTimer
End Sub
Sub StopTimer()
    KillTimer hWnd, 0&
End Sub
Private Sub ControlTimer(ByVal hWnd As Long, ByVal nIDEvent As Long, _
    ByVal uElapse As Long, ByVal lpTimerFunc As Long)
    On Error Resume Next
    Dim objControl As Control
    For Each objControl In UserForm1.Controls
        If TypeName(objControl) <> "CommandButton" Then
            objControl.BackColor = &H80000005
        ElseIf TypeName(objControl) <> "TextBox" Then
            UserForm1.ActiveControl.BackColor = &H80FF80
        Else
            UserForm1.ActiveControl.BackColor = &H80000005
        End If
    Next objControl
End Sub

Code gehört in ein Modul (Modul1) / Code belongs in a module (Module1):

Option Explicit
Sub Main()
    UserForm1.Show 0
End Sub

Code gehört in den Codebereich des Tabellenblattes / Code belongs in the code area of the worksheet:

Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim lngTMP As Long
    If Not Target.CountLarge > 1 Then
        With Target
            If .HasFormula Then
                UserForm1.TextBox1.Text = .Formula
                UserForm1.TextBox2.Text = .FormulaArray
                UserForm1.TextBox3.Text = .FormulaHidden
                UserForm1.TextBox4.Text = .FormulaLocal
                UserForm1.TextBox5.Text = .FormulaR1C1
                UserForm1.TextBox6.Text = .FormulaR1C1Local
                UserForm1.TextBox7.Text = Replace(.Formula, """", """""")
            Else
                For lngTMP = 1 To 6
                    UserForm1.Controls("TextBox" & lngTMP).Text = ""
                Next lngTMP
            End If
        End With
    End If
End Sub

04.04.2018

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

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

Hier noch eine Beispieldatei:
Word - Kontrollkästchen (Formularsteuerelement) auslesen...[ZIP 50 KB]

Option Explicit
Const wdFieldFormCheckBox = 71
Dim blnTMP As Boolean
'--------------------------------------------------------------------------
' Module    : Modul1
' Procedure : Main
' Author    : Case (Ralf Stolzenburg)
' Date      : 04.04.2018
' Purpose   : Aus Worddokumenten Kontrollkästchen (Formularsteuerelement)
'--------------------------------------------------------------------------
Public Sub Main()
    ' Dimensionieren der Variablen
    Dim wksSheet As Worksheet
    Dim objDocument As Object
    Dim fmControl As Object
    Dim lngLastRow As Long
    Dim strDatei As String
    Dim strPath As String
    Dim objApp As Object
    Dim lngCalc As Long
    ' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke
    On Error GoTo Fin
    ' Die Excelapplikation wird ruhig gestellt
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        lngCalc = .Calculation
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
    End With
    ' Pfad anpassen - fester Pfad vorgeben
    'strPath = "C:\Temp\Word\"
    ' Pfad anpassen - Worddateien sind im gleichen
    ' Verzeichnis wie DIESE Exceldatei
    strPath = ThisWorkbook.Path & Application.PathSeparator
    Set objApp = OffApp("Word")
    ' Word nicht sichtbar
    'Set objApp = OffApp("Word", False)
    If Not objApp Is Nothing Then
        ' Temporäres Tabellenblatt hinzufügen
        Worksheets.Add After:=Worksheets(Worksheets.Count)
        Set wksSheet = ActiveSheet
        strDatei = Dir$(strPath & "*.doc*", vbDirectory)
        Do While strDatei <> ""
            ' Worddokument öffnen
            Set objDocument = objApp.Documents.Open _
                (strPath & strDatei)
            ' WENN vorhanden werden die Kontrollkästchen ausgelesen
            If objDocument.FormFields.Count <> 0 Then
                ' Nimm jedes Objekt, das zu den FormFields gehört
                For Each fmControl In objDocument.FormFields
                    ' Bestimme jetzt die Anzahl der Zeilen in Spalte A
                    With wksSheet
                        lngLastRow = IIf(IsEmpty(.Cells(.Rows.Count, 1)), _
                            .Cells(.Rows.Count, 1). _
                            End(xlUp).Row, .Rows.Count) + 1
                    End With
                    ' Dateiname in die erste Zelle schreiben
                    wksSheet.Cells(lngLastRow, 1).Value = strDatei
                    ' Pfad in den Kommentar schreiben
                    wksSheet.Cells(lngLastRow, 1).AddComment.Text _
                        strPath & strDatei
                    With fmControl
                        ' Ist es ein Kontrollkästchen?
                        If .Type = wdFieldFormCheckBox Then
                            ' Ist der Haken gesetzt?
                            If .CheckBox.Value = True Then
                                wksSheet.Cells(lngLastRow, 2).Value = _
                                    "Typ: " & .Type
                                wksSheet.Cells(lngLastRow, 3).Value = _
                                    "Haken gesetzt!"
                            ' Sonst
                            Else
                                wksSheet.Cells(lngLastRow, 2).Value = _
                                    "Typ: " & .Type
                                wksSheet.Cells(lngLastRow, 3).Value = _
                                    "Haken nicht gesetzt!"
                            End If
                        Else
                            wksSheet.Cells(lngLastRow, 4).Value = _
                                "Typ: " & .Type
                            wksSheet.Cells(lngLastRow, 5).Value = _
                                .Range.Text
                        End If
                    End With
                Next fmControl
            End If
            ' Worddokument ohne speichern schlissen
            objDocument.Close False
            ' Die nächste Datei nehmen
            strDatei = Dir$()
            Set objDocument = Nothing
        Loop
        ' Spaltenbreite automatisch setzen
        wksSheet.Cells.EntireColumn.AutoFit
    Else
        MsgBox "Applikation nicht installiert!"
    End If
Fin:
    If Not objApp Is Nothing Then
        If blnTMP = True Then
            objApp.Quit
            blnTMP = False
        End If
    End If
    ' Objektvariablen leeren
    Set wksSheet = Nothing
    Set objDocument = Nothing
    Set objApp = Nothing
    ' Die Applikation aufwecken
    With Application
        .ScreenUpdating = True
        .AskToUpdateLinks = True
        .EnableEvents = True
        .Calculation = lngCalc
        .DisplayAlerts = True
        .CutCopyMode = True
    End With
    ' 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    : Modul1
' Procedure : OffApp
' Author    : Case (Ralf Stolzenburg)
' Date      : 04.04.2018
' Purpose   : Start application...
'--------------------------------------------------------------------------
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

14.08.2017

PowerPoint - Fusszeile - TextBox befüllen - alle Folien...

PowerPoint alle Folien - in der Fusszeile die Textbox befüllen.

PowerPoint all slides - fill the text box in the footer.

Hier noch eine Beispieldatei / Here's a sample file:
PowerPoint - Fusszeile - TextBox befüllen - alle Folien...[ZIP 50 KB]

Option Explicit
' Speichername der Datei
Const strPPSave As String = "EXCELnachPP" ' anpassen!!!
' Leeres Slide in PowerPoint
Const ppLayoutBlank As Long = 12
' Objektvariable für Applikation
Dim objPP As Object
'--------------------------------------------------------------------------
' Module    : Module1
' Procedure : Main
' Author    : Case (Ralf Stolzenburg)
' Date      : 14.08.2017
' Purpose   : PowerPoint - Fusszeile - TextBox befüllen...
'--------------------------------------------------------------------------
Public Sub Main()
    ' Variablendeklaration
    Dim objPPPres As Object
    Dim objPPDoc As Object
    Dim intLeft As Integer
    Dim intTMP As Integer
    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
        ' Das Bildschirmaktualisierung wird unterbrochen
        .ScreenUpdating = False
        ' Ereignisroutinen werden deaktiviert
        .EnableEvents = False
        ' Auslesen der momentanen Einstellung für die Berechnung
        lngCalc = .Calculation
        ' Setzen der Berechnung auf "Manuell"
        .Calculation = xlCalculationManual
        '  Eingabeaufforderungen und Warnmeldungen unterdrücken
        .DisplayAlerts = False
    End With
    ' PowerPoint starten
    ' Wenn PowerPoint ausgeblendet werden soll, dann so:
    ' http://vbanet.blogspot.de/2010/09/excel-powerpoint.html
    Set objPP = OffApp("PowerPoint")
    If Not objPP Is Nothing Then
        With objPP
            ' Vorhandene Präsentation öffnen GLEICHER Ordner wie die Exceldatei
            Set objPPPres = .Presentations.Open _
                (Filename:=ThisWorkbook.Path & _
                Application.PathSeparator & "Test.pptx")
            ' Schleife über alle Folien
            For intTMP = 1 To objPPPres.Slides.Count
                Set objPPDoc = objPPPres.Slides(intTMP)
                ' Fusszeile TextBox mit Name: "Footer Placeholder 3" befüllen
                objPPDoc.Shapes("Footer Placeholder 3").TextFrame.TextRange.Text = _
                    ThisWorkbook.Worksheets("Tabelle1").Range("C3").Value
                Set objPPDoc = Nothing
            Next intTMP
            ' Unter neuem Namen speichern
            objPPPres.SaveAs ThisWorkbook.Path & _
                Application.PathSeparator & strPPSave & _
                Format(Now, "ddMMyyyy_hhmmss")
            ' Auf langsamen Netzlaufwerken kann es zu Problemen kommen (Speichern)
            ' Deshalb hier 2 Sekunden Wartezeit - kann natürlich
            ' bei Bedarf auskommentiert bzw. verändert werden
            Application.Wait Now + TimeSerial(0, 0, 2)
            ' Präsentation Schliessen
            objPPPres.Close
            ' PP beenden
            .Quit
        End With
    Else
        MsgBox "Application not installed!"
    End If
Fin:
    ' Objektvariablen zurücksetzen
    Set objPPDoc = Nothing
    Set objPPPres = Nothing
    Set objPP = Nothing
    ' Die Applikation aufwecken
    With Application
        ' Bildschirmaktualisierung wieder einschalten
        .ScreenUpdating = True
        ' Ereignisroutinen werden wieder aktiviert
        .EnableEvents = True
        ' Setzen der Berechnung auf den gemerkten Wert
        .Calculation = lngCalc
        ' Eingabeaufforderungen und Warnmeldungen wieder zulassen
        .DisplayAlerts = True
        ' Abbrechen Ausschneide- bzw. Kopiermodus und entfernen des Laufrahmens
        .CutCopyMode = True
    End With
    ' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub
'--------------------------------------------------------------------------
' Module    : Module1
' Procedure : OffApp
' Author    : Case (Ralf Stolzenburg)
' Date      : 14.08.2017
' Purpose   : Start application...
'--------------------------------------------------------------------------
Private Function OffApp(ByVal strApp As String, _
    Optional blnVisible As Boolean = True) As Object
    On Error Resume Next
    Set objPP = GetObject(, strApp & ".Application")
    Select Case Err.Number
        Case 429
            Err.Clear
            Set objPP = CreateObject(strApp & ".Application")
            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

24.04.2017

Google Maps - Strasse aus Name, PLZ und Ort ausgeben...

Gegeben: Name, PLZ und Stadt der Firma. In Zelle daneben: Straße schreiben.
Bitte beachten: Es gibt Einschränkungen bei der Anzahl der Abfragen in Google Maps. Informieren Sie sich bitte über ALLE Einschränkungen.

Given: name, zip code and city of the company. In cell next to it: write street. Please note: There are restrictions on the number of queries in Google Maps. Please inform yourself about ALL restrictions.

Hier noch eine Beispieldatei / Here's a sample file:
Google Maps - Strasse aus Name, PLZ und Ort ausgeben...[XLSB 25 KB]

Option Explicit
'--------------------------------------------------------------------------
' Module    : modAddress
' Procedure : Main
' Author    : Case (Ralf Stolzenburg)
' Date      : 23.04.2017
' Purpose   : Google Maps - Strasse aus Name, PLZ und Ort ausgeben...
'--------------------------------------------------------------------------
Public Sub Main()
    Dim wksSheet As Worksheet
    Dim objXMLHTTP As Object
    Dim strFirma As String
    Dim varArr As Variant
    Dim objXML As Object
    Dim strURL As String
    Dim strPLZ As String
    Dim strOrt As String
    Dim lngCalc As Long
    Dim lngRow 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
        .AskToUpdateLinks = False
        .EnableEvents = False
        lngCalc = .Calculation
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
    End With
    ' Tabellenblattname - bei Bedarf anpassen
    Set wksSheet = ThisWorkbook.Worksheets("Address")
    ' XMLHttpRequest Objekt = Transport von Daten über das Webprotokoll HTTP
    Set objXMLHTTP = CreateObject("MSXML2.XMLHTTP")
    ' Der Code bezieht sich auf ein bestimmtes Objekt
    ' Hier das Objekt (bzw. die Variable) wksSheet
    ' Alles was sich auf dieses "With" bezieht
    ' MUSS mit einem Punkt beginnen
    With wksSheet
        ' Von der ersten Zeile bis zur letzten in Spalte A
        For lngRow = 1 To IIf(Len(.Cells(.Rows.Count, 1)), .Rows.Count, _
            .Cells(.Rows.Count, 1).End(xlUp).Row)
            ' Firmenname - Umlaute umwandeln (ä in ae usw.)
            strFirma = fncUmHTM(.Cells(lngRow, 1).Text)
            ' Postleitzahl
            strPLZ = .Cells(lngRow, 2).Text
            ' Ort/Stadt - Umlaute umwandeln (ä in ae usw.)
            strOrt = fncUmHTM(.Cells(lngRow, 3).Text)
            ' Internetadresse zusammensetzen
            strURL = "http://maps.googleapis.com/maps/api/geocode/xml?address=" & _
                strFirma & "%20" & strPLZ & "%20" & strOrt & "&sensor=false"
            ' Wie gehabt With siehe oben...
            With objXMLHTTP
                ' HTTP Kommando, URL angeben, False = Daten Synchron laden
                .Open "GET", strURL, False
                ' Anfrage absenden
                .Send
            End With
            ' Status 200 - alles OK
            If objXMLHTTP.Status = 200 Then
                ' Rückgabe XML
                Set objXML = CreateObject("MSXML2.DOMDocument")
                With objXML
                    ' Der komplette Rückgabetext
                    .LoadXML objXMLHTTP.ResponseText
                    ' Es wurde was gefunden
                    If .ParseError.ErrorCode = 0 Then
                        ' Text am Komma aufsplitten und Strasse ausgeben
                        ' Wenn Strasse nicht an erster Stelle MUSS angepasst werden
                        wksSheet.Cells(lngRow, 4).Value = _
                            Split(.SelectSingleNode("//formatted_address").Text, ",")
                    ' sonst Fehler in die Zelle schreiben
                    Else
                        wksSheet.Cells(lngRow, 4).Value = "Kein Ergebnis!"
                    End If
                End With
            Else
                wksSheet.Cells(lngRow, 4).Value = "Fehler"
            End If
        Set objXML = Nothing
        Next lngRow
    End With
Fin:
    ' Die Applikation aufwecken
    With Application
        .ScreenUpdating = True
        .AskToUpdateLinks = True
        .EnableEvents = True
        .Calculation = lngCalc
        .DisplayAlerts = True
    End With
    ' Setze die Objektvariablen auf Nothing
    Set wksSheet = Nothing
    Set objXML = Nothing
    Set objXMLHTTP = 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
' Umlaute umwandeln
Private Function fncUmHTM(strTMP As String) As String
    Dim varS As Variant
    Dim varE As Variant
    Dim lngTMP As Long
    varS = Array("Ä", "Ö", "Ü", "ä", "ö", "ü", "ß")
    varE = Array("Ae", "Oe", "Ue", "ae", "oe", "ue", "ss")
    For lngTMP = 0 To UBound(varS)
        strTMP = Replace(strTMP, varS(lngTMP), varE(lngTMP))
    Next lngTMP
    fncUmHTM = strTMP
End Function

04.04.2017

Range - Picture - Outlook Body...

Range (mit Format und Daten Gültigkeit) als Bild in Outlook Body.

Range (with format and data validity) as image in Outlook Body.

Hier noch eine Beispieldatei / Here's a sample file:
Range - Picture - Outlook Body...[ZIP 40 KB]

Option Explicit
' Bedingte Kompilierung für 32/64 Bit
#If Win64 Then
    Private Declare PtrSafe Function SearchTreeForFile Lib "imagehlp.dll" _
        (ByVal RootPath As String, ByVal InputPathName As String, _
        ByVal OutputPathBuffer As String) As Long
    Private Declare PtrSafe Function MakeSureDirectoryPathExists _
        Lib "imagehlp.dll" (ByVal Pfad As String) As Long
#Else
    Private Declare Function SearchTreeForFile Lib "imagehlp.dll" _
        (ByVal RootPath As String, ByVal InputPathName As String, _
        ByVal OutputPathBuffer As String) As Long
    Private Declare Function MakeSureDirectoryPathExists _
        Lib "imagehlp.dll" (ByVal Pfad As String) As Long
#End If
Public Sub Main()
    ' Puffer für Pfad- und Dateiname festlegen
    Dim strPathName As String * 255
    Dim strName As String
    Dim objFSO As Object
    Dim lngCalc As Long
    Dim lngTMP 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
        .AskToUpdateLinks = False
        .EnableEvents = False
        lngCalc = .Calculation
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
    End With
    ' Verzeichnis im %Temp% Ordner wird erstellt
    Call MakeSureDirectoryPathExists(Environ("Temp") & "\TT\")
    ' Bereich "B3:D7" wird als Bild kopiert
    Call ThisWorkbook.Worksheets("Lieferung").Range("B3:D7").CopyPicture(xlScreen, xlBitmap)
    ' ERST hier die Bildschirmaktualisierung ausschalten, SONST BLEIBT DAS BILD LEER!
    Application.ScreenUpdating = False
    ' Tabellenblatt hinzufügen - dies ist dann automatisch das aktive
    ThisWorkbook.Worksheets.Add
    ' Bild in A1 einfügen
    ThisWorkbook.ActiveSheet.Paste
    ' Bereich als "htm-Datei" im %Temp% Ordner speichern. Dabei wird das Bild automatisch
    ' als PNG-Datei in einen Unterordner abgelegt
    With ThisWorkbook.PublishObjects.Add(xlSourceRange, _
        Environ("Temp") & "\TT\TT.htm", ActiveSheet.Name, "$A:$E", xlHtmlStatic, "TT", "")
        .Publish (True)
        .AutoRepublish = False
    End With
    ' Temporäres Tabellenblatt wieder löschen
    ThisWorkbook.ActiveSheet.Delete
    ' Grafikdatei suchen - hat immer den Namen (hier TT) und 001.png im Namen
    lngTMP = SearchTreeForFile(Environ("Temp"), "\TT\TT_*001.png", strPathName)
    ' Wenn gefunden...
    If lngTMP <> 0 Then
        ' Den Pfad- und Dateiname auf die richtige Länge eindampfen
        strPathName = Left$(strPathName, InStr(1, strPathName, vbNullChar) - 1)
        strName = RTrim(strPathName)
        ' Mail senden - mit dem Pfad- und Dateinamen der Grafikdatei
        Call Mail(strName)
    End If
    ' Ordner im %Temp% wieder löschen
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    objFSO.DeleteFolder (Environ("Temp") & "\TT"), True
Fin:
    ' Objektvariablen zurücksetzen
    Set objFSO = Nothing
    ' Die Applikation aufwecken
    With Application
        .ScreenUpdating = True
        .AskToUpdateLinks = True
        .EnableEvents = True
        .Calculation = lngCalc
        .DisplayAlerts = True
    End With
    ' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung
    If Err.Number <> 0 Then MsgBox "Fehler: " & _
        Err.Number & " " & Err.Description
End Sub
Sub Mail(ByVal strTMP As String)
    Dim objOutApp As Object
    Dim strText1 As String
    Dim strText2 As String
    Dim strText3 As String
    Dim strFile As String
    ' Outlook starten - gleich mit neuer Mail - das ist die 0 - Kontakt wäre 2
    Set objOutApp = CreateObject("Outlook.Application").CreateItem(0)
    ' Die Variable in der richtigen Form mit dem Pfad- und Dateinamen der Grafikdatei befüllen
    strFile = " <img src=""file://" & strTMP & """>"
    ' Texte die später im Body auftauchen sollen. Muss man so nicht machen
    ' Man kann auch alles mit HTML-Code im Body schreiben
    strText1 = "Sehr geehrte Damen und Herren,"
    strText2 = "wir benötigen nächste Woche folgende LKW's:"
    With objOutApp
        ' Standardsignatur aufrufen und...
        .GetInSpector.Display
        ' ... zwischenspeichern
        strText3 = .HTMLBody
        ' An...
        .To = "Mail@dd.de"
        '.CC = "An@WenNoch.de
        ' Versteckte Empfänger...
        '.BCC = "AuchNoch@AnDen.de; UndNoch@AnJene.de"
        ' Anhang...
        '.Attachments.Add "C:\Temp\IrgendwasVonIrgendwo.xlsx"
        ' Betreff...
        .Subject = "Lieferungen " & ThisWorkbook.Worksheets("Lieferung").Range("A1").Text & "/" & Year(Date)
        ' Body...
        .HTMLBody = strText1 & "<br>" & "<br>" & strText2 & "<br>" & "<br>" & strFile & strText3
        ' Hier wird die Mail angezeigt, sonst gleich ".Send"
        .Display
        '.Send
    End With
    Set objOutApp = Nothing
End Sub

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 ...