troubleshooting Question

Access VBA causing system to crash

Avatar of Murray Brown
Murray BrownFlag for United Kingdom of Great Britain and Northern Ireland asked on
OutlookVBA
7 Comments1 Solution38 ViewsLast Modified:
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
ASKER CERTIFIED SOLUTION
Join our community to see this answer!
Unlock 1 Answer and 7 Comments.
Start Free Trial
Learn from the best

Network and collaborate with thousands of CTOs, CISOs, and IT Pros rooting for you and your success.

Andrew Hancock - VMware vExpert
See if this solution works for you by signing up for a 7 day free trial.
Unlock 1 Answer and 7 Comments.
Try for 7 days

”The time we save is the biggest benefit of E-E to our team. What could take multiple guys 2 hours or more each to find is accessed in around 15 minutes on Experts Exchange.

-Mike Kapnisakis, Warner Bros