Free Code Snippets in C#, Net Framework, Office 365, ASP.Net,WPF, Visual Studio, SQL Server, Antivirus free
#

Download:

Datei 1: Data.xlsx
Datei 2: Demo_Passport.dotm

 

 

Task:

This template shows how to dynamically swap images and photos in Word and how to use data from an Excel file as a merge document.

It does not use the mail merge manager, but executes the functions in vba code

 

Procedure:

The template is a Word.dotm file as a template. This means that when you double-click on the template in the File Explorer, a new Document1.docx file is created.

Then all you have to do is press the Start button and an output with the data sets from the enclosed Excel file will be created.

 

Output and print file

The Vba code creates a new output file Document2.docx like a new form letter and this contains the data from the Excel file and a matching photo and barcode for each record.

 

 

Excel file

The Excel file contains the columns Name, Firstname, Company, Nr and Test.

All data records which have an X in the test column are output. For the other columns, the values ​​are entered in the Word file similar to the functional form letter fields.

 

File structure

The base directory contains the Word template and the Excel data file

Word Template: Demo_Passport.dotm

Excel: Data.xlsx

 

_Photos

All photos will be inserted with the same naming format in an underneath folder _Photos.

In the vba code the path can of course be changed.

 

_Barcodes

Accordingly, here are all barcodes with a matching name in a subdirectory

 

 

Complete Vba code

Setting range

In the upper area you can set the name of the Excel file and the header area of ​​the Excel file

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

 

 

The main routine in the button event

The central code is run once in the event of the button. From there, all function methods are called

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

 

 

 

Create a new Word output

This routine creates a new Word document, such as a Remote Document.

Then the margins and the width and height are adjusted

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

 

 

 

Read in Excel

The first block opens the Excel file and looks for the header of the table.

Then all lines are run through and the values ​​of the columns and cells are read out.

This function then fetchs the values ​​in the new document and swaps the photos for each line.

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

 

 

 

Exchange photos

The photos are exchanged by incorporating a new InlineShape, adjusting the same dimensions as the placeholder and then deleting the placeholder.

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 Template: Attaching various photos and data from an Excel file
»
Word no longer displays the top and bottom margins.
»
Word: Preventing Word Wrap in a Table
»
Word Developer Tools
»
Word tables: tables change spacing
»
Word: Text mit Trennzeichen in eine Tabelle umwandeln
»
Word Anleitung: Serienbriefe erstellen mit Adressen aus Excel
»
Word: Angezeigter Text als Formatvorlage speichern

.

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