CodeDocu.com


 
 
Vba Code to import complete photo directories into a photo documentation
 
Contains Wordcode for:
- Insert photos into a Word file
- Customize the sizes of photos and images in Word
- File dialog under Word
- Button and textbox in Word as input controls
- Change the Document.Properties Title at runtime during a field input
 
Word Code: Edit photos and controls in vba
 
 
The vba code for the template can be found with Alt-F11
Word Code: Edit photos and controls in vba
 
 
 
Vba Code for template photo documentation

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

 

Software Entwicklung Stuttgart NĂ¼rtingen
Suche Projekte C#, WPF, Windows App,ASP.Net, vb.Net, WinForms, SQL Server, Access, Excel