home *** CD-ROM | disk | FTP | other *** search
/ PC Pro 1996 May / CD2_DEMO.ISO / code / database / listing1.txt
Encoding:
Text File  |  1996-02-28  |  5.7 KB  |  158 lines
  1. Private Sub cmdMailMerge_Click()
  2.    Dim lcQueryName As String, lcDataFile As String, lcMergeDoc As String
  3.    Dim loQuery As QueryDef, db As Database, SQL As String
  4.    Dim CRLF As String * 2, X As Variant
  5.     
  6.   ' Convenient short-hand form for carriage-return & line-feed
  7.     CRLF = Chr(13) + Chr(10)
  8.  
  9.   ' DataPath is a global constant defined elsewhere, defining
  10.   ' the location of mailshot data and document files
  11.     lcDataFile = AddBS(DataPath) & UniqueName(8) & ".txt"
  12.     
  13.     lcQueryName = UniqueName(8)    ' Get a random, unique-ish file name
  14.     
  15.   ' Establish a full path to the merge document
  16.     lcMergeDoc = "" & txtMergeDoc    ' This deals with a null
  17.     If lcMergeDoc = JustFName(lcMergeDoc) Then
  18.       lcMergeDoc = AddBS(DataPath) & lcMergeDoc
  19.     End If
  20.     
  21.     X = SysCmd(acSysCmdSetStatus, "Creating query...")
  22.     
  23.   ' Build some SQL to extract the appropriate records. We need to replace
  24.   ' all CRLFs with CHR(11) in case the merge document uses paragraph
  25.   ' spacing, since in Word CRLF is a paragraph break, and CHR(11) is a
  26.   ' line break.
  27.   ' We should only select records for the selected mailshot, and only
  28.   ' where theyÆre not yet marked as sent.
  29.     SQL = "select replaceall(replaceall(Forename & ' ' & Surname & '"
  30.     SQL = SQL & CRLF & "' & [Job Title] & '" & CRLF
  31.     SQL = SQL & "' & [Company Name] & '" & CRLF & "' & [Address] & '"
  32.     SQL = SQL & CRLF & "' & UCase([post code]), '" & CRLF
  33.     SQL = SQL & "', Chr(11)), Chr(11) & Chr(11), Chr(11)) as FullAddress, "
  34.     SQL = SQL & "iif(isempty(contacts.Title) or isnull(contacts.Title), "
  35.     SQL = SQL & "iif(Gender = 'M', 'Mr', 'Ms'), Contacts.Title) & ' ' & "
  36.     SQL = SQL & "Contacts.Surname as Salutation, forename, surname, "
  37.     SQL = SQL & "[company name], replaceall(Address, '" & CRLF
  38.     SQL = SQL & "', chr(11)), [Post Code], forename & ' ' & "
  39.     SQL = SQL & "surname as Contact "
  40.     SQL = SQL & "FROM Companies INNER JOIN (Contacts RIGHT JOIN "
  41.     SQL = SQL & "[Mailshot=Company] ON Contacts.ContactID = "
  42.     SQL = SQL & "[Mailshot=Company].ContactID) ON Companies.CompanyID = "
  43.     SQL = SQL & "[Mailshot=Company].CompanyID "
  44.     SQL = SQL & "where MailshotID = " & MailshotID & " and IsNull(Sent)"
  45.     
  46.  ' Create a querydef using the SQL to use for the export
  47.    Set db = CurrentDb()
  48.    Set loQuery = db.CreateQueryDef(lcQueryName, SQL)
  49.     
  50.    X = SysCmd(acSysCmdClearStatus)
  51.     
  52.  ' The useful TransferText macro action is called to do the export
  53.    DoCmd.TransferText acExportMerge, , lcQueryName, lcDataFile
  54.     
  55.  ' Use the new Access 95 RecordsAffected property to report how many
  56.  ' records were exported for debugging purposes.
  57.    Debug.Print db.RecordsAffected
  58.     
  59.     X = SysCmd(acSysCmdSetStatus, "Deleting query...")
  60.  
  61.    db.QueryDefs.Delete lcQueryName    ' Delete the spent querydef
  62.     
  63.    X = SysCmd(acSysCmdClearStatus)
  64.     
  65.   ' If thereÆs no merge document specified, or it doesnÆt yet exist
  66.   ' then just display a helpful message
  67.    If IsNull(txtMergeDoc) Or IsEmpty(txtMergeDoc) Or 
  68.        IsEmpty(Dir("" & txtMergeDoc)) Then
  69.            MsgBox "No merge has taken place because you did not specify
  70.                       a Merge Document or the document did not exist. 
  71.                      However, the data has been exported to the file '" & lcDataFile & "', 
  72.                      and may now be used for setting up a Merge Document.", 16, "Mail Merge"
  73.   Else
  74.     X = SysCmd(acSysCmdSetStatus, "Starting Word...")
  75.        
  76.     If TypeName(loWord) <> "wordbasic" Then
  77.            On Error Resume Next
  78.             
  79.         ' Try getting a handle to an open copy of Word
  80.            Set loWord = GetObject(, "word.basic")
  81.         
  82.         ' If Word isnÆt running, start it up
  83.          If Err <> 0 Then
  84.              Set loWord = CreateObject("word.basic")
  85.           End If
  86.          On Error GoTo 0
  87.      End If
  88.         
  89.      X = SysCmd(acSysCmdSetStatus, "Running MailMerge...")
  90.         
  91.      loWord.AppShow    ' Unhide Word
  92.      loWord.FileOpen (lcMergeDoc)          ' Open the merge document
  93.      loWord.MailMergeOpenDataSource lcDataFile        ' Open the data
  94.      loWord.MailMergeToDoc       ' Merge document & data to a new document
  95.         
  96.      X = SysCmd(acSysCmdClearStatus)
  97.         
  98.    ' Check with the user whether or not the operation worked
  99.     If Confirm("Did the mail-merge operation work?", "Mail Merge") Then
  100.         X = SysCmd(acSysCmdSetStatus, "Marking merged records...")
  101.             
  102.        SQL = "UPDATE [Mailshot=Company] SET Sent = Date()"
  103.        SQL = SQL & " where IsNull(Sent) and MailShotID = " & MailshotID
  104.        db.Execute SQL
  105.     End If
  106.         
  107.     X = SysCmd(acSysCmdClearStatus)
  108. End If
  109. End Sub
  110.  
  111.  
  112. Function AddBS(ByVal PathName As String) As String
  113.      ' Adds a backslash to a path name, if there isn't already one there
  114.        PathName = Trim(UCase(PathName))
  115.  
  116.        If (InStr("\:", Right(PathName, 1)) = 0) And PathName <> "" Then
  117.            PathName = PathName + "\"
  118.        End If
  119.     
  120.        AddBS = PathName
  121. End Function
  122.  
  123.  
  124. Function UniqueName(ByVal Length As Integer)
  125.     ' Makes a "unique" identifier of specified length out of random letters
  126.     
  127.     Dim TempName As String
  128.     Dim Counter As Integer
  129.     Dim Char as Integer
  130.     
  131.     Const LowerBound = 65 ' A
  132.     Const UpperBound = 90 ' Z
  133.     
  134.     Randomize
  135.     
  136.     TempName = ""
  137.     For Counter = 1 To Length
  138.         Char = (UpperBound - LowerBound + 1) * Rnd + LowerBound
  139.         TempName = TempName + Chr(Char)
  140.     Next
  141.  
  142.     UniqueName = TempName
  143. End Function
  144.  
  145.  
  146. Function JustFName(ByVal FileName As String) As String
  147.     ' Returns just the filename (i.e. no path) from FileName
  148.     If RAT("\", FileName) > 0 Then
  149.             FileName = Mid(FileName, RAT("\", FileName) + 1, 255)
  150.     End If
  151.     
  152.     If InStr(FileName, ":") > 0 Then
  153.         FileName = Mid(FileName, InStr(FileName, ":") + 1, 255)
  154.     End If
  155.     
  156.     JustFName = Trim(UCase(FileName))
  157. End Function
  158.