Readdy Write  
0,00 €
Your View Money
Views: Count
Self 20% 0
Your Content 60% 0

Users by Links 0
u1*(Content+Views) 10% 0
Follow-Follower 0
s2*(Income) 5% 0

Count
Followers 0
Login Register as User

Word Vorlage zum Einfügen von Fotos

04.11.2020 (👁14653)

Word Vorlage zum Einfügen von Fotos

Diese Word Vorlage macht folgendes:

Beim Klick auf den Button Fotos einfügen kann man Fotos vom lokalen Laufwerk auswählen und diese werden dann in den Vorlagen Block eingefügt.

Dabei wird in das Feld [Filename] die Datei als Dateiname plus eine laufende Bildnummer eingefügt.

Das Foto hier in grün wird ersetzt.

Vorteil:

Man kann den Bereich selber gestalten. Dabei ist der Titel und das Foto in einer Tabelle, wobei die Rahmen ausgeblendet sind.

Vba Code

1.               Vorlage kopieren

2.               Bild Titel mit Nummer austauschen

3.               Bild austauschen

4.               Am Schluss den Button und den Vorlage-Bereich löschen

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