asked on

Access VBA use location that wkll work on any computer

Hi. I was given the following code to email Access tables as Excel files. What can I change "F:\Documents\TableDump\Tables.zip" to so that it works on any computer with say a C drive? Thanks

Function ExportTables()
    Dim dbs As DAO.Database
    
    Dim tdf As DAO.TableDef
    
    Dim shell As Object
    Dim ZipFile As Variant
    
    InitializeZipFile ("F:\Documents\TableDump\Tables.zip")
    Set shell = CreateObject("Shell.Application")
    ZipFile = "F:\Documents\TableDump\Tables.zip"
    
    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, "F:\Documents\TableDump\" & tdf.Name & ".csv", True
            shell.namespace(ZipFile).copyhere ("F:\Documents\TableDump\" & tdf.Name & ".csv")
            Do Until shell.namespace(ZipFile).items.Count >= 1
                'Call gotosleep(100)
            Loop
        End If
    Next tdf
    
    Set shell = Nothing
    Set tdf = Nothing
    Set dbs = Nothing

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 EmailTables() As Boolean
    Dim objOL As Object
    Set objOL = CreateObject("Outlook.Application")
    
    Dim olMail As Object
    Set olMail = objOL.createitem(0)
    
    With olMail
        .to = "youremail@youremail.com"
        .subject = "Email Test"
        .attachments.Add ("F:\Documents\TableDump\Tables.zip")
        .send
    End With
    
    Set olMail = Nothing
    Set objOL = Nothing

End Function

Open in new window

ASKER CERTIFIED SOLUTION

John Tsioumpris

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

SOLUTION

Scott McDaniel (EE MVE )

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

Murray Brown

ASKER

Thanks very much

Murray Brown

ASKER

So something like this

Function ExportTables()
    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\TableDump"
    Dim oZipFile As String: oZipFile = oFolder & "\Tables.zip"
    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)
            Loop
        End If
    Next tdf
    
    Set shell = Nothing
    Set tdf = Nothing
    Set dbs = Nothing

End Function

Open in new window

SOLUTION

John Tsioumpris

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

Murray Brown

ASKER

Hi John. Thanks very much. Just ran that and realised I needed to ask the question but you had already answered it