'
' FIX2TD.TXT
'
' Version 1.0
' Released 5/6/94
'
' Copyright 1994 Stephen Schmidt
' All Rights Reserved
'
' OVERVIEW:
'    Applies the Table-related Table Datasheet properties from Access V1.x
'    databases to the corresponding Access V2 databases.  These properties
'    such as the RowHeight, FontName, and others are not converted properly
'    by the Access V2 Convert Database command.
'
' INSTRUCTIONS:
'    Create a new Access V2 database.  Load this text file into a new Module
'    in that new database, open the Immediate Window, then type RUN {Enter}.
'
' NOTES:
'    Your V1 databases are opened in read-only mode; but as a precaution, you
'    should backup your V2 databases before using this program.
'
'    The functions in this module properly salvaged all of the missing Table
'    Datasheet properties from my Access Version 1.1 databases; but, because
'    of the algorithm used, I cannot be sure that it will salvage all of the
'    settings from your databases.
'
'    There seems to be a problem setting the DatasheetFontName for a table's
'    datasheet using Access V2.  For each of those tables whose datasheet
'    is not based on the Default font, you will have to open the table's
'    datasheet, select the Format menu Font command, then press OK to have
'    the new settings take effect.
'
' CONTACT:
'    Send comments to Stephen Schmidt via E-mail:
'       CompuServe: 73200,3207
'       Internet:   73200.3207@compuserve.com
'    Do not send me messages via the CompuServe MSACCESS forum, because I do
'    not follow the messages that are posted there.
'
'                            DISCLAIMER OF WARRANTY
' THIS SOFTWARE (INCLUDING INSTRUCTIONS FOR ITS USE) IS PROVIDED "AS IS"
' WITHOUT WARRANTY OF ANY KIND.  STEPHEN SCHMIDT FURTHER DISCLAIMS ALL
' IMPLIED WARRANTIES INCLUDING WITHOUT LIMITATION ANY IMPLIED WARRANTIES OF
' MERCHANTABILITY OR OF FITNESS FOR A PARTICULAR PURPOSE.  THE ENTIRE RISK
' ARISING OUT OF THE USE OR PERFORMANCE OF THIS SOFTWARE AND DOCUMENTATION
' REMAINS WITH YOU.
'
' IN NO EVENT SHALL STEPHEN SCHMIDT, OR ANYONE ELSE INVOLVED IN THE CREATION,
' PRODUCTION, OR DELIVERY OF THIS SOFTWARE BE LIABLE FOR ANY DAMAGES
' WHATSOEVER (INCLUDING, WITHOUT LIMITATION, DAMAGES FOR LOSS OF BUSINESS
' PROFITS, BUSINESS INTERRUPTION, LOSS OF BUSINESS INFORMATION, OR OTHER
' PECUNIARY LOSS) ARISING OUT OF THE USE OR INABILITY TO USE THIS SOFTWARE OR
' DOCUMENTATION, EVEN IF STEPHEN SCHMIDT HAS BEEN ADVISED OF THE POSSIBILITY
' OF SUCH DAMAGES.
'
Option Compare Database   'Use database order for string comparisons
Option Explicit

Type STIStringType
    S As String * 2
End Type

Type STIIntegerType
    I As Integer
End Type

Private Sub run ()
    SalvageTableDatasheetSettings
End Sub

Private Sub SalvageTableDatasheetSettings ()
    Const FnName = "Salvage Table Datasheet Settings"

    Dim DfltGridLines As Integer
    Dim DfltFontName As String
    Dim DfltFontItalic As Integer
    Dim DfltFontUnderline As Integer
    
    DfltGridLines = Application.GetOption("Default Gridlines Behavior")
    DfltFontName = Application.GetOption("Default Font Name")
    DfltFontItalic = Application.GetOption("Default Font Italic")
    DfltFontUnderline = Application.GetOption("Default Font Underline")

    MsgBox "Access V2 'Datasheet' Category Options must be set to match those of Access V1!  If they are not, press Esc to Cancel at the next InputBox."

    Dim V1DbDir As String
    V1DbDir = InputBox("Directory containing V1 MDBs:", FnName, "i:\tmp\")
    If V1DbDir = "" Then Beep: Exit Sub

    Dim V2DbDir As String
    V2DbDir = InputBox("Directory containing V2 MDBs:", FnName, "i:\v2\")
    If V2DbDir = "" Then Beep: Exit Sub

    Dim V2DbPatt As String
    V2DbPatt = InputBox("File pattern for V2 MDBs:", FnName, "*.mdb")
    If V2DbPatt = "" Then Beep: Exit Sub

    ' Get a list of the MDBs to process.
    Dim DbFiles() As String
    ReDim DbFiles(0 To 1024)
    Dim NumDbFiles As Integer
    NumDbFiles = 0
    Dim CurFile As String
    CurFile = Dir$(V2DbDir & V2DbPatt)
    Do Until CurFile = ""
	NumDbFiles = NumDbFiles + 1
	DbFiles(NumDbFiles) = CurFile
	CurFile = Dir$
    Loop

    ' Process each of the MDBs in the list.
    Do Until NumDbFiles <= 0
	Dim CurDbName As String
	CurDbName = DbFiles(NumDbFiles)
	
	Debug.Print

	If Dir$(V1DbDir & CurDbName) = "" Then
	    Debug.Print "WARNING: VERSION 1 DATABASE " & CurDbName & " NOT FOUND"
	    Beep
	    GoTo NextDb
	End If

	Debug.Print "Database " & DbFiles(NumDbFiles)

	Dim V1Db As Database
	Set V1Db = OpenDatabase(V1DbDir & CurDbName, False, True)

	Dim V2Db As Database
	Set V2Db = OpenDatabase(V2DbDir & CurDbName, False, False)

	Dim V1Tab As Dynaset
	Set V1Tab = V1Db.CreateDynaset("select Name, LvExtra from MSysObjects where Type = -32760 order by Name;")

	' Process each of the Table Datasheet definitions.
	Do Until V1Tab.EOF
	    Debug.Print "   Table " & V1Tab!Name

	    On Error Resume Next
	    Dim V2TD As TableDef
	    Set V2TD = V2Db.TableDefs(V1Tab!Name)
	    If Err <> 0 Then
		On Error GoTo 0
		Debug.Print "   WARNING: TABLE " & V1Tab!Name & " DOES NOT EXIST IN V2 DATABASE!"
		Beep
	    Else ' Table exists in both old and new MDBs.
		On Error GoTo 0

		Dim LvExtra As String
		LvExtra = V1Tab!LvExtra


		Do Until LvExtra = ""
		    Select Case Asc(Left$(LvExtra, 1))
			Case 3 ' Record Header
			    Strip LvExtra, 10

			Case 7 ' Font Italic
			    Debug.Print "      DatasheetFontItalic"
			    SetTableDefProperty V2TD, "DatasheetFontItalic", 1, Not DfltFontItalic
			    Strip LvExtra, 1
	
			Case 8 ' Font Underline
			    Debug.Print "      DatasheetFontUnderline"
			    SetTableDefProperty V2TD, "DatasheetFontUnderline", 1, Not DfltFontUnderline
			    Strip LvExtra, 1
	
			Case 9 ' GridLines
			    Debug.Print "      ShowGrid"
			    SetTableDefProperty V2TD, "ShowGrid", 1, Not DfltGridLines
			    Strip LvExtra, 1
	
			Case 54, 56 ' Unknown
			    Strip LvExtra, 2

			Case 97, 98, 99, 103, 105, 107 ' Unknown
			    Strip LvExtra, 3
			
			Case 100 ' Row Height
			    Debug.Print "      RowHeight"
			    SetTableDefProperty V2TD, "RowHeight", 3, StringToInt(Mid$(LvExtra, 2, 2))
			    Strip LvExtra, 3

			Case 101 ' Font Size
			    Debug.Print "      DatasheetFontHeight"
			    SetTableDefProperty V2TD, "DatasheetFontHeight", 3, StringToInt(Mid$(LvExtra, 2, 2))
			    Strip LvExtra, 3
			
			Case 102 ' Font Weight
			    Debug.Print "      DatasheetFontWeight"
			    SetTableDefProperty V2TD, "DatasheetFontWeight", 3, StringToInt(Mid$(LvExtra, 2, 2))
			    Strip LvExtra, 3

			Case 108 ' Frozen Columns
			    Debug.Print "      FrozenColumns"
			    SetTableDefProperty V2TD, "FrozenColumns", 3, StringToInt(Mid$(LvExtra, 2, 2)) - 1
			    Strip LvExtra, 3

			Case 220 ' Table Name
			    StripString LvExtra

			Case 231 ' Font Name
			    Dim FontName As String
			    FontName = Mid$(LvExtra, 3, Asc(Mid$(LvExtra, 2, 1)))
			    If FontName <> DfltFontName Then
				Debug.Print "      DatasheetFontName"
				SetTableDefProperty V2TD, "DatasheetFontName", 9, FontName
			    End If
			    StripString LvExtra
	
			Case 232 ' Table Description
			    Debug.Print "      Description"
			    SetTableDefProperty V2TD, "Description", 10, Mid$(LvExtra, 3, Asc(Mid$(LvExtra, 2, 1)))
			    StripString LvExtra

			Case Else
			    If Asc(Left$(LvExtra, 1)) <> 254 Then
				Debug.Print "ERROR: TOKEN #" & Asc(Left$(LvExtra, 1)) & " UNKNOWN--SKIPPING REST OF TABLE."
				Beep
			    End If

			    Exit Do
		    End Select
		Loop ' Until LvExtra = ""
	    End If ' V2 Table Exists

	    V1Tab.MoveNext
	Loop ' Until V1Tab.EOF

	V1Tab.Close

	V2Db.Close
	V1Db.Close

NextDb:
	NumDbFiles = NumDbFiles - 1
    Loop ' Until NumDbFiles <= 0

    Beep: Beep: Beep
End Sub

Private Sub SetTableDefProperty (MyTableDef As TableDef, PropertyName As String, PropertyType As Integer, PropertyValue As Variant)
    Const ERR_PROPERTY_NONEXISTENT = 3270

    On Error Resume Next    ' Function handles errors.
    MyTableDef.properties(PropertyName) = PropertyValue

    If Err = ERR_PROPERTY_NONEXISTENT Then
	On Error GoTo 0
	' Create Property object, setting its Name, Type, and Value properties.
	Dim MyProperty As Property
	Set MyProperty = MyTableDef.CreateProperty(PropertyName, PropertyType, PropertyValue)
	MyTableDef.properties.Append MyProperty
    Else
	On Error GoTo 0
    End If
End Sub

Private Function StringToInt (ByVal TwoByteInteger As String) As Integer
    Dim S As STIStringType
    S.S = Left$(TwoByteInteger & Space$(2), 2)

    Dim I As STIIntegerType
    LSet I = S

    StringToInt = I.I
End Function

Private Sub Strip (FromString As String, ByVal NumChars As Integer)
    ' Strip up to NumChars characters from the left of the string.

    If Len(FromString) <= NumChars Then
	FromString = ""
    Else
	FromString = Right$(FromString, Len(FromString) - NumChars)
    End If
End Sub

Private Sub StripString (CurrentStream As String)
    Strip CurrentStream, Asc(Mid$(CurrentStream, 2, 1)) + 2
End Sub

