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