Freelance Project Requests info@CodeDocu.de Software Development in C# WPF Asp.Net Core Vba Excel Word SQL-Server EF Linq, UWP Net
#

Download:

Datei 1: word_Foto_Ordner_importieren.docm

 

 

 

This Word template does the following: clicking on the button Import Photos from Folder opens a file dialog, which can preview photos.

In the dialog select a folder and then the complete directory is inserted into Word as space-saving photo images.

The photos are inserted to a maximum length of 13 centimeters. The length can be changed in the macro of the button.

 

 

Start inserting the photos

Click on the button in the Word template

 

Then you have to select a folder by selecting or double-clicking an image

 

Then all photos are inserted individually and cut to a maximum length or width.

After inserting, you must save the document.

 

 

 

'----< Setup Parameters >----

Const const_Path_Photos_Default = ""

Const const_int_maxLength_Photos = 11   'breite in Zentimeter

'----</ Setup Parameters >----

 

Private Sub btnFotos_importiern_Click()

    '--------------------< btnFotos_importiern_Click() >--------------------

    ' this word macro imports all photos from a folder into a new Word Document.

 

 

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

 

 

    '< Tabelle sortieren >

    '*nach Dateinamen

    recFiles.Sort = "FileName"

    '</ Tabelle sortieren >

 

    '< neues Dokument ersetellen >

    Dim newDoc As Document

    Set newDoc = Application.Documents.Add

    '</ neues Dokument ersetellen >

   

    '-------< @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

             

        '----< File als Bitmap einfuegen >----

        Set objInlineShape = newDoc.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 >

        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.TypeText Text:=Chr(11)

        '</ Filename schreiben >

 

        '< next >

        recFiles.MoveNext

        '</ next >

    Loop

    '-------</ @Loop: Sortierte Ausgabe-Files einfuegen >--------

 

    '< finish >

    recFiles.Close

    Set recFiles = Nothing

    '</ finish >

   

    '< save >

    On Error Resume Next

    newDoc.Save '   "Fotos_" & Format(Date, "YYYY MM DD")

 

    '</ save >

    '--------------------</ btnFotos_importiern_Click() >--------------------

End Sub

 

 

Mobile
»
Word template for inserting von photos Version 55
»
Word Addin: Insert photos after a picture mark into a table
»
Photo documentaion in Word
»
Word Automatic Photo Documentation Template 1 Column 2 Photos with Numbers
»
Photo Template 4-Columns
»
Word Photo Template for Photo Documentation
»
Word macro: Insert all photos from input folder with macro
»
Word Template: Read the complete photo folder to base path and folder name
»
Word Template: Import photo documentation as a photo directory
»
Word Template: Photo Documentation

.

Contact for Jobs, Project Requests: raimund.popp@microsoft-programmierer.de