|
Option Explicit On
Sub Macro_Insert_Photos_From_Folder()
'-----------------<
Insert_Photos_at_Position() >-----------------
'*Insert
Photos from a definite Folder after a Text-Bookmark
'<
setup >
Const centimeters_height As Double = 7.5
'</
setup >
'< Init
>
Dim sBookmark_Name As String
sBookmark_Name = "Fotos"
'</ 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
'---<
Foldername >---
For Each control In doc.ContentControls
If control.Tag = "inputField_Foldername" Then
bControl_Exists = True
Exit For
End If
Next
If bControl_Exists = False Then
MsgBox "Das Eingabefeld
Foldername existiert nicht", vbCritical,
"Eingabefeld fehlt"
Exit Sub
End If
'-</
check InputControl exists >
'< Get
Input_Field >
Dim sFolderName As String
sFolderName = control.Range.Text
If sFolderName Like "" Then
MsgBox "Das
Feld Foldername: ist leer", vbCritical, "Check Foldername"
Exit Sub
End If
'</ Get
Input_Field >
'---</
Foldername >---
'------<
Insert Pictures From Folder >------
'< init
>
Dim sFolder_Path As String
sFolder_Path = sFolderName
'</
init >
Dim objFileSystem As New FileSystemObject
'<
check >
If Not objFileSystem.FolderExists(sFolder_Path)
Then
MsgBox "The
folder " &
sFolder_Path & "
does not exist", vbCritical, "Check Entry Basefolder and Foldername"
Exit Sub
End If
'</
check >
'< init
File-System >
'*Reference
Microsoft scripting Runtime
http://www.microsoft-programmierer.de/Details?d=1076
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(centimeters_height)
'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
|