Übergabe von Excel nach Word und und und

Informationen und Beispiele zu den hier genannten Dialog-Elementen:
Bild

Betrifft: Übergabe von Excel nach Word und und und
von: Stefan H.
Geschrieben am: 11.06.2015 15:38:38

Servus,
ich hoffe es findet sich jemand, der mich bei meinem VBA-Code, für eine Übergabe aus einer Excel Kalkulation, ins Word für eine Angebotslegung, unterstützt.
Code befindet sich in Excel
Was passiert:
Word erstellen,
Dokument einrichten,
Texte aus Excel nach Word übergeben,
MsgBox für "mit Bilder" Ja/Nein,
Texte formatieren,
Bilder einfügen und Positionieren,
Speicherdialog.
Ich bräuchte nun bitte Anregungen bzw. Empfehlungen
für mein Problemkind Namens Bilder einfügen und positionieren.


Private Sub CommandButton2_Click()
Debug.Print "Start: " & Time
    With Windows.Application
        .CutCopyMode = False
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With
    
    Dim wdApp As Word.Application
    Dim wdDoc As Word.Document
    Dim iCounter As Integer
    Dim strSaveName As String
    Dim strSavePath As String
    Dim strTxt As String
    Dim strPic As String
    Dim strPicPath As String
    Dim strPicName As String
    Dim strPicWm As String
    Dim strPicBmp As String
    Dim Shp As Word.Shape
    Dim dblLeft As Double
    Dim dblTop As Double
    Dim blnYesNo As Boolean
    
    'Speicherort für Angebot
    strSavePath = ThisWorkbook.Path & "\"
    strSaveName = Worksheets("Eingabe").Range("E14")
    'Speicherort der Bilddateien
    strPicPath = "C:\FHK95\Bilder\"
    strPicBmp = ".bmp"
    strPicWm = "Shape_Watermark"
    'Create Word Application
    Set wdApp = CreateObject("Word.Application")
    Set wdDoc = wdApp.Documents.Add
    'Format Word Document
    With wdApp
        With .Selection.ParagraphFormat
            .LeftIndent = wdApp.CentimetersToPoints(0)
            .RightIndent = wdApp.CentimetersToPoints(0)
            .SpaceBefore = 0
            .SpaceBeforeAuto = False
            .SpaceAfter = 0
            .SpaceAfterAuto = False
            .LineSpacingRule = wdLineSpaceSingle
            .Alignment = wdAlignParagraphLeft
            .WidowControl = True
            .KeepWithNext = False
            .KeepTogether = False
            .PageBreakBefore = False
            .NoLineNumber = False
            .Hyphenation = True
            .FirstLineIndent = wdApp.CentimetersToPoints(0)
            .OutlineLevel = wdOutlineLevelBodyText
            .CharacterUnitLeftIndent = 0
            .CharacterUnitRightIndent = 0
            .CharacterUnitFirstLineIndent = 0
            .LineUnitBefore = 0
            .LineUnitAfter = 0
            .MirrorIndents = False
            .TextboxTightWrap = wdTightNone
        End With
        With .ActiveDocument.PageSetup
            .LineNumbering.Active = False
            .Orientation = wdOrientPortrait
            .TopMargin = wdApp.CentimetersToPoints(5)
            .BottomMargin = wdApp.CentimetersToPoints(2)
            .LeftMargin = wdApp.CentimetersToPoints(2)
            .RightMargin = wdApp.CentimetersToPoints(1.5)
            .Gutter = wdApp.CentimetersToPoints(0)
            .HeaderDistance = wdApp.CentimetersToPoints(0)
            .FooterDistance = wdApp.CentimetersToPoints(0)
            .PageWidth = wdApp.CentimetersToPoints(21)
            .PageHeight = wdApp.CentimetersToPoints(29.7)
            .FirstPageTray = wdPrinterFormSource
            .OtherPagesTray = wdPrinterFormSource
            .SectionStart = wdSectionNewPage
            .OddAndEvenPagesHeaderFooter = False
            .DifferentFirstPageHeaderFooter = False
            .VerticalAlignment = wdAlignVerticalTop
            .SuppressEndnotes = False
            .MirrorMargins = False
            .TwoPagesOnOne = False
            .BookFoldPrinting = False
            .BookFoldRevPrinting = False
            .BookFoldPrintingSheets = 1
            .GutterPos = wdGutterPosLeft
        End With
        'Insert Watermark
        strPic = strPicPath & strPicWm & strPicBmp
        With .ActiveDocument.Sections(1).Headers(wdHeaderFooterPrimary).Shapes.AddPicture( _
Filename:=strPic, linktofile:=False, savewithdocument:=True)
            .Name = "Wolf Briefpapier"
            .PictureFormat.Brightness = 0.5
            .PictureFormat.Contrast = 0.5
            .LockAspectRatio = True
            .Height = wdApp.CentimetersToPoints(32)
            .Width = wdApp.CentimetersToPoints(20.6)
            .WrapFormat.AllowOverlap = True
            .WrapFormat.Side = wdWrapNone
            .WrapFormat.Type = wdWrapBehind
            .RelativeHorizontalPosition = wdRelativeHorizontalPositionMargin
            .RelativeVerticalPosition = wdRelativeVerticalPositionMargin
            .Left = wdShapeCenter
            .Top = wdShapeCenter
        End With
    End With
    'Format Text in Excel
    Worksheets("zwischen").Range("A2:Z800").ClearContents
    Worksheets("text").Range("A1:Z800").ClearContents
    Worksheets("auswert").Range("B2:B500").Copy
    Worksheets("zwischen").Range("a2").PasteSpecial Paste:=xlValues, Operation:=xlNone,  _
SkipBlanks:=False, Transpose:=False
    Worksheets("zwischen").Range("a1").AutoFilter Field:=1, Criteria1:="<>0", Operator:=xlAnd
    Worksheets("zwischen").Range("A2:A500").Copy
    Worksheets("text").Range("A1").PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
    Worksheets("text").Range("A:A").Copy
Debug.Print "Word formatiert, Texte formatieren: " & Time
    'WORD VBA
    With wdApp
        'Insert Text
        .Selection.PasteExcelTable False, False, True
        Dim tbl As Table
        For Each tbl In .ActiveDocument.Tables
            tbl.ConvertToText Separator:=wdSeparateByParagraphs
        Next tbl
        Set tbl = Nothing
        'MsgBox Angebot mit Bilder?
        If MsgBox("Angebot mit Bildern Ja, oder nein?", vbYesNo) = vbYes Then blnYesNo = True  _
Else blnYesNo = False
        'Format Text
        For iCounter = 0 To 10
            ' 0 = (Jump) = xx   -> Absätze
            ' 1 = (Jump) = Normalbeton
            ' 2 = (Jump) = Dichtbeton
            ' 3 = (Jump) = Fundamentplatte
            ' 4 = (Jump) = Fundamentplatte auf Frostkoffer
            ' 5 = (Jump) = Datum
            ' 6 = (Loop) = *    -> FETT
            ' 7 = (Loop) = ///  -> FETT
            ' 8 = (Loop) = ###  -> löschen
            ' 9 = (Loop) = yy   -> Tabs einfügen
            '10 = ( ** ) = °°°  -> *If blnYesNo=True then Jump else Loop* Bei Bildern mit zu  _
geringem Textabstand für das Bild mehr Absätze einfügen
            If iCounter = 0 Then strTxt = "xx" Else If iCounter = 1 Then strTxt = "ANGEBOT  _
NORMALBETONKELLER" Else If iCounter = 2 Then strTxt = "ANGEBOT DICHTBETONKELLER" _
            Else If iCounter = 3 Then strTxt = "ANGEBOT FUNDAMENTPLATTE mit STREIFENFUNDAMENTEN" _
 Else If iCounter = 4 Then strTxt = "ANGEBOT FUNDAMENTPLATTE auf FROSTKOFFER" _
            Else If iCounter = 5 Then strTxt = "Datum" Else If iCounter = 6 Then strTxt = "*"  _
Else If iCounter = 7 Then strTxt = "///" Else If iCounter = 8 Then strTxt = "###" _
            Else If iCounter = 9 Then strTxt = "yy" Else If iCounter = 10 Then strTxt = "°°°"
.Visible = True
            If iCounter < 6 Then GoTo Jump1:                        'declare !! DO NOT LOOP !!
            If iCounter = 10 And blnYesNo = True Then GoTo Jump1:   'declare !! DO NOT LOOP !!
            Do
Jump1:          With .Selection     'Achtung innerhalb von -> With .Selection <- darf keine  _
DoLoop Schleife angewendet werden!!! DoLoop nur bei Einzelschritten und Mehrfachanwendung!!!
                    With .Find
                        .ClearFormatting
                        .Text = strTxt
                        .Replacement.Text = "^l"
                        .Forward = True
                        .Wrap = wdFindContinue
                        .Format = False
                        .MatchCase = False
                        .MatchWholeWord = False
                        .MatchWildcards = False
                        .MatchSoundsLike = False
                        .MatchAllWordForms = False
                        If iCounter < 6 Then
                            If iCounter = 0 Then        'Absätze einfügen
                                .Execute Replace:=wdReplaceAll
                            Else: If iCounter > 0 Then .Execute
                            End If
                        End If
                        If blnYesNo = True Then         '°°° Bildabstände
                            If iCounter = 10 Then
                                .Execute Replace:=wdReplaceAll
                            End If
                        End If
                    End With
                    If iCounter = 1 Or iCounter = 2 Or iCounter = 3 Or iCounter = 4 Then 'Ü _
berschriften Formatierung
                        .Font.Size = 14
                        .Font.Bold = wdToggle
                        .Font.Italic = wdToggle
                        .ParagraphFormat.Alignment = wdAlignParagraphCenter
                        .MoveRight unit:=wdCharacter, Count:=1
                    End If
                    If iCounter = 5 Then            'Datum einfügen
                        .InsertDateTime DateTimeFormat:="dd.MM.yyyy", InsertAsField:=False,  _
DateLanguage:=wdGerman, CalendarType:=wdCalendarWestern, InsertAsFullWidth:=False
                        .MoveLeft unit:=wdCharacter, Count:=10
                        .ParagraphFormat.Alignment = wdAlignParagraphRight
                    End If
                    If iCounter = 6 Then        '* FETT
                        If .Find.Execute = True Then
                            .InsertSymbol Font:="CommercialPi BT", CharacterNumber:=-4047,  _
Unicode:=True
                            .MoveLeft unit:=wdCharacter, Count:=1
                            .EndKey unit:=wdLine, Extend:=wdExtend
                            .Font.Bold = wdToggle
                            If blnYesNo = True Then 'Tab & Indent if PIC
                                .Paragraphs.TabStops.Add Position:=InchesToPoints(4), Alignment: _
=wdAlignTabRight
                                .Paragraphs.RightIndent = 165
                            Else:                   'Tab if no PIC
                                .Paragraphs.TabStops.Add Position:=InchesToPoints(6.4),  _
Alignment:=wdAlignTabRight
                            End If
                        Else: Exit Do
                        End If
                    End If
                    If iCounter = 7 Then        '/// FETT
                        If .Find.Execute = True Then
                            .Delete
                            .EndKey unit:=wdLine, Extend:=wdExtend
                            .Font.Bold = wdToggle
                        Else: Exit Do
                        End If
                    End If
                    If iCounter = 8 Then        '### + Leerzeilen entfernen
                        If .Find.Execute = True Then
                            .EndKey unit:=wdStory, Extend:=wdExtend
                            .Delete unit:=wdCharacter, Count:=1
                        Else: Exit Do
                        End If
                    End If
                    If iCounter = 9 Then        'yy Tabs einfügen
                        If .Find.Execute = True Then
                            .Delete
                            .InsertAfter (vbTab)
                        Else: Exit Do
                        End If
                    End If
                    If blnYesNo = False Then
                        If iCounter = 10 Then        '°°° Bildabstände
                            If .Find.Execute = True Then
                                .Delete
                            Else: Exit Do
                            End If
                        End If
                    End If
                    If iCounter < 6 Then GoTo Jump2:                        'declare !! DO NOT  _
LOOP !!
                    If iCounter = 10 And blnYesNo = True Then GoTo Jump1:   'declare !! DO NOT  _
LOOP !!
                End With
            Loop
Jump2:  Next iCounter
Debug.Print "Texte formatiert, Bilder formatieren: " & Time
        For iCounter = 1 To 15
                If iCounter = 1 Then strPicName = "Shape_Streifenfundament" Else If iCounter =  _
2 Then strPicName = "Shape_Schalstein" Else If iCounter = 3 Then strPicName = "Shape_Punktfundament" _
                Else If iCounter = 4 Then strPicName = "Shape_WP" Else If iCounter = 5 Then  _
strPicName = "Shape_Erdung" Else If iCounter = 6 Then strPicName = "Shape_Platte" _
                Else If iCounter = 7 Then strPicName = "Shape_Kanal" Else If iCounter = 8 Then  _
strPicName = "Shape_Drainage_norm" Else If iCounter = 9 Then strPicName = "Shape_Drainage_sys" _
                Else If iCounter = 10 Then strPicName = "Shape_Dämmung" Else If iCounter = 11  _
Then strPicName = "Shape_Niro" Else If iCounter = 12 Then strPicName = "Shape_Aushub" _
                Else If iCounter = 13 Then strPicName = "Shape_Rollierung" Else If iCounter =  _
14 Then strPicName = "Shape_Pumpensumpf" Else If iCounter = 15 Then strPicName = "Shape_Aussparung" _
                Else If iCounter = 16 Then strPicName = "" Else If iCounter = 17 Then  _
strPicName = "" Else If iCounter = 18 Then strPicName = "" _
                Else If iCounter = 19 Then strPicName = "" Else If iCounter = 20 Then  _
strPicName = "" Else If iCounter = 21 Then strPicName = "Shape_Abstecken"
            strPic = strPicPath & strPicName & strPicBmp
            Do
                If blnYesNo = True Then
                    Set Shp = wdDoc.Shapes.AddPicture(Filename:=strPic, linktofile:=False,  _
savewithdocument:=True)
                    With Shp
                        .Select
                        .ConvertToInlineShape
                        .Width = 125
                        .Height = 50
                    End With
                    wdApp.Selection.Cut
                End If
                With .Selection.Find
                    .ClearFormatting
                    .Text = strPicName
                    .Forward = True
                    .Wrap = wdFindContinue
                    .Format = False
                    .MatchCase = False
                    .MatchWholeWord = True
                    If blnYesNo = False Then
                        .Replacement.Text = ""
                        .Execute Replace:=wdReplaceAll
                        Exit Do
                    ElseIf blnYesNo = True Then
                        If .Execute = True Then
                            wdApp.Selection.Paste
                            dblLeft = Shp.Left
                            dblTop = Shp.Top
                            Shp.Delete
                            wdApp.Selection.Paste
                            Shp.WrapFormat.Type = wdWrapFront
                            Shp.Left = dblLeft + 365
                            Shp.Top = dblTop + 45
                        Else: Exit Do
                        End If
                    End If
                End With
            Loop
        Next iCounter
        .Selection.HomeKey unit:=wdStory
        .ActiveWindow.ActivePane.View.Zoom.Percentage = 100
        '.Visible = True
        With .Dialogs(wdDialogFileSaveAs)
            .Name = strSavePath & "AN_" & strSaveName
            If .Display <> 0 Then
                wdApp.ActiveDocument.SaveAs2 Filename:=strSavePath & "AN_" & strSaveName
            Else
                wdApp.WordBasic.MsgBox "Speichern vom Benutzer abgebrochen!!"
            End If
        End With
    End With
    'END WORD VBA
    Worksheets("Eingabe").Range("E13").Select
    
    With Windows.Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
    End With
    
    Set wdDoc = Nothing
    Set wdApp = Nothing
    
Debug.Print "Ende: " & Time
End Sub

Bild

Betrifft: nachfrage
von: selli
Geschrieben am: 11.06.2015 15:42:24
hallo stefan,
ein serienbrief tut es hier wohl nicht?
auch in den kann man bilder einfügen.
gruß
selli

Bild

Betrifft: AW: nachfrage
von: Stefan H.
Geschrieben am: 11.06.2015 15:59:12
Du musst dir das folgendermaßen vorstellen,
Bei mir hat der Außendienst eine Kalkulationsoberfläche,
dort gibt er die Massenermittlungen ein,
bekommt dann die Preise natürlich ausgeworfen und kann sich die Kalkulation drucken.
Nun kommt der Code zu tragen, er klickt in der Kalkulation auf
"druck Angebot" und es übergibt dann die ganzen Massen mit Bauteilbeschreibungen und und und
ins Word.
Somit ist die Basis das mein Vertriebspartner nur Office.
Ergo die Excel Datei beinhaltet für das entstehende Word Dokument alle Richtlinien wie dieses Angebot auszusehen hat.
nur das Problem ist irgendwie dass er auf den ersten 2 Seiten im Angebot die Bilder richtig neben
dem Text positioniert werden und ab der 3. Seite fügt er die Bilder ein aber sie verschwinden warum auch immer im Nirgendwo und sind unauffindbar.

 Bild

Beiträge aus den Excel-Beispielen zum Thema "Übergabe von Excel nach Word und und und"