Geeky Bob

A few months ago I wrote a blog titled Using FrontPage 2003 to Bulk Rename Images Using VBA, in which I shared a VBA macro that renamed all of the images in a website to a common file-naming syntax. In that blog I explained my reasoning behind my use of the long-outdated FrontPage 2003, and that reason was that FrontPage's "Link Fix Up" feature replicates file renames across your entire website. This single feature can greatly reduce your development time for websites when you have a lot of renaming to do.

Recently I ran into another interesting situation where combining with FrontPage's VBA and "Link Fix Up" features saved me an incredible amount of time, so I thought that I would share that in today's blog.

Problem Description and Solution

I recently inherited a large website with thousands of images that were spread across dozens of folders throughout the website. Unfortunately, this website was created by several developers, so there were a large number of duplicate images scattered throughout the website.

It would have taken me several days to remove all of the duplicates and edit all of the HTML in the web pages, so this seemed like a task that was better suited for automation in FrontPage 2003.

VBA Bulk Image Moving Macro

The following VBA macro for FrontPage 2003 will locate every image in a website, and it will move all images to the website's root-level "images" folder if they are not already located in that folder:

Public Sub MoveImagesToImagesFolder()
    Dim objFolder As WebFolder
    Dim objWebFile As WebFile
    Dim intCount As Integer
    Dim strExt As String
    Dim strRootUrl As String
    Dim strImagesUrl As String
    Dim blnFound As Boolean
    
    ' Define the file extensions for image types.
    Const strValidExt = "jpg|jpeg|gif|bmp|png"
    ' Define the images folder name.
    Const strImagesFolder = "images"

    With Application
        ' Retrieve the URL of the website's root folder.
        strRootUrl = LCase(.ActiveWeb.RootFolder.Url)
        ' Define the root-level images folder URL.
        strImagesUrl = LCase(strRootUrl & "/" & strImagesFolder)
        
        ' Set the initial search status to not found.
        blnFound = False
        ' Loop through the root-level folders.
        For Each objFolder In .ActiveWeb.RootFolder.Folders
            ' Search for the images folder.
            If StrComp(objFolder.Url, strImagesUrl, vbTextCompare) = 0 Then
                ' Exit the loop if the images folder is found.
                blnFound = True
                Exit For
            End If
        Next
        
        ' Test if the images folder is missing...
        If blnFound = False Then
            ' ... and create it if necessary.
            .ActiveWeb.RootFolder.Folders.Add strImagesFolder
        End If
     
        ' Loop through the collection of images.
        For Each objWebFile In .ActiveWeb.AllFiles
            ' Retrieve the file extension.
            strExt = LCase(objWebFile.Extension)
            ' Test if the file extension is for an image type.
            If InStr(1, strValidExt, strExt, vbTextCompare) Then
                ' Test if the image is in the root-level images folder...
                If StrComp(objWebFile.Parent, strImagesUrl, vbTextCompare) <> 0 Then
                    ' ... and move the file if it is not.
                    objWebFile.Move strImagesUrl & "/" & objWebFile.Name, True, True
                End If
            End If
        Next
    End With

End Sub

In Closing...

This macro is pretty straight-forward, but there are a couple of parameters that I pass to the WebFile.Move() method which I would like to point out. The first parameter for the Move() is the destination URL, which should be obvious, but the second and third parameters should be explained:

• The second parameter is set to True in order to update hyperlinks during the move process; this is the "Link Fix Up" feature.
• The third parameter is set to True in order to overwrite duplicate files; this has the potential to be a destructive operation if you are not careful. In my situation that was acceptable, but you might want to double-check your content first.

Another thing to note is that you can easily update this macro to move other file types. For example, you could move all of the JavaScript files in your website to a common root-level "scripts" folder by changing the values of the strValidExt and strImagesFolder constants.

As always, have fun... ;-]

Note: This blog was originally posted at http://blogs.msdn.com/robert_mcmurray/

Despite the plethora of other tools and editors that I use to create websites, there are times when I simply have to dust off my copy of (gasp!) Microsoft FrontPage 2003. It may be a dinosaur, but there are some things that it does really well, and periodically I simply need to use it.

An often-mocked and yet critically essential feature that FrontPage 2003 provided was affectionately called "Link Fix Up," which was a feature that would replicate file renames across your entire website. In other words, if you had a file that was named "foo.html," you could rename it to "bar.html" and FrontPage 2003 would update every hyperlink in every file in your entire website which pointed to that file. Needless to say, this feature was often indispensable when I was working with extremely large websites.

Other applications may have similar features, but when you combine that feature with FrontPage 2003's built-in Visual Basic for Applications (VBA) functionality, you have a really powerful combination that can quickly seem indispensable.

With all of that being said, here's a scenario where using FrontPage 2003's "Link Fix Up" functionality with VBA really paid off, and I thought that it would make a great blog (in case anyone else runs into a similar issue and still has a copy of FrontPage 2003 lying around somewhere.)

Problem Description and Solution

I created a mixed-media website some years ago where I had thousands of images that were named like IMG5243.1024x768.png, IMG2745.1280x1024.png, IMG6354.800x600.png, etc. Some part of the file name obviously contained the image dimensions, which was useful at the time that I created the website, but that information was no longer necessary, and the filenames made the Obsessive Compulsive side of my behavior start to act up. (Too many characters.) With that in mind, I decided that I would rename all of those images back to simpler names like IMG5243.png, IMG2745.png, IMG6354.png, etc.

This is where FrontPage 2003's "Link Fix Up" functionality would come in handy; trying to crawl every webpage in my website to update the thousands of image links would have been incredibly painful, whereas FrontPage 2003 would take care of keeping the image links up-to-date for free, provided that I could come up with a way to automate the renaming process. (Enter VBA.)

Here is where I quickly ran into a problem - I hadn't standardized my file naming syntax. (Shame on me.) A lot of filenames had other parts or character strings that were going to cause problems, for example: IMG5243.1024x768_cropped.png, IMG2745.edited_1280x1024.png, IMG6354.new_800x600_small.png, etc. This meant that I was going to have to crawl through each filename character by character and look for image dimensions. This is not difficult through VBA, but it added a bit of complexity because I would have to locate any "x" character in a filename and then starting working my way to the right and left to see if it was surrounded by numbers. In other words, I would have to traverse every file name like "aaa_123x456_aaa.jpg" and "aaa.123x456.aaa.jpg" in order to remove "123x456," while leaving "aaa.wxy.jpg" untouched. Of course, there were also topics to be considered after I removed the numbers, like malformed image names like "aaa__aaa.jpg" and "aaa..aaa.jpg" that had unnecessary character duplications.

VBA Bulk File Renaming Macro

All that being said, here is the VBA macro that I created, which worked great; I was able to have this macro rename my thousands of images in a matter of seconds, and FrontPage 2003 made sure that every image URL in my HTML/ASP files were kept up-to-date.

Sub RemoveImageSizesFromFilenames()
  Dim intSectionCount As Integer
  Dim intXPosition As Integer
  Dim intCharPosition As Integer
  Dim intDictionaryCount As Integer
  Dim objWebFile As WebFile
  Dim strExt As String
  Dim strOldName As String
  Dim strNewName As String
  Dim strUrlStub As String
  Dim strSections() As String
  Dim strWidth As String
  Dim strHeight As String
  Dim objDictionary As Object
  Dim objItem As Object
  Dim varKeys As Variant
  Dim varItems As Variant
  
  ' Define the list of file extensions to process.
  Const strValidExt = "jpg|jpeg|gif|bmp|png"
  
  ' Create a dictionary object to hold the list of old/new filenames.
  Set objDictionary = CreateObject("Scripting.Dictionary")
  
  ' Verify that a website is open; exit if not.
  If Len(Application.ActiveWeb.Title) = 0 Then
    MsgBox "A website must be open." & vbCrLf & vbCrLf & "Aborting.", vbCritical
    Exit Sub
  End If
  
  ' Loop through the files colleciton for the website.
  For Each objWebFile In Application.ActiveWeb.AllFiles
    ' Retrieve the file extension for each file.
    strExt = LCase(objWebFile.Extension)
    ' Verify if the filename is part of the valid list.
    If InStr(strValidExt, strExt) Then
      ' Retrieve the current file name
      strOldName = LCase(Left(objWebFile.Name, Len(objWebFile.Name) - Len(strExt) - 1))
      ' Verify a multi-part filename.
      If InStr(strOldName, ".") Then
        ' Split the multi-part filename into sections.
        strSections = Split(strOldName, ".")
        ' Loop through the sections.
        For intSectionCount = 0 To UBound(strSections)
          ' Verify that each section actually has characters in it.
          If Len(strSections(intSectionCount)) > 1 Then
            ' Check for a lowercase X character.
            intXPosition = InStr(2, strSections(intSectionCount), "x")
            ' Make sure that the X character does not start or end the string.
            If intXPosition > 1 And intXPosition < Len(strSections(intSectionCount)) Then
              ' Make sure that the X character has numbers to the left and right of it.
              If IsNumeric(Mid(strSections(intSectionCount), intXPosition - 1, 1)) And IsNumeric(Mid(strSections(intSectionCount), intXPosition + 1, 1)) Then
                ' Initialize the width/height strings.
                strWidth = ""
                strHeight = ""
                ' Loop through the string to find the height.
                For intCharPosition = intXPosition + 1 To Len(strSections(intSectionCount))
                  If IsNumeric(Mid(strSections(intSectionCount), intCharPosition, 1)) Then
                    strHeight = strHeight & Mid(strSections(intSectionCount), intCharPosition, 1)
                  Else
                    Exit For
                  End If
                Next
                ' Loop through the string to find the width.
                For intCharPosition = intXPosition - 1 To 1 Step -1
                  If IsNumeric(Mid(strSections(intSectionCount), intCharPosition, 1)) Then
                    strWidth = Mid(strSections(intSectionCount), intCharPosition, 1) & strWidth
                  Else
                    Exit For
                  End If
                Next
                ' Remove the width/height string from the current filename section.
                strSections(intSectionCount) = Replace(strSections(intSectionCount), strWidth & "x" & strHeight, "")
              End If
            End If
          End If
        Next
        ' Reassemble the file sections.
        strNewName = Join(strSections, ".")
        If Right(strNewName, 1) = "." Then strNewName = Left(strNewName, Len(strNewName) - 1)
        ' Cleanup several unnecessary character sequences.
        If StrComp(strOldName, strNewName, vbTextCompare) <> 0 Then
          strOldName = strOldName & "." & strExt
          strNewName = strNewName & "." & strExt
          strNewName = Replace(strNewName, "_.", ".", 1, -1)
          strNewName = Replace(strNewName, "._", "_", 1, -1)
          strNewName = Replace(strNewName, "..", ".", 1, -1)
          strNewName = Replace(strNewName, "__", "_", 1, -1)
          strUrlStub = Left(objWebFile.Url, Len(objWebFile.Url) - Len(strOldName))
          ' Add the old/new file URLs to the dictionary.
          objDictionary.Add strUrlStub & strOldName, strUrlStub & strNewName
        End If
      End If
    End If
  Next
  
  varKeys = objDictionary.Keys
  varItems = objDictionary.Items
  
  ' Loop through the collection of URLs to rename.
  For intDictionaryCount = 0 To (objDictionary.Count - 1)
    ' Avoid collisions with existing URLs.
    If Application.ActiveWeb.LocateFile(varItems(intDictionaryCount)) Is Nothing Then
      ' Get current URL.
      Set objWebFile = Application.ActiveWeb.LocateFile(varKeys(intDictionaryCount))
      ' Rename the URL.
      objWebFile.Move varItems(intDictionaryCount), True, False
    End If
  Next
  
End Sub

In Closing...

There are a couple of additional details about this macro that you should consider:

First of all, this macro intentionally avoids overwriting the destination filename if it already exists. For example, if you have two files named IMG1234.100x100.jpg and IMG1234.200x200.jpg, simply removing the image size characters from each file name would result in a collision for the name IMG1234.jpg. What the macro currently does is to rename the first file, then it leaves any possible collisions unchanged. You could easily modify this script to prompt the user what to do, or you could configure it to rename each file with a syntax like IMG1234a.jpg / IMG1234b.jpg / IMG1234c.jpg, but I'll leave that up to you.

Second, I wrote this macro for a specific set of file types and filenames, but you could modify the macro for a variety of scenarios. For example, one developer that I knew liked to test his content on his production server by creating preview files with names like foo.preview.html and bar.preview.aspx. This allowed the production files to coexist on the same server with the preview files, although the production files would have the production-ready filenames like foo.html and bar.aspx. Once he was ready to push the preview files into production, he would simply rename the necessary files. This system worked for a small set of files, but it didn't scale very well, so the amount of labor on his part would increase as the website grew more complex. (Of course, he should have been using a development website for his preview testing, but that's another story.) In any event, this macro could easily be modified to remove the ".preview." string from every file name.

Note: This blog was originally posted at http://blogs.msdn.com/robert_mcmurray/

Using this FrontPage VBA Macro

This FrontPage VBA Macro is designed to fix potential filename problems by:

• Converting all filenames to lowercase.
• Converting all non-alphanumeric characters to underscore characters.
• Removing duplicate underscore characters.

FrontPage VBA Macro Example Code

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

Using this Outlook VBA Macro

Over the years, I had noticed that I had appointments from years ago stuck in my calendar, so I wrote this Outlook VBA Macro to export a list of all my appointments to a tab-separated (TSV) file so that I could open it in Microsoft Excel and analyze all of my appointments. (After writing this macro, I wrote my Delete Old Appointments macro to delete old appointments.)

Outlook VBA Macro Example Code

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

Using this Outlook VBA Macro

Over the years, I had noticed that I had appointments from years ago stuck in my calendar, so I wrote this Outlook VBA Macro to help keep my outlook calendar thinned-out.

Note: This macros deletes appointments and attachments from your Outlook calendar - make sure that you want to do this before running this macro.

By default the macro will:

• Delete all appointments over a year old (except recurring appointments.)
• Delete all attachments from 6-month-old appointments.
• Delete large attachments from 2-month-old appointments.

You can alter these dates by adjusting the appropriate lines in the macro.

Outlook VBA Macro Example Code

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

Using this FrontPage VBA Macro

This FrontPage VBA Macro is designed to disable the right-click and text selection functionality for every HTML or ASP file within the currently open web site by inserting some simple JavaScript code.

Note: Unfortunately, not all web clients are created or configured equally, so some web clients will ignore this JavaScript code. So this feature will almost always work, but there's no way to guarantee.

FrontPage VBA Macro Example Code

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

Using this FrontPage VBA Macro

This FrontPage VBA Macro is designed to return an array of all the folder URLs for the currently-open web site. I call this function from a lot of my other macros.

FrontPage VBA Macro Example Code

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

Using this FrontPage VBA Macro

This FrontPage VBA Macro is designed to reformat the HTML for every HTML or ASP file within the currently open web site.

FrontPage VBA Macro Example Code

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

Using this Access VBA Macro

I wrote this Access VBA Macro for a friend to export an Access table or query to a spreadsheet; it might come in handy. ;-]

Access VBA Macro Example Code

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

Summary

This article shows you a Windows Script Host (WSH) application that will create a report based on the schema of an Access Database.

More Information

1. Open Windows Notepad and copy/paste the WSH code listed below into it.
2. Modify the strDatabaseFile and strOutputFile constants for your database and desired report name.
3. Save the file as "DatabaseScema.vbs" to your desktop.
4. Double-click the WSH file to run it.
   Note: A message box that says "Finished!" will appear when the script has finished executing.

Windows Script Host (WSH) Code

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