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