We help IT Professionals succeed at work.

Access VBA causing system to crash

Murray Brown
Murray Brown asked
on
28 Views
Last Modified: 2020-08-01
Hi. The following code is causing my system to crash. I can't work out why

Option Compare Database

Public Function Export_And_Email_Tables()

    Dim dbs As DAO.Database
   
    Dim tdf As DAO.TableDef
   
    Dim shell As Object
    Dim ZipFile As Variant
   
    Dim oFolder As String: oFolder = Environ("USERPROFILE") & "\Documents\ArmsTracker_Export"
       
    Dim oZipFile As String: oZipFile = oFolder & "\ArmsTracker.zip"
   
    If DirExists(oFolder) = False Then
        createNewDirectory (oFolder)
    End If
   
    InitializeZipFile (oZipFile)
    Set shell = CreateObject("Shell.Application")
    ZipFile = oZipFile
   
    Set dbs = CurrentDb
   
    For Each tdf In dbs.TableDefs
        If Left(tdf.Name, 4) <> "MSYS" Then
            '/ output the table to a CSV file:
            DoCmd.TransferText acExportDelim, , tdf.Name, oFolder & "_" & tdf.Name & ".csv", True
            shell.namespace(ZipFile).copyhere (oFolder & "_" & tdf.Name & ".csv")
            Do Until shell.namespace(ZipFile).items.Count >= 1
                'Call gotosleep(100)
                 'Email one at a time
            Loop
        End If
    Next tdf
   
    EmailZippedFile (oZipFile)
   
    Set shell = Nothing
    Set tdf = Nothing
    Set dbs = Nothing

End Function

Public Sub createNewDirectory(directoryName As String)
    If Not DirExists(directoryName) Then
        MkDir (directoryName)
    End If
End Sub
 
Function DirExists(DirName As String) As Boolean
On Error GoTo ErrorHandler
    DirExists = GetAttr(DirName) And vbDirectory
ErrorHandler:
End Function

Private Sub InitializeZipFile( _
  ZipFile As String _
)

    Dim intFile As Integer
   
      If Len(Dir(ZipFile)) > 0 Then
        Kill ZipFile
      End If
   
      intFile = FreeFile
      Open ZipFile For Output As #intFile
      Print #intFile, Chr$(80) & Chr$(75) & _
        Chr$(5) & Chr$(6) & String(18, 0)
      Close #intFile
End Sub


Function EmailZippedFile(ByVal oZipFile As String) As Boolean

On Error GoTo EH

    Dim oEmailTo As String
    oEmailTo = InputBox("Please enter email address", "Email Recipient(s)")

    Dim objOL As Object
    Set objOL = CreateObject("Outlook.Application")
   
    Dim olMail As Object
    Set olMail = objOL.createitem(0)
   
    With olMail
          .To = oEmailTo
         '.to = "murbro9@yahoo.com"
         '.to = "palpers@armedviolencereduction.org"
        .subject = "ArmsTracker Data"
        .attachments.Add (oZipFile)
        '.attachments.Add ("F:\Documents\TableDump\Tables.zip")
        .send
    End With
   
    Set olMail = Nothing
    Set objOL = Nothing
   
    MsgBox "Data Sent"
   
Exit Function

EH:

    MsgBox "Error sending Outlook message " & Err.Description

End Function
Comment
Watch Question

John TsioumprisSoftware & Systems Engineer
CERTIFIED EXPERT
Distinguished Expert 2019

Commented:

The code is not telling much

Just add an "error handler" so for example after every line you write down an entry to a Log table in order to get the  exact position where the crash occurs

Daniel PineaultPresident / Owner CARDA Consultants Inc.
CERTIFIED EXPERT
Distinguished Expert 2018

Commented:

I agree with John, add error handling throughout and see what gets reported back


Option Compare Database

Public Function Export_And_Email_Tables()
          Dim dbs                   As DAO.Database
          Dim tdf                   As DAO.TableDef
          Dim shell                 As Object
          Dim ZipFile               As Variant
10        Dim oFolder               As String: oFolder = Environ("USERPROFILE") & "\Documents\ArmsTracker_Export"
20        Dim oZipFile              As String: oZipFile = oFolder & "\ArmsTracker.zip"

30        On Error GoTo Error_Handler

40        If DirExists(oFolder) = False Then
50            createNewDirectory (oFolder)
60        End If

70        InitializeZipFile (oZipFile)
80        Set shell = CreateObject("Shell.Application")
90        ZipFile = oZipFile

100       Set dbs = CurrentDb

110       For Each tdf In dbs.TableDefs
120           If Left(tdf.Name, 4) <> "MSYS" Then
                  '/ output the table to a CSV file:
130               DoCmd.TransferText acExportDelim, , tdf.Name, oFolder & "_" & tdf.Name & ".csv", True
140               shell.namespace(ZipFile).copyhere (oFolder & "_" & tdf.Name & ".csv")
150               Do Until shell.namespace(ZipFile).items.Count >= 1
                      'Call gotosleep(100)
                      'Email one at a time
160               Loop
170           End If
180       Next tdf

190       EmailZippedFile (oZipFile)

Error_Handler_Exit:
200       On Error Resume Next
210       If Not shell Is Nothing Then Set shell = Nothing
220       If Not tdf Is Nothing Then Set tdf = Nothing
230       If Not dbs Is Nothing Then Set dbs = Nothing
240       Exit Function

Error_Handler:
250       MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _
                 "Error Number: " & Err.Number & vbCrLf & _
                 "Error Source: Export_And_Email_Tables" & vbCrLf & _
                 "Error Description: " & Err.Description & _
                 Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
                 , vbOKOnly + vbCritical, "An Error has Occurred!"
260       Resume Error_Handler_Exit

End Function

Public Sub createNewDirectory(directoryName As String)
10        On Error GoTo Error_Handler

20        If Not DirExists(directoryName) Then
30            MkDir (directoryName)
40        End If

Error_Handler_Exit:
50        On Error Resume Next
60        Exit Sub

Error_Handler:
70        MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _
                 "Error Number: " & Err.Number & vbCrLf & _
                 "Error Source: createNewDirectory" & vbCrLf & _
                 "Error Description: " & Err.Description & _
                 Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
                 , vbOKOnly + vbCritical, "An Error has Occurred!"
80        Resume Error_Handler_Exit
End Sub

Function DirExists(DirName As String) As Boolean
10        On Error GoTo Error_Handler

20        DirExists = GetAttr(DirName) And vbDirectory

Error_Handler_Exit:
30        On Error Resume Next
40        Exit Function

Error_Handler:
50        MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _
                 "Error Number: " & Err.Number & vbCrLf & _
                 "Error Source: DirExists" & vbCrLf & _
                 "Error Description: " & Err.Description & _
                 Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
                 , vbOKOnly + vbCritical, "An Error has Occurred!"
60        Resume Error_Handler_Exit
End Function

Private Sub InitializeZipFile( _
        ZipFile As String _
        )
          Dim intFile               As Integer

10        On Error GoTo Error_Handler

20        If Len(Dir(ZipFile)) > 0 Then
30            Kill ZipFile
40        End If

50        intFile = FreeFile
60        Open ZipFile For Output As #intFile
70        Print #intFile, Chr$(80) & Chr$(75) & _
                          Chr$(5) & Chr$(6) & String(18, 0)
80        Close #intFile

Error_Handler_Exit:
90        On Error Resume Next
100       Exit Sub

Error_Handler:
110       MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _
                 "Error Number: " & Err.Number & vbCrLf & _
                 "Error Source: InitializeZipFile" & vbCrLf & _
                 "Error Description: " & Err.Description & _
                 Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
                 , vbOKOnly + vbCritical, "An Error has Occurred!"
120       Resume Error_Handler_Exit
End Sub


Function EmailZippedFile(ByVal oZipFile As String) As Boolean
          Dim oEmailTo              As String
          Dim objOL                 As Object
          Dim olMail                As Object

10        On Error GoTo Error_Handler

20        oEmailTo = InputBox("Please enter email address", "Email Recipient(s)")

30        Set objOL = CreateObject("Outlook.Application")
40        Set olMail = objOL.createitem(0)

50        With olMail
60            .To = oEmailTo
              '.to = "murbro9@yahoo.com"
              '.to = "palpers@armedviolencereduction.org"
70            .Subject = "ArmsTracker Data"
80            .Attachments.Add (oZipFile)
              '.attachments.Add ("F:\Documents\TableDump\Tables.zip")
90            .send
100       End With

110       MsgBox "Data Sent"

Error_Handler_Exit:
120       On Error Resume Next
130       If Not olMail Is Nothing Then Set olMail = Nothing
140       If Not objOL Is Nothing Then Set objOL = Nothing
150       Exit Function

Error_Handler:
160       MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _
                 "Error Number: " & Err.Number & vbCrLf & _
                 "Error Source: EmailZippedFile" & vbCrLf & _
                 "Error Description: " & Err.Description & _
                 Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
                 , vbOKOnly + vbCritical, "An Error has Occurred!"
170       Resume Error_Handler_Exit
End Function

Also, in lines


DoCmd.TransferText acExportDelim, , tdf.Name, oFolder & "_" & tdf.Name & ".csv", True

shell.namespace(ZipFile).copyhere (oFolder & "_" & tdf.Name & ".csv")


aren't you missing a \ instead of _, shouldn't it be


DoCmd.TransferText acExportDelim, , tdf.Name, oFolder & "\" & tdf.Name & ".csv", True

shell.namespace(ZipFile).copyhere (oFolder & "\" & tdf.Name & ".csv")

Fabrice LambertConsulting
CERTIFIED EXPERT
Distinguished Expert 2017

Commented:

@Murray:
Unless you have a very valid Reason (like working with binary files), prefer using the FileSystemObject Library when dealing with the file system. It is far easyer to manipulate and more reliable.


@Daniel:
Unless it is within a top level function, error handlers should rethrow the error, else the calling function will never know something went wrong, thus they will continue processing with variables / object in an unknow state and effectivelly produce an undefined behavior.
Plus, most error handlers should remain silent, poping a message to the user is the sole responsibility of the top lvl functions.

Daniel PineaultPresident / Owner CARDA Consultants Inc.
CERTIFIED EXPERT
Distinguished Expert 2018

Commented:

@Fabrice,

Why don't you show us how it's done.


Normally, a function would return a True/False and with proper error handling this will indicate that it ran properly, or not, thus you can in calling procs continue, or not.  

Consulting
CERTIFIED EXPERT
Distinguished Expert 2017
Commented:
This one is on us!
(Get your first solution completely free - no credit card required)
UNLOCK SOLUTION
Benjamin LuSAP/ERP Data Processing
CERTIFIED EXPERT

Commented:

No error while running your code on my PC.

Windows10

Office365/Access2016

You can run your code step by step via F8, then you will find out which line causing the error.

Please double check if ZIP/Outlook program installed

Murray BrownASP.net/VBA/VSTO Developer

Author

Commented:
Thanks very much Fabrice
Unlock the solution to this question.
Join our community and discover your potential

Experts Exchange is the only place where you can interact directly with leading experts in the technology field. Become a member today and access the collective knowledge of thousands of technology experts.

*This site is protected by reCAPTCHA and the Google Privacy Policy and Terms of Service apply.

OR

Please enter a first name

Please enter a last name

8+ characters (letters, numbers, and a symbol)

By clicking, you agree to the Terms of Use and Privacy Policy.