Re: VB6, SQL2000 and Word
From: Damon (damon_at_nospam.co.uk)
Date: 06/04/04
- Next message: vbMark: "Re: What am I missing here? (FAXCOMEXLib)"
- Previous message: Bob Butler: "Re: Do You Name Your Labels?"
- In reply to: Peter Newman: "VB6, SQL2000 and Word"
- Messages sorted by: [ date ] [ thread ]
Date: Fri, 4 Jun 2004 15:09:30 +0100
I have done this exact thing using a class merge which I wrote, here is the
class merge code:-
Option Explicit
'local variable(s) to hold property value(s)
Private tempdoc As Word.Document
Private mvarwrdApp As Word.Application 'local copy
Private mvarwrdDoc As Word.Document 'local copy
Private mvarNoCopies As Integer 'local copy
Private mvarwrdDocName As String 'local copy
Private mvarwrdDataDocName As String 'local copy
'To fire this event, use RaiseEvent with the following syntax:
'RaiseEvent FileNotFound[(arg1, arg2, ... , argn)]
Public Event FileNotFound(vData As Variant)
'local variable(s) to hold property value(s)
Private mvarAddPic As Boolean 'local copy
Private mvarpic_name As String 'local copy
Public Property Let pic_name(ByVal vData As String)
'used when assigning a value to the property, on the left side of an
assignment.
'Syntax: X.pic_name = 5
mvarpic_name = vData
End Property
Public Property Get pic_name() As String
'used when retrieving value of a property, on the right side of an
assignment.
'Syntax: Debug.Print X.pic_name
pic_name = mvarpic_name
End Property
Public Property Let AddPic(ByVal vData As Boolean)
'used when assigning a value to the property, on the left side of an
assignment.
'Syntax: X.AddPic = 5
mvarAddPic = vData
End Property
Public Property Get AddPic() As Boolean
'used when retrieving value of a property, on the right side of an
assignment.
'Syntax: Debug.Print X.AddPic
AddPic = mvarAddPic
End Property
Public Property Let wrdDataDocName(ByVal vData As String)
'used when assigning a value to the property, on the left side of an
assignment.
'Syntax: X.wrdDataDocName = 5
mvarwrdDataDocName = vData
End Property
Public Property Get wrdDataDocName() As String
'used when retrieving value of a property, on the right side of an
assignment.
'Syntax: Debug.Print X.wrdDataDocName
wrdDataDocName = mvarwrdDataDocName
End Property
Public Property Let wrdDocName(ByVal vData As String)
'used when assigning a value to the property, on the left side of an
assignment.
'Syntax: X.wrdDocName = 5
mvarwrdDocName = vData
End Property
Public Property Get wrdDocName() As String
'used when retrieving value of a property, on the right side of an
assignment.
'Syntax: Debug.Print X.wrdDocName
wrdDocName = mvarwrdDocName
End Property
Private Sub CreateMailMergeDataFile(getfields() As String)
On Error GoTo Err_CreateMailMergeDataFile
Dim wrdDataDoc As Word.Document
' Open a data source at mergedoc containing the field data
wrdDoc.MailMerge.OpenDataSource name:=wrdDataDocName
' Open the file to insert data
Set wrdDataDoc = wrdApp.Documents.Open(wrdDataDocName)
' Fill in the data
FillRow wrdDataDoc, getfields
Exit_CreateMailMergeDataFile:
Exit Sub
Err_CreateMailMergeDataFile:
MsgBox Err.Number & " " & Err.Description
Resume Exit_CreateMailMergeDataFile
End Sub
Private Sub FillRow(Doc As Word.Document, getfields() As String)
Dim i As Integer
Dim arraysize As Long
arraysize = UBound(getfields)
For i = 0 To arraysize
With Doc.Tables(1)
.Cell(2, i + 1).Range.InsertAfter getfields(i)
End With
Next i
End Sub
Public Sub printmerge(getfields() As String)
On Error GoTo Err_printmerge
Dim wrdSelection As Word.Selection
Dim wrdMailMerge As Word.MailMerge
Dim wrdMergeFields As Word.MailMergeFields
Dim StrToAdd As String
Dim curdoc As Word.Document
Dim fs As Object
Dim strtemp As String
Screen.MousePointer = vbHourglass
strtemp = wrdApp.Options.DefaultFilePath(wdDocumentsPath)
wrdApp.Options.DefaultFilePath(wdDocumentsPath) = "I:\Scu System
Documentation\GMS\GMS Letters\mdata"
' Get a Document
Set wrdDoc = wrdApp.Documents.Open(wrdDocName)
'wrdDoc.Select
Set wrdSelection = wrdApp.Selection
Set wrdMailMerge = wrdDoc.MailMerge
' --- Perform MAIL MERGE --- '
If AddPic = True And StrComp(Nz(pic_name), "") <> 0 Then
wrdApp.ActiveDocument.Bookmarks("image").Select
Set fs = CreateObject("Scripting.FileSystemObject")
If fs.FileExists(pic_name) = False Then
wrdApp.Selection.InsertAfter "FILE: " & pic_name & vbNewLine &
" - NOT FOUND/DOES NOT EXIST"
Else
Select Case UCase(Right(pic_name, 3))
Case "JPG"
wrdApp.Selection.InlineShapes.AddPicture pic_name, True,
False
wrdApp.Selection.MoveUp Unit:=wdLine, count:=1,
Extend:=wdExtend
wrdApp.Selection.InlineShapes(1).Height = 316
wrdApp.Selection.InlineShapes(1).Width = 235
wrdApp.Selection.ParagraphFormat.Alignment =
wdAlignParagraphCenter
Case "WMF"
wrdApp.Selection.InlineShapes.AddPicture pic_name, True,
False
wrdApp.Selection.MoveUp Unit:=wdLine, count:=1,
Extend:=wdExtend
wrdApp.Selection.InlineShapes(1).Height = 600
wrdApp.Selection.InlineShapes(1).Width = 415
wrdApp.Selection.ParagraphFormat.Alignment =
wdAlignParagraphCenter
Case "CDR"
wrdApp.Selection.InlineShapes.AddOLEObject
ClassType:="CorelDRAW.Graphic.10", _
FileName:=pic_name, LinkToFile:=False,
DisplayAsIcon:=False
wrdApp.Selection.MoveUp Unit:=wdLine, count:=1,
Extend:=wdExtend
wrdApp.Selection.InlineShapes(1).Height = 600
wrdApp.Selection.InlineShapes(1).Width = 415
wrdApp.Selection.ParagraphFormat.Alignment =
wdAlignParagraphCenter
Case Else
MsgBox "File: " & pic_name & " - format not
recognised"
End Select
End If
'Documents(wrdDoc).Close
Set fs = Nothing
End If
' Create MailMerge Data file
CreateMailMergeDataFile getfields
wrdMailMerge.Execute True
'Selects number of copies to print
wrdApp.ActiveDocument.PrintOut False, , , , , , , NoCopies
'Close the original form Document
wrdDoc.Close False
'close all documents in our instance of word
With wrdApp
For Each curdoc In .Documents
curdoc.Close False
Next curdoc
End With
wrdApp.Options.DefaultFilePath(wdDocumentsPath) = strtemp
Set wrdSelection = Nothing
Set wrdMailMerge = Nothing
Set wrdMergeFields = Nothing
Set wrdDoc = Nothing
Set curdoc = Nothing
Screen.MousePointer = vbDefault
Exit_printmerge:
Exit Sub
Err_printmerge:
MsgBox Err.Number & " " & Err.Description
Resume Exit_printmerge
End Sub
Public Property Let NoCopies(ByVal vData As Integer)
'used when assigning a value to the property, on the left side of an
assignment.
'Syntax: X.NoCopies = 5
If vData <= 0 Then
MsgBox "You cannot set the number of copies to less than 0" &
vbNewLine & _
"resetting to 1", vbExclamation, "Invalid Copy Number"
vData = 1
End If
mvarNoCopies = vData
End Property
Public Property Get NoCopies() As Integer
'used when retrieving value of a property, on the right side of an
assignment.
'Syntax: Debug.Print X.NoCopies
NoCopies = mvarNoCopies
End Property
Private Property Set wrdDoc(ByVal vData As Word.Document)
'used when assigning an Object to the property, on the left side of a Set
statement.
'Syntax: Set x.wrdDoc = Form1
Set mvarwrdDoc = vData
End Property
Private Property Get wrdDoc() As Word.Document
'used when retrieving value of a property, on the right side of an
assignment.
'Syntax: Debug.Print X.wrdDoc
Set wrdDoc = mvarwrdDoc
End Property
Private Property Set wrdApp(ByVal vData As Word.Application)
'used when assigning an Object to the property, on the left side of a Set
statement.
'Syntax: Set x.wrdApp = Form1
Set mvarwrdApp = vData
End Property
Private Property Get wrdApp() As Word.Application
'used when retrieving value of a property, on the right side of an
assignment.
'Syntax: Debug.Print X.wrdApp
Set wrdApp = mvarwrdApp
End Property
Private Sub Class_Initialize()
Dim temp As Word.Application
'Test if object is already created before calling CreateObject:
If TypeName(wrdApp) <> "Application" Then
Set temp = CreateObject("Word.Application")
Set wrdApp = CreateObject("Word.Application")
temp.Quit
Set temp = Nothing
End If
wrdApp.Visible = False
NoCopies = 1
AddPic = False
pic_name = ""
End Sub
Private Sub Class_Terminate()
' Quits word without saving the file
wrdApp.Quit False
' Release References
Set wrdApp = Nothing
Set mvarwrdDoc = Nothing
Set mvarwrdApp = Nothing
End Sub
You won;t need to add the part with the CDR, WMF & JPG as I was also adding
pictures into my word document along with the merged data.
Here is the procedure in which you pass the recordset results into the class
merge:-
Public Sub print_survey_form()
On Error GoTo Err_print_survey_form
Dim cmd As ADODB.Command
Dim rst As ADODB.Recordset
Dim alldata(5) As String
Dim wrk As frm_working
Dim mrg As cls_merge
Set cmd = New ADODB.Command
Set rst = New ADODB.Recordset
Set wrk = New frm_working
Set mrg = New cls_merge
If con_open = False Then
msg_con_failed
Else
With rst
Set .ActiveConnection = cn
.CursorType = adOpenStatic
.CursorLocation = adUseClient
.LockType = adLockBatchOptimistic
End With
frm_month_select.Show 1
If frm_month_select.Cancel = False Then
wrk.Show , frm_menu
wrk.Caption = "Printing Survey Form"
wrk.ProgressBar.Value = 2
select_date CStr(frm_month_select.cmb_month.Text)
With cmd
Set .ActiveConnection = cn
.CommandType = adCmdStoredProc
.CommandText = "proc_rs_survey_form"
.Parameters("@begindate").Value = BeginDate
.Parameters("@enddate").Value = EndDate
End With
With rst
.Open cmd
If .RecordCount > 0 Then
.MoveFirst
alldata(0) = Nz(!ss_tenancy_name)
alldata(1) = Nz(!ss_add1)
alldata(2) = Nz(!ss_district)
alldata(3) = Nz(!ss_ward)
alldata(4) = Nz(!ss_city)
alldata(5) = Nz(!ss_pcode)
With mrg
.AddPic = False
.NoCopies = 1
.wrdDocName = "I:\Scu System Documentation\Housing
Satisfaction Project\HSS survey_form\survey_form.doc"
.wrdDataDocName = "I:\Scu System Documentation\Housing
Satisfaction Project\HSS\mdata\survey_merge.doc"
.printmerge alldata()
End With
wrk.ProgressBar.Value = wrk.ProgressBar.Value + 2
With cmd
Set .ActiveConnection = cn
.CommandType = adCmdStoredProc
.CommandText = "proc_update_print"
.Parameters("@prop_ref").Value = Nz(rst!ss_prop_ref)
.Execute
End With
.MoveNext
End If
End With
wrk.ProgressBar.Value = 100
wrk.Caption = "DONE"
End if
End If
Exit_print_survey_form:
con_close
Unload wrk
Set mrg = Nothing
Set cmd = Nothing
Set rst = Nothing
Set wrk = Nothing
Exit Sub
Err_print_survey_form:
MsgBox Err.Number & " " & Err.Description
Resume Exit_print_survey_form
End Sub
obviously it will be slightly different for yourself as I am passing through
a date range but the rest should work perfectly. Remember to add a
reference to Word.
Hope this helps.
Damon
"Peter Newman" <anonymous@discussions.microsoft.com> wrote in message
news:5F4753E4-2786-4F08-AA56-0536A41E5E8A@microsoft.com...
> I have a vb 6 application that uses SQL2000 to access client details. What
i'd like to do is be able to mail merge Word Documents with the current
clients details.
>
> Can anybody help on how to do this ?
- Next message: vbMark: "Re: What am I missing here? (FAXCOMEXLib)"
- Previous message: Bob Butler: "Re: Do You Name Your Labels?"
- In reply to: Peter Newman: "VB6, SQL2000 and Word"
- Messages sorted by: [ date ] [ thread ]
Relevant Pages
|
