Free Code Snippets in C#, Net Framework, Office 365, ASP.Net,WPF, Visual Studio, SQL Server, Antivirus free
#

Download:

Datei 1: Word_Foto-Vorlage_2_Fotos_pro_Seite.dotm

Word Automatic Photo Documentation Template

 

This Word template creates a photo documentation. The photos can be selected with a file dialog and then the photos are inserted with a width of 17 centimeters.

An invisible table is filled with 1 column and 2 photos per page.

The photos are compressed and reduced so that the original photos are not inserted with 5 MB, but only with 0.3 MB.

 

Characteristics:

1 column

2 photos per page (depending on the photos)

3 Below the pictures is the consecutive picture number and the picture name

 

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

 

 

 

By clicking on the button, a file dialog will be opened, via which you can then select the photos.

 

In the file dialog one can select several photos

And then with the button: import images

Tip: the photos are visible in the file explorer, if you set the view to "Large view" at the top.

 

settings

With Alt + F11 you can adjust the inserted image size to the longest edge in centimeters

In the vba code block at the top of the vba macro you can set:

1 Start path where the photos are usually located

2 Maximum edge length of the photos.

3 in which table the photos should be inserted (here the second table)

4 Display of file names

5 Display of the current picture number

6 Blank line after the photo to insert 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 macro 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
»
Photo documentaion in Word
»
Word Automatic Photo Documentation Template 1 Column 2 Photos with Numbers
»
Photo Template 4-Columns
»
Word Photo Template for Photo Documentation
»
Word macro: Insert all photos from input folder with macro
»
Word Template: Read the complete photo folder to base path and folder name
»
Word Template: Import photo documentation as a photo directory
»
Word Template: Photo Documentation
»
Word Template: Import a photo directory into a Word document

.

Contact for Jobs, Project Requests: raimund.popp@microsoft-programmierer.de