freiberuflicher Software Entwickler C#, vb.Net, vba, UWP, WPF, WinForms, SQL Server, Access, Excel, ASP.Net Core MVC Telefon: 07022/9319004   Kontakt
#

Download:

Datei 1: word_Foto_Ordner_importieren.docm

 

Diese Word Vorlage macht folgendes: beim klicken auf den Button Fotos von Ordner importieren wird ein Datei Dialog geöffnet, der Fotos in der Vorschau anzeigen kann.

Im Dialog wählt man einen Ordner aus und danach wird das komplette Verzeichnis in Word als platzsparende Foto Images eingefügt.

Die Fotos werden dabei auf eine maximale Länge von 17 Zentimeter eingefügt. Die Länge ist im Makro des Buttons veränderbar.

 

 

Start des Einfügen der Fotos

Durch klick auf den Button in der Word-Vorlage

 

Dann muss man einen Ordner auswählen, indem man ein Bild auswählt oder doppelklickt

 

Dann werden alle Fotos einzeln eingefügt und auf eine maximale länge oder Breite zugeschnitten.

Nach den Einfügen muss man das Dokument speichern.

 

 

 

'----< 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 Automatische Foto Dokumentation Vorlage 1 Spaltig 2 Fotos sortiert mit BildNamen
»
Foto Vorlage 4-Spaltig
»
Word Foto Vorlage für Fotodokumentationen
»
Word Makro: Alle Fotos einfügen von Eingabe-Ordner mit Makro
»
Word Vorlage: Kompletten Foto Ordner einlesen nach Basispfad und Ordnername
»
Word Vorlage: Foto-Dokumentation als Foto-Verzeichnis einlesen
»
Word Vorlage: Foto-Dokumentation
»
Word Vorlage: Foto Verzeichnis in ein Word Dokument einlesen
»
Word Vorlage: Einfügen von Fotos in mehrspaltige Tabelle
»
Word Makro: Fotos einfügen mit Auswahl Dialog mit Word Download-Datei

.

Jobs, Projekte, Angebote für Freiberufler, Selbstständig an Raimund.Popp@Microsoft-Programmierer.de