#

Einspaltig, vorgefertigte Word-Vorlage. Kopfbereich bitte anpassen
 
Mit der hier gezeigten Word Vorlage kann man einen automatische Foto-Dokumentation in Word erstellen.
Dabei muss man nur die Vorlage nach den eingenen Wünschen optisch anpassen. Die Datei speichern und beim Explorer per Doppelklick oder Neu öffnen.
Dann muss man nur noch den Button Insert Photos klicken und schon kann man die gewünschten Fotos auswählen und automatisch zugeschnitten und verkleinert in das Word-Dokument einfügen.
Der Vorteil der Vorlage ist, dass die Fotos automatisch auf ein kleines Speicherformat komprimiert werden, wodurch das Word-Dokument trotz 100 Fotos nur wenige MB-Speicher verbraucht.
Und zudem werden die Fotos in der Breite automatisch angepasst.
 
Die Word-Vorlage sieht wie hier dargestellt aus.
Die Texte und die oberen zwei Tabellen kann man frei gestalten und anpassen.
Weiter unten kommt ein Button: Insert Photos und eine Tabelle, welche für das Automatischen Einfügen verwendet werden.

 
 
Video

 
Für die Eingabe eines neuen Dokuments öffnet man die Vorlage im Dateiexplorer per Doppelklick oder neu.

 
Dadurch wird automatisch aus der Vorlage Word.dotm ein neues leeren Word-Dokument1.docx erstellt.
Jetzt muss man nur noch den Insert Photos-Button klicken und die Fotos auswählen, welche eingefügt werden sollen.
Ein Tipp: im Einfügen-Dialog kann man rechts oben die Ansicht der Fotos auf „Große Elemente“ umschalten und sieht dadurch die Fotos in der Vorschau.

 
Anschliessend werden die Fotos automatisch eingefügt.
Über jedem Foto und unter jedem Foto ist eine Zeile platz, wo man noch einen Titel oder Kommentar hinterlassen kann.

 
 
Wer die Vorlage verbessern möchte oder anpassen möchte, der sollte die Vorlage öffnen und anschliessend mit Alt-F11 auf die vba Code-Seite wechseln.
Unter Project->Microsoft Word Objekte->ThisDocument findet man im Header zwei Konstanten, welche man gerne einstellen kann
Hier kann man den Foto-Pfad voreinstellen und die maximale Fotobreite (oder Höhe) in Zentimenter einstellen
 
Unter Alt-F11 findte man den den Macro-Code in welchem man

 
 
 
 
Folgender Macro-Code ist in der Vorlage gespeichert:

Option Explicit On
 
'----< Setup Parameters >----
Const const_Path_Photos_Default = "B:\2017"
Const const_int_maxLength_Photos = 14
'----</ Setup Parameters >----
 
'< variables >
Dim position_Button As Integer
'< variables >
 
Private Sub CommandButton1_Click()
'-----------------< btnBilder_einfuegen_Click() >-----------------
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 "*Insert*" Then
'*delete Control
position_Button = objControl.Automation.Range.Start
objShape.Delete
Exit For
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
 
'< get Document >
Dim doc As Document
Set doc = Application.ActiveDocument
'</ get Document >
 


'*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 = "Select the photos.."
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
Button_delete()
 
'< Find table_Photos >
Dim tblPictures As Table
Set tblPictures = doc.Tables(1)

Dim tbl As Table
For Each tbl In doc.Tables
If tbl.Range.Start > position_Button Then
Set tblPictures = tbl
End If
Next
 
'</ Find table_Photos >
 
 
'-------< @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 Step 1
'------< 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;*.bmp", sExtension) > 0 Then 'JPG-Datei
'----< IsPhoto >----
iPicture = iPicture + 1
iCol = iCol + 1
 
'-< new Row >-
If iPicture > (tblPictures.Columns.Count * (tblPictures.Rows.Count - 1)) Then
Dim new_Row As Row
Set new_Row = tblPictures.Rows.Add()
iCol = 1
End If
'-</ new Row >-
 
'< set Cell >
Dim cell_Range As Range
Set cell_Range = tblPictures.Cell(iPicture + 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)
'</ 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
'</ cut >
 
'*pasteBitmap is much smaller
Selection.PasteSpecial Link:=False, DataType:=wdPasteBitmap, Placement:=wdInLine, DisplayAsIcon:=False, IconLabel:="Imported Photo"
'--</ replace as png >--
 
'< Text Row >
Selection.TypeText Text:=Chr(11)
'</ Text Row >
 
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
 

 
Mobile

.

0123movie.net