Attribute VB_Name = "modMain"
'--------------------------------
' Acknowledgements:
' - For registry layout as it pertains to typelibs, clsids, etc.,
' see: http://www.visibleprogress.com/vb_binary_compatibility.htm
' - for tutorial on how to examine a typelib
' see: http://msdn.microsoft.com/msdnmag/issues/1200/TypeLib/default.aspx
' - OLE View in VS tools File|ViewTypelib
' - http://www.devx.com/vb2themax/Article/19830/0/page/2
' - http://www.visualbasicforum.com/showthread.php?t=129504
' - OnErr0r, Obsessive OPtimizer, Super Moderator
' - http://www.visualbasicforum.com
' - http://www.cpcug.org/user/clemenzi/technical/WinExplorer/WinExplorerEditFlags.htm
' - http://msdn.microsoft.com/library/default.asp?url=/library/en-us/automat/htm/chap9_1axu.asp
'----------------------------------------
'
'TOD:
' - Remove FSO
' - Add option to display just the fixed references.
' Notes:
' - Use the GUID to look up the typelib in HKCR/typelib
' - use the win32 subkey to get the path to the typelib or dll
' - the default value of the version key is the friendly name.
' - under the typelib key there are version keys.
'-----------------------------------------------------
Option Explicit
Private moFS As FileSystemObject
Private Const msWINDOW_TITLE As String = "VB Reference Fixer"
Private mbUnFixable As Boolean
' Keep each section in alphabetical order to make hints easy.
Public Enum enumOptions
eRunInvisible = 1 ' lets us make sure that zero is detectable as invalid
eRunMinimized = 2
eRunRestored = 4
eShowAsSoonAs
eShowIfUnfixable
eShowRegardless
eShowNever
End Enum
Public Enum enumErrorCodes
MissingClosingQuotationMark
ExpectedOpeningCurlyBracket
End Enum
'-----------------
' Option names for config file
'----------------------
Private Const msOPTION_RUN As String = "run"
Private Const msOPTION_SHOW As String = "show"
'-----------------------------
' Option values read from config or set by setup dialog
'-----------------------------
Public glRunOption As Long
Public glShowOption As Long
'---------------------------------------------------------------------
'expects a single argument that is a folder name, vbp name of vbg name
'---------------------------------------------------------------------
Public Sub Main()
If LenB(Trim$(Command$)) = 0 Then
xInstall
Else
xRunCommandLine
End If
End Sub
'---------------------------------------------------------------------
' Command line is:
' option option file-or-folder
' Options are Unix style -x where x is a letter. file-or-folder is simply the last item
' on the command line and may include spaces if it is quoted with double quotes.
'---------------------------------------------------------------------
Private Sub xRunCommandLine()
Set moFS = New FileSystemObject
xLoadOptions
Dim sCmdLine As String
sCmdLine = Trim$(Command$)
Dim sSource As String
Dim sToken As String
Do While LenB(sCmdLine)
sToken = GetToken(sCmdLine)
If Left$(sToken, 1) = "-" Then
Select Case sToken
Case "-s"
' show setup
frmSetup.Show 1
Exit Sub
Case "-u"
' unregister context menu
Exit Sub
Case Else
' TODO: raise error unrecognized token
End Select
Else
' must be source
sSource = sToken
End If
Loop
' Something to do
xRun sSource
End Sub
'---------------------------------------------------------------------
'---------------------------------------------------------------------
Private Sub xRun(ByRef sSource As String)
frmProgress.Caption = msWINDOW_TITLE
If (moFS.FileExists(sSource)) Then
xQShowProgress
xProcessVBFile sSource
xShow "Finished file scan"
ElseIf (moFS.FolderExists(sSource)) Then
xQShowProgress
xProcessFolder sSource
xShow "Finished folder scan"
End If
If (glShowOption = eShowRegardless) _
Or ((glShowOption = eShowIfUnfixable) And mbUnFixable) Then
frmProgress.Show
frmProgress.WindowState = vbNormal
Else
Unload frmProgress
End If
End Sub
'--------------------------------------------------------------------
'expects a single argument that is a vbp name or vbg name Ignores all
'other files.
'--------------------------------------------------------------------
Private Sub xProcessVBFile(ByRef rsFileName As String)
If rsFileName Like "*.vbp" Then
xProcessVBP rsFileName
ElseIf rsFileName Like "*.vbg" Then
xProcessVBG rsFileName
End If
End Sub
'--------------------------------------------------------------------
'read the VBP and fix all the references in it
'--------------------------------------------------------------------
Private Sub xProcessVBP(ByRef rsVBPPath As String)
If FileExists(rsVBPPath) Then
' ignore non-existent files
Dim bNeedToReWrite As Boolean ' true if VBP must be rewritten
Dim sVBP As String ' content of file
xShow "Processing VBP: " & rsVBPPath
With moFS.OpenTextFile(rsVBPPath, ForReading, False)
Dim aLines As Variant
sVBP = .ReadAll
aLines = Split(sVBP, vbCrLf)
End With
Dim lX As Long
For lX = LBound(aLines) To UBound(aLines)
Dim aLine As Variant
aLine = Split(aLines(lX), "=")
If UBound(aLine) >= 1 Then
' xshow aLine(0), aLine(1)
If aLine(0) = "Reference" Then
''' xShow (aLine(1))
If Not (xReferenceIsValid((aLine(1)))) Then
Dim sFixedReference As String
sFixedReference = xFixedReference((aLine(1)), rsVBPPath)
If (sFixedReference <> "") Then
' if empty then failed to get a good reference
xShow "Rewriting from " & aLine(1)
xShow "Rewriting to " & sFixedReference
bNeedToReWrite = True
sVBP = Replace(sVBP, aLine(1), sFixedReference)
Else
xShow "Failed to fix reference:" & vbCrLf & " " & aLine(1)
End If
End If
End If
End If
Next lX
If bNeedToReWrite Then
xShow "Rewriting <" & rsVBPPath & ">"
WriteFile rsVBPPath, sVBP, True
Else
xShow "References are valid"
End If
End If
End Sub
'--------------------------------------------------------------------
'Look up the reference to see if it is valid. must distinguish
'between DLL/typelib references and project references. If th GUI is
'found then look up the version
'--------------------------------------------------------------------
Private Function xReferenceIsValid(ByRef rsReference As String) As Boolean
Dim aReference As Variant
aReference = Split(rsReference, "#")
If UBound(aReference) = 0 Then
' project reference. Can't fix it so pretend it is alright
xShow "Cannot fix reference: " & aReference(0)
xReferenceIsValid = True
Else
xReferenceIsValid = RegistryKeyExists(HKEY_CLASSES_ROOT, _
"TypeLib\{" _
& Mid$(aReference(0), 5, _
Len(aReference(0)) - 5) & "}\" & aReference(1))
End If
End Function
'-----------------------------------------------------------------
'Open the typelib to extrac the reference information.
'-----------------------------------------------------------------
Private Function xFixedReference(ByRef rsReference As String, _
ByRef rsVBPFileName As String) As String
Dim aReference As Variant
aReference = Split(rsReference, "#")
Dim lRetValue As Long ' result of API call. Must be zero for success
Dim sExpectedTypeLibPath As String
sExpectedTypeLibPath = aReference(3)
With moFS
ChDrive rsVBPFileName
ChDir GetParentFolderName(rsVBPFileName)
sExpectedTypeLibPath = GetAbsolutePathName(sExpectedTypeLibPath)
' xshow "sExpectedTypeLibPath", sExpectedTypeLibPath
End With
' look up the guid in the typelib/dll
Dim oTypeLib As cTypeLib ' TODO: make global to reduce overheads
Set oTypeLib = New cTypeLib
With oTypeLib
If .RegisterTypeLibrary(sExpectedTypeLibPath, True) Then
' look up details in the type lib. Also register type lib as
' this could be the reason for not finding it.
xShow .tlbGuid & "/" & .tlbName & "/" & .tlbRegister & "/" & .tlbVersion
If "*\G" & .tlbGuid = aReference(0) Then
End If
xFixedReference = "*\G" & .tlbGuid & "#" _
& .tlbVersion & "#0#" _
& sExpectedTypeLibPath & "#" _
& .tlbName
End If
End With
End Function
'-----------------------------------------------------------------
'read the VBG and call xProcessVBP for each VBP mentioned.
'-----------------------------------------------------------------
Private Sub xProcessVBG(ByRef rsVBGPath As String)
xShow "Processing VBG: " & rsVBGPath
With moFS.OpenTextFile(rsVBGPath, ForReading, False)
Dim aLine As Variant
Do While Not .AtEndOfStream
aLine = Split(.ReadLine, "=")
If UBound(aLine) = 1 Then
If aLine(0) Like "*Project" Then
With moFS
xProcessVBP .BuildPath(.GetParentFolderName(rsVBGPath), aLine(1))
End With
End If
End If
Loop
End With
xShow "Finished Processing VBG <" & rsVBGPath & ">"
End Sub
'-----------------------------------------------------------------
'read the folder and call xProcessVBP or xProcessVBG for each such
'file. Processes all sub folders
'-----------------------------------------------------------------
Private Sub xProcessFolder(ByRef rsFolderpath As String)
xShow "Processing folder: " & rsFolderpath
DoEvents
With moFS
Dim ofile As File
For Each ofile In .GetFolder(rsFolderpath).Files
xProcessVBFile ofile.Path
Next ofile
Dim oFolder As Folder
For Each oFolder In .GetFolder(rsFolderpath).SubFolders
xProcessFolder oFolder.Path
Next oFolder
End With
End Sub
'---------------------------------------------------------------------
'
'--------------------------------------------------------------------
Private Function xIsFolderName(ByRef rsFoldername As String) As Boolean
''' xIsFolderName = moFS.FolderExists(rsFoldername)
xIsFolderName = FolderExists(rsFoldername)
End Function
'-----------------------------------------------------------------
'Show a string in the progress window
'-----------------------------------------------------------------
Private Sub xShow(ByRef rsLine As String)
With frmProgress.txtProgress
Dim s As String
s = .Text
s = s & vbCrLf & rsLine
If Len(s) > 30000 Then
.Text = Mid$(s, Len(s) - 30000)
Else
.Text = s
End If
.SelStart = Len(.Text)
End With
End Sub
'---------------------------------------------------------------------
'
'--------------------------------------------------------------------
Public Sub SaveOptions()
WriteFile xOptionsPath, xCollectOptions, False
End Sub
'---------------------------------------------------------------------
'
'--------------------------------------------------------------------
Private Function xOptionsPath() As String
xOptionsPath = Environ$("USERPROFILE") & "\." & App.EXEName
End Function
'---------------------------------------------------------------------
'
'--------------------------------------------------------------------
Private Function xCollectOptions() As String
xCollectOptions = msOPTION_RUN & "=" & glRunOption & vbCrLf _
& msOPTION_SHOW & "=" & glShowOption & vbCrLf
End Function
'---------------------------------------------------------------------
'--------------------------------------------------------------------
Private Sub xLoadOptions()
'set defaults
glRunOption = eRunInvisible
glShowOption = eShowAsSoonAs
Dim oOptions As Dictionary
With moFS
If .FileExists(xOptionsPath) Then
Set oOptions = New Dictionary
oOptions.CompareMode = TextCompare
Dim sOptions As String
With .OpenTextFile(xOptionsPath, ForReading, True)
If Not .AtEndOfStream Then
Dim vOption As Variant
For Each vOption In Split(Trim$(.ReadAll), vbCrLf)
If LenB(vOption) Then
Dim aOption As Variant
aOption = Split(Trim$(vOption), "=")
If UBound(aOption) = 1 Then
Dim sOptionName As String
Dim sOptionValue As String
sOptionName = Trim$(aOption(0))
sOptionValue = Trim$(aOption(1))
If LenB(sOptionName) Then
oOptions(sOptionName) = sOptionValue
End If
End If
End If
Next vOption
End If
End With
Else
End If
End With
glRunOption = oOptions(msOPTION_RUN)
glShowOption = oOptions(msOPTION_SHOW)
If glRunOption = 0 Then
' No options file so show setup
frmSetup.Show 1
End If
End Sub
'---------------------------------------------------------------------
'
'--------------------------------------------------------------------
Private Sub xQShowProgress()
If glRunOption And (eRunRestored Or eRunMinimized) Then
frmProgress.Show
If glRunOption = eRunMinimized Then
frmProgress.WindowState = vbMinimized
Else
frmProgress.WindowState = vbNormal
End If
End If
End Sub
'---------------------------------------------------------------------
'Install the registry keys to add this to the Windows Explorer context
'menu
'Find the entry for the VBP and VBG file extensions. Then add keys to
'the shell sub key.
'---------------------------------------------------------------------
Private Sub xInstall()
Dim sEXEPath As String
sEXEPath = App.Path & "\" & App.EXEName & ".exe"
xCreateAndSet "\VisualBasic.Project\shell\VB Fix References\command", _
"", sEXEPath & " ""%1"""
xCreateAndSet "\VisualBasic.Project\shell\VB Fix References Setup\command", _
"", sEXEPath & " -s"
xCreateAndSet "\VisualBasic.ProjectGroup\shell\VB Fix References\command", _
"", sEXEPath & " ""%1"""
xCreateAndSet "\VisualBasic.ProjectGroup\shell\VB Fix References Setup\command", _
"", sEXEPath & " -s"
xCreateAndSet "\Folder\shell\VB Fix References\command", _
"", sEXEPath & " ""%1"""
MsgBox "You can now run the VB Reference Fixer by right clicking on a VBP or VBG in Windows Explorer or on a folder", , msWINDOW_TITLE
End Sub