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: Data.xlsx
Datei 2: Demo_Passport.dotm

 

 

Aufgabe:

Diese Vorlage zeigt, wie man in Word Bilder und Fotos dynamisch austauschen kann  und Daten von einer Excel Datei als Seriendokument verwenden kann.

Dabei wird nicht der Serienbrief-Manager verwendet, sondern die Funktionen in vba Code ausgeführt

 

Ablauf:

Die Vorlage ist eine Word.dotm Datei als Vorlage. Das heißt, beim doppelklick auf die Vorlage im Dateiexplorer entsteht eine neue Datei Document1.docx.

Dann muss man nur noch den Button Start drücken und schon wird eine Ausgabe mit den Datensätzen aus der beiliegenden Excel Datei erstellt.

 

Ausgabe und Print-Datei

Der Vba Code erzeugt eine neue Ausgabe-Datei Document2.docx wie ein neuer Serienbrief und dieser enthält die Daten aus der Excel-Datei und zu jedem Datensatz ein passendes Foto und ein geänderter Barcode.

 

 

Excel Datei

Die Excel-Datei enthält die Spalten Name, Firstname, Company, Nr und Test.

Alle Datensätze, welche ein X in der Test-Spalte haben werden dabei ausgegeben. Bei den anderen Spalten werden die Wert in die Word Datei eingetragen ähnlich den funktionellen Serienbrief Feldern.

 

Datei Struktur

Im Basis-Verzeichnis liegt die Word-Vorlage und die Daten-Datei Excel

Word-Vorlage: Demo_Passport.dotm

Excel: Data.xlsx

 

_Fotos

Alle Fotos werden mit gleicher Benenungsformat in einen unterliegenden Ordner _Fotos eingefügt.

Im vba Code kann der Pfad natürlich geändert werden.

 

_Barcodes

Dementsprechend liegen hier alle Barcodes mit einer passenden Benennung in einem Unterverzeichnis

 

 

Kompletter Vba Code

Settingsbereich

Im oberen bereich kann man den Namen der Excel -Datei und die Kopfbereiche der Excel -Datei einstellen

'< Settings >

Const Excel_Import_Dateiname As String = "Data.xlsx"

 

Const Key_Header_Start = "Name"

Const sHeader_Firstname As String = "Firstname"

Const sHeader_Company As String = "Company"

Const sHeader_Test As String = "Test"

Const sHeader_Nr As String = "Nr"

'</ Settings >

 

Public Path_of_Template As String

Public docOutput As Document

 

 

Die Hauptroutine im Button-Event

Der Zentrale Code wird im Event des Buttons einmal durchlaufen. Von dort werden alle Funktion Methoden aufgerufen

Private Sub BtnImport_Click()

    '-------------< BtnImport_Click() >-------------

    '*Main Routine

    '< act Document >

    Dim doc As Document

    Set doc = ActiveDocument

    '</ act Document >

   

    '< Serial Output >

    fg_get_Document_Template_Path()

 

    fg_create_Word_Dokument()

    fg_Excel_einlesen()

    '</ Serial Output >

 

    '< close >

    docOutput.Activate

    doc.Close False

    '</ close >

    '-------------</ BtnImport_Click() >-------------

End Sub

 

 

 

Neue Word-Ausgabe erstellen

Diese Routine erstellt ein neues Word-Dokument wie ein Remote Document.

Dann werden die Ränder und die Breite und Höhe eingestellt

Public Sub fg_create_Word_Dokument()

    '---------------------< fg_create_Word_Dokument() >---------------------

    '----< Copy to new Document >----

    '--< create new Word Document >--

    Set docOutput = Word.Documents.Add

   

    '< Margins >

    docOutput.PageSetup.LeftMargin = CentimetersToPoints(0.5)

    docOutput.PageSetup.TopMargin = CentimetersToPoints(0.5)

    docOutput.PageSetup.RightMargin = CentimetersToPoints(0.5)

    docOutput.PageSetup.BottomMargin = CentimetersToPoints(0.5)

    '</ Margins >

 

    '< page size >

    docOutput.PageSetup.PageHeight = CentimetersToPoints(5.5)

    docOutput.PageSetup.PageWidth = CentimetersToPoints(8.5)

    '</ page size >

    '--</ create new Word Document >--

    '----</ Copy to new Document >----

 

    '---------------------</ fg_create_Word_Dokument() >---------------------

End Sub

 

 

 

Excel Einlesen

Der erste Block öffnet die Excel-Datei und sucht den Header der Tabelle.

Dann werden alle Zeilen durchlaufen und die Werte der Spalten und Zellen ausgelesen.

Diese Funktion ruft für jede Zeile dann das Erstellen der Werte im neuen Dokument und das Tauschen der Fotos aus.

Public Sub fg_Excel_einlesen()

    '---------------------< fg_Excel_einlesen() >---------------------

    On Error Resume Next

 

    Dim sImport_Filename_Fullpath As String

    sImport_Filename_Fullpath = Path_of_Template & "\" & Excel_Import_Dateiname   'Excel\

 

    '< Excel-Datei oeffnen >

    Dim objExcel As New Excel.Application

    Dim objWorkbook As Excel.Workbook

    Set objWorkbook = objExcel.Workbooks.Open(sImport_Filename_Fullpath)

    '</ Excel-Datei oeffnen >

   

    '< Kontrolle >

    If objWorkbook Is Nothing Then

        MsgBox "Die Excel Datei konnte nicht geöffnet werden", vbCritical, "Excel Datei Pfad prüfen"

        Exit Sub

    End If

    '</ Kontrolle >

 

    '< Blatt oeffnen >

    Dim objSheet As Excel.Worksheet

    Set objSheet = objWorkbook.Sheets(1)

    '</ Blatt oeffnen >

   

    '< Range definieren >

    Dim objRange As Excel.Range

    Set objRange = objSheet.UsedRange

    '</ Range definieren >

 

    Dim sHeader_Nachname As String

    sHeader_Nachname = Key_Header_Start

    Dim iCol_Nachname As Integer

    iCol_Nachname = 0

 

    '----< Header suchen >----

    Dim iRow As Integer

    Dim iCol As Integer

    Dim iRow_Header As Integer

    Dim objCell As Excel.Range

    Dim sWert As String

    DoEvents

 

    '----< @Loop: Rows >----

    For iRow = 1 To objRange.Rows.Count

        '--< @Loop: Spalten >--

        For iCol = 1 To objRange.Columns.Count

            sWert = objRange.Cells(iRow, iCol).Text

            If sWert = sHeader_Nachname Then

                iRow_Header = iRow

                iCol_Nachname = iCol

                Exit For

            End If

        Next

        '--</ @Loop: Spalten >--

    Next

    '----</ @Loop: Rows >----

    '----</ Header suchen >----

 

    '< Init Felder >

    Dim iCol_Vorname As Integer

    Dim iCol_Firma As Integer

    Dim iCol_Test As Integer

    Dim iCol_Nr As Integer

    iCol_Vorname = 0

    iCol_Firma = 0

    iCol_Test = 0

    iCol_Nr = 0

    '</ Init Felder >

 

    '----< Columns suchen >----

    '--< @Loop: Spalten >--

    For iCol = 1 To objRange.Columns.Count

        sWert = objRange.Cells(iRow_Header, iCol).Text

 

        If sWert = sHeader_Firstname Then

            iCol_Vorname = iCol

        ElseIf sWert = sHeader_Company Then

            iCol_Firma = iCol

        ElseIf sWert = sHeader_Test Then

            iCol_Test = iCol

        ElseIf sWert Like "Nr" Then

            iCol_Nr = iCol

        End If

    Next

    '--</ @Loop: Spalten >--

 

    '----</ Columns suchen >----

 

 

    '----< Zeilen einlesen >----

    DoEvents

 

    '--< @Loop: Rows >--

    For iRow = iRow_Header + 1 To objRange.Rows.Count

        '< check ende >

        sWert = objRange.Cells(iRow, iCol_Nachname).Text

        If sWert Like "" Then

            Exit For

        End If

        '</ check ende >

 

        '====< Export >====

        '--< Werte aus Excel lesen >--

        Dim sNachname As String, sVorname As String, sFirma As String, sNr As String, sTest As String

        sNachname = objRange.Cells(iRow, iCol_Nachname).Text

        sVorname = objRange.Cells(iRow, iCol_Vorname).Text

        sFirma = objRange.Cells(iRow, iCol_Firma).Text

        sNr = objRange.Cells(iRow, iCol_Nr).Text

        sTest = objRange.Cells(iRow, iCol_Test).Text

        '--</ Werte aus Excel lesen >--

 

        If sTest Like "*x*" Or sTest Like "*X*" Then

            '--< Ausgabe >--

            fg_set_Cell_Texts sVorname, sNachname, sFirma

            fg_replace_Photo sNr

            fg_replace_Barcode sNr

            '--</ Ausgabe >--

 

            '< copy Table >

            Tables(2).Select

            Selection.Copy

            Dim Range2 As Range

            Set Range2 = docOutput.Content

            Range2.Collapse Direction:=wdCollapseEnd

            Range2.Paste

            '</ copy Table >

        End If

 

        '====</ Export >====

 

    Next

    '--</ @Loop: Rows >--

 

    '----< Zeilen einlesen >----

 

    '< Abschluss >

    objWorkbook.Close

   

    Set objExcel = Nothing

    Set objWorkbook = Nothing

    Set objSheet = Nothing

    '</ Abschluss >

   

    'MsgBox "Fertig mit Einlesen"

 

    '---------------------</ fg_Excel_einlesen() >---------------------

End Sub

 

 

 

Fotos austauschen

Die Fotos werden ausgetauscht, indem man ein neues InlineShape einbinden, die gleichen Maße anpasst wie der Platzhalter und dann den Platzhalter löscht.

Public Sub fg_replace_Photo(ByVal sNr As String)

    '---------------------< fg_replace_Photo() >---------------------

    '< select old Photo >

    Dim imgOld As InlineShape

    Set imgOld = Tables(2).Tables(1).Range.InlineShapes(1)

    imgOld.Select

 

    Dim range_of_Image As Range

    Set range_of_Image = Selection.Range

    '</ select old Photo >

   

    '< get new photo >

    Dim sFilename As String

    sFilename = Path_of_Template & "\_Fotos\Photo0" & sNr & ".JPG"

 

    Dim imgNew As InlineShape

    Set imgNew = Me.InlineShapes.AddPicture(FileName:=sFilename, LinkToFile:=True, SaveWithDocument:=False, Range:=range_of_Image)

    '</ get new photo >

   

    '< adapt size >

    imgNew.Width = imgOld.Width

    imgNew.Height = imgOld.Height

    '</ adapt size >

 

    '< delete old >

    imgOld.Delete

    '</ delete old >

    '---------------------</ fg_replace_Photo() >---------------------

End Sub

 

 

 

 

 

Option Explicit On

 

 

'< Settings >

Const Excel_Import_Dateiname As String = "Data.xlsx"

 

Const Key_Header_Start = "Name"

Const sHeader_Firstname As String = "Firstname"

Const sHeader_Company As String = "Company"

Const sHeader_Test As String = "Test"

Const sHeader_Nr As String = "Nr"

'</ Settings >

 

Public Path_of_Template As String

Public docOutput As Document

 

 

 

'=======================< Buttons >=======================

Private Sub BtnImport_Click()

    '-------------< BtnImport_Click() >-------------

    '*Main Routine

    '< act Document >

    Dim doc As Document

    Set doc = ActiveDocument

    '</ act Document >

   

    '< Serial Output >

    fg_get_Document_Template_Path()

 

    fg_create_Word_Dokument()

    fg_Excel_einlesen()

    '</ Serial Output >

 

    '< close >

    docOutput.Activate

    doc.Close False

    '</ close >

    '-------------</ BtnImport_Click() >-------------

End Sub

'=======================</ Buttons >=======================

 

 

 

 

'=======================< Funktionen >=======================

 

Public Sub fg_Excel_einlesen()

    '---------------------< fg_Excel_einlesen() >---------------------

    On Error Resume Next

 

    Dim sImport_Filename_Fullpath As String

    sImport_Filename_Fullpath = Path_of_Template & "\" & Excel_Import_Dateiname   'Excel\

 

    '< Excel-Datei oeffnen >

    Dim objExcel As New Excel.Application

    Dim objWorkbook As Excel.Workbook

    Set objWorkbook = objExcel.Workbooks.Open(sImport_Filename_Fullpath)

    '</ Excel-Datei oeffnen >

   

    '< Kontrolle >

    If objWorkbook Is Nothing Then

        MsgBox "Die Excel Datei konnte nicht geöffnet werden", vbCritical, "Excel Datei Pfad prüfen"

        Exit Sub

    End If

    '</ Kontrolle >

 

    '< Blatt oeffnen >

    Dim objSheet As Excel.Worksheet

    Set objSheet = objWorkbook.Sheets(1)

    '</ Blatt oeffnen >

   

    '< Range definieren >

    Dim objRange As Excel.Range

    Set objRange = objSheet.UsedRange

    '</ Range definieren >

 

    Dim sHeader_Nachname As String

    sHeader_Nachname = Key_Header_Start

    Dim iCol_Nachname As Integer

    iCol_Nachname = 0

 

    '----< Header suchen >----

    Dim iRow As Integer

    Dim iCol As Integer

    Dim iRow_Header As Integer

    Dim objCell As Excel.Range

    Dim sWert As String

    DoEvents

 

    '----< @Loop: Rows >----

    For iRow = 1 To objRange.Rows.Count

        '--< @Loop: Spalten >--

        For iCol = 1 To objRange.Columns.Count

            sWert = objRange.Cells(iRow, iCol).Text

            If sWert = sHeader_Nachname Then

                iRow_Header = iRow

                iCol_Nachname = iCol

                Exit For

            End If

        Next

        '--</ @Loop: Spalten >--

    Next

    '----</ @Loop: Rows >----

    '----</ Header suchen >----

 

    '< Init Felder >

    Dim iCol_Vorname As Integer

    Dim iCol_Firma As Integer

    Dim iCol_Test As Integer

    Dim iCol_Nr As Integer

    iCol_Vorname = 0

    iCol_Firma = 0

    iCol_Test = 0

    iCol_Nr = 0

    '</ Init Felder >

 

    '----< Columns suchen >----

    '--< @Loop: Spalten >--

    For iCol = 1 To objRange.Columns.Count

        sWert = objRange.Cells(iRow_Header, iCol).Text

 

        If sWert = sHeader_Firstname Then

            iCol_Vorname = iCol

        ElseIf sWert = sHeader_Company Then

            iCol_Firma = iCol

        ElseIf sWert = sHeader_Test Then

            iCol_Test = iCol

        ElseIf sWert Like "Nr" Then

            iCol_Nr = iCol

        End If

    Next

    '--</ @Loop: Spalten >--

 

    '----</ Columns suchen >----

 

 

    '----< Zeilen einlesen >----

    DoEvents

 

    '--< @Loop: Rows >--

    For iRow = iRow_Header + 1 To objRange.Rows.Count

        '< check ende >

        sWert = objRange.Cells(iRow, iCol_Nachname).Text

        If sWert Like "" Then

            Exit For

        End If

        '</ check ende >

 

        '====< Export >====

        '--< Werte aus Excel lesen >--

        Dim sNachname As String, sVorname As String, sFirma As String, sNr As String, sTest As String

        sNachname = objRange.Cells(iRow, iCol_Nachname).Text

        sVorname = objRange.Cells(iRow, iCol_Vorname).Text

        sFirma = objRange.Cells(iRow, iCol_Firma).Text

        sNr = objRange.Cells(iRow, iCol_Nr).Text

        sTest = objRange.Cells(iRow, iCol_Test).Text

        '--</ Werte aus Excel lesen >--

 

        If sTest Like "*x*" Or sTest Like "*X*" Then

            '--< Ausgabe >--

            fg_set_Cell_Texts sVorname, sNachname, sFirma

            fg_replace_Photo sNr

            fg_replace_Barcode sNr

            '--</ Ausgabe >--

 

            '< copy Table >

            Tables(2).Select

            Selection.Copy

            Dim Range2 As Range

            Set Range2 = docOutput.Content

            Range2.Collapse Direction:=wdCollapseEnd

            Range2.Paste

            '</ copy Table >

        End If

 

        '====</ Export >====

 

    Next

    '--</ @Loop: Rows >--

 

    '----< Zeilen einlesen >----

 

    '< Abschluss >

    objWorkbook.Close

   

    Set objExcel = Nothing

    Set objWorkbook = Nothing

    Set objSheet = Nothing

    '</ Abschluss >

   

    'MsgBox "Fertig mit Einlesen"

 

    '---------------------</ fg_Excel_einlesen() >---------------------

End Sub

 

 

 

 

Public Sub fg_set_Cell_Texts(ByVal sVorname As String, ByVal sNachname As String, ByVal sFirma As String)

    '---------------------< fg_set_Cell_Texts() >---------------------

    Tables(2).Tables(2).Tables(1).Rows(1).Cells(2).Range.Text = sVorname

    Tables(2).Tables(2).Tables(1).Rows(2).Cells(2).Range.Text = sNachname

    Tables(2).Tables(2).Tables(1).Rows(3).Cells(2).Range.Text = sFirma

    '---------------------</ fg_set_Cell_Texts() >---------------------

End Sub

 

Public Sub fg_replace_Photo(ByVal sNr As String)

    '---------------------< fg_replace_Photo() >---------------------

    '< select old Photo >

    Dim imgOld As InlineShape

    Set imgOld = Tables(2).Tables(1).Range.InlineShapes(1)

    imgOld.Select

 

    Dim range_of_Image As Range

    Set range_of_Image = Selection.Range

    '</ select old Photo >

   

    '< get new photo >

    Dim sFilename As String

    sFilename = Path_of_Template & "\_Fotos\Photo0" & sNr & ".JPG"

 

    Dim imgNew As InlineShape

    Set imgNew = Me.InlineShapes.AddPicture(FileName:=sFilename, LinkToFile:=True, SaveWithDocument:=False, Range:=range_of_Image)

    '</ get new photo >

   

    '< adapt size >

    imgNew.Width = imgOld.Width

    imgNew.Height = imgOld.Height

    '</ adapt size >

 

    '< delete old >

    imgOld.Delete

    '</ delete old >

    '---------------------</ fg_replace_Photo() >---------------------

End Sub

 

 

Public Sub fg_replace_Barcode(ByVal sNr As String)

    '---------------------< fg_replace_Photo() >---------------------

    '< select old Photo >

    Dim imgOld As InlineShape

    Set imgOld = Tables(2).Tables(2).Rows(3).Cells(1).Range.InlineShapes(1)

    imgOld.Select

 

    Dim range_of_Image As Range

    Set range_of_Image = Selection.Range

    '</ select old Photo >

   

    '< get new photo >

    Dim sFilename As String

    sFilename = Path_of_Template & "\_Barcodes\barcode_00" & sNr & ".png"

 

    Dim imgNew As InlineShape

    Set imgNew = Me.InlineShapes.AddPicture(FileName:=sFilename, LinkToFile:=True, SaveWithDocument:=False, Range:=range_of_Image)

    '</ get new photo >

   

    '< adapt size >

    imgNew.Width = imgOld.Width

    imgNew.Height = imgOld.Height

    '</ adapt size >

 

    '< delete old >

    imgOld.Delete

    '</ delete old >

    '---------------------</ fg_replace_Photo() >---------------------

End Sub

 

 

 

 

Public Sub fg_create_Word_Dokument()

    '---------------------< fg_create_Word_Dokument() >---------------------

    '----< Copy to new Document >----

    '--< create new Word Document >--

    Set docOutput = Word.Documents.Add

   

    '< Margins >

    docOutput.PageSetup.LeftMargin = CentimetersToPoints(0.5)

    docOutput.PageSetup.TopMargin = CentimetersToPoints(0.5)

    docOutput.PageSetup.RightMargin = CentimetersToPoints(0.5)

    docOutput.PageSetup.BottomMargin = CentimetersToPoints(0.5)

    '</ Margins >

 

    '< page size >

    docOutput.PageSetup.PageHeight = CentimetersToPoints(5.5)

    docOutput.PageSetup.PageWidth = CentimetersToPoints(8.5)

    '</ page size >

    '--</ create new Word Document >--

    '----</ Copy to new Document >----

 

    '---------------------</ fg_create_Word_Dokument() >---------------------

End Sub

 

 

Public Sub fg_get_Document_Template_Path()

    '---------------------< fg_get_Document_Template_Path() >---------------------

    '< Document 1 >

    Dim doc As Document

    Set doc = ActiveDocument

    '</ Document 1 >

   

    '< get Template >

    Dim tmp 'As wdAttachedTemplate

    Set tmp = doc.AttachedTemplate

    '</ get Template >

   

    '< set Path >

    Path_of_Template = tmp.Path

    '</ set Path >

    '---------------------< fg_get_Document_Template_Path() >---------------------

End Sub

'=======================</ Funktionen >=======================

 

 

 

Mobile
»
Word Vorlage: Anbinden verschiedener Fotos und Daten aus einer Excel Datei
»
Word: Alle Makros sind weg. Wo findet man die Word-Vorlage Normal.dotm
»
Word Vorlage: Foto einfügen, automatisch drehen und in Breite und Höhe anpassen
»
Word Vorlage: Fotos in eine Tabelle laden
»
Word Vorlage: Fotos einfügen in eine mehrspaltige Tabelle
»
Word Makro: Fotos aus einem Bildarchiv an ein Word-Dokument anfügen und anpassen
»
Bilder in Word skalieren

.

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