Link to home
Start Free TrialLog in
Avatar of Biggles1
Biggles1Flag for United States of America

asked on

VBA Indentifying version of Access

I have an Access Application that runs in 2003, 2007 and 2010.

Some of the VBA code does not run the same in all three versions.  How would the Application identify which version of Access is running so I can modify the code with an If then Else statement?

Biggles1
SOLUTION
Avatar of IrogSinta
IrogSinta
Flag of United States of America image

Link to home
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Start Free Trial
ASKER CERTIFIED SOLUTION
Link to home
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Start Free Trial
Avatar of Biggles1

ASKER

Well, there is one statement that wont even compile on Access 2003.  Try this in 2003:

DoCmd.SendObject acSendReport, "rptInUnitMaintenanceInvoice", acFormatPDF, strEmailTo, , , "In Unit Maintenance Invoice " & strInvoiceNo & " for work completed " & strDateCompleted

in 2003 only
DoCmd.SendObject acSendReport, "rptInUnitMaintenanceInvoice", "Snapshot Format", strEmailTo, , , "In Unit Maintenance Invoice " & strInvoiceNo & " for work completed " & strDateCompleted

works!

Unfortunately I have a customer who emails to a recipient who cannot read "Snapshot Format"!!
No surprise there.
The ability to export reports to PDF was added in A2007.

That's why I have this sub for A2007+
Private Sub SaveAsOfficePDF(stDocName As String)

Dim FormatValue As String
If Application.Version > 11 Then
    FormatValue = "PDF Format (*.pdf)"
Else
    FormatValue = acFormatRTF
End If

Me.SentToPrint.Value = False
If Not stDocName Like "*QD*" Then
    DoCmd.OpenReport stDocName, acPreview
    DoCmd.OutputTo acOutputReport, stDocName, FormatValue, "c:\tempPdf\" & Reports(stDocName).Caption & ".pdf"
    DoCmd.Close acReport, stDocName, acSaveYes
Else
    DoCmd.Close acReport, stDocName, acSaveYes
    DoCmd.OpenReport stDocName, acNormal
    RenameAGenericReport (stDocName)
End If
End Sub

Open in new window


In A2003, that's not going to play, so life's more complex.
What you do in that case is have a PDF printer installed.  
I have a mix of Adobe Acrobat and doPDF on the go.
It is VERY nice to have a .Caption property for the report created dynamically as that by default becomes the filename
You switch Access's printer to the PDF printer and render the document.
And then you switch the printer back.  This uses the API code I posted earlier to keep tabs on the PDF queue.
Private Sub CreatePDF(stDocName As String)

If Application.Version > 11 Then
    Call SaveAsOfficePDF(stDocName)
    Exit Sub
End If
    
Dim OldDefaultPrinterName As String
Dim NewPrinterName As String
Dim OldDefaultPrinterIndex As Integer
Dim NewPrinterIndex As Integer
Dim x As Integer

'Get the existing printer name to set the app default back to later
OldDefaultPrinterName = Application.Printer.DeviceName
NewPrinterName = "Adobe PDF"

Dim prtLoop As Printer
x = 0
For Each prtLoop In Application.Printers
    With prtLoop
        If .DeviceName = OldDefaultPrinterName Then
            OldDefaultPrinterIndex = x
        ElseIf .DeviceName = NewPrinterName Then
            NewPrinterIndex = x
        End If

    End With
    x = x + 1
Next prtLoop

'now change the printer to adobe pdf and print
Set Application.Printer = Application.Printers(NewPrinterIndex)
Set Application.Printer = Application.Printers("Adobe PDF")
'MsgBox "changed to " & Application.Printer.DeviceName


        DoCmd.OpenReport stDocName, acPreview
        DoCmd.OpenReport stDocName, acNormal
        DoCmd.Close acReport, stDocName, acSaveYes

Dim Wait As Double
Wait = Timer + 5
'MsgBox Application.Printer.DeviceName
'now these structures pause things up until the job spools up and completes
'what happens if the default printer never gets the job, or can complete it before it gets here?
'it hangs, that's what!
'gotta fix that.

Do While GetPrinterDetails("Adobe PDF").Jobs = 0 And Timer < Wait
    If GetPrinterDetails("Adobe PDF").Jobs > 0 Then
        Exit Do
    End If
    DoEvents 'wait for spooling to start
    
    'wait = wait + 1
    'MsgBox wait & " " & Timer
    'MsgBox GetPrinterDetails("Adobe PDF").Jobs
Loop

spooling:
Wait = Timer + 5

Do Until GetPrinterDetails("Adobe PDF").Jobs = 0 And Timer > Wait
    If GetPrinterDetails("Adobe PDF").Jobs = 0 Then
        Exit Do
    End If
    DoEvents 'wait til spooling is complete
    'wait = wait + 1
    'MsgBox wait & " " & Timer
Loop

'then change the printer back
Set Application.Printer = Application.Printers(OldDefaultPrinterIndex)
'MsgBox "changed back to " & Application.Printer.DeviceName


'If fs.FileExists("\\sb2008\customer\schl\pdf\" & Forms!frmjobID![WO#] & " FR3.pdf") = False Then
    Select Case True
    Case fs.FileExists("c:\temppdf\" & Forms!frmJobID![wo#] & " FR4.pdf")
        fs.CopyFile "c:\temppdf\" & Forms!frmJobID![wo#] & " FR4.pdf", "\\sb2008\customer\schl\pdf\" & Forms!frmJobID![wo#] & " FR3.pdf", True
    Case fs.FileExists("c:\temppdf\" & Forms!frmJobID![wo#] & " FR 4.pdf")
        fs.CopyFile "c:\temppdf\" & Forms!frmJobID![wo#] & " FR 4.pdf", "\\sb2008\customer\schl\pdf\" & Forms!frmJobID![wo#] & " FR3.pdf", True
    Case fs.FileExists("c:\temppdf\" & Forms!frmJobID![wo#] & " FR3.pdf")
        fs.CopyFile "c:\temppdf\" & Forms!frmJobID![wo#] & " FR3.pdf", "\\sb2008\customer\schl\pdf\" & Forms!frmJobID![wo#] & " FR3.pdf", True
    Case fs.FileExists("c:\temppdf\" & Forms!frmJobID![wo#] & " FR 3.pdf")
        fs.CopyFile "c:\temppdf\" & Forms!frmJobID![wo#] & " FR 3.pdf", "\\sb2008\customer\schl\pdf\" & Forms!frmJobID![wo#] & " FR3.pdf", True
    Case fs.FileExists("c:\temppdf\" & Forms!frmJobID![wo#] & " FR2.pdf")
        fs.CopyFile "c:\temppdf\" & Forms!frmJobID![wo#] & " FR2.pdf", "\\sb2008\customer\schl\pdf\" & Forms!frmJobID![wo#] & " FR3.pdf", True
    Case fs.FileExists("c:\temppdf\" & Forms!frmJobID![wo#] & " FR 2.pdf")
        fs.CopyFile "c:\temppdf\" & Forms!frmJobID![wo#] & " FR 2.pdf", "\\sb2008\customer\schl\pdf\" & Forms!frmJobID![wo#] & " FR3.pdf", True
    End Select
'End If

Select Case ReturnComputerName
    Case "itadmin1"
        Call CloseAdobeWindow
    Case "mobile3"
        'Call CloseAdobeWindow
    Case Else
        Exit Sub
End Select


Sleep 1000
'Wait = Timer + 1
'Do Until Timer > Wait
'    DoEvents 'wait a second
'Loop
Call CloseAdobeWindow
End Sub

Open in new window


After that, you have to automate Outlook to create the message and attach the newly created PDF.
First, you get an Outlook object the right way
https://www.experts-exchange.com/articles/17466/Properly-open-Outlook-as-an-Application-object-in-VBA.html
Option Compare Database
Option Explicit
Public wasOpen As Boolean
Function StartApp(ByVal appName) As Object
On Error GoTo ErrorHandler
Dim oApp As Object

wasOpen = True
Set oApp = GetObject(, appName)    'Error here - Run-time error '429':
Set StartApp = oApp

Exit Function

ErrorHandler:
If Err.Number = 429 Then
    'App is not running; open app with CreateObject
    Set oApp = CreateObject(appName)
    wasOpen = False
    Resume Next
Else
    MsgBox Err.Number & " " & Err.Description
End If
End Function

Open in new window

And then make the email message
Public Sub CreateAnEmail(reportcaption As String, ClientName As String, Optional Suppress As Boolean, Optional TheBodyText As String, Optional WantReadReceipt As Boolean)
'On Error Resume Next
Dim db As Database
Dim rs As Recordset
Dim ClientEmail As String
Dim DisplayMsg As Boolean
Dim AttachmentPath As String
Dim objOutlook As Outlook.Application
Dim objOutlookMsg As Outlook.MailItem
Dim objOutlookRecip As Outlook.Recipient
Dim objOutlookAttach As Outlook.Attachment
Dim objOutlookExplorers As Outlook.Explorers
Dim myarray() As String
Dim myaddresses() As String
Dim x As Integer
Dim fs As Object
Dim BuiltPath As String
Dim response As Integer


Do While GetPrinterDetails("Adobe PDF").Jobs > 0
DoEvents
Loop

myarray = Split(reportcaption, ";")
'MsgBox UBound(MyArray, 1)

DisplayMsg = True
'AttachmentPath = "c:\temp\" & ReportCaption & ".pdf"

If Nz(Suppress, False) <> True Then
MsgBox "The email is about to be created!" & vbCrLf & _
        "If nothing appears to be happening, the Outlook security box may be hiding behind an open window." & vbCrLf & _
        "Click the Outlook icon on the taskbar to bring it to the front, if necessary."
End If


Set objOutlook = StartApp("Outlook.Application")

Dim ns As Outlook.Namespace
Dim Folder As Outlook.MAPIFolder
Set ns = objOutlook.GetNamespace("MAPI")
Set Folder = ns.GetDefaultFolder(olFolderInbox)
Set objOutlookExplorers = objOutlook.Explorers

If wasOpen = False Then
    objOutlookExplorers.Add Folder
    Folder.Display
    'done opening
End If


' Create the message.
'Set objOutlookMsg = objOutlook.CreateItem(olMailItem)
Set objOutlookMsg = objOutlook.CreateItem(olMailItem)

With objOutlookMsg
    If Not ClientName Like "*@*" Then
        Set db = CurrentDb
        Set rs = db.OpenRecordset("select [client email] from tblclients where [client name] = " & Chr(34) & ClientName & Chr(34) & ";", dbOpenDynaset, dbSeeChanges)
        If rs.RecordCount <> 0 Then
            ClientEmail = Nz(rs![Client Email], "")
        Else
            ClientEmail = ""
        End If
        rs.Close
        db.Close
        Set db = Nothing
        Set rs = Nothing
    Else
        ClientEmail = ClientName
    End If
    
    
    If Nz(ClientEmail, "") <> "" Then
    ' Add the To recipient(s) to the message.
    myaddresses = Split(ClientEmail, ";")
    For x = LBound(myaddresses) To UBound(myaddresses)
        Set objOutlookRecip = .Recipients.Add(myaddresses(x))
        objOutlookRecip.Type = olTo
    Next x
    End If
      
    'can't do this, the mail never gets sent
    ' Add the from recipient(s) to the message.
    'Set objOutlookRecip = .Recipients.Add(fGetFullNameOfLoggedUser())
    'objOutlookRecip.Type = olOriginator
    
    ' Add the CC recipient(s) to the message.
    'Set objOutlookRecip = .Recipients.Add(fGetFullNameOfLoggedUser())
    'objOutlookRecip.Type = olCC

   ' Add the BCC recipient(s) to the message.
    'Set objOutlookRecip = .Recipients.Add("Biggles1")
    'objOutlookRecip.Type = olBCC
    
   ' Set the Subject, Body, and Importance of the message.
            .Subject = "Requested report " & IIf(Len(reportcaption) < 161, reportcaption, Left(reportcaption, 159) & "...")

    
    If Nz(TheBodyText, "") = "" Then
        .body = "This is an automated sending by Biggles1 as requested." & vbCrLf & vbCrLf & _
        "Please respond to Biggles1 with any inquiries"
    Else
       .body = TheBodyText
    End If
   '.Importance = olImportanceHigh  'High importance
    
   ' Add attachments to the message.
   'reportcaption is passed in and split into myarray
   'one attachment needs to be added for each element in myarray

    For x = LBound(myarray, 1) To UBound(myarray, 1)
    If Right(myarray(x), 3) = "xls" Then
        AttachmentPath = "c:\tempPDF\" & myarray(x)
    ElseIf reportcaption Like "*_cert.pdf" Then
        AttachmentPath = reportcaption
    Else
        AttachmentPath = "c:\tempPDF\" & myarray(x) & ".pdf"
    End If
    'MsgBox reportcaption
    If Not IsMissing(AttachmentPath) Then
        Set objOutlookAttach = .Attachments.Add(AttachmentPath)
    Else
        MsgBox "The attachment was not found or attached!"
    End If
    Next x
               
   ' Resolve each Recipient's name.
   For Each objOutlookRecip In .Recipients
       objOutlookRecip.Resolve
   Next
   
   'Read receipt
   If Nz(WantReadReceipt, False) = True Then
    .ReadReceiptRequested = True
   End If

   ' Should we display the message before sending?
   If DisplayMsg Then
       .Display
   Else
       .Save
       .Send
   End If
End With

Set objOutlook = Nothing

End Sub

Open in new window


This code was simplified down from working code and so is not likely to be perfect.
Still, it gives the bones and the Google keywords to see how to use VBA to create an Outlook message

There's a big discussion of it here
https://www.experts-exchange.com/questions/28471183/Need-code-to-programmatically-send-an-email-in-MS-Access-that-will-work-in-Access-2K-as-well-as-current-versions.html
Nick:  This is Excellent!  Is there a way you can earn points for this additional information?
You really should have created another question because this is a different subject altogether from your original question.  That way, others can benefit when they search for this particular topic; secondly, you may get a variety of responses on how to accomplish this; and lastly, you will be able to award points to the expert.  I myself used a version of Leban's method that I modified (copyright intact) that converts a snapshot to a PDF so whenever I need a report as a PDF I use this function:
Public Sub ConvertToPDF(rptName As String, pdfName As String, folderPath As String)
    'Create a snapshot of the report & save it in the current database path.  Don't show snapshot.
    DoCmd.OutputTo acOutputReport, rptName, "SNAPSHOT FORMAT (*.snp)", database_path & "\REPORT.SNP", False
    Shell ("\\corpsrv01\pcbackup\ConverterSnapToPDF\ConvertSnapshotToPDF.exe " & database_path & "\REPORT.SNP," & pdfName & "," & folderPath)
    
End Sub

Open in new window

Ron
Is there a way you can earn points for this additional information?
I don't know if the 'good comment' button awards points or not.
And to me personally, the points are not that big a deal.

I am glad that you've gotten a handle on your problem and some new techniques.
DoCmd.SendObject is simple but very limited -- especially since you can only send a single report

Once you get a handle on how to automate Outlook many other possibilities open up.
Multiple files
Multiple sender types (CC and BCC)
HTML format mail
That last one is especially nice.

You can export a recordset to Excel, save the Excel as HTML and then TextStream the HTML to the .HTMLBody of a mail message and have formatted tables in the message body.
Lots of possibilities :)