VBCommons/api/API_Project.cls

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "API_Project"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
' ================ Import / export code functionality =============
' Shared module version: 20220407
' Tested in:
' Depends on:
' Required reference: Scripting, VBIDE
Option Explicit

Private fso_ As Scripting.FileSystemObject
Private proj_ As VBIDE.VBProject

Private contents_ As Scripting.Dictionary
Private sharedContents_ As Scripting.Dictionary

Private sourceHome_ As String
Private importsHome_ As String

Private Sub Class_Initialize()
  Set fso_ = New Scripting.FileSystemObject
End Sub

Private Sub Class_Terminate()
  Call Detach
End Sub

Public Function Init(target As VBIDE.VBProject, Optional sImportsHome$ = "") As Boolean
  Init = target.Protection <> 1
  If Not Init Then
    Call MsgBox("Project code is protected, cannot acccess", vbCritical)
    Exit Function
  End If
  
  Set proj_ = target
  importsHome_ = sImportsHome
  
  Set contents_ = New Scripting.Dictionary
  Set sharedContents_ = New Scripting.Dictionary
End Function

Public Function Detach()
  Set proj_ = Nothing
  importsHome_ = ""
End Function

Public Function SetInternals(ByRef oContents As Scripting.Dictionary, _
                            ByRef oSharedCont As Scripting.Dictionary)
  Set contents_ = oContents
  Set sharedContents_ = oSharedCont
End Function

Public Function ExportSrcTo(sPath$)
  sourceHome_ = sPath
  Call PrepareFolders(contents_)
  Call InternalExport(contents_)
End Function

Public Function ExportShared()
  sourceHome_ = importsHome_
  Call PrepareFolders(sharedContents_)
  Call InternalExport(sharedContents_)
End Function

Public Function ImportSrcFrom(sPath$)
  sourceHome_ = sPath
  Call InternalImport(contents_)
End Function

Public Function ImportShared()
  sourceHome_ = importsHome_
  Call InternalImport(sharedContents_)
End Function

Public Function RemoveAll()
  Dim nItem&: nItem = 1
  Dim aComponent As VBIDE.VBComponent
  Do While nItem <= proj_.VBComponents.Count
    Set aComponent = proj_.VBComponents.Item(nItem)
    If aComponent.Type <> vbext_ct_Document Then
      If Not TryRemoving(aComponent) Then _
        nItem = nItem + 1
    Else
      nItem = nItem + 1
    End If
  Loop
End Function

Public Function AddItem(sName$, sFolder$)
  Call contents_.Add(sName, sFolder)
End Function

Public Function AddSharedItem(sName$, sFolder$)
  Call sharedContents_.Add(sName, sFolder)
End Function

Public Function ReloadFrom(sFile$) As Boolean
  ReloadFrom = False
  If fso_.FileExists(sFile) Then _
    ReloadFrom = TryImportFile(fso_.GetFile(sFile))
End Function

' =========
Private Function PrepareFolders(target As Scripting.Dictionary)
  Call ProjEnsureFolderExists(sourceHome_)
  
  Dim sKey As Variant
  For Each sKey In target
    Call ProjEnsureFolderExists(sourceHome_ & "\" & CStr(target(sKey)))
  Next sKey
End Function

Private Function InternalExport(target As Scripting.Dictionary)
  Dim fso As New Scripting.FileSystemObject
  Dim aComponent As VBComponent
  For Each aComponent In proj_.VBComponents
    Dim sName$: sName = ComponentName(aComponent)
    If Not target.Exists(sName) Then _
      GoTo NEXT_COMPONENT
    
    Dim sPath$: sPath = sourceHome_ & "\" & target(sName) & "\" & sName
    If aComponent.Type = vbext_ct_MSForm Then _
      If HasNoChanges(aComponent, sPath) Then _
        GoTo NEXT_COMPONENT
    Call aComponent.Export(sPath)
NEXT_COMPONENT:
  Next aComponent
End Function

Private Function InternalImport(tContents As Scripting.Dictionary)
  Dim sFileName As Variant
  Dim sPath$
  For Each sFileName In tContents
    sPath = sourceHome_ & "\" & tContents(sFileName) & "\" & CStr(sFileName)
    If fso_.FileExists(sPath) Then _
      Call TryImportFile(fso_.GetFile(sPath))
  Next sFileName
End Function

Private Function TryImportFile(target As Scripting.File) As Boolean
  TryImportFile = False
  
  Dim sExt$: sExt = fso_.GetExtensionName(target.Name)
  Dim sName$: sName = fso_.GetBaseName(target.Name)
  Dim sComp As VBIDE.VBComponent: Set sComp = ComponentByName(sName)
  If Not sComp Is Nothing Then _
    If Not TryRemoving(sComp) Then _
      Exit Function
      
  Call proj_.VBComponents.Import(target.Path)
  If sExt = "frm" Then _
    Call RemoveEmptyFirstLine(ComponentByName(sName).CodeModule)
  
  TryImportFile = True
End Function

Private Function ComponentName(target As VBComponent) As String
  ComponentName = target.Name
  Select Case target.Type
    Case vbext_ct_ClassModule: ComponentName = ComponentName & ".cls"
    Case vbext_ct_MSForm: ComponentName = ComponentName & ".frm"
    Case vbext_ct_StdModule: ComponentName = ComponentName & ".bas"
    Case Else: ComponentName = vbNullString
  End Select
End Function

Private Function RemoveEmptyFirstLine(target As CodeModule)
  Dim firstLineTxt$: firstLineTxt = target.Lines(1, 1)
  If firstLineTxt = vbNullString Then _
    Call target.DeleteLines(1, 1)
End Function

Private Function TryRemoving(target As VBIDE.VBComponent) As Boolean
  Dim nCount&
  nCount = proj_.VBComponents.Count
  Call proj_.VBComponents.Remove(target)
  TryRemoving = nCount <> proj_.VBComponents.Count
End Function

Private Function ComponentByName(sName$) As VBIDE.VBComponent
  Dim aComponent As VBComponent
  For Each aComponent In proj_.VBComponents
    If aComponent.Name = sName Then
      Set ComponentByName = aComponent
      Exit Function
    End If
  Next aComponent
End Function

Private Function ProjEnsureFolderExists(sPath$)
  If fso_.FolderExists(sPath) Then _
    Exit Function
  
  Dim sParent$: sParent = sPath
  Do While VBA.Right(sParent, 1) = "\"
    sParent = VBA.Left(sParent, VBA.Len(sParent) - 1)
  Loop
  sParent = VBA.Left(sParent, VBA.InStrRev(sParent, "\") - 1)
  
  Call ProjEnsureFolderExists(sParent)
  Call fso_.CreateFolder(sPath)
End Function

Private Function HasNoChanges(aForm As VBIDE.VBComponent, sPath$) As Boolean
  HasNoChanges = False
  
  Dim fso As New Scripting.FileSystemObject
  If Not fso.FileExists(sPath) Then _
    Exit Function
    
  Dim tmpDir$: tmpDir = fso.GetParentFolderName(sPath) & "\tmpFrm"
  Dim tmpFile$: tmpFile = tmpDir & "\" & aForm.Name & ".frm"
  Call fso.CreateFolder(tmpDir)
  Call aForm.Export(tmpFile)
  
  Dim nFile1&: nFile1 = FreeFile
  Open sPath For Input As #nFile1
  Dim cont1 As Variant: cont1 = Input(LOF(nFile1), nFile1)
  Close nFile1
  
  Dim nFile2&: nFile2 = FreeFile
  Open tmpFile For Input As #nFile2
  Dim cont2 As Variant: cont2 = Input(LOF(nFile2), nFile2)
  Close nFile2
  
  HasNoChanges = cont1 = cont2
  Call fso.DeleteFolder(tmpDir)
End Function