' 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