Microsoft Bob

Public Sub FixFilenames()
   Dim objWebFile As WebFile
   Dim objWebFolder As WebFolder
   Dim strOldFile As String
   Dim strNewFile As String

   If Len(Application.ActiveWeb.Title) = 0 Then
      MsgBox "A web must be open." & vbCrLf & vbCrLf & "Aborting.", vbCritical
      Exit Sub
   End If

   For Each objWebFolder In Application.ActiveWeb.AllFolders
Here:
      For Each objWebFile In objWebFolder.Files
         strOldFile = objWebFile.Name
         strNewFile = FixName(strOldFile)
         If strNewFile <> strOldFile Then
            objWebFile.Move objWebFolder.Url & "/" & strNewFile & _
               ".tmp.xyz." & objWebFile.Extension, True, False
            objWebFile.Move objWebFolder.Url & "/" & strNewFile, True, False
            GoTo Here
         End If
      Next
   Next

   MsgBox "Finished!"

End Sub

Private Function FixName(ByVal tmpOldName As String) As String
   Dim intChar As Integer
   Dim strChar As String
   Dim tmpNewName As String

   Const strValid = "1234567890_-.abcdefghijklmnopqrstuvwxyz"

   tmpOldName = LCase(tmpOldName)

   For intChar = 1 To Len(tmpOldName)
      strChar = Mid(tmpOldName, intChar, 1)
      If InStr(strValid, strChar) Then
         tmpNewName = tmpNewName & strChar
      Else
         tmpNewName = tmpNewName & "_"
      End If
   Next

   Do While InStr(tmpNewName, "__")
      tmpNewName = Replace(tmpNewName, "__", "_")
   Loop

   Do While InStr(tmpNewName, "_-_")
      tmpNewName = Replace(tmpNewName, "_-_", "_")
   Loop

   FixName = tmpNewName

End Function

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

Public Sub DisableRightClickInAllFolders()
    Dim objWebFolder As WebFolder
    Dim objWebFile As WebFile
    Dim strExt As String
    
    If Len(Application.ActiveWeb.Title) = 0 Then
        MsgBox "A web must be open." & vbCrLf & vbCrLf & "Aborting.", vbCritical
        Exit Sub
    End If

    With Application
        For Each objWebFile In .ActiveWeb.AllFiles
            DoEvents
            strExt = LCase(objWebFile.Extension)
            If strExt = "htm" Or strExt = "html" Or strExt = "asp" Then
                objWebFile.Edit
                DoEvents
                .ActiveDocument.body.onContextMenu = "return false"
                .ActiveDocument.body.onselectstart = "return false"
                .ActivePageWindow.Save
                .ActivePageWindow.Close
                End If
            Next
    End With

End Sub

Private Function BuildFolderUrlTree() As Variant

    On Error Resume Next

    ' Declare all our variables
    Dim objWebFolder As WebFolder
    Dim objFolder As WebFolder
    Dim objSubFolder As WebFolder
    Dim strBaseFolder As String
    Dim lngFolderCount As Long
    Dim lngBaseCount As Long
         
    With Application
    
        ' Check the caption of the application to see if a web is open.
        If .ActiveWebWindow.Caption = "Microsoft FrontPage" Then
            ' If no web is open, display an informational message...
            MsgBox "Please open a web before running this function.", vbCritical
            ' ... and end the macro.
            Exit Function
        End If
    
        ' Change the web view to folder view.
        .ActiveWeb.ActiveWebWindow.ViewMode = fpWebViewFolders
        ' Refresh the web view and recalc the web.
        .ActiveWeb.Refresh
        
        ' Define the initial values for our folder counters.
        lngFolderCount = 1
        lngBaseCount = 0
    
        ' Dimension an aray to hold the folder names.
        ReDim strFolders(1) As Variant
    
        ' Get the URL of the root folder for the web...
        strBaseFolder = .ActiveWeb.RootFolder.Url
        ' ... and store the URL in our array.
        strFolders(1) = strBaseFolder
        
        ' Loop while we still have folders to process.
        While lngFolderCount <> lngBaseCount
            ' Set up a WebFolder object to a base folder.
            Set objFolder = .ActiveWeb.LocateFolder(strBaseFolder)
            ' Loop through the collection of subfolders for the base folder.
            For Each objSubFolder In objFolder.Folders
                ' Check to make sure that the subfolder is not a web.
                If objSubFolder.IsWeb = False Then
                    ' Increment our folder count.
                    lngFolderCount = lngFolderCount + 1
                    ' Increase our array size
                    ReDim Preserve strFolders(lngFolderCount)
                    ' Store the folder name in our array.
                    strFolders(lngFolderCount) = objSubFolder.Url
                End If
            Next
            ' Increment the base folder counter.
            lngBaseCount = lngBaseCount + 1
            ' Get the name of the next folder to process.
            strBaseFolder = strFolders(lngBaseCount + 1)
        Wend
    End With

    ' Return the array of folder names.
    BuildFolderUrlTree = strFolders

End Function

Public Sub ReformatHTML()
    Dim objWebFile As WebFile
    Dim strExt As String
    Dim cbCommandBar As CommandBar
    Dim cbCommandBarControl As CommandBarControl

    If Len(Application.ActiveWeb.Title) = 0 Then
        MsgBox "A web must be open." & vbCrLf & vbCrLf & "Aborting.", vbCritical
        Exit Sub
    End If

    For Each objWebFile In Application.ActiveWeb.AllFiles
        strExt = LCase(objWebFile.Extension)
        If strExt = "htm" Or strExt = "html" Or strExt = "asp" Then
            objWebFile.Edit
            Application.ActivePageWindow.ViewMode = fpPageViewHtml
            DoEvents
            Set cbCommandBar = Application.CommandBars("Html Page View Context Menu")
            Set cbCommandBarControl = cbCommandBar.FindControl( _
                Type:=msoControlButton, _
                Id:=CommandBars("Html Page View Context Menu").Controls("Reformat HT&ML").Id)
            cbCommandBarControl.Execute
            DoEvents
            Application.ActivePageWindow.Save
            Application.ActivePageWindow.Close
        End If
    Next

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!"