| Option Explicit '* Create by Tmess '* Modified by David Peake '* See class module for more details Private WithEvents objclass As clsWordMerge Dim db As ADODB.Connection Dim rs As ADODB.Recordset Dim rs1 As ADODB.Recordset Dim strSQL As String Dim StrEmpname As String Dim i As Integer Private Sub Form_Load() Set objclass = New clsWordMerge End Sub Private Sub Form_Unload(Cancel As Integer) Set objclass = Nothing End Sub Private Sub Command1_Click() On Error GoTo err1 'OK what this does best is sort of like an Access subreport 'Say you have one person who has multiple orders 'You can print 1 letter for one person but have all 'the orders put in a table for that person in the document 'This user the northwind database that comes with ms access 'C:\projects\vb6\debtcoll\dc.mdb Set db = New ADODB.Connection db.Open "Provider=Microsoft.Jet.OLEDB.4.0;User ID=David Peake;Data Source=C:\projects\vb6\debtcoll\dc.mdb;Persist Security Info=False;Jet OLEDB:System database=c:\projects\vb6\debtcoll\secured.mdw", "user", "password" db.CursorLocation = adUseClient Set rs = New ADODB.Recordset rs.Open "Debtors", db rs.MoveLast rs.MoveFirst 'The below database is only necesary if you are going to compare data 'in one database with another 'objclass.DatabaseToConnect "H:\My documents\FieldDirectory1998.mdb" 'Only do 2 records because that demonstrates enough For i = 1 To rs.RecordCount StrEmpname = rs.Fields("AccNo") & ", " & rs.Fields("CompanyName") strSQL = "SELECT TransNo, TransValue FROM Transactions WHERE Transactions.DebtorID = " & rs.Fields("DebtorID") & ";" Set rs1 = New ADODB.Recordset rs1.Open strSQL, db, adOpenKeyset, adLockOptimistic 'rs1.Open strSQL, db MousePointer = vbHourglass If rs1.RecordCount > 0 Then With objclass .OpenNewDoc 'Pagesetups.landscape is a constant 'Pagesetups.portrait is a constant .PageSetupDocument = PageSetups.Landscape .InsertText "Hi my name is Tmess. This document belongs to " & StrEmpname & vbCrLf & _ "Below is a hyper link" _ , 12, True, Alignment.Left .InsertLinesInDoc = 2 .InsertHyperlinkAddress = "Http:\\intranet1\chapter\" .InsertLinesInDoc = 2 .InsertText "Now you can insert the current date", _ 18, False, Alignment.Left .InsertLinesInDoc = 1 .InsertCurrentDate .InsertLinesInDoc = 3 .InsertText "Now you can insert data from a recordset", _ 20, False, Alignment.Center .InsertLinesInDoc = 2 'Change the font for the table .InsertText " ", _ 8, False, Alignment.Center .InsertLinesInDoc = 2 'This is how you pass an entire recordset .InsertTableWithData "", rs1 'You can pass an sql string if you want but you will have to open 'a connection in the class '.InsertTableWithData strSQL 'Printout the document '.printDoc '.SaveDocAsAndClose "C:\My documents\", StrEmpname .CloseDoc 'unRem if you want to send; put in a recordset field that contains 'the e-mail address to make it dynamic If Not IsNull(rs.Fields("Email")) Or rs.Fields("Email") <> "" Then .SaveDocAsAndClose "C:\My documents\", StrEmpname .SendDoc rs.Fields("Email"), "Owe Me Money", "Please see attachment.." End If 'unRem if you want to delete the document '.DeleteDoc "C:\My documents\" & StrEmpname & ".doc" End With End If rs.MoveNext Next i rs.Close rs1.Close exit1: MousePointer = vbNormal Exit Sub err1: MsgBox Err.Number & " " & Err.Description Resume exit1 'objclass.DatabaseDisConnect End Sub Private Sub objclass_ConnectionNotSuccessful(errNum As Integer, msgWhy As String) Debug.Print errNum & " " & msgWhy End Sub Private Sub objclass_ConnectionSuccessful() MsgBox "Connection Successfull" End Sub Private Sub objclass_DocumentNotSaved(errNum As Integer, msgWhy As String) Debug.Print errNum & " " & msgWhy End Sub Private Sub objclass_DocumentSaved() MsgBox "Doc saved for " & StrEmpname End Sub Private Sub objclass_MergeComplete() MsgBox "MergeComplete for " & StrEmpname End Sub Private Sub objclass_MergeFailed(errNum As Integer, msgWhy As String) Debug.Print errNum & " " & msgWhy End Sub Private Sub objclass_MessageNotSent(errNum As Integer, msgWhy As String) Debug.Print errNum & " " & msgWhy End Sub Private Sub objclass_MessageSent() MsgBox "Message sent for " & StrEmpname End Sub '------------------------------------------------------the Class clsMergeDataWithWord ----------------------------------- Option Explicit '**(CLASS HEADER)************************************************* '* '* Author: Tmess EMail: MessinaThomas@Hotmail.com '* Modified by David Peake djpeake@bcmnet.com '* Purpose: 1.Create New word Document '* 2.Set the pagesetup and Add text to the document '* 3.Position and format the text '* 4.Insert data from a database into the table '* 5.Save the document '* 6.Create a new e-mail using outlook '* 7.Insert the document into an e-mail '* 8.Send the e-mail '* 9.Delete the document '* 10.All errors are logged in a textfile and can be raised in the form '* '* You can use all the above or some '* '* Use this at your own risk. I am not responsible for misuse of this class '* Please improve if you want. Let me know '* '****************************************************************** Public Enum PageSetups Landscape = wdOrientLandscape Portrait = wdOrientPortrait End Enum Public Enum Alignment Center = WdParagraphAlignment.wdAlignParagraphCenter Left = WdParagraphAlignment.wdAlignParagraphLeft Right = WdParagraphAlignment.wdAlignParagraphRight Justify = WdParagraphAlignment.wdAlignParagraphJustify End Enum Private m_ProcedureName As String 'Name of current procedure: for error handling Private m_dbPathName As String 'Path and name of Database Private m_IsConnected As Boolean 'Is there a connection to database Private m_NumOfLines As Integer 'Number of blank lines to insert Private m_StrHyperlink As String 'Name of hyperlink Private m_Strsubject As String 'Subject of E-mail message Private m_StrTo As String 'Recipient address Private m_StrToAdd As String 'Text to add to Word doc Private m_VarMsgBody As Variant 'Body of e-mail message Private m_FontSize As Integer 'Font size of StrToAdd Private m_FontBold As Boolean 'Is strToAdd bold or Not Private m_ParaAlign As Integer 'StrToAdd alignment SEE ENUM ALIGNMENT Private m_PageSetup As Integer 'Page setup of Word Doc SEE ENUM PAGESETUPS Private m_Connection As ADODB.Connection ' ADO Database Connection Object 'Private m_Database As Dao.Database 'DAO database object 'Private m_Recordset As Dao.Recordset 'DAO Recordset object Private m_Recordset As ADODB.Recordset 'ADO Recordset object Private m_sql As String 'SQL String passed from client Private i As Integer 'Used in for next loop Private wrdApp As Word.Application 'MS Word object Private wrdDoc As Word.Document 'MS Word Document Private wrdSelection As Word.Selection 'MS Word Selection Private strDocName As String 'MS Word document name 'Raised if merge successful Public Event MergeComplete() 'Raised if merge Unsuccessful Public Event MergeFailed(errNum As Integer, msgWhy As String) 'Raised if merge document saved successfully Public Event DocumentSaved() 'Raised if merge document saved Unsuccessfully Public Event DocumentNotSaved(errNum As Integer, msgWhy As String) 'Raised if document was e-mailed successfully Public Event MessageSent() 'Raised if document was e-mailed Unsuccessfully Public Event MessageNotSent(errNum As Integer, msgWhy As String) 'Raised if database connection was successful Public Event ConnectionSuccessful() 'Raised if database connection was Unsuccessful Public Event ConnectionNotSuccessful(errNum As Integer, msgWhy As String) 'Raise for unknown errors Public Event UnknownError(errNum As Integer, msgWhy As String) Private Sub Class_Initialize() Set wrdApp = New Word.Application 'Set to false if you don't want to see the word doc wrdApp.Visible = True 'Database connection has not been established yet m_IsConnected = False End Sub Private Sub Class_Terminate() wrdApp.Quit Set wrdSelection = Nothing Set wrdDoc = Nothing Set wrdApp = Nothing End Sub Public Sub OpenNewDoc() Set wrdDoc = wrdApp.Documents.Add wrdDoc.Select Set wrdSelection = wrdApp.Selection End Sub Public Property Let PageSetupDocument(IntPageSetup As Integer) m_PageSetup = IntPageSetup wrdDoc.PageSetup.Orientation = m_PageSetup End Property Public Sub DatabaseToConnect(dbPathAndName As String) On Error GoTo Err_Handler 'Check to see if a connection to a database is already opened If m_IsConnected Then MsgBox "Connection already established. Close the current " & _ "connection first before opening a new database", vbInformation, _ "Connection Already Established" Exit Sub End If m_dbPathName = dbPathAndName 'Check to see if the path and the database exists If FileExist(m_dbPathName) = False Then MsgBox "File Not Found. Could not Establish Connection", vbCritical, _ "File Not Found" Exit Sub End If 'Set m_Database = DBEngine.OpenDatabase(m_dbPathName) Set m_Connection = New ADODB.Connection ' modify with user ID and Password m_Connection.Open "Provider=Microsoft.Jet.OLEDB.4.0;User ID=David Peake;Data Source=" & dbpathname & ";Persist Security Info=False;Jet OLEDB:System database=c:\projects\vb6\debtcoll\secured.mdw", , "userid", "password" m_IsConnected = True Exit Sub Err_Handler: m_ProcedureName = "DatabaseToConnect" Call ClsErrorHandler End Sub Public Sub DatabaseDisConnect() 'Close and Release database object from memory If m_IsConnected Then m_Database.Close Set m_Database = Nothing m_IsConnected = False Exit Sub End If End Sub Public Property Let InsertLinesInDoc(numOfLines As Integer) m_NumOfLines = numOfLines InsertLines m_NumOfLines End Property Public Sub InsertText(strToAdd As String, IntFontSize As Integer, _ blBold As Boolean, intParagraphAlign As Integer) m_StrToAdd = strToAdd m_FontBold = blBold m_FontSize = IntFontSize m_ParaAlign = intParagraphAlign InsertTextIntoDoc End Sub Public Property Let InsertHyperlinkAddress(strHyperlink As String) m_StrHyperlink = strHyperlink InsertHyperlink End Property Public Sub InsertTableWithData(strRecordSet As String, _ Optional RecordSetToUse As ADODB.Recordset) On Error GoTo Error_Handler Dim intNumofRows As Integer Dim intNumofColumns As Integer Dim p As Integer, ColWidth As Integer 'Check to see if a new connection to the database 'has been established Set m_Recordset = New ADODB.Recordset If m_IsConnected Then m_sql = strRecordSet m_Recordset.Open m_sql, m_Connection, adOpenKeyset, adLockOptimistic Else Set m_Recordset = RecordSetToUse End If m_Recordset.MoveLast m_Recordset.MoveFirst intNumofColumns = m_Recordset.Fields.Count intNumofRows = m_Recordset.RecordCount 'Insert a new table with rows according to recordCount plus Column header 'and the number of columns in the recordset wrdDoc.Tables.Add wrdSelection.Range, NumRows:=intNumofRows + 1, _ NumColumns:=intNumofColumns With wrdDoc.Tables(1) ' Set the column widths For i = 0 To intNumofColumns - 1 ColWidth = Len(m_Recordset.Fields(i).Name) .Columns(i + 1).SetWidth ColWidth * 25, wdAdjustNone .Cell(1, i + 1).Range.InsertAfter UCase(m_Recordset.Fields(i).Name) Next i ' Set the shading on the first row to light gray .Rows(1).Cells.Shading.BackgroundPatternColorIndex = wdGray25 ' Bold the first row .Rows(1).Range.Bold = True ' Center the text in Cell (1,1) .Cell(1, 1).Range.Paragraphs.Alignment = wdAlignParagraphCenter ' Fill each row of the table with data For i = 1 To intNumofRows For p = 1 To intNumofColumns FillRow i + 1, p, m_Recordset.Fields(p - 1) Next p p = 1 m_Recordset.MoveNext Next i End With RaiseEvent MergeComplete Exit_Handler: 'release objects from memory If m_IsConnected Then m_Recordset.Close End If Set m_Recordset = Nothing Exit Sub Error_Handler: m_ProcedureName = "InsertTableWithData" Call ClsErrorHandler Resume Exit_Handler End Sub Private Sub InsertHyperlink() 'Inserts a hyperlink wrdSelection.Hyperlinks.Add Anchor:=wrdSelection.Range, _ Address:=m_StrHyperlink End Sub Private Sub InsertTextIntoDoc() 'This routines insert text into the word document and sets the font 'and alignment wrdSelection.ParagraphFormat.Alignment = m_ParaAlign wrdSelection.Font.Size = m_FontSize wrdSelection.Font.Bold = m_FontBold wrdSelection.TypeText m_StrToAdd End Sub Private Sub InsertLines(LineNum As Integer) Dim iCount As Integer 'Insert blank lines in Word document For iCount = 1 To LineNum wrdApp.Selection.TypeParagraph Next iCount End Sub Private Sub FillRow(Row As Integer, Column, Text1 As String) ' Insert the data into the specific cell With wrdDoc.Tables(1) .Cell(Row, Column).Range.InsertAfter Text1 End With End Sub Public Sub printDoc() 'print out the word doc wrdDoc.PrintOut End Sub Public Sub SendDoc(ByVal strTo As String, ByVal strSubject As String, _ varMsgBody As Variant) On Error GoTo OutLookTrap 'Mail the word document to recipient specified Dim ObjOutlook As Outlook.Application Dim ObjMailItem As Outlook.MailItem m_Strsubject = strSubject m_StrTo = strTo m_VarMsgBody = varMsgBody 'Check to see if the e-mail address is correct by checking the format If checkEmailAddress = False Then m_ProcedureName = "SendDoc" Call ClsErrorHandler Exit Sub End If Set ObjOutlook = New Outlook.Application Set ObjMailItem = ObjOutlook.CreateItem(olMailItem) 'create e-mail and insert attachment With ObjMailItem .Recipients.Add m_StrTo .Subject = m_Strsubject .Body = m_VarMsgBody & vbCrLf & vbCrLf .Attachments.Add strDocName End With ObjMailItem.Send RaiseEvent MessageSent OutLookTrapExit: Set ObjMailItem = Nothing Set ObjOutlook = Nothing Exit Sub OutLookTrap: m_ProcedureName = "SendDoc" Resume OutLookTrapExit End Sub Public Sub SaveDocAsAndClose(Path As String, StrToSaveAs As String) On Error GoTo Err_Handler 'Check to see if the path exists If DriveExist(Path) = False Then Exit Sub ' Save the document, close it strDocName = Path & StrToSaveAs & ".doc" wrdDoc.SaveAs strDocName wrdDoc.Close RaiseEvent DocumentSaved Exit_Err_Handler: Exit Sub Err_Handler: m_ProcedureName = "SaveDocAsAndClose" Resume Exit_Err_Handler End Sub Public Sub CloseDoc() On Error GoTo Err_Handler wrdDoc.Close wdDoNotSaveChanges Exit_Err_Handler: Exit Sub Err_Handler: m_ProcedureName = "CloseDoc" Resume Exit_Err_Handler End Sub Public Sub DeleteDoc(PathAndDocName As String) 'Delete a file If FileExist(PathAndDocName) Then Kill PathAndDocName End If End Sub Public Sub InsertCurrentDate() 'Inserts the current date with the deafult font wrdSelection.InsertDateTime _ DateTimeFormat:="dddd, MMMM dd, yyyy", InsertAsField:=False End Sub Private Function checkEmailAddress() As Boolean 'on error resume next 'parses e-mail address to see if is correct i = InStr(m_StrTo, "@") checkEmailAddress = (InStr(i + 1, m_StrTo, ".") > 0) End Function Private Function FileExist(filename As String) As Boolean 'on error resume next FileExist = (Dir$(UCase((filename))) <> "") End Function Private Function DriveExist(Path As String) As Boolean 'on error resume next DriveExist = (Dir(UCase((Path))) <> "") End Function Private Sub ClsErrorHandler() 'Generic Error handling routine Dim handleErr As String Dim textfile As String 'Raise the event according the procedure passed. Will write all errors 'to an error log. Errors on the form will only be visible if 'the event is active and a debug.print statement or message box 'is inserted Select Case m_ProcedureName Case Is = "SaveDocAsAndClose" RaiseEvent DocumentNotSaved(Err.Number, Err.Description) Case Is = "SendDoc" RaiseEvent MessageNotSent(Err.Number, Err.Description) Case Is = "InsertTableWithData" RaiseEvent MergeFailed(Err.Number, Err.Description) Case Is = "DatabaseToConnect" RaiseEvent ConnectionNotSuccessful(Err.Number, Err.Description) Case Else RaiseEvent UnknownError(Err.Number, Err.Description) End Select 'Log the errors to an error log textfile = App.Path & "\ErrogLog.txt" handleErr = "Error: " & Err.Number & " " & Err.Description & " " & Err.Source Open textfile For Append As #1 'write error to textfile Write #1, Now; handleErr; m_ProcedureName Close #1 Err.Clear End Sub |
Merge With Word |
Freelance ASP PHP web development | Web developer India Web development India | Prayagasoft - web designer India, Ecommerce developer india, Ecommerce design