Geeky Bob

Sub ExportAppointmentsToTsvFile()

   Dim objOutlook As Outlook.Application
   Dim objNamespace As Outlook.NameSpace
   Dim objFolder As Outlook.MAPIFolder
   Dim objAppointement As Outlook.AppointmentItem
   Dim objNetwork As Object
   Dim objFSO As Object
   Dim objFile As Object
   Dim strUserName As String

   Set objOutlook = Application
   Set objNamespace = objOutlook.GetNamespace("MAPI")
   Set objFolder = objNamespace.GetDefaultFolder(olFolderCalendar)

   Set objNetwork = CreateObject("WScript.Network")

   strUserName = objNetwork.UserName

   If InStr(strUserName, "\") = 0 Then
      strUserName = objNetwork.UserDomain & "\" & strUserName
   End If

   Set objFSO = CreateObject("Scripting.FileSystemObject")
   Set objFile = objFSO.CreateTextFile("c:\outlook-calendar.tsv")

   objFile.WriteLine "UserName" & vbTab & _
      "AppointementStart" & vbTab & _
      "AppointementEnd" & vbTab & _
      "AppointementRecurrenceState" & vbTab & _
      "AppointementSubject" & vbTab & _
      "AppointementSize" & vbTab & _
      "AppointementUnRead" & vbTab & _
      "AppointementLocation"

   For Each objAppointement In objFolder.Items
      DoEvents
      objFile.WriteLine strUserName & vbTab & _
      objAppointement.Start & vbTab & _
      objAppointement.End & vbTab & _
      objAppointement.RecurrenceState & vbTab & _
      objAppointement.Subject & vbTab & _
      objAppointement.Size & vbTab & _
      objAppointement.UnRead & vbTab & _
      objAppointement.Location
   Next

   MsgBox "Done!"

End Sub

Sub DeleteOldAppointments()

   Dim objOutlook As Outlook.Application
   Dim objNamespace As Outlook.NameSpace
   Dim objFolder As Outlook.MAPIFolder
   Dim objAppointement As Outlook.AppointmentItem
   Dim objAttachment As Outlook.Attachment
   Dim objNetwork As Object
   Dim lngDeletedAppointements As Long
   Dim lngCleanedAppointements As Long
   Dim lngCleanedAttachments As Long
   Dim blnRestart As Boolean
   Dim intDateDiff As Integer

   Set objOutlook = Application
   Set objNamespace = objOutlook.GetNamespace("MAPI")
   Set objFolder = objNamespace.GetDefaultFolder(olFolderCalendar)

Here:

   blnRestart = False

   For Each objAppointement In objFolder.Items
      DoEvents
      intDateDiff = DateDiff("d", objAppointement.Start, Now)

      ' Delete year-old appointments.
      If intDateDiff > 365 And objAppointement.RecurrenceState = olApptNotRecurring Then
         objAppointement.Delete
         lngDeletedAppointements = lngDeletedAppointements + 1
         blnRestart = True

      ' Delete attachments from 6-month-old appointments.
      ElseIf intDateDiff > 180 And objAppointement.RecurrenceState = olApptNotRecurring Then
         If objAppointement.Attachments.Count > 0 Then
            While objAppointement.Attachments.Count > 0
               objAppointement.Attachments.Remove 1   Wend
            lngCleanedAppointements = lngCleanedAppointements + 1
        End If

      ' Delete large attachments from 60-day-old appointments.
      ElseIf intDateDiff > 60 Then
         If objAppointement.Attachments.Count > 0 Then
            For Each objAttachment In objAppointement.Attachments
               If objAttachment.Size > 500000 Then
                  objAttachment.Delete
                  lngCleanedAttachments = lngCleanedAttachments + 1
               End If
            Next
         End If
      End If
   Next

   If blnRestart = True Then GoTo Here

   MsgBox "Deleted " & lngDeletedAppointements & " appointment(s)." & vbCrLf & _
      "Cleaned " & lngCleanedAppointements & " appointment(s)." & vbCrLf & _
      "Deleted " & lngCleanedAttachments & " attachment(s)."

End Sub

Sub ExportTableOrQueryToExcel()

    Const strTitle = "This is my worksheet title"
    Const strTableOrQuery = "Query1"
    
    ' define the path to the output file
    Dim strPath As String
    strPath = "C:\TestFile " & _
        Year(Now) & Right("0" & _
        Month(Now), 2) & Right("0" & _
        Day(Now), 2) & ".xls"
    
    ' create and open an Excel workbook
    Dim objXL As Object
    Set objXL = CreateObject("Excel.Application")
    objXL.WorkBooks.Add
    objXL.Worksheets(1).Name = strTitle
    objXL.Visible = False
   
    ' delete the extra worksheets
    Dim intX As Integer
    If objXL.Worksheets.Count > 1 Then
        For intX = 2 To objXL.Worksheets.Count
            objXL.Worksheets(2).Delete
        Next
    End If
    
    ' open the database
    Dim objDB As DAO.Database
    Dim objRS As DAO.Recordset
    Dim objField As DAO.Field
    Set objDB = CurrentDb
    
    ' open the query/table
    Dim strSQL As String
    strSQL = "SELECT * FROM [" & strTableOrQuery & "]"
    Set objRS = objDB.OpenRecordset(strSQL)
    
    Dim lngRow As Long
    Dim lngCol As Long
    
    If Not objRS.EOF Then
    
        lngRow = 1: lngCol = 1
        
        For Each objField In objRS.Fields
            objXL.Worksheets(1).Cells(lngRow, lngCol).Value = objField.Name
            lngCol = lngCol + 1
        Next
        
        lngRow = lngRow + 1
    
        ' loop through the table records
        Do While Not objRS.EOF
            lngCol = 1
            For Each objField In objRS.Fields
                objXL.Worksheets(1).Cells(lngRow, lngCol).Value = objField.Value
                lngCol = lngCol + 1
            Next
            lngRow = lngRow + 1
            objRS.MoveNext
        Loop
    
    End If
    
    objXL.DisplayAlerts = False
    objXL.ActiveWorkbook.SaveAs strPath, 46
    objXL.ActiveWorkbook.Close

End Sub

Option Explicit

' --------------------------------------------------
' Define variables and constants
' --------------------------------------------------

Const strDatabaseFile = "MusicStuff.mdb"
Const strOutputFile = "MusicStuff.htm"
Const adSchemaTables = 20

Dim strSQL
Dim strCN
Dim objCN
Dim objRS1
Dim objRS2
Dim objField
Dim intCount
Dim objFSO
Dim objFile

' --------------------------------------------------
' Open the output file
' --------------------------------------------------

Set objFSO = WScript.CreateObject("Scripting.FileSystemObject")
Set objFile = objFSO.CreateTextFile(strOutputFile)
objFile.WriteLine "<html><head>" & _
"<style>BODY { font-family:arial,helvetica; }</style>" & _
"</head><body>"
objFile.WriteLine "<h2>Schema Report for &quot;" & _
strDatabaseFile & "&quot;</h2>"

' --------------------------------------------------
' Setup the string array of field type descriptions
' --------------------------------------------------

Dim strColumnTypes(205)

' initialize array

For intCount = 0 To UBound(strColumnTypes)
strColumnTypes(intCount) = "n/a"
Next

' add definitions

strColumnTypes(2) = "Integer"
strColumnTypes(3) = "Long Integer"
strColumnTypes(4) = "Single"
strColumnTypes(5) = "Double"
strColumnTypes(6) = "Currency"
strColumnTypes(11) = "Yes/No"
strColumnTypes(17) = "Byte"
strColumnTypes(72) = "Replication ID"
strColumnTypes(131) = "Decimal"
strColumnTypes(135) = "Date/Time"
strColumnTypes(202) = "Text"
strColumnTypes(203) = "Memo/Hyperlink"
strColumnTypes(205) = "OLE Object"

' --------------------------------------------------
' Open database and schema
' --------------------------------------------------

strCN = "DRIVER={Microsoft Access Driver (*.mdb)};DBQ=" & strDatabaseFile
Set objCN = WScript.CreateObject("ADODB.Connection")
objCN.Open strCN
Set objRS1 = objCN.OpenSchema(adSchemaTables)

' --------------------------------------------------
' Loop through database schema
' --------------------------------------------------

Do While Not objRS1.EOF
  If Left(objRS1("TABLE_NAME"),4) <> "MSys" Then
    objFile.WriteLine "<p><big>" & objRS1("TABLE_NAME") & "</big></p>"
    objFile.WriteLine "<blockquote><table border=1>" & _
      "<tr><th>Field Name</th><th>Data Type</th></tr>"
    strSQL = "SELECT * FROM [" & objRS1("TABLE_NAME") & "]"
    Set objRS2 = objCN.Execute(strSQL)
    For Each objField in objRS2.Fields
      objFile.WriteLine "<tr><td>" & objField.Name _
      & "</td><td>" & strColumnTypes(objField.Type) & "</td></tr>"
    Next
    objFile.WriteLine "</table></blockquote>"
  End If
  objRS1.MoveNext
Loop

' --------------------------------------------------
' Close the output file
' --------------------------------------------------

objFile.WriteLine "</body></html>"

MsgBox "Finished!"