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

Select all Open in new window

  Dim OutApp As Object
    Dim OutMail As Object
    Dim strbody As String

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    strbody = managername & "," & vbNewLine & vbNewLine & _
              "Data has been dumped from the survey controller on project number " & newjob & ".  The name of the file is: " & vbNewLine & vbNewLine & _
              filefromname & vbNewLine & vbNewLine & _
              "and it is located in the following folder:" & vbNewLine & vbNewLine & _
            "<a href=""<file:///" & GetFolder & ">"">" & GetFolder & "</a>" & vbNewLine & vbNewLine & _
                "Comments:" & vbNewLine & surveynotes
    MsgBox strbody
    
    On Error Resume Next
    With OutMail
        .To = manageremail
        .Subject = "Some survey points have been downloaded on one of your projects"
        .Body = strbody
        'You can add a file like this
        '.Attachments.Add ("C:\test.txt")
        .Send   'or use .Display
    End With
    On Error GoTo 0

    Set OutMail = Nothing
    Set OutApp = Nothing

Select all Open in new window

Option Explicit 
 
Sub ListAppointments() 
     
    Dim olApp As Object 
    Dim olNS As Object 
    Dim olFolder As Object 
    Dim olApt As Object 
    Dim NextRow As Long 
     
    Set olApp = CreateObject("Outlook.Application") 
     
    Set olNS = olApp.GetNamespace("MAPI") 
     
    Set olFolder = olNS.GetDefaultFolder(9) 'olFolderCalendar
     
    Range("A1:D1").Value = Array("Subject", "Start", "End", "Location") 
     
    NextRow = 2 
     
    For Each olApt In olFolder.Items 
        Cells(NextRow, "A").Value = olApt.Subject 
        Cells(NextRow, "B").Value = olApt.Start 
        Cells(NextRow, "C").Value = olApt.End 
        Cells(NextRow, "D").Value = olApt.Location 
        NextRow = NextRow + 1 
    Next olApt 
     
    Set olApt = Nothing 
    Set olFolder = Nothing 
    Set olNS = Nothing 
    Set olApp = Nothing 
     
    Columns.AutoFit 
End Sub

Select all Open in new window