Coder Board Community

Source code

Private Sub schreiben(adr As String, plz As String, ort As String, refid As Long, r_nr As Long, lst_rech As Collection)
    Dim filename As String, path As String
    Dim sh As Object
    Dim summe As String
    Dim Word As Object
    Dim rst As Recordset
    Dim sqls As String
    Dim getr As String
    Dim r_adr_ref As String
    Dim Zeile As Integer
    
    Set Word = CreateObject("Word.Application")
   
   'Dateiname generieren
   filename = Left(Form_rechnung.r_jahr.Value, 1) & Right(Form_rechnung.r_jahr.Value, 1)
   Select Case r_nr
     Case Is < 10
       filename = filename & "00"
     Case Is < 100
       filename = filename & "0"
   End Select
   filename = filename & r_nr & Form_rechnung.r_kkurz.Column(1) & "_TEST.doc"
   'Pfad generieren
   path = "X:\" & Form_rechnung.r_jahr.Value & "\@CAD-GmbH\@Rechnung\Rechnungen\"

   'Application ausblenden
   Word.Visible = False
   'Neues Dokument aus Vorlage
   Word.Documents.Add "x:\2006\@Listen\Brief\rechnung.dot", False, wdNewBlankDocument, True
   'Textfeld für Empfängeradresse anwählen
   Word.ActiveDocument.Shapes(1).Select
   

   
   
   With Word.Selection
     'Schreibe Adresse in Feld
     .TypeText Form_rechnung.r_kkurz.Column(5) & Chr(10)
     If Form_rechnung.r_kkurz.Column(6) <> "" Then
        .TypeText Form_rechnung.r_kkurz.Column(6) & Chr(10)
     End If
     If Form_rechnung.r_kkurz.Column(7) <> "" Then
        .TypeText Form_rechnung.r_kkurz.Column(7) & Chr(10)
     End If
     .TypeText adr & Chr(10) & plz & " " & ort

     'Drücke 2x ESC
     .EscapeKey
     .EscapeKey

     'Drücke 'Pos1
     .HomeKey wdStory

     'gehe 4 Wörter nach rechts
     .MoveRight wdWord, 4

     'Markiere die nächsten 4 Wörter rechts von Position
     .MoveRight wdWord, 4, wdExtend

     'Schreibe richtiges Datum
     .TypeText Form_rechnung.r_date.Value

     'Gehe Zu Zeile 6
     .GoTo wdGoToLine, wdGoToAbsolute, 6

     'Gehe 6 Wörter nach rechts
     .MoveRight wdWord, 6

     'Markieren die nächsten 2 Wörter rechts von Position
     .MoveRight wdWord, 2, wdExtend

     'Schreibe Rechnungsnummer
     .TypeText "AR" & Form_rechnung.r_jahr & "-" & r_nr

     'Gehe zu Zeile 9
     .GoTo wdGoToLine, wdGoToAbsolute, 9

     'Markiere die Zeile
     .EndKey wdLine, wdExtend

     'Wenn Bestellnummer
     If Form_rechnung.r_bnr.ValidationRule <> "" Then
       'Bestellnumer schreiben und eine Zeile tiefer
       .TypeText "Ihre Bestellung:" & vbTab & vbTab & Form_rechnung.r_bnr.Value
       .GoTo wdGoToLine, wdGoToAbsolute, 10
     'Wenn keine Bestellnumer aber Bestelldatum
     ElseIf Form_rechnung.r_bnr.Value <> "" Then
       'Schreibe Bestelldatum und eine Zeile tiefer
       .TypeText "Ihre Bestellung:" & vbTab & vbTab & Form_rechnung.r_bdate.Value
       .GoTo wdGoToLine, wdGoToAbsolute, 10
     Else
       'Markierung um 1 Zeichen nach links verringeren und Backspace drücken
       .MoveLeft wdCharacter, 1, wdExtend
       .TypeBackspace
     End If

     'Wenn Angebotsnummer, dann schreiben und eine Zeile tiefer
     If Form_rechnung.r_anr.Value <> "" Then
       .TypeText "Unser Angebot:" & vbTab & vbTab & Form_rechnung.r_anr.Value
       .GoTo wdGoToLine, wdGoToAbsolute, 11
     End If

     'Wenn Lieferantennummer, dann schreiben und eine Zeile tiefer
     If Form_rechnung.r_lnr.Value <> "" Then
       .TypeText "Unsere Lieferanten-Nr.:" & vbTab & Form_rechnung.r_lnr.Value
       .GoTo wdGoToLine, wdGoToAbsolute, 12
     End If

     'Wenn Lieferantennummer, dann schreiben und eine Zeile tiefer
     If Form_rechnung.r_wart.Value <> "" Then
       .TypeText "Wartungsvertrag vom:" & vbTab & Form_rechnung.r_wart.Value
       .GoTo wdGoToLine, wdGoToAbsolute, 13
     End If

     'Exceltabelle holen
     Set sh = Word.ActiveDocument.InlineShapes(1).OLEFormat
     'mit Tabelle mache
     With sh
       'Aktivieren
       .Activate
       'mit Activesheet mache
       With .Object.ActiveSheet
         If lst_rech.Count > 3 Then
           For Zeile = 1 To lst_rech.Count - 3
                 .Rows("3:3").Insert Shift:=xlDown
           Next Zeile
         End If
         Zeile = 2
         For Each itm In lst_rech
            .Cells(Zeile, 1).Value = Zeile - 1
            .Cells(Zeile, 2).Value = itm(1)
            .Cells(Zeile, 3).Value = itm(2)
            .Cells(Zeile, 4).Value = itm(3)
            .Cells(Zeile, 5).FormulaR1C1 = "=RC[-3]*RC[-1]"
            Zeile = Zeile + 1
         Next itm
         
         .Cells(Zeile, 5).FormulaR1C1 = "=SUM(R[-" & Zeile - 2 & "]C:R[-1]C)"

         'Rechnungsbetrag auslesen
         summe = .Cells(Zeile + 2, 5).Text
       End With
     End With
     
     'Hier Tabelle anpassen

     Set sh = Nothing
     '2x ESC drücken
     .EscapeKey
     .EscapeKey

     'Pos1 drücken
     .HomeKey wdStory

     'Gehe zu Zeile 19
     .GoTo wdGoToLine, wdGoToAbsolute, 20

     'Gehe 13 Wörter nach rechts
     .MoveRight wdWord, 12

     'Markiere die nächsten 3 Wörter rechts von Position
     .MoveRight wdWord, 3, wdExtend

     'Schreibe Rechnungsbetrag
     .TypeText summe

     .GoTo wdGoToLine, wdGoToAbsolute, 21
     .MoveRight wdWord, 8
     .MoveRight wdWord, 5, wdExtend
     .MoveLeft wdCharacter, 1, wdExtend
     If Not IsNull(Form_rechnung.r_zahlung.Value) Then
        .TypeText Form_rechnung.r_zahlung.Value
     End If
   End With
'
   'Dokument speichern und schließen
   Word.ActiveDocument.SaveAs path & filename
   Word.ActiveDocument.Close
   Word.Application.Quit
 End Sub