DEVelopers HUT

'---------------------------------------------------------------------------------------
' Procedure  : SendBroadCast
' Author     : CARDA Consultants Inc.
' Website    : http://www.cardaconsultants.com
' Code Source: http://msdn2.microsoft.com/en-us/library/ms693479.aspx
' Purpose    : Send Broadcast fax (send fax to multiple recipients)
' References : requires 'Microsoft Fax Service Extended COM Type Library'
' Copyright : The following may be altered and reused as you wish so long as the
'             copyright notice is left unchanged (including Author, Website and 
'             Copyright).  It may not be sold/resold or reposted on other sites (links
'             back to this site are allowed).
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' strDoc - path and filname of the document to be faxed
'---------------------------------------------------------------------------------------
'
Function SendBroadCast(strDoc As String)
 
Dim objFaxDocument As New FAXCOMEXLib.FaxDocument
Dim collFaxRecipients As FaxRecipients
Dim JobId As Variant
Dim strMsg As String
 
'Error handling
On Error GoTo Error_Handler
 
'Set the fax body
objFaxDocument.Body = strDoc
 
'Name the document
objFaxDocument.DocumentName = "Database Fax"
 
'Get the recipients collection
Set collFaxRecipients = objFaxDocument.Recipients
 
'Update the table from which the info is pull to generate the fax recipient list
DoCmd.SetWarnings False 'Turn off warning messages so it is transparent to the user
DoCmd.OpenQuery "Qry_Need To Be Faxed", acViewNormal
DoCmd.SetWarnings True 'Turn back on warning messages

'Add the recipients
With collFaxRecipients
    'Using the table created by the above run query loop through the record
    'To populate the fax recipient list
    Dim rst As DAO.Recordset
    Set rst = CurrentDb.OpenRecordset("Temp01")
    If rst.RecordCount > 0 Then 'ensure there is data
        rst.MoveLast  'goto the last recordset
        Do Until rst.BOF  'beginning of file
           'perform a desired action
           .Add rst![Fax], rst![Company]
           rst.MovePrevious
        Loop
    Else
        MsgBox "There are no faxes to be sent at this time!", vbInformation
    End If
 
End With
 
'Display number of recipients
strMsg = "Total Number of Recipients: " & collFaxRecipients.Count & vbCrLf
 
'Display recipient information
Dim i As Long
For i = 1 To collFaxRecipients.Count
    strMsg = strMsg & "Recipient number " & i & ": " & collFaxRecipients.Item(i).Name & _
             ", " & collFaxRecipients.Item(i).FaxNumber & vbCrLf
Next
MsgBox strMsg, vbInformation, "The following faxes are being processed."
 
'Load the default sender
objFaxDocument.Sender.LoadDefaultSender
 
'Group the broadcast receipts
objFaxDocument.GroupBroadcastReceipts = True
 
'Connect to the fax server, submit the document, and get back the
'job ID array. "" indicates the local server.
JobId = objFaxDocument.Submit("")
 
'UBound finds the size of the array
'Display jobIDs for each of the fax jobs
'For n = 0 To UBound(JobId)
'    MsgBox "The Job ID is " & JobId(n)
'Next

'Remove the recipients from the collection. If you don't take this step,
'and run this code again without closing the program, the recipients
'collection will retain the recipients and keep adding more recipients.
'The count and item numbering will change as you remove the items, so
'just remove item (1) Count times
Dim lCount As Long
lCount = collFaxRecipients.Count
For i = 1 To lCount
    collFaxRecipients.Remove (1)
Next
Exit Function
 
Error_Handler:
    'Implement error handling at the end of your subroutine. This
    'implementation is for demonstration purposes
    If Err.Number = -2147024864 Then
        MsgBox "You currently have the document to be faxed open and are therefore" & _
               " stopping the fax from being sent.  Please close the document in " & _
               "question and then try again.", vbInformation, "Your Fax cannot be " & _
               "sent at this time"
    Else
        MsgBox "Error number: " & Err.Number & ", " & Err.Description
    End If
End Function