#

Download:

Datei 1: Word_Template_Photos_into_Table.dotm

Word Vorlage: Fotos in eine Tabelle laden
 
Diese Word Vorlage mit einem Makro in vba fügt in die darunterliegende Tabelle ausgewählte Fotos aus einem Datei-Dialog ein.
Die Vorlage kann heruntergeladen werden.
 
Beim Starten wird ein neues document1.docx erstellt mit einem Button und einer leeren Tabelle.
Sobald man den Button: Insert Photos drückt, erscheint ein Datei-Dialog bei welchem man verschiedene *.jpg und *.png Fotos auswählen kann.
Mit Einfügen werden dann diese Fotos in die darunterliegende Tabelle eingefügt und automatisch in der Größe zugeschnitten.
Dabei wird der Button auch gleichzeitig entfernt.
 

 
 
Die Fotos werden automatisch in die Tabelle eingefügt.
Dabei wird nur die Spalte Foto befüllt.
Das Word Dokument selbst hat dann kein Makro Code mehr und kann deshalb mit .docx gespeichert werden.

 
 
Wenn man die Word Vorlage als Datei in einem Ordner gespeichert hat, dann muss man diese nur per doppelklick starten.
Dadurch wird automatisch eine neues Dokument als document1.docx erstellt.

 
 
 
 
Macro Code, vba:
Wer den Code anpassen oder optimierten möchte, der kann den vba Code mit Alt-F11 erreichen und verändern
Kompletter Makro Code im Hintergrund:

Private Sub CommandButton1_Click()
'-----------------< btnBilder_einfuegen_Click() >-----------------
Button_delete()
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
objShape.Delete
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
 
'< Init >
Dim sTable_Column_Header As String
sTable_Column_Header = "Foto"
 
Dim intPicture_Size_in_Centimeters As Integer
intPicture_Size_in_Centimeters = 6
 
Dim sBase_Path As String
sBase_Path = "C:\"
'</ Init >
 
'< get Document >
Dim doc As Document
Set doc = Application.ActiveDocument
'</ get Document >

'----< check TableCaption exists >----
Dim bControl_Exists As Boolean
bControl_Exists = False
 
Dim tbl_Target As Table
Dim tbl As Table
Dim iCol_Target As Integer
Dim iCol As Integer
 
For Each tbl In doc.Tables
If tbl.Rows.Count > 0 And tbl.Columns.Count > 0 Then
'*Table Header in Row=1
For iCol = 1 To tbl.Columns.Count
Dim tblCell As Cell
Set tblCell = tbl.Cell(1, iCol)

Dim sHeader As String
sHeader = tblCell.Range.Text
Dim iLenHeader As Integer
iLenHeader = Len(sHeader)
If sHeader Like sTable_Column_Header Then
iCol_Target = iCol
Set tbl_Target = tbl

bControl_Exists = True
Exit For
ElseIf sHeader Like sTable_Column_Header & "*" Then
'*Foto [] chr(13) chr(7)
Dim sRange_Header As String
'sRange_Header = Mid(sHeader, 1, iLenHeader - 2)
sRange_Header = sHeader
sRange_Header = Replace(sRange_Header, Chr(13), "")
sRange_Header = Replace(sRange_Header, Chr(7), "")
sRange_Header = Trim(sRange_Header)
If sRange_Header Like sTable_Column_Header Then
iCol_Target = iCol
Set tbl_Target = tbl
bControl_Exists = True
Exit For
End If
End If
 
Next
End If
Next
If bControl_Exists = False Then
MsgBox "I could not find the Table-Column-Header: " & sTable_Column_Header, vbCritical, "Table Title missing"
Exit Sub
End If
'----</ check TableCaption exists >---
 
 
'*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"
objFiledialog.Title = "Select the photos.."
objFiledialog.InitialView = msoFileDialogViewTiles
objFiledialog.InitialFileName = sBase_Path
If objFiledialog.Show() = False 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 iFile As Integer
For iFile = 1 To objFiledialog.SelectedItems.Count Step 1
'------< Loop.Item >------
DoEvents
 
'< get selection >
sFilename = objFiledialog.SelectedItems(iFile)
'</ get selection >
 
If UCase(sFilename) Like "*.JPG" Then 'JPG-Datei
'----< IsPhoto >----
iPicture = iPicture + 1
'-< select cell >-
If (tbl_Target.Rows.Count - 1) < iPicture Then
Dim new_Row As Row
Set new_Row = tbl_Target.Rows.Add()
 
End If
'-</ select cell >-
Dim cell_Range As Range
Set cell_Range = tbl_Target.Cell(iPicture + 1, iCol_Target).Range
cell_Range.Select
Selection.EndKey
DoEvents
 
'refresh Style
tbl_Target.Style = tbl_Target.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(intPicture_Size_in_Centimeters) 'in Centimeters
Else
objInlineShape.Height = CentimetersToPoints(intPicture_Size_in_Centimeters) '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 >--
 
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 >------
 
 
' '------< Convert all InlineShapes to Shapes >------
' Dim inlineShape As inlineShape
' For Each inlineShape In doc.InlineShapes
' Dim shape As shape
' Set shape = inlineShape.ConvertToShape()
'
' shape.WrapFormat.AllowOverlap = 0
' shape.WrapFormat.Type = wdWrapSquare
' shape.WrapFormat.Side = wdWrapRight
'
' shape.WrapFormat.DistanceBottom = CentimetersToPoints(0.5)
' shape.WrapFormat.DistanceLeft = CentimetersToPoints(0.5)
' shape.WrapFormat.DistanceRight = CentimetersToPoints(0.5)
' shape.WrapFormat.DistanceTop = CentimetersToPoints(0.5)
' Next
' '------</ Convert all InlineShapes to Shapes >------
 
'-----------------< Fotos_einfuegen() >-----------------
End Sub
 
 

 
Mobile

.

0123movie.net