' Makro do tworzenia korespondencji seryjnej
' dane zapisane do pliku csv oddzielone ;
Option Explicit
Dim strFileCSV As String            ' nazwa pliku CSV
Dim lngFileCSV As Long              ' nr pliku CSV

Dim newDoc As Document
Dim docName As String

Dim mybar As CommandBar
Dim mybtn As CommandBarButton
Dim mycbo As CommandBarComboBox

Dim arrOne(1 To 40) As String      ' tablica nazw znacznikow
Dim arrTwo(1 To 40) As String      ' tablica danych zastepujacych znaczniki
     
         
     
     
' procedura wywolywana automatycznie po otwarciu szablonu
Sub Main()
Dim AuOk As Boolean
Dim strLine As String              ' linia z pliku
Dim intBeg As Integer
Dim intEnd As Integer
Dim i As Integer

'wybor pliku z danymi
    strFileCSV = OpenDialog("*.*", "Wybierz plik z danymi w formacie CSV...", Options.DefaultFilePath(wdDocumentsPath))
    If strFileCSV = "" Then Exit Sub
    lngFileCSV = FreeFile
    
'nowa nazwa dokumentu
    docName = StripPath(strFileCSV)
    intBeg = InStr(1, docName, ".")
    docName = Left(docName, intBeg) & "doc"
    'docName = SaveDialog("*.doc", "Zapisz nowy dokument jako...", strFileCSV, "*.doc", docName)
    docName = "C:\Windows\Temp\tmp_generator.doc"
    If docName = "" Then Exit Sub
    
' wyciecie ostatniego znaku z nazwy doka
' funkcja SaveDialog zwraca nazwe + Chr(0) to powodowalo bledy
    'docName = Left(docName, Len(docName) - 1)

' zapis pod nowa nazwa
    Documents(1).SaveAs docName

' domyslna sciezka do zapisu w katalogu z nowym dokiem
    Options.DefaultFilePath(wdDocumentsPath) = Documents(1).Path

' sprawdzenie czy istnieje commandbar
    For Each mybar In CommandBars
        If mybar.Name = "Automat" Then AuOk = True
    Next

' dodanie commandbar
    If Not AuOk Then
        Set mybar = CommandBars.Add(Name:="Automat", Position:=msoBarTop, Temporary:=True)
        mybar.Visible = True
        
        ' dodanie comboboxa
        mybar.Controls.Add Type:=msoControlComboBox
        Set mycbo = mybar.Controls(1)
        mycbo.Caption = "Wstaw znacznik"
        mycbo.Style = msoComboLabel
        mycbo.OnAction = "cboEvents"
        
        'otwarcie pliku i wczytanie pierwszej lini z naglowkami
        Open strFileCSV For Input As lngFileCSV
        Line Input #lngFileCSV, strLine
        Close #lngFileCSV
        
        'analiza lini z naglowkami i wpisanie do cboBoxa i tablicy
        intBeg = 1
        i = 1
        Do
            intEnd = InStr(intBeg, strLine, ";")
            If intEnd = 0 Then Exit Do
            mycbo.AddItem Mid(strLine, intBeg, intEnd - intBeg)
            arrOne(i) = UCase(Mid(strLine, intBeg, intEnd - intBeg))
            i = i + 1
            If i > 40 Then
                MsgBox "Zbyt dużo znaczników w pliku danych"
                Exit Do
            End If
            intBeg = intEnd + 1
        Loop

        ' dodanie przycisku
        mybar.Controls.Add Type:=msoControlButton
        Set mybtn = mybar.Controls(2)
        mybtn.Style = msoButtonIconAndCaption
        mybtn.Caption = "Generuj dokumenty"
        mybtn.FaceId = 1
        mybtn.OnAction = "btnEvents"
                
        ' dodanie przycisku
        mybar.Controls.Add Type:=msoControlButton
        Set mybtn = mybar.Controls(3)
        mybtn.Style = msoButtonIconAndCaption
        mybtn.Caption = "Generuj i drukuj"
        mybtn.FaceId = 1
        'mybtn.OnAction = "btnPrint"
        mybtn.Enabled = False
    End If
    
End Sub



























' zdazenie wywolywane przy wybraniu combo boxa
' wstawianie znacznika do dokumentu (do poprawienia)
Private Sub cboEvents()
    Selection.InsertAfter UCase(mycbo.Text)
End Sub

' zdazenie wywolywane przy wcisnieciu przycisku
' generowanie nowych dokow
Private Sub btnEvents()
Dim strWygen As String
Dim strLine As String
Dim A As Long
Dim p As String
Dim intBeg As Integer
Dim intEnd As Integer
Dim i As Integer

    Open strFileCSV For Input As lngFileCSV
    ' w pierwszej linii nagłowki, wczytajemy i pomijamy
        Line Input #1, strLine
        Do While Not EOF(lngFileCSV)
            Line Input #1, strLine
            
            'wczytanie danych z strline do tablicy
            intBeg = 1
            i = 1
            Do
                intEnd = InStr(intBeg, strLine, ";")
                If intEnd = 0 Then Exit Do
                arrTwo(i) = Mid(strLine, intBeg, intEnd - intBeg)
                i = i + 1
                If i > 40 Then
                    MsgBox "Zbyt dużo znaczników w pliku danych"
                    Exit Do
                End If
                intBeg = intEnd + 1
            Loop

            'kopiowanie calosci dokumentu
            Documents(docName).Select
            Selection.Copy
            
            'stworzenie nowego doca
            Set newDoc = Documents.Add

            'nowy doc aktywny
            newDoc.Activate
            'zaznaczony caly
            newDoc.Select
            'wklejenie danych do nowego doca :)
            Selection.Paste
            ' przegladanie w petli doka i zamiana znacznikow na slowa
            For A = 1 To Documents(newDoc.Name).Words.Count - 1
                p = Trim$((Documents(newDoc.Name).Words(A).Text))
                i = 1
                Do
                    If Len(arrOne(i)) = 0 Then Exit Do
                    If p = arrOne(i) Then Documents(newDoc.Name).Words(A).Text = arrTwo(i) & " "
                    i = i + 1
                Loop
            Next A
            strWygen = SaveDialog("*.doc", "Zapisz wygenerowany dokument jako...", Options.DefaultFilePath(wdDocumentsPath), "*.doc", "dokument")
            strWygen = Left(strWygen, Len(strWygen) - 1)
            'newDoc.SaveAs FileName:=Left(strWygen, (InStr(1, strWygen, ".doc")) - 1) & ".doc"
            newDoc.SaveAs FileName:=strWygen
            newDoc.Close
        Loop
    Close #lngFileCSV

'zamkniecie dokumentu glownego
'Documents(docName).Close SaveChanges:=wdDoNotSaveChanges
Application.Quit SaveChanges:=wdDoNotSaveChanges
End Sub


____________________________________



Option Explicit

Public Const OFN_READONLY = &H1
Public Const OFN_OVERWRITEPROMPT = &H2
Public Const OFN_HIDEREADONLY = &H4
Public Const OFN_NOCHANGEDIR = &H8
Public Const OFN_SHOWHELP = &H10
Public Const OFN_ENABLEHOOK = &H20
Public Const OFN_ENABLETEMPLATE = &H40
Public Const OFN_ENABLETEMPLATEHANDLE = &H80
Public Const OFN_NOVALIDATE = &H100
Public Const OFN_ALLOWMULTISELECT = &H200
Public Const OFN_EXTENSIONDIFFERENT = &H400
Public Const OFN_PATHMUSTEXIST = &H800
Public Const OFN_FILEMUSTEXIST = &H1000
Public Const OFN_CREATEPROMPT = &H2000
Public Const OFN_SHAREAWARE = &H4000
Public Const OFN_NOREADONLYRETURN = &H8000
Public Const OFN_NOTESTFILECREATE = &H10000
Public Const OFN_NONETWORKBUTTON = &H20000
Public Const OFN_NOLONGNAMES = &H40000
Public Const OFN_EXPLORER = &H80000
Public Const OFN_NODEREFERENCELINKS = &H100000
Public Const OFN_LONGNAMES = &H200000
Public Const OFN_SHAREFALLTHROUGH = 2
Public Const OFN_SHARENOWARN = 1
Public Const OFN_SHAREWARN = 0

Public Const BIF_RETURNONLYFSDIRS = 1
Public Const MAX_PATH = 260

Private Type OPENFILENAME
        lStructSize As Long
        hwndOwner As Long
        hInstance As Long
        lpstrFilter As String
        lpstrCustomFilter As String
        nMaxCustFilter As Long
        nFilterIndex As Long
        lpstrFile As String
        nMaxFile As Long
        lpstrFileTitle As String
        nMaxFileTitle As Long
        lpstrInitialDir As String
        lpstrTitle As String
        flags As Long
        nFileOffset As Integer
        nFileExtension As Integer
        lpstrDefExt As String
        lCustData As Long
        lpfnHook As Long
        lpTemplateName As String
End Type



Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
Private Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Long

Public Function StripPath(T$) As String
Dim X%, ct%
    StripPath$ = T$
    X% = InStr(T$, "\")
    Do While X%
        ct% = X%
        X% = InStr(ct% + 1, T$, "\")
    Loop
    If ct% > 0 Then StripPath$ = Mid$(T$, ct% + 1)
End Function

Function SaveDialog(Filter As String, Title As String, InitDir As String, defExt As String, iniFile As String) As String
Dim ofn As OPENFILENAME
Dim A As Long
    ofn.lStructSize = Len(ofn)
    'ofn.hwndOwner = Form1.hWnd
    'ofn.hInstance = App.hInstance
    If Right$(Filter, 1) <> "|" Then Filter = Filter + "|"
        For A = 1 To Len(Filter)
            If Mid$(Filter, A, 1) = "|" Then Mid$(Filter, A, 1) = Chr$(0)
        Next
    ofn.lpstrDefExt = defExt
    ofn.lpstrFilter = Filter
    ofn.lpstrFile = iniFile & Space$(254 - Len(iniFile))

    ofn.nMaxFile = 255
    ofn.lpstrFileTitle = Space$(254)
    ofn.nMaxFileTitle = 255
    ofn.lpstrInitialDir = InitDir
    ofn.lpstrTitle = Title
    ofn.flags = OFN_HIDEREADONLY Or OFN_OVERWRITEPROMPT Or OFN_CREATEPROMPT
    A = GetSaveFileName(ofn)
    If (A) Then
        SaveDialog = Trim$(ofn.lpstrFile)
    Else
        SaveDialog = ""
    End If
End Function

Function OpenDialog(Filter As String, Title As String, InitDir As String) As String
Dim ofn As OPENFILENAME
Dim A As Long
    ofn.lStructSize = Len(ofn)
    'ofn.hwndOwner = Form1.hWnd
    'ofn.hInstance = App.hInstance
    If Right$(Filter, 1) <> "|" Then Filter = Filter + "|"
    For A = 1 To Len(Filter)
        If Mid$(Filter, A, 1) = "|" Then Mid$(Filter, A, 1) = Chr$(0)
    Next
    ofn.lpstrFilter = Filter
    ofn.lpstrFile = Space$(254)
    ofn.nMaxFile = 255
    ofn.lpstrFileTitle = Space$(254)
    ofn.nMaxFileTitle = 255
    ofn.lpstrInitialDir = InitDir
    ofn.lpstrTitle = Title
    ofn.flags = OFN_HIDEREADONLY Or OFN_FILEMUSTEXIST
    A = GetOpenFileName(ofn)
    If (A) Then
        OpenDialog = Trim$(ofn.lpstrFile)
    Else
        OpenDialog = ""
    End If
End Function