#

Download:

Datei 1: Word_Foto-Vorlage_2_Fotos_pro_Seite.dotm

Word Automatische Foto Dokumentation Vorlage

 

Diese Word Vorlage erstellt eine Foto-Dokumentation. Die Fotos können mit einem Datei-Dialog ausgewählt werden und dann werden die Fotos eingefügt mit einer Breite von  17 Zentimeter.

Dabei wird eine unsichtbare Tabelle gefüllt mit 1 Spalte und 2 Fotos pro Seite.

Die Fotos werden dabei komprimiert und verkleinert, sodass die Originalfotos nicht mit 5 MB eingefügt werden, sondern nur mit 0,3 MB.

 

Eigenschaften:

1 Spalte

2 Fotos pro Seite (Abhängig von den Fotos)

3 Unterdem Fotos ist die fortlaufende Bildnummer und die eigentliche Bildbezeichnung

 

Video hierzu unter: https://www.youtube.com/watch?v=fSMnyM5Uga4

 

 

 

Beim Klick auf den Button wird ein Dateidialog geöffnet, über welchen man dann die Fotos auswählen kann.

 

Im Dateidialog kann man mehrere Fotos auswählen

Und dann mit dem Button: Import Images übernehmen

Tip: die Fotos sind im Dateiexplorer sichtbar, wenn man oben die Ansicht auf Große Ansicht einstellt.

 

Einstellungen

Mit Alt+F11 könnt Ihr die eingefügte Bildgröße anpassen auf die längste Kante in Zentimeter

Im dem vba Code-Block am Kopfbereich des vba Makros kann man Einstellen:

1 Startpfad wo die Fotos normalerweise liegen

2 Maximale Kantenlänge der Fotos.

3 in Welche Tabelle die Fotos eingefügt werden sollen (hier die zweite Tabelle)

4 Anzeige der Dateinamen

5 Anzeige der laufenden Bild Nummer

6 Leerzeile nach dem Foto zu Einfügen von Text

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

Const const_Path_Photos_Default As String = "B:\2017"

Const const_int_maxLength_Photos As String = 17

Const Nr_Table_with_Fotos As Integer = 2

Const Show_Filenames As Boolean = True

Const Show_ImageNr As Boolean = True

Const Add_Empty_Textline As Boolean = True

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

 

 

 

 

 

 

 

 

Vba Makro Code

Option Explicit On

 

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

Const const_Path_Photos_Default As String = "B:\2017"

Const const_int_maxLength_Photos As String = 17

Const Nr_Table_with_Fotos As Integer = 2

Const Show_Filenames As Boolean = True

Const Show_ImageNr As Boolean = True

Const Add_Empty_Textline As Boolean = True

 

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

 

Private Sub CommandButton1_Click()

    '-----------------< btnBilder_einfuegen_Click() >-----------------

    Button_delete()

    Insert_Photos()

    '-----------------</ btnBilder_einfuegen_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 objShape As inlineShape

    For Each objShape In doc.InlineShapes

        If objShape.Type = wdInlineShapeOLEControlObject Then

            '< Is_Control  >

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

                Dim objControl As Object

                Set objControl = objShape.OLEFormat.Object

                If objControl.Caption Like "*" Then

                    '*delete Control

                    objShape.Delete

                    Selection.Delete wdCharacter, 1

                End If

            End If

            '< Is_Control >

        End If

    Next

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

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

End Sub

 

 

Sub Insert_Photos()

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

    '*Description:

    '*This macro inserts photos in a table at column 3 and creates for each picture one row

    '*The selection is by a folder dialog and imports the entire folder

    '*Table: it searchs for the first table, which has the text: "foto" in the table-header

 

    '*Reference Microsoft scripting Runtime    http://www.microsoft-programmierer.de/Details?d=1076

 

    '------< Insert Pictures From Folder >------

    '--< Import-Dialog >--

    Dim objFiledialog As FileDialog

    Set objFiledialog = Application.FileDialog(msoFileDialogFilePicker)

    objFiledialog.AllowMultiSelect = True

    objFiledialog.ButtonName = "Import Images"

    objFiledialog.Filters.Add "Images Photos", "*.jpg;*.png;*.tiff;*.gif"

    objFiledialog.Title = "Fotos auswählen.."

    objFiledialog.InitialView = msoFileDialogViewTiles

    objFiledialog.InitialFileName = const_Path_Photos_Default

    objFiledialog.AllowMultiSelect = True

    If Not objFiledialog.Show() = True Then

        Exit Sub

    End If

    '--< Import-Dialog >--

 

 

    '-< check >-

    '</ Ordner ist leer >

    If objFiledialog.SelectedItems().Count = 0 Then

        Exit Sub

    End If

    '</ Ordner ist leer >

    '-</ check >-

 

 

    '--< Init Document >--

    '< get Document >

    Dim doc As Document

    Set doc = Application.ActiveDocument

    '</ get Document >

       

    Dim tblPictures As Table

    Set tblPictures = doc.Tables(Nr_Table_with_Fotos)

   

    Dim columns_Count As Integer

    columns_Count = tblPictures.Columns.Count

    '--</ Init Document >--

 

    'On Error Resume Next

 

    '-------< @Loop: Insert all Images >--------

    Dim objInlineShape As inlineShape

    Dim sFilename As String

    Dim iPicture As Integer

    iPicture = 0

    Dim iCol As Integer

    iCol = 0

    Dim iFile As Integer

    For iFile = 1 To objFiledialog.SelectedItems.Count

        '------< Loop.Item  >------

        DoEvents

 

        '< get selection >

        sFilename = objFiledialog.SelectedItems(iFile)

        '</ get selection >

 

        '< get Extension >

        Dim sExtension As String

        Dim intLen_Extension As Integer

        intLen_Extension = InStrRev(sFilename, ".", -1, vbBinaryCompare)

        sExtension = Mid(LCase(sFilename), intLen_Extension)

        '</ get Extension >

 

        If InStr(1, "*.jpg;*.png;*.tiff;*.gif", sExtension) > 0 Then 'JPG-Datei

            '----< IsPhoto >----

            iPicture = iPicture + 1

            iCol = iCol + 1

 

 

            Dim iRow As Integer

            iRow = Int((iPicture - 1) / columns_Count)

 

            '-< new Row >-

            If iPicture > 1 Then

                If iPicture Mod columns_Count = 1 Or columns_Count = 1 Then

                    Dim new_Row As Row

                    Set new_Row = tblPictures.Rows.Add()

                    iCol = 1

                End If

            End If

            '-</ new Row >-

 

            '< set Cell >

            Dim cell_Range As Range

            Set cell_Range = tblPictures.Cell(iRow + 1, iCol).Range

            cell_Range.Select

            Selection.EndKey

            '</ set Cell >

 

            '< Title Row >

            Selection.TypeText Text:=Chr(11)

            '</ Title Row >

 

            DoEvents

           

            'refresh Style

            'tblPictures.Style = tblPictures.Style

 

            '< insert Photo after Bookmark >

            '*SaveWithDocument:= True to save the linked picture with the document. The default value is False.

            '*LinkToFile: True to link the picture to the file from which it was created. False to make the picture an independent copy of the file. The default value is False.

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

            '</ insert Photo after Bookmark >

 

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

 

            '--< replace as png >--

            '*reduce memory 1 MB to 1kb

            '< cut >

            objInlineShape.Select

            Selection.Cut

            'DoEvents

            '</ cut >

 

            '*pasteBitmap is much smaller

            cell_Range.PasteSpecial Link:=False, DataType:=wdPasteBitmap, Placement:=wdInLine, DisplayAsIcon:=False, IconLabel:="Imported Photo"

            'Selection.PasteSpecial Link:=False, DataType:=wdPasteBitmap, Placement:=wdInLine, DisplayAsIcon:=False, IconLabel:="Imported Photo"

            '--</ replace as png >--

 

            '--< Filename >--

            If Show_Filenames = True Or Show_ImageNr = True Then

                Dim sLabel As String

                sLabel = ""

 

                If Show_Filenames Then

                    Dim pos As Integer

                    pos = InStrRev(sFilename, "\")

                    If pos < 0 Then

                        pos = InStrRev(sFilename, "/")

                    End If

 

                    sLabel = Mid(sFilename, pos + 1)

                    sLabel = Replace(sLabel, ".jpg", "", , , vbTextCompare)

                End If

 

                If Show_ImageNr Then

                    sLabel = iPicture & ": " & sLabel

                End If

 

                'cell_Range.Select

                Selection.EndKey

                Selection.InsertBreak wdLineBreak

                Selection.TypeText Text:=sLabel

                DoEvents

            End If

            '--< Filename >--

 

 

            '< Empty TextLine >

            If Add_Empty_Textline = True Then

                Selection.TypeText Text:=Chr(11)

                DoEvents

            End If

            '</ Empty TextLine >

 

 

            If Err.Number <> 0 Then

                MsgBox Err.Description

                Err.Clear

            End If

            '----</ Insert Image  >----

 

            '----</ IsPhoto >----

        End If

    Next

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

    '------</ Insert Pictures From Folder >------

 

 

 

 

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

End Sub

 

 

 

 

Mobile

.

0123movie.net