#

Download:

Datei 1: Demo_Insert_Fotos_from_Folder_by_InputField_small.docx

Word Makro: Fotos aus einem Bildarchiv an ein Word-Dokument anfügen und anpassen
 
Dieses kleine Word Makro importiert Fotos aus einem Bildarchiv und hinterlegt es in einem geöffneten Dokument.
 
Die Fotos werden als kleinere, angepasste Fotos mit 5 Zentimeter Höhe in einen Foto-Bereich eingefügt.
Der Foto Ordner, aus dem die Fotos kommen, wird durch eine Word-Eingabefeld im Dokument festgelegt.
 
Besonderheit:
Bereich festgelegt wo die Fotos eingefügt werden, Größe wird angepasst, Foto-Pfad wird im Eingabe-Feld definiert.

 
Anleitung:
Schritt 1: Kopiere die Zeilen: Ordner und Fotos in eure eigenes Word-Dokument
Schritt 2: den folgenden Makro-Code Block müsst ihr einfach nehmen und in euren Makro Bereich kopieren.
In meinem Video-Tutorial steh hierzu die Anleitung oder auf meiner Webseite
 
Video Anleitung:

 
 
Import-Ordner:
Fotos werden automatisch aus einem Foto-Ordner oder Album importiert.
Es werden alle .jpg Fotos kopiert. Die Fotogröße und Auflösung wird beim Import angepasst.

 
 
Anleitung:
Schritt 1: Kopiere die Zeilen: Ordner und Fotos in eure eigenes Word-Dokument
Schritt 2: den folgenden Makro-Code Block müsst ihr einfach nehmen und in euren Makro Bereich kopieren.
In meinem Video-Tutorial steh hierzu die Anleitung oder auf meiner Webseite
 

'*Beschreibung:
'*Dieses Makro fuegt Fotos nach der Textmarke:Fotos im Word-Dokument ein und passt die Fotos in der Hoehe auf 5 Zentimeter an.
'*die Fotos werden automatisch aus einem Ordner entnommen, welcher sich aus einem Basis-Pfad plus einer Nummer ermitteln, welche im Eingabefeld: OrdnerNummer zusammensetzt.
'*zum Beispiel: I:\Bildarchiv\5684\
'*fuer diesen Code muss das Word-Dokument eine Textmarke mit dem Namen "Fotos" enthalten, damit nach dieser Position die Fotos eingefuegt werden koennen
 
Sub makro_Fotos_einfuegen()
    '-----------------< Insert_Photos_at_Position() >-----------------
    '*Insert Photos from a definite Folder after a Text-Bookmark
    '< Init >
    Dim sBookmark_Name As String
    sBookmark_Name = "Fotos"
 
    Dim sInputField_Foldername As String
    sInputField_Foldername = "inputField_OrdnerNr"
 
    Dim sBase_Path As String
    sBase_Path = "I:\Bildarchiv"
    '</ Init >
 
    '< get Document >
    Dim doc As Document
    Set doc = Application.ActiveDocument
    '</ get Document >
   
    '----< Jump to Bookmark >----
 
   
    '< check Bookmark >
    If Not doc.Bookmarks.Exists(sBookmark_Name) Then
        MsgBox "Ich kann die Textmarke Fotos nicht finden", vbCritical, "Textmarke Fotos fehlt"
        Exit Sub
    End If
    '</ check Bookmark >
 
    '< Jump >
    doc.Bookmarks(sBookmark_Name).Select                'select the bookmark
    doc.range(Selection.End, Selection.End).Select
    Selection.TypeParagraph                             'Insert new Line
    Selection.GoToNext wdGoToLine                       'jump to line after the Bookmark
    '</ Jump >
 
    '----</ Jump to Bookmark >----
 
    '-< check InputControl exists >-
    Dim bControl_Exists As Boolean
    bControl_Exists = False
 
    Dim control As ContentControl
    For Each control In doc.ContentControls
        If control.Tag = sInputField_Foldername Then
            bControl_Exists = True
            Exit For
        End If
    Next
    If bControl_Exists = False Then
        MsgBox "Das Eingabefeld OrdnerNr [" & sInputField_Foldername & "] existiert nicht", vbCritical, "Eingabefeld OrdnerNr fehlt"
        Exit Sub
    End If
    '-</ check InputControl exists >
 
    '< Get Input_Field >
    Dim sFolderNr As String
    sFolderNr = control.range.Text
    If sFolderNr Like "" Then
        MsgBox "Das Feld OrdnerNr: ist leer", vbCritical, "Check FolderNr"
        Exit Sub
    End If
    '</ Get Input_Field >
 
    '------< Insert Pictures From Folder >------
    '< init >
    Dim sFolder_Path As String
    sFolder_Path = sBase_Path & "\" & sFolderNr
    '</ init >
 
    '< init File-System >
    '*Reference Microsoft scripting Runtime    http://www.microsoft-programmierer.de/Details?d=1076
    Dim objFileSystem As New FileSystemObject
    Dim objFolder As Folder
    Set objFolder = objFileSystem.GetFolder(sFolder_Path)
    '</ init File-System >
   
    '----< @Loop: all Files >----
    On Error Resume Next
    Dim objFile As File
    For Each objFile In objFolder.Files
        If objFile.Type Like "JPG*" Then    'JPG-Datei
            '----< IsPhoto >----
            Dim sFilename As String
            sFilename = objFile.Path
 
            '< 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.
 
            Dim objShape As inlineShape
            Set objShape = doc.InlineShapes.AddPicture(FileName:=sFilename, LinkToFile:=False, SaveWithDocument:=True)
            '</ insert Photo after Bookmark >
           
            '< scale >
            objShape.LockAspectRatio = msoTrue
            objShape.Height = CentimetersToPoints(5)    '5 Centimeters height
            '</ scale >
 
            '--< replace as png >--
            '*reduce memory 1 MB to 1kb
            '< cut >
            objShape.Select
            Selection.Cut
            '</ cut >
 
            '*pasteBitmap is much smaller
            Selection.PasteSpecial Link:=False, DataType:=wdPasteBitmap, Placement:=wdInLine, DisplayAsIcon:=False
            '--</ replace as png >--
 
 
            '< add spacer >
            'objShape.Select
            Selection.MoveRight
            Selection.TypeText Text:=Chr(11)
            Selection.TypeText Text:=Chr(11)
            DoEvents
            '</ add spacer >
 
 
            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 >------
    '-----------------< Insert_Photos_at_Position() >-----------------
End Sub
 

 
 
 
Mobile

.

0123movie.net