Freelance Project Requests info@CodeDocu.de Software Development in C# WPF Asp.Net Core Vba Excel Word SQL-Server EF Linq, UWP Net
#

Download:

Datei 1: Foto_Dokumentation_Version55_Tabelle_20201125.dotm

 

 

This Word template does the following:

By clicking on the Insert Photos button you can select photos from the local drive and they will be inserted into the templates block.

The file is inserted into the [Filename] field as a file name plus a sequential image number.

The photo here in green will be replaced.

 Version 54: Height of inserted photos will be set by the heigthof the template photos

Verison 55: removed reference to Office16

Advantage:

You can design the area yourself. The title and photo are in a table, with the borders hidden.

 

Vba Code

1.               Copy template

2.               Picture title with number exchange

3.               Share image

4.               At the end, delete the button and the template area

 

 

Vba Code Example

 

 

Zum Starten einfach die Vorlage herunterladen und in ein Verzeichnis legen

Dann per Doppelklick oder Kontext->Neu auf die Dokumentvorlage.dotm ein neues Word-Dokument1 erstellen

 

 

Vba Makro Code in der Datei

Option Explicit On

 

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

Const const_Path_Photos_Default As String = "B:\2020"

Const const_int_maxLength_Photos As String = 17

Const Nr_Table_with_Fotos As Integer = 1

Const Show_Filenames As Boolean = True

Const Show_ImageNr As Boolean = True

Const Add_Empty_Textline As Boolean = True

 

Public doc As Document

 

Const sPlaceholder_Vorlage = "Vorlage"

Public range_Placeholder_Vorlage As Range

 

Const sPlaceholder_Filename = "Filename"

Public range_Vorlage As Range

 

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

 

 

'=====< BUTTONS >=========

Private Sub btnMarkieren_Click()

    '----< btnMarkieren_Click() >----

    '--< Init Document >--

    '< get Document >

    Set doc = Application.ActiveDocument

    '</ get Document >

    '--</ Init Document >--

   

    '--< get Template >--

    Set range_Placeholder_Vorlage = get_Placeholder(sPlaceholder_Vorlage)

   

    Dim range_Platzhalter_Filename As Range

    Set range_Platzhalter_Filename = get_Placeholder(sPlaceholder_Filename)

    Set range_Vorlage = range_Platzhalter_Filename.Tables(1).Range

    '--</ get Template >--

   

   

    Button_delete()

    Insert_Photos()

 

    Delete_Template()

 

    doc.Range(doc.Range.End - 1, doc.Range.End).Select

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

    Selection.TypeBackspace

    '----</ btnMarkieren_Click() >----

End Sub

'=====</ BUTTONS >=========

 

 

 

 

 

'=====< FUNCTIONS >=========

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

 

 

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

    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

            Application.ScreenUpdating = False

 

            '--< new WorkRange >--

            range_Vorlage.Copy

 

            Dim WorkRange As Range

            Set WorkRange = Application.ActiveDocument.Range(range_Placeholder_Vorlage.Start - 1, range_Placeholder_Vorlage.Start - 1)

            WorkRange.Paste

            '--< new WorkRange >--

 

            '--< Filename >--

            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

 

 

            '-< replace Filename >

            Dim range_Filename As Range

            Set range_Filename = get_Placeholder_inRange(sPlaceholder_Filename, WorkRange)

            range_Filename.Text = sLabel

 

            '--< Filename >--

 

 

 

            '----< Change_Image >----

            '--< get Photo >--

            Dim range_Photo As Range

            Set range_Photo = get_ImageRange_inRange(WorkRange)

            range_Photo.Select

            '--</ get Photo >--

 

            DoEvents

           

            '< 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:=range_Photo)

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

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

            '--</ replace as png >--

            range_Photo.Select

            Selection.EndKey

            '----</ Change_Image >----

 

            '----< Abstand >----

            WorkRange.Collapse Direction:=wdCollapseEnd

            WorkRange.InsertParagraphAfter

            If iPicture Mod 2 = 0 Then

                WorkRange.InsertBreak WdBreakType.wdPageBreak

            End If

            '----</ Abstand >----

 

            Application.ScreenUpdating = True

            Application.ScreenRefresh

            DoEvents

 

            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

 

Private Sub Button_delete()

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

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

 

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

    '*loop all InlineShapes

 

    Dim objShape As shape

    Dim iShape As Long

    For Each objShape In doc.Shapes

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

                'objShape.Select

                'objControl.TakeFocusOnClick = False

                'objShape.Width = 0.1

                'objShape.Height = 0.1

 

            End If

        End If

        '< Is_Control >

 

    Next

    'Application.ScreenUpdating = True

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

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

End Sub

 

 

Sub Delete_Template()

    '-----------------< Delete_Template() >-----------------

    Dim Range_Template As Range

    Set Range_Template = doc.Range(range_Placeholder_Vorlage.Start - 2, doc.Range.End)

    Range_Template.Delete

 

    '-----------------</ Delete_Template() >-----------------

End Sub

 

 

 

 

'=====</ FUNCTIONS >=========

 

'=====< HELPERS >====

Private Function get_Placeholder(ByVal sPlatzhalter As String) As Range

    '-----------------< Find_Placeholder() >-----------------

 

    '< init >

    Dim lenPlaceholder As Integer

    lenPlaceholder = Len(sPlatzhalter)

 

    Dim doc As Document

    Set doc = Application.ActiveDocument

    '</ init >

 

    Dim range_Placeholder As Range

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

    '*loop all Phrases

    Dim i As Long

    For i = 1 To doc.Words.Count - 2

        Dim var As Variant

        Set var = doc.Words(i)

        If var.Text = "[" Then

            Dim varPlatzhalter As Variant

            Set varPlatzhalter = doc.Words(i + 1)

            If varPlatzhalter = sPlatzhalter Then

                '--< Platzhalter gefunden >--

                Set range_Placeholder = var.Paragraphs(1).Range 'satz auswaehlen

                range_Placeholder.SetRange range_Placeholder.Start, range_Placeholder.End - 1 'markieren

                Exit For

                '--</ Platzhalter gefunden >--

            End If

        End If

    Next

   

    Set get_Placeholder = range_Placeholder

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

    '-----------------</ Find_Placeholder() >-----------------

End Function

 

 

Private Function get_Placeholder_inRange(ByVal sPlatzhalter As String, ByRef sInRange As Range) As Range

    '-----------------< Find_Placeholder() >-----------------

 

    '< init >

    Dim lenPlaceholder As Integer

    lenPlaceholder = Len(sPlatzhalter)

 

    Dim doc As Document

    Set doc = Application.ActiveDocument

    '</ init >

 

    Dim range_Placeholder As Range

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

    '*loop all Phrases

    Dim i As Long

    For i = 1 To sInRange.Words.Count - 2

        Dim var As Variant

        Set var = sInRange.Words(i)

        If var.Text = "[" Then

            Dim varPlatzhalter As Variant

            Set varPlatzhalter = sInRange.Words(i + 1)

            If varPlatzhalter = sPlatzhalter Then

                '--< Platzhalter gefunden >--

                Set range_Placeholder = var.Paragraphs(1).Range 'satz auswaehlen

                range_Placeholder.SetRange range_Placeholder.Start, range_Placeholder.End - 1 'markieren

                Exit For

                '--</ Platzhalter gefunden >--

            End If

        End If

    Next

   

    Set get_Placeholder_inRange = range_Placeholder

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

    '-----------------</ Find_Placeholder() >-----------------

End Function

 

Private Function get_ImageRange_inRange(ByRef sInRange As Range) As Range

    '-----------------< Find_Placeholder() >-----------------

 

    '< init >

    Dim doc As Document

    Set doc = Application.ActiveDocument

    '</ init >

 

    Dim range_Placeholder As Range

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

    '*loop all Phrases

    If sInRange.InlineShapes.Count < 1 Then Exit Function

    Dim objImage As inlineShape

    Set objImage = sInRange.InlineShapes(1)

       

    Set get_ImageRange_inRange = objImage.Range

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

    '-----------------</ Find_Placeholder() >-----------------

End Function

'=====</ HELPERS >====

 

 

 

 

Mobile
»
Word template for inserting von photos Version 55
»
Word Addin: Insert photos after a picture mark into a table
»
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

.

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