vbAccelerator - Contents of code file: cVBProject.cls

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "cVBProject"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Private m_sFileName As String
Private m_sPath As String
Private m_sType As String
Private m_sStartup As String
Private m_sName As String

Private m_lMajorVer As Long
Private m_lMinorVer As Long
Private m_lRevisionVer As Long
Private m_lAutoIncrementVer As Long
Private m_lServerSupportFiles  As Long
Private m_sVersionCompanyName As String
Private m_sVersionComments As String
Private m_sVersionFileDescription As String
Private m_sVersionLegalCopyright As String
Private m_sVersionProductName As String

Private m_lCompilationType As Long
Private m_lOptimizationType  As Long
Private m_lFavorPentiumProtm As Long
Private m_lCodeViewDebugInfo As Long
Private m_lNoAliasing As Long
Private m_lBoundsCheck As Long
Private m_lOverflowCheck  As Long
Private m_lFlPointCheck As Long
Private m_lFDIVCheck As Long
Private m_lUnroundedFP As Long

Private m_lStartMode As Long
Private m_lUnattended As Long
Private m_lThreadPerObject As Long
Private m_lMaxNumberOfThreads As Long

Private m_sLines() As String
Private m_iLineCount As Long
Private Type tFileInfo
   sPath As String
   iType As EVBPFileTypes
   sGUID As String
   sDescription As String
   lMajor As Long
   lMinor As Long
   lRevision As Long
   iLine As Long
End Type
Private m_iCount As Long
Private m_tFile() As tFileInfo

Private m_bNoBaseLine As Boolean
Private m_sBaseLinePath As String

Private m_bStartup As Boolean

Private m_bFixPaths As Boolean

Public Property Get FixPaths() As Boolean
   FixPaths = m_bFixPaths
End Property
Public Property Let FixPaths(ByVal bState As Boolean)
   m_bFixPaths = bState
End Property

Public Sub Show( _
      lstThis As ListBox, _
      cODList As cSimpleODListBox, _
      cSysILS As cVBALSysImageList, _
      ByVal lBaseIndent As Long, _
      ByVal bShowFolders As Boolean _
   )
Dim i As Long
Dim iType As Long
Dim sE As String
Dim sS As String
Dim bFirst As Boolean
Dim lIndent As Long
Dim iPos As Long
Dim iIconIndex As Long
Dim sFilename As String

   sFilename = NormalizePath(ProjectPath) & ProjectFileName
   cODList.AddItem lstThis, m_sName & " (" & sFilename & ")" & vbTab &
    "<Project><Name>" & m_sName & "</Name><Filename>" & sFilename &
    "</Filename><Files>?</Files></Project>", cSysILS.ItemIndex("C:\Junk.VBP"),
    lBaseIndent
   For iType = 0 To 10
      bFirst = True
      lIndent = lBaseIndent + 1
      For i = 1 To m_iCount
         With m_tFile(i)
            If .iType = iType Then
               Select Case .iType
               Case evbpUserDocument
                  sE = ".dob"
                  sS = "UserDocuments"
               Case evbpUserControl
                  sE = ".ctl"
                  sS = "UserControls"
               Case evbpResourceFile
                  sE = ".res"
                  sS = "Resource Files"
               Case evbpPropertyPage
                  sE = ".pag"
                  sS = "Property Page"
               Case evbpRelatedFile
                  iPos = InstrRev(.sPath, ".")
                  If iPos > 0 Then
                     sE = Mid$(.sPath, iPos)
                  Else
                     sE = "/home/VB/Utilities/VBPZip/.txt"
                  End If
                  sS = "Related Files"
               Case evbpReference
                  sE = ".dll"
                  sS = "References"
               Case evbpModule
                  sE = ".bas"
                  sS = "Modules"
               Case evbpForm
                  sE = ".frm"
                  sS = "Forms"
               Case evbpControl
                  sE = ".ocx"
                  sS = "Components"
               Case evbpClass
                  sE = ".cls"
                  sS = "Classes"
               Case evbpBinary
                  iPos = InstrRev(.sPath, ".")
                  If iPos > 0 Then
                     sE = Mid$(.sPath, iPos)
                  End If
                  sS = "Project Binaries"
               End Select
               
               If bFirst And bShowFolders Then
                  cODList.AddItem lstThis, sS & vbTab & "<Null/>", 4, lIndent
                  lIndent = lIndent + 1
                  bFirst = False
                  lstThis.Selected(lstThis.NewIndex) =
                   g_cFileTypes.IncludeInZip(iType)
               End If
               If .iType = evbpBinary Then
                  iIconIndex = cSysILS.ItemIndex(.sPath, True)
               Else
                  iIconIndex = cSysILS.ItemIndex("C:\Junk" & sE)
               End If
               If .iType = evbpControl Then
                  cODList.AddItem lstThis, .sPath & " " & .sGUID & vbTab &
                   "<File><ID>" & i & "</ID></File>", iIconIndex, lIndent
               Else
                  cODList.AddItem lstThis, .sDescription & "(" & .sPath & ")" &
                   vbTab & "<File><ID>" & i & "</ID></File>", iIconIndex,
                   lIndent
               End If
               lstThis.Selected(lstThis.NewIndex) =
                g_cFileTypes.IncludeInZip(iType)
            End If
         End With
      Next i
   Next iType
End Sub


Public Sub Load(ByVal sPath As String, ByVal sFile As String, ByVal bStartup As
 Boolean)
Dim sFullPath As String
Dim sText As String
Dim sThis As String
Dim sItem As String
Dim sType As String
Dim sExeName As String
Dim iExeLine As Long
Dim iPos As Long
Dim i As Long

   sPath = ReplaceSection(sPath, """", "")
   sFullPath = AddFileToPath(sPath, sFile)
   
   ' Need to re-extract path & file from the fullpath, because sFile
   ' might have contained ..\ etc:
   iPos = InstrRev(sFullPath, "\")
   sPath = Left$(sFullPath, iPos - 1)
   sFile = Mid$(sFullPath, iPos + 1)
   
   m_bStartup = bStartup
   m_bNoBaseLine = True
   m_sBaseLinePath = ""
   m_iCount = 0
   Erase m_tFile
   m_sPath = sPath
   m_sFileName = sFile
   
   If ReadFileText(sFullPath, sText) Then
      Dim cS As New cSplitString
      cS.TheString = sText
      cS.Splitter(1) = vbCrLf
      cS.Splitter(2) = "="
      Do
         sThis = cS.NextItem
         If cS.SplitItem = 2 Then
            sType = sThis
         Else
            sItem = sThis
            
            m_iLineCount = m_iLineCount + 1
            ReDim Preserve m_sLines(1 To m_iLineCount) As String
            m_sLines(m_iLineCount) = sType & "=" & sItem
            
            Select Case Trim$(sType)
            Case "Type"
               m_sType = sItem
            Case "Startup"
               m_sStartup = sItem
            Case "Name"
               m_sName = sItem
            Case "MajorVer"
               m_lMajorVer = sItem
            Case "MinorVer"
               m_lMinorVer = sItem
            Case "RevisionVer"
               m_lRevisionVer = sItem
            Case "AutoIncrementVer"
               m_lAutoIncrementVer = sItem
            Case "ServerSupportFiles"
               m_lServerSupportFiles = sItem
            Case "VersionCompanyName"
               m_sVersionCompanyName = sItem
            Case "VersionComments"
               m_sVersionComments = sItem
            Case "VersionFileDescription"
               m_sVersionFileDescription = sItem
            Case "VersionLegalCopyright"
               m_sVersionLegalCopyright = sItem
            Case "VersionProductName"
               m_sVersionProductName = sItem
            Case "CompilationType"
               m_lCompilationType = sItem
            Case "OptimizationType"
               m_lOptimizationType = sItem
            Case "FavorPentiumPro(tm)"
               m_lFavorPentiumProtm = sItem
            Case "CodeViewDebugInfo"
               m_lCodeViewDebugInfo = sItem
            Case "NoAliasing"
               m_lNoAliasing = sItem
            Case "BoundsCheck"
               m_lBoundsCheck = sItem
            Case "OverflowCheck"
               m_lOverflowCheck = sItem
            Case "FlPointCheck"
               m_lFlPointCheck = sItem
            Case "FDIVCheck"
               m_lFDIVCheck = sItem
            Case "UnroundedFP"
               m_lUnroundedFP = sItem
            
            Case "StartMode"
               m_lStartMode = sItem
            Case "Unattended"
               m_lUnattended = sItem
            Case "ThreadPerObject"
               m_lThreadPerObject = sItem
            Case "MaxNumberOfThreads"
               'm_lMaxNumberOfThreads = sItem
               
            Case "Module"
               pAddFile sItem, evbpModule, m_iLineCount
            Case "Class"
               pAddFile sItem, evbpClass, m_iLineCount
            Case "Reference"
               pAddFile sItem, evbpReference, m_iLineCount
            Case "Form"
               pAddFile sItem, evbpForm, m_iLineCount
            Case "Object"
               pAddFile sItem, evbpControl, m_iLineCount
            Case "UserControl"
               pAddFile sItem, evbpUserControl, m_iLineCount
            Case "PropertyPage"
               pAddFile sItem, evbpPropertyPage, m_iLineCount
            Case "UserDocument"
               pAddFile sItem, evbpUserDocument, m_iLineCount
            Case "ResFile32"
               pAddFile sItem, evbpResourceFile, m_iLineCount
            Case "RelatedDoc"
               pAddFile sItem, evbpRelatedFile, m_iLineCount
               
            Case "ExeName32"
               sExeName = sItem
               iExeLine = m_iLineCount
            Case "Path32"
               sExeName = NormalizePath(sItem) & sExeName
               pAddFile sExeName, evbpBinary, m_iLineCount
               sExeName = ""
            End Select
            
         End If
      Loop While cS.More
      
      If Not sExeName = "" Then
         pAddFile sExeName, evbpBinary, iExeLine
      End If
      
      If m_bFixPaths Then
         sText = ""
         For i = 1 To m_iLineCount
            If i > 1 Then
               sText = sText & vbCrLf
            End If
            sText = sText & m_sLines(i)
         Next i
         ReplaceFileText sFullPath, sText
      End If
      
      
   End If
End Sub
Private Sub pAddFile(ByVal sItem As String, ByVal eType As EVBPFileTypes, ByVal
 iLine As Long)
Dim sFile As String
Dim iPos As Long
Dim sBit As String
Dim iCP As Long
Dim sNum As String
Dim sRelPath As String
   m_iCount = m_iCount + 1
   ReDim Preserve m_tFile(1 To m_iCount) As tFileInfo
   With m_tFile(m_iCount)
      .iType = eType
      .iLine = iLine
      Select Case eType
      Case evbpClass, evbpModule
         iPos = InStr(sItem, "; ")
         If iPos > 0 Then
            .sDescription = Left$(sItem, iPos - 1)
            .sPath = AddFileToPath(m_sPath, ReplaceSection(Mid$(sItem, iPos +
             2), """", ""))
            sRelPath = RelativePath(m_sPath, .sPath)
         Else
            .sPath = AddFileToPath(m_sPath, ReplaceSection(sItem, """", ""))
            sRelPath = RelativePath(m_sPath, .sPath)
         End If
         Debug.Print
         If InStr(sRelPath, " ") Then sRelPath = """" & sRelPath & """"
         iPos = InStr(m_sLines(iLine), "=")
         m_sLines(iLine) = Left$(m_sLines(iLine), iPos) & .sDescription & "; "
          & sRelPath
         Debug.Print
      Case evbpForm, evbpResourceFile, evbpRelatedFile, evbpUserControl,
       evbpBinary, evbpPropertyPage
         .sPath = AddFileToPath(m_sPath, ReplaceSection(sItem, """", ""))
         sRelPath = RelativePath(m_sPath, .sPath)
         iPos = InStr(m_sLines(iLine), "=")
         If InStr(sRelPath, " ") Then sRelPath = """" & sRelPath & """"
         If Left$(m_sLines(iLine), iPos) = "Path32=" Then
            iPos = InstrRev(sRelPath, "\")
            If iPos > 0 Then
               m_sLines(iLine) = "Path32=" & Left$(sRelPath, iPos - 1)
            Else
               m_sLines(iLine) = "Path32="
            End If
         Else
            m_sLines(iLine) = Left$(m_sLines(iLine), iPos) & sRelPath
         End If
         Debug.Print
      Case evbpReference
         Dim cS As New cSplitString
         cS.TheString = sItem
         cS.Splitter = "#"
         Do
            sBit = cS.NextItem
            iPos = iPos + 1
            Select Case iPos
            Case 1
               ' GUID:
               iCP = InStr(sBit, "*\G")
               If iCP > 0 Then
                  .sGUID = Mid$(sBit, iCP + 3)
               Else
                  .sGUID = sBit
               End If
            Case 2
               ' Major . Minor
               On Error Resume Next
               iCP = InStr(sBit, ".")
               If iCP > 0 Then
                  sNum = Left$(sBit, iCP - 1)
                  If Asc(sNum) > 65 Then
                     .lMajor = Asc(sNum) - Asc("A") + 10
                  Else
                     .lMajor = sNum
                  End If
                  sNum = Mid$(sBit, iCP + 1)
                  If Asc(sNum) > 65 Then
                     .lMinor = Asc(sNum) - Asc("A") + 10
                  Else
                     .lMinor = sNum
                  End If
               Else
                  .lMajor = sBit
               End If
               Err.Clear
            Case 3
               ' Revision
               .lRevision = sBit
            Case 4
               ' Path
               .sPath = AddFileToPath(m_sPath, ReplaceSection(sBit, """", ""))
               sRelPath = RelativePath(m_sPath, .sPath)
            Case 5
               ' Description
               .sDescription = sBit
            End Select
         Loop While cS.More
         
      Case evbpControl
         '
         cS.TheString = sItem
         cS.Splitter = "#"
         Do
            sBit = cS.NextItem
            iPos = iPos + 1
            Select Case iPos
            Case 1
               ' GUID:
               .sGUID = sBit
            Case 2
               ' Major . Minor
               iCP = InStr(sBit, ".")
               If iCP > 0 Then
                  .lMajor = Left$(sBit, iCP - 1)
                  .lMinor = Mid$(sBit, iCP + 1)
               Else
                  .lMajor = sBit
               End If
            Case 3
               ' Revision
               iCP = InStr(sBit, ";")
               If iCP > 0 Then
                  .lRevision = Left$(sBit, iCP - 1)
                  .sPath = Trim$(Mid$(sBit, iCP + 1))
               Else
                   '?
               End If
            End Select
         Loop While cS.More
      End Select
   End With
End Sub

Private Sub pSetBaseLinePath(ByVal sPath As String)
Dim iPos As Long
Dim sThisPath As String
   iPos = InstrRev(sPath, "\")
   sThisPath = Left$(sThisPath, iPos - 1)
   If m_bNoBaseLine Then
      m_sBaseLinePath = sThisPath
   Else
      If InStr(m_sBaseLinePath, sPath) Then
         m_sBaseLinePath = sPath
      Else
         Do
            iPos = InstrRev(m_sBaseLinePath, "\")
            If iPos > 0 Then
               m_sBaseLinePath = Left$(m_sBaseLinePath, iPos - 1)
               If InStr(m_sBaseLinePath, sPath) Then
                  m_sBaseLinePath = sPath
                  Exit Do
               End If
            Else
               m_sBaseLinePath = ""
               Exit Do
            End If
         Loop
      End If
   End If
End Sub

Public Property Get ProjectPath() As String
   ProjectPath = m_sPath
End Property
Public Property Get ProjectFileName() As String
   ProjectFileName = m_sFileName
End Property
Public Property Get ProjectName() As String
   ProjectName = m_sName
End Property
Public Property Get FileCount() As Long
   FileCount = m_iCount
End Property
Public Property Get FilePath(ByVal nIndex As Long) As String
   FilePath = m_tFile(nIndex).sPath
End Property
Public Property Get FileDescription(ByVal nIndex As Long) As String
   FileDescription = m_tFile(nIndex).sDescription
End Property
Public Property Get FileGUID(ByVal nIndex As Long) As String
   FileGUID = m_tFile(nIndex).sGUID
End Property
Public Property Get FileType(ByVal nIndex As Long) As EVBPFileTypes
   FileType = m_tFile(nIndex).iType
End Property
Public Property Get FileMajorVer(ByVal nIndex As Long) As Long
   FileMajorVer = m_tFile(nIndex).lMajor
End Property
Public Property Get FileMinorVer(ByVal nIndex As Long) As Long
   FileMinorVer = m_tFile(nIndex).lMinor
End Property
Public Property Get FileRevisionVer(ByVal nIndex As Long) As Long
   FileRevisionVer = m_tFile(nIndex).lRevision
End Property
Public Property Get BaseLinePath() As String
   BaseLinePath = m_sBaseLinePath
End Property
Public Sub Zip( _
      cZ As cZip _
   )
Dim i As Long
Dim bStore As Boolean
   cZ.AddFileSpec AddFileToPath(ProjectPath, ProjectFileName)
   For i = 1 To m_iCount
      If g_cFileTypes.IncludeInZip(m_tFile(i).iType) Then
         If m_tFile(i).iType = evbpForm Or m_tFile(i).iType = evbpUserControl
          Then
            ' need to check for frx/ctx
            cZ.AddFileSpec Left$(FilePath(i), Len(FilePath(i)) - 1) & "*"
         ElseIf m_tFile(i).iType = evbpPropertyPage Then
            ' why, why, why..
            cZ.AddFileSpec FilePath(i)
            If (FileExists(Left$(FilePath(i), Len(FilePath(i)) - 2) & "gx"))
             Then
               cZ.AddFileSpec Left$(FilePath(i), Len(FilePath(i)) - 2) & "gx"
            End If
         Else
            cZ.AddFileSpec FilePath(i)
         End If
      End If
   Next i
End Sub