Microsoft Bob

Just a short, simple blog for Bob to share some tips and tricks.

Be sure to check out my non-technical blog at www.bobsbasement.net.

Month List

Using FrontPage 2003 to Consolidate Images in a Common Folder

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/
Posted: Oct 27 2013, 16:00 by Bob | Comments (0)
  • Currently 0/5 Stars.
  • 1
  • 2
  • 3
  • 4
  • 5
Filed under: FrontPage | Macros | VBA
Social Bookmarks: E-mail | Kick it! | DZone it! | del.icio.us

Using FrontPage 2003 to Bulk Rename Images Using VBA

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/
Posted: Jun 21 2013, 07:19 by Bob | Comments (0)
  • Currently 0/5 Stars.
  • 1
  • 2
  • 3
  • 4
  • 5
Filed under: FrontPage | Macros | VBA
Social Bookmarks: E-mail | Kick it! | DZone it! | del.icio.us

FrontPage Macro: Fix Filenames

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
Posted: Apr 05 2009, 15:15 by Bob | Comments (0)
  • Currently 0/5 Stars.
  • 1
  • 2
  • 3
  • 4
  • 5
Filed under: FrontPage
Social Bookmarks: E-mail | Kick it! | DZone it! | del.icio.us

Outlook Macro: Export Appointments to TSV File

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
Posted: Sep 30 2008, 13:33 by Bob | Comments (0)
  • Currently 0/5 Stars.
  • 1
  • 2
  • 3
  • 4
  • 5
Filed under: Office | VBA
Social Bookmarks: E-mail | Kick it! | DZone it! | del.icio.us

Outlook Macro: Delete Old Appointments

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
Posted: Sep 30 2008, 13:31 by Bob | Comments (3)
  • Currently 0/5 Stars.
  • 1
  • 2
  • 3
  • 4
  • 5
Filed under: Office | VBA
Social Bookmarks: E-mail | Kick it! | DZone it! | del.icio.us

FrontPage Macro: Disable Right-Click and Text Selection

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
Posted: Feb 17 2008, 04:34 by Bob | Comments (0)
  • Currently 0/5 Stars.
  • 1
  • 2
  • 3
  • 4
  • 5
Filed under: FrontPage
Social Bookmarks: E-mail | Kick it! | DZone it! | del.icio.us

FrontPage Macro: Build Folder URL Tree

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
Posted: Feb 17 2008, 02:22 by Bob | Comments (0)
  • Currently 0/5 Stars.
  • 1
  • 2
  • 3
  • 4
  • 5
Filed under: FrontPage
Social Bookmarks: E-mail | Kick it! | DZone it! | del.icio.us

FrontPage Macro: Reformat HTML

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
Posted: Feb 17 2008, 01:32 by Bob | Comments (0)
  • Currently 0/5 Stars.
  • 1
  • 2
  • 3
  • 4
  • 5
Filed under: FrontPage
Social Bookmarks: E-mail | Kick it! | DZone it! | del.icio.us

Access Macro: Export Table/Query To Excel

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
Posted: Feb 17 2008, 01:06 by Bob | Comments (0)
  • Currently 0/5 Stars.
  • 1
  • 2
  • 3
  • 4
  • 5
Filed under: Office
Social Bookmarks: E-mail | Kick it! | DZone it! | del.icio.us

Access: Database Schema Report

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!"
Posted: Feb 16 2008, 23:58 by Bob | Comments (0)
  • Currently 0/5 Stars.
  • 1
  • 2
  • 3
  • 4
  • 5
Filed under: Office
Social Bookmarks: E-mail | Kick it! | DZone it! | del.icio.us