Option Explicit
Sub StartHere()
ufDNA.Show
End Sub
Sub PrintDocsSub(ReportType As String)
Dim wrdApp As Word.Application
Dim wrdDoc As Word.Document
Dim NewDoc As Word.Document
Dim WS As Worksheet
Dim A As Long, B As Long
Dim aRow As Long
Dim Cols As Variant
Dim FF As Integer
Dim Mypath As String
Dim sDBPath As String
Dim FN$
Dim DockNum As String
Set WS = ActiveSheet
Mypath = ActiveWorkbook.Path & "\"
FN$ = "Mergedata.dat"
'CreateHeaderFiles
Application.ScreenUpdating = False
Set wrdApp = CreateObject("Word.Application")
'wrdApp.Visible = True 'If it's hanging, uncomment this to see if error in Word.
For A = 0 To ufDNA.lbData.ListCount - 1
If ufDNA.lbData.Selected(A) Then
aRow = ufDNA.lbData.List(A, 6)
ufDNA.lblFeedback.Caption = "Working on docket " & WS.Range("F" & aRow)
Select Case ReportType
Case "CODNA"
'ufDNA.lblFeedback.Caption = "Working on docket " & WS.Range("F" & aRow)
Select Case ufDNA.lbData.List(A, 5)
Case "YES"
'To prevent Merge from stopping and asking questions,
'all merge fields must be represented with a field name
'and a value, even if the value is empty.
Cols = Split("G,H,I,J,K,M,E,B,C,A,P,L,D,F,AG,AH,AC,N,S,Q,AJ", ",")
FF = FreeFile
Open Mypath & FN$ For Output As #FF
Write #FF, "SURNAME"; '--------------------G
Write #FF, "Given1"; '---------------------H
Write #FF, "Given2"; '---------------------I
Write #FF, "DOB"; '------------------------J
Write #FF, "FPS"; '------------------------K
Write #FF, "Order_Issue_Date"; '-----------M
Write #FF, "EPS_File"; '-------------------E
Write #FF, "RECEIVED_YYYYMM"; '------------B
Write #FF, "Day_DD"; '---------------------C
Write #FF, "Initial_Data_Entry_Member"; '--A
Write #FF, "Endorsement_"; '---------------P
Write #FF, "Offence"; '--------------------L
Write #FF, "FILE_"; '----------------------D
Write #FF, "Docket__Number"; '-------------F
Write #FF, "Order_to_Appear_Date"; '-------AG
Write #FF, "First_Possible_Warrant_Date"; 'AH
Write #FF, "Warrant_Issued"; '-------------AC
Write #FF, "Order_Execution_Date"; '-------N
Write #FF, "Member"; '---------------------S
Write #FF, "Time"; '-----------------------Q
Write #FF, "AB30059" '---------------------AJ
For B = 0 To UBound(Cols) - 1
Write #FF, WS.Range(Cols(B) & aRow);
Next
Write #FF, WS.Range(Cols(UBound(Cols)) & aRow)
Close #FF
Set wrdDoc = wrdApp.Documents.Add(ActiveWorkbook.Path & "\" & _
"A DNA Basic Documents Merge 2014-OCT-01 Endorsement.dot")
Case "NO"
Cols = Split("G,H,I,J,K,M,E,B,C,A,P,L,D,F,AG,AH,AC,N,S,Q,AJ", ",")
FF = FreeFile
Open Mypath & FN$ For Output As #FF
Write #FF, "SURNAME"; '--------------------G
Write #FF, "Given1"; '---------------------H
Write #FF, "Given2"; '---------------------I
Write #FF, "DOB"; '------------------------J
Write #FF, "FPS"; '------------------------K
Write #FF, "Order_Issue_Date"; '-----------M
Write #FF, "EPS_File"; '-------------------E
Write #FF, "RECEIVED_YYYYMM"; '------------B
Write #FF, "Day_DD"; '---------------------C
Write #FF, "Initial_Data_Entry_Member"; '--A
Write #FF, "Endorsement_"; '---------------P
Write #FF, "Offence"; '--------------------L
Write #FF, "FILE_"; '----------------------D
Write #FF, "Docket__Number"; '-------------F
Write #FF, "Order_to_Appear_Date"; '-------AG
Write #FF, "First_Possible_Warrant_Date"; 'AH
Write #FF, "Warrant_Issued"; '-------------AC
Write #FF, "Order_Execution_Date"; '-------N
Write #FF, "Member"; '---------------------S
Write #FF, "Time"; '-----------------------Q
Write #FF, "AB30059" '---------------------AJ
For B = 0 To UBound(Cols) - 1
Write #FF, WS.Range(Cols(B) & aRow);
Next
Write #FF, WS.Range(Cols(UBound(Cols)) & aRow)
Close #FF
Set wrdDoc = wrdApp.Documents.Add(ActiveWorkbook.Path & "\" & _
"A DNA Basic Documents Merge 2014-OCT-01 Sample.dot")
End Select
Case "JudgeCourt"
'To prevent Merge from stopping and asking questions,
'all merge fields must be represented with a field name
'and a value, even if the value is empty.
Cols = Split("E,D,F,S,G,H,I,J,AL,AM,N,Q", ",")
FF = FreeFile
'Header row. Required for merge.
Close
Open Mypath & FN$ For Output As #FF
Write #FF, "EPS_File"; '-------------------E
Write #FF, "FILE_"; '----------------------D
Write #FF, "Docket__Number"; '-------------F
Write #FF, "Member"; '---------------------S
Write #FF, "SURNAME"; '--------------------G
Write #FF, "Given1"; '---------------------H
Write #FF, "Given2"; '---------------------I
Write #FF, "DOB"; '------------------------J
Write #FF, "Endorsement_Merge_X"; '-------AL
Write #FF, "Sample_Merge_X"; '------------AM
Write #FF, "Order_Execution_Date"; '-------N
Write #FF, "Time" '------------------------Q-- Last Write has no semicolon.
'Data from sheet.
For B = 0 To UBound(Cols) - 1
Write #FF, WS.Range(Cols(B) & aRow);
Next
'We have to seperate the last record to produce a VbCr for record seperation.
Write #FF, WS.Range(Cols(UBound(Cols)) & aRow) 'Last column without semicolon produces VbCr.
Close #FF
'Open a new document based on template.
Set wrdDoc = wrdApp.Documents.Add(ActiveWorkbook.Path & "\" & _
"B Report to a Prov Court Judge or the Court OCT 2014.dotx")
End Select
End If
' or
'Set wrdDoc = wrdApp.Documents.Open("C:\Foldername\Filename.doc")
' open an existing document
' example word operations
If Not wrdDoc Is Nothing Then
With wrdDoc
'Move data here.
With .MailMerge
.MainDocumentType = wdFormLetters
'Set up the mail merge data source to MergeData.dat
sDBPath = Mypath & FN
.OpenDataSource Name:=sDBPath, _
SQLStatement:="SELECT * FROM [EPS_File]"
'Grab record Docket number. We'll use it to save file.
DockNum = .DataSource.DataFields("Docket__Number").Value
'Perform the mail merge to a new document.
.Destination = wdSendToPrinter ' = 1
'.Destination = wdSendToNewDocument ' = 0
ufDNA.lblFeedback.Caption = "Printing " & WS.Range("F" & aRow)
.Execute Pause:=False
'If .Destination = wdSendToNewDocument Then
'If the docket number is blank for some reason,
'just use a incremental number.
'If DockNum = "" Then
A = A + 1
DockNum = "Doc Num" & A
'End If
'Define object for merge document.
Set NewDoc = wrdApp.ActiveDocument
'Delete any previous version with the same name.
'If Dir(Mypath & DockNum & ".docx") <> "" Then
Kill Mypath & DockNum & ".docx"
'End If
'Save the new merged document using docket number as filename.
'NewDoc.SaveAs Mypath & DockNum & ".docx"
'Close the new document.
'NewDoc.Close False
Set NewDoc = Nothing
'End If
End With
End With
'Close the template file.
wrdDoc.Close True
End If
Set wrdDoc = Nothing
Next
wrdApp.Quit ' close the Word application
Set wrdApp = Nothing
Application.ScreenUpdating = False
ufDNA.lblFeedback.Caption = ""
End Sub
'Sub AgencyAssist()
'Day_DD
'Endorsement_Form
'EndorsementSample_Merge
'EPS_File
'FILE_
'Given1
'Given2
'Location_Merge
'Member
'Order_Execution_Date
'Order_to_a_Person_Merge
'RECEIVED_YYYYMM
'SURNAME
'EPS_File
'End Sub
LinkBack URL
About LinkBacks
Register To Reply
Bookmarks