21.12.2012

Bilder aus Tabellenblatt auf Festplatte exportieren...

Frage:

In einem Tabellenblatt habe ich verschiedene Bilder. Manchmal muss ich ein Bild auf die Festplatte speichern. Dies möchte ich auf zwei Arten erreichen. Das Bild wird angeklickt und dann über einen Button oder eine Taste gespeichert. Oder das Bild wird angeklickt und sofort gespeichert. Wie geht das?

In a spreadsheet I have various images. Sometimes I need to save an image to the hard drive. I want to achieve this in two ways. The image is clicked and saved via a button or a key. Or the image is clicked and saved immediately. How does it work?

Hier noch eine Beispieldatei / Here's a sample file:
Bilder aus Tabellenblatt auf Festplatte exportieren...[XLS 160 KB]

Code gehört in "DieseArbeitsmappe" / Code belongs in "ThisworkBook":

Option Explicit
'-------------------------------------------------------------------------- 
' Module    : DieseArbeitsmappe / Thisworkbook 
' Procedure : Workbook_Open 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 21.12.2012 
' Purpose   : Mit einer Taste (hier F8) ein Makro starten... 
'-------------------------------------------------------------------------- 
Private Sub Workbook_Open()
    Application.OnKey "{F8}", "Modul1.ExportPicture"
End Sub
Private Sub Workbook_Deactivate()
    Application.OnKey "{F8}"
End Sub

Code gehört in ein Modul / Code belongs in a module:

Option Explicit
Private Declare Function MakeSureDirectoryPathExists _
    Lib "imagehlp.dll" (ByVal Pfad As String) As Long
'-------------------------------------------------------------------------- 
' Module    : Modul1 
' Procedure : ExportPicture 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 21.12.2012 
' Purpose   : Bild exportieren Verzeichnis bei Bedarf erstellen... 
'-------------------------------------------------------------------------- 
Public Sub ExportPicture()
    Dim strPicture As String
    Dim lngPicHeight As Long
    Dim lngPicWidth As Long
    Dim strChart As String
    Dim strSheet As String
    Dim strPath As String
    On Error Resume Next
    strPicture = Selection.Name
    If Not Err.Number = 1004 Then
        On Error GoTo 0
        On Error GoTo Fin
        Application.ScreenUpdating = False
        strSheet = "Tabelle1" ' anpassen!!! 
        strPath = "C:\Temp\" ' anpassen!!! 
        strPath = IIf(Right(strPath, 1) <> "\", strPath & "\", strPath)
        With Selection
            lngPicHeight = .ShapeRange.Height
            lngPicWidth = .ShapeRange.Width
        End With
        Charts.Add
        ActiveChart.Location Where:=xlLocationAsObject, Name:=strSheet
        Selection.Border.LineStyle = 0
        strChart = Selection.Name & " " & Split(ActiveChart.Name, " ")(2)
        With ActiveSheet
            With .Shapes(strChart)
                .Width = lngPicWidth
                .Height = lngPicHeight
            End With
            .Shapes(strPicture).Copy
            With ActiveChart
                .ChartArea.Select
                .Paste
            End With
            MakeSureDirectoryPathExists (strPath)
            .ChartObjects(1).Chart.Export Filename:=strPath & _
                strPicture & ".jpg", FilterName:="jpg"
            .Shapes(strChart).Cut
        End With
    End If
Fin:
    Application.CutCopyMode = False
    If Err.Number <> 0 Then MsgBox "Fehler: Kein Bild! " & _
        "Oder: " & Err.Number & " " & Err.Description
    Application.ScreenUpdating = True
End Sub

Code gehört in ein Modul / Code belongs in a module:

Option Explicit
Private Declare Function MakeSureDirectoryPathExists _
    Lib "imagehlp.dll" (ByVal Pfad As String) As Long
'-------------------------------------------------------------------------- 
' Module    : Modul2 
' Procedure : ExportPicture_1 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 21.12.2012 
' Purpose   : Bild exportieren Verzeichnis bei Bedarf erstellen... 
'-------------------------------------------------------------------------- 
Public Sub ExportPicture_1()
    Dim wksSheet As Worksheet
    Dim strPicture As String
    Dim lngPicHeight As Long
    Dim lngPicWidth As Long
    Dim strChart As String
    Dim strPath As String
    On Error Resume Next
    strPicture = Selection.Name
    If Not Err.Number = 1004 Then
        On Error GoTo 0
        On Error GoTo Fin
        Application.ScreenUpdating = False
        strPath = "C:\Temp\" ' anpassen!!! 
        strPath = IIf(Right(strPath, 1) <> "\", strPath & "\", strPath)
        With Selection
            lngPicHeight = .ShapeRange.Height
            lngPicWidth = .ShapeRange.Width
        End With
        Set wksSheet = Worksheets.Add
        Charts.Add
        ActiveChart.Location Where:=xlLocationAsObject, Name:=wksSheet.Name
        Selection.Border.LineStyle = 0
        strChart = Selection.Name & " " & Split(ActiveChart.Name, " ")(2)
        With wksSheet
            With .Shapes(strChart)
                .Width = lngPicWidth
                .Height = lngPicHeight
            End With
            Tabelle1.Shapes(strPicture).Copy
            With ActiveChart
                .ChartArea.Select
                .Paste
            End With
            MakeSureDirectoryPathExists (strPath)
            .ChartObjects(1).Chart.Export Filename:=strPath & _
                strPicture & ".jpg", FilterName:="jpg"
        End With
    End If
Fin:
    Application.CutCopyMode = False
    If Not wksSheet Is Nothing Then
        Application.DisplayAlerts = False
        wksSheet.Delete
        Application.DisplayAlerts = True
    End If
    Set wksSheet = Nothing
    If Err.Number <> 0 Then MsgBox "Fehler: Kein Bild! " & _
        "Oder: " & Err.Number & " " & Err.Description
    Application.ScreenUpdating = True
End Sub

Code gehört in ein Modul / Code belongs in a module:

Option Explicit
Option Private Module
Private Declare Function MakeSureDirectoryPathExists _
    Lib "imagehlp.dll" (ByVal Pfad As String) As Long
'-------------------------------------------------------------------------- 
' Module    : Modul3 
' Procedure : Test 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 21.12.2012 
' Purpose   : Bild exportieren Verzeichnis bei Bedarf erstellen... 
'-------------------------------------------------------------------------- 
Public Sub Test()
    ExportPicture_2 Application.Caller
End Sub
Public Sub ExportPicture_2(ByVal strShape As String)
    Dim wksSheet As Worksheet
    Dim lngPicHeight As Long
    Dim lngPicWidth As Long
    Dim strChart As String
    Dim strPath As String
    On Error Resume Next
    If Not Err.Number = 1004 Then
        On Error GoTo 0
        On Error GoTo Fin
        Application.ScreenUpdating = False
        strPath = "C:\Temp\" ' anpassen!!! 
        strPath = IIf(Right(strPath, 1) <> "\", strPath & "\", strPath)
        With Tabelle2.Shapes(strShape)
            lngPicHeight = .Height
            lngPicWidth = .Width
        End With
        Set wksSheet = Worksheets.Add
        Charts.Add
        ActiveChart.Location Where:=xlLocationAsObject, Name:=wksSheet.Name
        Selection.Border.LineStyle = 0
        strChart = Selection.Name & " " & Split(ActiveChart.Name, " ")(2)
        With wksSheet
            With .Shapes(strChart)
                .Width = lngPicWidth
                .Height = lngPicHeight
            End With
            Tabelle2.Shapes(strShape).Copy
            With ActiveChart
                .ChartArea.Select
                .Paste
            End With
            MakeSureDirectoryPathExists (strPath)
            .ChartObjects(1).Chart.Export Filename:=strPath & _
                Tabelle2.Shapes(strShape).Name & ".jpg", FilterName:="jpg"
        End With
    End If
Fin:
    Application.CutCopyMode = False
    If Not wksSheet Is Nothing Then
        Application.DisplayAlerts = False
        wksSheet.Delete
        Application.DisplayAlerts = True
    End If
    Set wksSheet = Nothing
    If Err.Number <> 0 Then MsgBox "Fehler: " & _
        Err.Number & " " & Err.Description
    Application.ScreenUpdating = True
End Sub

18.12.2012

In Worddokumenten Wörter ersetzen - Liste in Excel...

Frage:

In allen Worddokumenten - optional auch nur in bestimmten Worddateien mit Dateiauswahldialog - sollen Wörter ersetzt werden. Die Liste der alten bzw. neuen Wörter ist in Excel in den Spalten B und C. Wie geht das?
In all Word documents - also only in certain Word files with file selection dialog - words should be replaced. The list of old and new words is in an Excel file in columns B and C. How does it work?

Hier noch eine Beispieldatei / Here's a sample file:
In Worddokumenten Wörter ersetzen - Liste in Excel...[ZIP 50 KB]

Option Explicit
Const wdreplaceAll = 2
Dim blnTMP As Boolean
'-------------------------------------------------------------------------- 
' Module    : AllFiles 
' Procedure : Main 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 18.12.2012 
' Purpose   : In Worddokumenten Wörter ersetzen - Liste in Excel... 
'-------------------------------------------------------------------------- 
Public Sub Main()
    ' Dimensionieren der Variablen 
    Dim wksSheet As Worksheet
    Dim objDocument 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
        ' Tabellenblattname gegebenenfalls anpassen 
        Set wksSheet = ThisWorkbook.Worksheets("Tabelle1")
        ' Erste Worddatei in die Variable holen 
        strDatei = Dir$(strPath & "*.doc*", vbDirectory)
        ' Mach das so lange, bis keine Worddatei mehr da ist 
        Do While strDatei <> ""
            ' Worddokument öffnen 
            Set objDocument = objApp.Documents.Open _
                (strPath & strDatei)
            ' Schleife von Zeile 2 in Spalte B bis zum Ende von Spalte B 
            For lngLastRow = 2 To wksSheet.Cells _
                (wksSheet.Rows.Count, 2).End(xlUp).Row
                With objDocument.Content.Find
                    ' Diesen Text suchen 
                    .Text = wksSheet.Cells(lngLastRow, 2).Value
                    ' Mit diesem Text austauschen / ersetzen 
                    .Replacement.Text = wksSheet.Cells(lngLastRow, 3).Value
                    ' Tu es! 
                    .Execute Replace:=wdreplaceAll
                End With
            Next lngLastRow
            ' Worddokument MIT speichern schliessen 
            objDocument.Close True
            ' Die nächste Datei nehmen 
            strDatei = Dir$()
            ' Objektvariable leeren 
            Set objDocument = Nothing
        Loop
    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
    ' 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
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
Code gehört in das Modul "SomeFiles"
Option Explicit
Const wdreplaceAll = 2
Dim blnTMP As Boolean
'-------------------------------------------------------------------------- 
' Module    : SomeFiles 
' Procedure : Main_1 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 18.12.2012 
' Purpose   : In Worddokumenten Wörter ersetzen - Liste in Excel... 
'-------------------------------------------------------------------------- 
Public Sub Main_1()
    ' Dimensionieren der Variablen 
    Dim wksSheet As Worksheet
    Dim objDocument As Object
    Dim varFiles As Variant
    Dim intFiles As Integer
    Dim lngLastRow As Long
    Dim strDatei As String
    Dim objApp As Object
    Dim lngCalc As Long
    ' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke 
    On Error GoTo Fin
    ChDrive ("C")
    ChDir (ThisWorkbook.Path)
    ' Dateiauswahl - MEHRERE Dateien können ausgewählt werden 
    ' Mit STRG / CTRL bzw. mit der Umschalttaste 
    varFiles = Application.GetOpenFilename( _
        FileFilter:="Word-Dateien (*.doc*), *.doc*", _
        MultiSelect:=True)
    If Not VarType(varFiles) = vbBoolean Then
        ' Die Excelapplikation wird ruhig gestellt 
        With Application
            .ScreenUpdating = False
            .EnableEvents = False
            lngCalc = .Calculation
            .Calculation = xlCalculationManual
            .DisplayAlerts = False
        End With
        Set objApp = OffApp("Word")
        ' Word nicht sichtbar 
        'Set objApp = OffApp("Word", False) 
        If Not objApp Is Nothing Then
            ' Tabellenblattname gegebenenfalls anpassen 
            Set wksSheet = ThisWorkbook.Worksheets("Tabelle1")
            ' Mach das für alle im Dialog ausgewählten Dateien 
            For intFiles = 1 To Ubound(varFiles)
                ' Worddokument öffnen 
                Set objDocument = objApp.Documents.Open _
                    (varFiles(intFiles))
                ' Schleife von Zeile 2 in Spalte B bis zum Ende von Spalte B 
                For lngLastRow = 2 To wksSheet.Cells _
                    (wksSheet.Rows.Count, 2).End(xlUp).Row
                    With objDocument.Content.Find
                        ' Diesen Text suchen 
                        .Text = wksSheet.Cells(lngLastRow, 2).Value
                        ' Mit diesem Text austauschen / ersetzen 
                        .Replacement.Text = wksSheet.Cells(lngLastRow, 3).Value
                        ' Tu es! 
                        .Execute Replace:=wdreplaceAll
                    End With
                Next lngLastRow
                ' Worddokument MIT speichern schliessen 
                objDocument.Close True
                ' Objektvariable leeren 
                Set objDocument = Nothing
            ' Die nächste ausgewählte Datei 
            Next intFiles
        Else
            MsgBox "Application not installed!"
        End If
    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
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

12.12.2012

Word - Inhaltssteuerelemente auslesen...

Frage: Es gibt einige Worddokumente mit Inhaltssteuerelementen. Diese möchte ich gerne nach Excel auslesen. Wie geht das?

Hier noch eine Beispieldatei: Word - Inhaltssteuerelemente auslesen...[ZIP 100 KB]

Im Download ist das Exceldokument sowie ein paar Worddokumente mit Beispieldaten.

Option Explicit
Const wdContentControlCheckBox = 8
Dim blnTMP As Boolean
'-------------------------------------------------------------------------- 
' Module    : Modul1 
' Procedure : Main 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 12.12.2012 
' Purpose   : Aus Worddokumenten Inhaltssteuerelemente auslesen... 
'-------------------------------------------------------------------------- 
Public Sub Main()
    ' Dimensionieren der Variablen 
    Dim wksSheet As Worksheet
    Dim objDocument As Object
    Dim conControl 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 Inhaltssteuerelemente ausgelesen 
            If objDocument.ContentControls.Count <> 0 Then
                For Each conControl In objDocument.ContentControls
                    ' 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, 1).AddComment.Text _
                        strPath & strDatei
                    With conControl
                        If .Type = wdContentControlCheckBox Then
                            wksSheet.Cells(lngLastRow, 2).Value = _
                                "Typ: " & .Type
                            wksSheet.Cells(lngLastRow, 3).Value = _
                                "Tag: " & .Tag
                            wksSheet.Cells(lngLastRow, 4).Value = _
                                "Text: " & .Range.Text
                            wksSheet.Cells(lngLastRow, 5).Value = _
                                "Haken: " & .Checked
                        Else
                            wksSheet.Cells(lngLastRow, 6).Value = _
                                "Typ: " & .Type
                            wksSheet.Cells(lngLastRow, 7).Value = _
                                "Tag: " & .Tag
                            wksSheet.Cells(lngLastRow, 8).Value = _
                                "Text: " & .Range.Text
                        End If
                    End With
                Next conControl
            End If
            ' Worddokument ohne speichern schliessen 
            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
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

' Ausgegeben in WORD per Debug.Print 
' With conControl 
'     If .Type = wdContentControlCheckBox Then 
'         Debug.Print .Type & " - " & .Tag & _
'             " - " & .Range.Text & " - " & .Checked 
'     Else 
'         Debug.Print .Type & " - " & .Tag & " - " & .Range.Text 
'     End If 
' End With 

' Ergibt für das Dokument im Anhang: 
'0 - Titel - Titel 
'1 - Auftragsart - Worum geht es? 
'8 -  - ? - Wahr 
'8 -  - ? - Falsch 
'8 -  - ? - Wahr 
'8 -  - ? - Wahr 
'8 -  - ? - Falsch 
'8 -  - ? - Falsch 
'8 -  - ? - Falsch 
'1 - Leiter - Peter Muster 
'1 - Auftraggeber - Peter Muster 
'1 - Kunde - Kunde 1 
'6 - Beginn - 20.12.2012 
'6 - Ende - 21.12.2012 
'0 - Problembeschreibung - Keine Probleme bekannt 
'1 - Gesamtziel - Kein Ziel 
'0 - Teilziele - Teilziel 1 
'Teilziel 2 
'Teilziel 3 
'0 - Ergebnisse - Ergebnis 1 
'Ergebnis 2 
'0 - Leistungen - Leistung 1 
'Leistung 2 
'0 - Randbedingung - Randbedingung 
'0 - Auftragsorganisation - Firma 1 
'Peter Muster 
'Abteilung 1 
'Jobbezeichnung 1 
'Firma 2 
'Frank Muster 
'Abteilung 2 
'Jobbezeichnung 2 
'1 - Kosten - 2000 Euro 
'1 - Sonstiges - Keine weiteren Informationen 
'1 -  - Keine Anlagen 

' Die Konstanten: 
'wdContentControlBuildingBlockGallery = 5 
'wdContentControlCheckBox = 8 
'wdContentControlComboBox = 3 
'wdContentControlDate = 6 
'wdContentControlDropdownList = 4 
'wdContentControlGroup = 7 
'wdContentControlPicture = 2 
'wdContentControlRichText = 0 
'wdContentControlText = 1 

Verschiedene Links zu dem Thema:

Link 1
Link 2
Link 3
Link 4

11.12.2012

Internet - Dateien / Files - Download....

Frage / Question: Ich habe zwei Spalten. In der ersten Spalte steht ein Link zu den Dateien im Internet die ich downloaden will. In der zweiten Spalte der Name den die Datei erhalten soll. Basically what I have is two columns. The first has a url I can click on, which sends me to a download link that automatically brings up the Save As (Windows 7) box. The second column contains the name I would like the file to be.

Hier noch eine Beispieldatei / Here's a sample file: Internet - Dateien / Files - Download....

Option Explicit
Private Declare Function MakeSureDirectoryPathExists _
    Lib "imagehlp.dll" (ByVal Pfad As String) As Long
Private Declare Function DeleteUrlCacheEntry Lib "wininet" Alias _
    "DeleteUrlCacheEntryA" (ByVal lpszUrlName As String) As Long
Private Declare Function PathFileExists Lib "shlwapi.dll" _
    Alias "PathFileExistsA" (ByVal pszPath As String) As Long
Private Declare Function URLDownloadToFile Lib "urlmon" _
    Alias "URLDownloadToFileA" ( _
    ByVal pCaller As Long, _
    ByVal szURL As String, _
    ByVal szFileName As String, _
    ByVal dwReserved As Long, _
    ByVal lpfnCB As Long) As Long
'-------------------------------------------------------------------------- 
' Module    : Module1 
' Procedure : Main 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 11.12.2012 
' Purpose   : Drag files from the Internet - Dateien aus dem Internet laden 
'-------------------------------------------------------------------------- 
Public Sub Main()
    Dim strFile As String
    Dim strPath As String
    Dim lngResult As Long
    Dim lngLastRow As Long
    Dim wksSheet As Worksheet
    Dim strURL As String
    On Error GoTo Fin
    With ThisWorkbook
        .Worksheets("Sheet2").Visible = -1 ' = xlVisible 
        .Worksheets("Sheet1").Visible = 0 ' = xlHidden 
    End With
    Application.ScreenUpdating = False
    Set wksSheet = ThisWorkbook.Worksheets("Sheet1") 'adapt 
    With wksSheet
        strPath = .Range("A1").Text
        strPath = IIf(Right(strPath, 1) <> "\", strPath & "\", strPath)
        lngLastRow = IIf(IsEmpty(.Range("B" & .Rows.Count)), _
            .Range("B" & .Rows.Count).End(xlUp).Row, .Rows.Count)
        If Not IsFilePath(strPath) Then MakeSureDirectoryPathExists strPath
        For lngLastRow = 1 To lngLastRow
            strURL = .Cells(lngLastRow, 2).Text
            strFile = .Cells(lngLastRow, 3).Text
            Call DeleteUrlCacheEntry(strURL)
            lngResult = URLDownloadToFile(0, strURL, strPath & strFile, 0, 0)
        Next lngLastRow
    End With
    Shell "Explorer.exe /E," & strPath, vbNormalFocus
Fin:
    With ThisWorkbook
        .Worksheets("Sheet1").Visible = -1 ' = xlVisible 
        .Worksheets("Sheet2").Visible = 2 ' = xlSheetVeriHidden 
    End With
    Application.ScreenUpdating = True
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub
Private Function IsFilePath(strPath As String) As Boolean
    IsFilePath = CBool(PathFileExists(strPath))
End Function

10.12.2012

Formeln - auch Array - per VBA eintragen...

Frage: In einer Tabelle habe ich einige Formeln, die ich - aus welchem Grund auch immer - per VBA eintragen möchte. Wie geht das?

Hier noch eine Beispieldatei: Formeln - auch Array - per VBA eintragen...

WICHTIG! In der Formel vorkommende Hochkommata müssen gedoppelt werden - also aus "" wird """"!

Zunächst wird die Zelle mit der Formel markiert.


Dann öffnet man im VBA-Editor das Direktfenster bzw. den Direktbereich (wenn nicht schon geschehen) per STRG+G, gibt folgendes ein (inklusive das Fragezeichen am Anfang) und beendet die Zeile mit Return:


Das gleiche für die Formel in B1:


Dann die Formeln in VBA so nutzen - Arrayformeln werden mit Evaluate direkt in VBA berechnet:


Über "Application.ErrorCheckingOptions.BackgroundChecking" wird verhindert, dass dieses "grüne" Flag mit dem Fehlerhinweis (Zahl als Text) angezeigt wird. Weitere Beispiele folgend und in der Beispieldatei.

Option Explicit
'-------------------------------------------------------------------------- 
' Module    : Modul1 
' Procedure : Main 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 10.12.2012 
' Purpose   : Formeln per VBA eintragen... 
'-------------------------------------------------------------------------- 
Sub Main()
    With Tabelle1
        .Range("E1").NumberFormat = "@"
        .Range("E1").Formula = _
            .Evaluate("=RIGHT(A1,COUNT(RIGHT(A1,COLUMN(1:1))*1))")
        Application.ErrorCheckingOptions.BackgroundChecking = False
        .Range("D1").Formula = "=MID(A1,1,LEN(A1)-LEN(C1))"
    End With
End Sub
Sub Main_1()
    Dim lngLastRow As Long
    With Tabelle1
        lngLastRow = IIf(IsEmpty(.Cells(.Rows.Count, 1)), _
            .Cells(.Rows.Count, 1).End(xlUp).Row, .Rows.Count)
        .Range("G1:G" & lngLastRow).NumberFormat = "@"
        For lngLastRow = 1 To lngLastRow
            .Range("G" & lngLastRow).Formula = _
                .Evaluate("=RIGHT(A" & lngLastRow & ",COUNT(RIGHT(A" & _
                lngLastRow & ",COLUMN(1:1))*1))")
        Next lngLastRow
        Application.ErrorCheckingOptions.BackgroundChecking = False
        .Range("F1:F" & lngLastRow).Formula = "=MID(A1,1,LEN(A1)-LEN(C1))"
    End With
End Sub
Sub Main_2()
    Dim lngLastRow As Long
    With Tabelle1
        lngLastRow = IIf(IsEmpty(.Cells(.Rows.Count, 1)), _
            .Cells(.Rows.Count, 1).End(xlUp).Row, .Rows.Count)
        .Range("I1:I" & lngLastRow).NumberFormat = "@"
        For lngLastRow = 1 To lngLastRow
            .Range("I" & lngLastRow).Formula = _
                .Evaluate("=RIGHT(A" & lngLastRow & ",COUNT(RIGHT(A" & _
                lngLastRow & ",COLUMN(1:1))*1))")
        Next lngLastRow
        Application.ErrorCheckingOptions.BackgroundChecking = False
        .Range("H1:H" & lngLastRow).Formula = "=MID(A1,1,LEN(A1)-LEN(C1))"
        .Range("H1:H" & lngLastRow).Value = .Range("H1:H" & lngLastRow).Value
    End With
End Sub

05.12.2012

Word - bestimmte Werte nach Excel...

Frage: Es gibt eine ganze Menge von Worddokumenten, in denen in zwei Spalten (keine Tabelle, sondern Tabulatorgetrennt) Analysedaten und die entsprechenden Werte stehen. Es gibt noch Überschriften und am Ende ein paar Daten, die nicht benötigt werden. Diese brauche ich in Excel. Wie geht das?

Im Download ist das Exceldokument sowie ein paar Worddokumente mit Beispieldaten.

Hier noch eine Beispieldatei: Word - bestimmte Werte nach Excel...[ZIP 60 KB]

Option Explicit
Dim blnTMP As Boolean
'-------------------------------------------------------------------------- 
' Module    : Modul1 
' Procedure : Main 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 05.12.2012 
' Purpose   : Aus Worddokumenten bestimmte Werte nach Excel übertragen... 
'-------------------------------------------------------------------------- 
Public Sub Main()
    ' Dimensionieren der Variablen 
    Dim wksSheet As Worksheet
    Dim objDocument As Object
    Dim lngLastRow As Long
    Dim strDatei As String
    Dim strPfad 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 
    'strPfad = "C:\Temp\Word\" 
    ' Pfad anpassen - Worddateien sind im gleichen 
    'Verzeichnis wie diese Exceldatei 
    strPfad = 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$(strPfad & "*.doc*", vbDirectory)
        Do While strDatei <> ""
            ' Worddokument öffnen 
            Set objDocument = objApp.Documents.Open _
                (strPfad & strDatei)
            ' Die erste Tabelle wird kopiert 
            'objDocument.Tables(1).Range.Copy 
            ' Der gesamte Inhalt wird kopiert 
            objDocument.Range.Copy
            ' und in das temporäre Tabellenblatt eigefügt 
            wksSheet.Paste
            ' Leerzellen in Splate B werden gelöscht 
            wksSheet.Columns(2).SpecialCells _
                (xlCellTypeBlanks).Delete Shift:=xlUp
            ' Werte aus Spalte D werden nachgerückt 
            wksSheet.Range("D6:D43").Copy wksSheet.Range("D1")
            ' Ameisenrennen um den kopierten Bereich beenden 
            ' und Zwischenspeicher leeren 
            Application.CutCopyMode = True
            ' Bestimme jetzt die Anzahl der Zeilen in Spalte A 
            With Tabelle1
                lngLastRow = IIf(IsEmpty(.Cells(.Rows.Count, 1)), _
                    .Cells(.Rows.Count, 1).End(xlUp).Row, .Rows.Count)
            End With
            ' Den Bereich aus dem temporären Tabellenblatt kopieren 
            wksSheet.Range("D1:D33").Copy
            ' Und TRANSPONIERT in Tabelle1 erste freie Zeile einfügen 
            Tabelle1.Cells(lngLastRow + 1, 1).PasteSpecial Transpose:=True
            With Application
                .GoTo Tabelle1.Range("A1"), True
                .CutCopyMode = True
            End With
            ' Dateiname in den Kommentar schreiben 
            Tabelle1.Cells(lngLastRow + 1, 1).AddComment.Text strDatei
            ' Worddokument ohne speichern schlissen 
            objDocument.Close False
            ' Die nächste Datei nehmen 
            strDatei = Dir$()
            ' Setze die Objektvariable auf Nothing 
            Set objDocument = Nothing
        Loop
        ' Temporäres Tabellenblatt löschen 
        wksSheet.Delete
    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
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

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