#

Download:

Datei 1: FotoOrdner_einfügen_mit_Nr.dotm

 

 

 

Vba Code zum Importieren von kompletten Fotoverzeichnissen in eine Foto-Dokumentation

 

Enthält Word Code zu:

- Einfügen von Fotos in eine Word-Datei

- Anpassen der Größen von Fotos und Bildern in Word

- Datei-Dialog unter Word

- Button und Textbox in Word als Eingabe-Controls

- Ändern der Dokument.Properties Title zur Laufzeit während einer Feld-Eingabe

 

 

 

Den vba Code zum Template findet man mit Alt-F11

 

 

 

Vba Code zum Template Foto-Dokumentation

Option Explicit On

 

 

'----< Setup Parameters >----

Const const_int_maxLength_Photos = 17   'breite in Zentimeter

Const const_Path_Photos_Default = "B:\2017"

Public position_Button As Long

Public position_Textbox As Long

Public sNr As String

'Oder alternativ X:\Service

'----</ Setup Parameters >----

 

Private Sub btnFotos_importiern_Click()

    '--------------------< btnFotos_importiern_Click() >--------------------

    Insert_Photos()

    '--------------------</ btnFotos_importiern_Click() >--------------------

End Sub

 

 

Private Sub Button_delete()

    '-----------------< Button_loeschen() >-----------------

    '*Delete Word Button, Option... ActiveX Controls

    '< init >

    Dim doc As Document

    Set doc = Application.ActiveDocument

    Selection.MoveStart

    '</ init >

 

    '----< @Loop: Controls >----

    '*loop all InlineShapes

    Dim objControl As Object

    Dim objShape As InlineShape

    For Each objShape In doc.InlineShapes

        If objShape.Type = wdInlineShapeOLEControlObject Then

            '< Delete_Button >

            If objShape.OLEFormat.ClassType Like "*Button*" Then

                Set objControl = objShape.OLEFormat.Object

                If objControl.Caption Like "*Fotos*" Then

                    '*delete Control

                    position_Button = objControl.Automation.Range.Start

                    objShape.Delete

                    Set objShape = Nothing

                End If

            End If

            '< /Delete_Button >

        End If

    Next

    For Each objShape In doc.InlineShapes

        If objShape.Type = wdInlineShapeOLEControlObject Then

 

            '< Delete_Textbox  >

            If Not objShape Is Nothing Then

                If objShape.OLEFormat.ClassType Like "*TextBox*" Then

                    Set objControl = objShape.OLEFormat.Object

                    If objControl.Name Like "*Nr*" Then

                        '*delete Control

                        position_Textbox = objControl.Automation.Range.Start

                        objShape.Delete

                    End If

                End If

            End If

            '< /Delete_Textbox >

        End If

    Next

    '----</ @Loop: Controls >----

    '-----------------</ Button_loeschen() >-----------------

End Sub

 

Sub Insert_Photos()

    '-----------------< Fotos_einfuegen() >-----------------

    '*Description:

    '*This macro inserts photos after the button

    ' this word macro imports all photos from a folder into a new Word Document.

 

    '< neues Dokument ersetellen >

    Dim doc As Document

    Set doc = ActiveDocument

    '</ neues Dokument ersetellen >

   

    '--< Dateidialog >--

    Dim objFiledialog As FileDialog

    Set objFiledialog = Application.FileDialog(msoFileDialogFilePicker)

    objFiledialog.AllowMultiSelect = True

    objFiledialog.ButtonName = "Ordner übernehmen"

    objFiledialog.Filters.Add "Bilder", "*.jpg,*gif,*.tiff,*.png"

    objFiledialog.Title = "Wählen Sie einen Ordner aus"

    objFiledialog.AllowMultiSelect = False

    objFiledialog.InitialFileName = const_Path_Photos_Default

    Dim sFilename As String

    If objFiledialog.Show() = True Then

        sFilename = objFiledialog.SelectedItems(1)

    End If

    '--< Dateidialog >--

 

 

    '< Ordner bestimmen >

    Dim sFolder As String

    sFolder = Left(sFilename, InStrRev(sFilename, "\", , vbTextCompare))

    '</ Ordner bestimmen >

 

    '--< Kontrolle >--

    '< Ordner ist leer >

    If sFolder Like "" Then

        Exit Sub

    End If

    '</ Ordner ist leer >

 

 

    '< Kontrolle: ist Ordner >

    Dim objFilesystem As New FileSystemObject

    If Not objFilesystem.FolderExists(sFolder) = True Then

        MsgBox "Der eingegebene Pfad ist kein Ordner", vbOKOnly, "Ordner prüfen"

        Exit Sub

    End If

    '</ Kontrolle: ist Ordner >

    '--</ Kontrolle >--

 

 

 

    '< Ordner laden >

    Dim objFolder As Folder

    Set objFolder = objFilesystem.GetFolder(sFolder)

    '</ Ordner laden >

   

   

    '----< sortierbare Tabelle erstellen >----

    Dim recFiles As New ADODB.Recordset

    recFiles.Fields.Append "FileName", adVarChar, 255, adFldIsNullable

    recFiles.Open

    '----</ sortierbare Tabelle erstellen >----

 

    '-------< @Loop: Eingabe-Files >--------

    Dim objFile As File

 

    For Each objFile In objFolder.Files

        '----< File >----

        Dim intPos As Integer

        intPos = InStrRev(objFile.Name, ".")

        If intPos > 0 Then

            Dim sExtension As String

            sExtension = LCase(Mid(objFile.Name, intPos + 1))

            If InStr(".jpg .jpeg .bmp .png .tiff .gif", sExtension) > 0 Then

                '----< File ist Foto >----

                '< Datei eintragen >

                recFiles.AddNew

                sFilename = objFile.Path

                recFiles("FileName") = sFilename

                recFiles.Update

                '</ Datei eintragen >

                '----</ File ist Foto >----

            End If

        End If

        '----</ File >----

    Next

    '-------</ @Loop: Eingabe-Files >--------

 

    '< Kontrolle >

    If recFiles.RecordCount = 0 Then

        recFiles.Close

        Exit Sub

    End If

    '</ Kontrolle >

 

    '< delete controls >

    Button_delete()

    '</ delete controls >

 

    '< delete current line >

    Dim objParagraph As Paragraph

    For Each objParagraph In doc.Paragraphs

        If Selection.Range.InRange(objParagraph.Range) Then

            objParagraph.Range.Select

        End If

    Next

    Selection.Delete

    '</ delete current line >

 

 

 

    '< Tabelle sortieren >

    '*nach Dateinamen

    recFiles.Sort = "FileName"

    '</ Tabelle sortieren >

 

 

 

    '-------< @Loop: Sortierte Ausgabe-Files einfuegen >--------

    Dim objInlineShape As InlineShape

    recFiles.MoveFirst

    Do Until recFiles.EOF

        Dim sDateiname As String

        sDateiname = recFiles("FileName")

        'On Error Resume Next

        On Error GoTo 0

             

        '----< File als Bitmap einfuegen >----

        Set objInlineShape = doc.InlineShapes.AddPicture(FileName:=sDateiname, LinkToFile:=False, SaveWithDocument:=True)

       

        '< scale >

        objInlineShape.LockAspectRatio = msoTrue

        If objInlineShape.Width > objInlineShape.Height Then

            objInlineShape.Width = CentimetersToPoints(const_int_maxLength_Photos)    'in Centimeters

        Else

            objInlineShape.Height = CentimetersToPoints(const_int_maxLength_Photos)    'in Centimeters

        End If

        '</ scale >

 

 

        objInlineShape.Select

        Selection.Cut

        '< als png einfuegen >

        '*ist dann schon kleiner auch fuer den Speicher

        On Error Resume Next

        Selection.PasteSpecial Link:=False, DataType:=wdPasteBitmap, Placement:=wdInLine, DisplayAsIcon:=False

 

        '</ als png einfuegen >

        '----</ File als Bitmap einfuegen >----

 

        '< Filename schreiben >

        DoEvents

        'Selection.MoveDown

        '< Text Row >

        Selection.TypeText Text:=Chr(11)

        '</ Text Row >

        sFilename = Mid(sDateiname, InStrRev(sDateiname, "\", , vbTextCompare) + 1)

        'Selection.InsertParagraph

        Selection.TypeText sFilename

        'Selection.InsertParagraph

        'Selection.TypeText Text:=Chr(11)

        Selection.TypeParagraph

        Selection.TypeText Text:=Chr(11)

        '</ Filename schreiben >

 

        '< next >

        recFiles.MoveNext

        '</ next >

    Loop

    '-------</ @Loop: Sortierte Ausgabe-Files einfuegen >--------

 

    '< delete empty page >

    Selection.MoveDown Unit:=wdLine, Count:=4, Extend:=wdExtend

    Selection.Delete Unit:=wdCharacter, Count:=1

    '</ delete empty page >

 

 

    '< finish >

    recFiles.Close

    Set recFiles = Nothing

    '</ finish >

   

    '< save >

    On Error Resume Next

    doc.Save '   "Fotos_" & Format(Date, "YYYY MM DD")

 

    '</ save >

    '-----------------</ Fotos_einfuegen() >-----------------

End Sub

 

Private Sub tbxNr_Change()

    '----< tbxNr_Change() >----

    '*change internal variable propertie Title

    ActiveDocument.BuiltInDocumentProperties("Title") = tbxNr.Value

    '----</ tbxNr_Change() >----

End Sub

 

 

Mobile

.

123movies