Option Explicit On
'----<
Setup Parameters >----
Const const_int_maxLength_Photos = 17 'breite in
Zentimeter
Const const_Path_Photos_Default = "B:\2017"
Public position_Button As Long
Public position_Textbox As Long
Public sNr As String
'Oder
alternativ X:\Service
'----</
Setup Parameters >----
Private Sub
btnFotos_importiern_Click()
'--------------------<
btnFotos_importiern_Click() >--------------------
Insert_Photos()
'--------------------</
btnFotos_importiern_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 objControl As Object
Dim objShape As
InlineShape
For Each
objShape In doc.InlineShapes
If objShape.Type = wdInlineShapeOLEControlObject Then
'<
Delete_Button >
If objShape.OLEFormat.ClassType Like "*Button*" Then
Set objControl = objShape.OLEFormat.Object
If objControl.Caption Like "*Fotos*" Then
'*delete Control
position_Button =
objControl.Automation.Range.Start
objShape.Delete
Set objShape = Nothing
End If
End If
'<
/Delete_Button >
End If
Next
For Each
objShape In doc.InlineShapes
If objShape.Type = wdInlineShapeOLEControlObject Then
'<
Delete_Textbox >
If Not
objShape Is Nothing Then
If objShape.OLEFormat.ClassType Like "*TextBox*" Then
Set objControl = objShape.OLEFormat.Object
If objControl.Name Like "*Nr*" Then
'*delete Control
position_Textbox =
objControl.Automation.Range.Start
objShape.Delete
End If
End If
End If
'<
/Delete_Textbox >
End If
Next
'----</
@Loop: Controls >----
'-----------------</
Button_loeschen() >-----------------
End Sub
Sub Insert_Photos()
'-----------------<
Fotos_einfuegen() >-----------------
'*Description:
'*This macro
inserts photos after the button
' this word
macro imports all photos from a folder into a new Word Document.
'< neues
Dokument ersetellen >
Dim doc As
Document
Set doc = ActiveDocument
'</ neues
Dokument ersetellen >
'--<
Dateidialog >--
Dim objFiledialog As FileDialog
Set objFiledialog = Application.FileDialog(msoFileDialogFilePicker)
objFiledialog.AllowMultiSelect = True
objFiledialog.ButtonName = "Ordner übernehmen"
objFiledialog.Filters.Add "Bilder", "*.jpg,*gif,*.tiff,*.png"
objFiledialog.Title = "Wählen Sie einen Ordner aus"
objFiledialog.AllowMultiSelect = False
objFiledialog.InitialFileName =
const_Path_Photos_Default
Dim sFilename As String
If objFiledialog.Show() = True Then
sFilename =
objFiledialog.SelectedItems(1)
End If
'--<
Dateidialog >--
'< Ordner
bestimmen >
Dim sFolder As String
sFolder = Left(sFilename, InStrRev(sFilename,
"\", ,
vbTextCompare))
'</ Ordner
bestimmen >
'--<
Kontrolle >--
'< Ordner
ist leer >
If sFolder Like "" Then
Exit Sub
End If
'</ Ordner
ist leer >
'<
Kontrolle: ist Ordner >
Dim objFilesystem As New
FileSystemObject
If Not
objFilesystem.FolderExists(sFolder) = True Then
MsgBox "Der
eingegebene Pfad ist kein Ordner", vbOKOnly, "Ordner prüfen"
Exit Sub
End If
'</
Kontrolle: ist Ordner >
'--</
Kontrolle >--
'< Ordner
laden >
Dim objFolder As Folder
Set objFolder = objFilesystem.GetFolder(sFolder)
'</ Ordner
laden >
'----<
sortierbare Tabelle erstellen >----
Dim recFiles As New ADODB.Recordset
recFiles.Fields.Append "FileName", adVarChar,
255, adFldIsNullable
recFiles.Open
'----</
sortierbare Tabelle erstellen >----
'-------<
@Loop: Eingabe-Files >--------
Dim objFile As File
For Each
objFile In objFolder.Files
'----<
File >----
Dim intPos As Integer
intPos = InStrRev(objFile.Name, ".")
If intPos > 0 Then
Dim sExtension As String
sExtension =
LCase(Mid(objFile.Name, intPos + 1))
If InStr(".jpg .jpeg .bmp .png .tiff
.gif", sExtension) > 0 Then
'----< File ist Foto >----
'< Datei eintragen >
recFiles.AddNew
sFilename = objFile.Path
recFiles("FileName") = sFilename
recFiles.Update
'</ Datei eintragen >
'----</ File ist Foto >----
End If
End If
'----</
File >----
Next
'-------</
@Loop: Eingabe-Files >--------
'<
Kontrolle >
If recFiles.RecordCount = 0 Then
recFiles.Close
Exit Sub
End If
'</
Kontrolle >
'< delete
controls >
Button_delete()
'</ delete
controls >
'< delete
current line >
Dim objParagraph As Paragraph
For Each
objParagraph In
doc.Paragraphs
If Selection.Range.InRange(objParagraph.Range) Then
objParagraph.Range.Select
End If
Next
Selection.Delete
'</ delete
current line >
'< Tabelle
sortieren >
'*nach
Dateinamen
recFiles.Sort = "FileName"
'</ Tabelle
sortieren >
'-------<
@Loop: Sortierte Ausgabe-Files einfuegen >--------
Dim objInlineShape As InlineShape
recFiles.MoveFirst
Do Until
recFiles.EOF
Dim sDateiname As String
sDateiname = recFiles("FileName")
'On Error
Resume Next
On Error GoTo 0
'----<
File als Bitmap einfuegen >----
Set objInlineShape =
doc.InlineShapes.AddPicture(FileName:=sDateiname, LinkToFile:=False, SaveWithDocument:=True)
'< 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
>
objInlineShape.Select
Selection.Cut
'< als png
einfuegen >
'*ist dann
schon kleiner auch fuer den Speicher
On Error Resume Next
Selection.PasteSpecial Link:=False, DataType:=wdPasteBitmap,
Placement:=wdInLine, DisplayAsIcon:=False
'</ als
png einfuegen >
'----</
File als Bitmap einfuegen >----
'<
Filename schreiben >
DoEvents
'Selection.MoveDown
'< Text
Row >
Selection.TypeText Text:=Chr(11)
'</ Text
Row >
sFilename = Mid(sDateiname,
InStrRev(sDateiname, "\", , vbTextCompare) + 1)
'Selection.InsertParagraph
Selection.TypeText sFilename
'Selection.InsertParagraph
'Selection.TypeText
Text:=Chr(11)
Selection.TypeParagraph
Selection.TypeText Text:=Chr(11)
'</
Filename schreiben >
'< next
>
recFiles.MoveNext
'</ next
>
Loop
'-------</
@Loop: Sortierte Ausgabe-Files einfuegen >--------
'< delete
empty page >
Selection.MoveDown Unit:=wdLine,
Count:=4, Extend:=wdExtend
Selection.Delete Unit:=wdCharacter, Count:=1
'</ delete
empty page >
'< finish
>
recFiles.Close
Set recFiles = Nothing
'</ finish
>
'< save
>
On Error Resume Next
doc.Save ' "Fotos_" & Format(Date,
"YYYY MM DD")
'</ save
>
'-----------------</
Fotos_einfuegen() >-----------------
End Sub
Private Sub
tbxNr_Change()
'----<
tbxNr_Change() >----
'*change
internal variable propertie Title
ActiveDocument.BuiltInDocumentProperties("Title") =
tbxNr.Value
'----</
tbxNr_Change() >----
End Sub
|