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
|