openaccess/source/modules/VCS_IE_Functions.bas

Option Compare Database
Option Private Module
Option Explicit

Private Const AggressiveSanitize As Boolean = True
Private Const StripPublishOption As Boolean = True

' Constants for Scripting.FileSystemObject API
Public Const ForReading = 1, ForWriting = 2, ForAppending = 8
Public Const TristateTrue = -1, TristateFalse = 0, TristateUseDefault = -2

' constants for names conversion
Public Const ForbiddenCars = "34,42,47,58,60,62,63,92,124"

Dim p_source_dir As String
Public Function source_dir() As String
    If Len(p_source_dir) = 0 Then
        ' get the source directory's path
        p_source_dir = norm_dir_path(CurrentProject.path) & "source\"
        logger "source_dir", "DEBUG", "> Source's directory defined: " & p_source_dir
    End If
    source_dir = p_source_dir
End Function


'returns true if named module is NOT part of the VCS / OA code
Public Function IsNotVCS(ByVal name As String) As Boolean

    '*** if OA addin is used from its developement version (OA exporting itself)
    If CurrentProject.name = "openaccess.accda" Then
        IsNotVCS = True
        Exit Function
    End If
    '****

    If name <> "OA_Controls" And _
      name <> "OA_Log" And _
      name <> "OA_Main" And _
      name <> "OA_Optimizer" And _
      name <> "OA_Properties" And _
      name <> "OA_Shell" And _
      name <> "OA_Utils" And _
      name <> "VCS_DataMacro" And _
      name <> "VCS_Dir" And _
      name <> "VCS_File" And _
      name <> "VCS_IE_Functions" And _
      name <> "VCS_ImportExport" And _
      name <> "VCS_Reference" And _
      name <> "VCS_Relation" And _
      name <> "VCS_Report" And _
      name <> "VCS_String" And _
      name <> "VCS_Table" Then
        IsNotVCS = True
    Else
        IsNotVCS = False
    End If

End Function


'[DEPRECATED]
' Export a database object with optional UCS2-to-UTF-8 conversion.
'Public Sub ExportObject(ByVal obj_type_num As Integer, ByVal obj_name As String, _
'                    ByVal file_path As String, Optional ByVal Ucs2Convert As Boolean = False)
'
'    VCS_Dir.MkDirIfNotExist Left$(file_path, InStrRev(file_path, "\"))
'
'    If Ucs2Convert Then
'        Dim tempFileName As String
'        tempFileName = VCS_File.TempFile()
'        Application.SaveAsText obj_type_num, obj_name, tempFileName
'        VCS_File.ConvertUcs2Utf8 tempFileName, file_path
'
'        Dim FSO As Object
'        Set FSO = CreateObject("Scripting.FileSystemObject")
'        FSO.DeleteFile tempFileName
'    Else
'        Application.SaveAsText obj_type_num, obj_name, file_path
'    End If
'
'    logger "ExportObject", "DEBUG", "Object of type " & obj_type_num & " named " & obj_name & " exported to " & file_path
'
'    If obj_type_num <> acModule Then
'        SanitizeFile file_path
'    End If
'
'End Sub

'[DEPRECATED]
' Import a database object with optional UTF-8-to-UCS2 conversion.
'Public Sub ImportObject(ByVal obj_type_num As Integer, ByVal obj_name As String, _
'                    ByVal file_path As String, Optional ByVal Ucs2Convert As Boolean = False)
'    Dim tempFileName As String
'    tempFileName = ""
'
'    logger "ImportObject", "DEBUG", "Try to import " & obj_name & "(type " & obj_type_num & ")  from: " & file_path
'
'    If Not VCS_Dir.FileExists(file_path) Then
'        logger "ImportObject", "ERROR", "Can't find the file " & file_path
'        GoTo end_
'    End If
'
'    On Error GoTo err
'
'    If Ucs2Convert Then
'
'        tempFileName = VCS_File.TempFile()
'        VCS_File.ConvertUtf8Ucs2 file_path, tempFileName
'
'        logger "ImportObject", "DEBUG", "Load data from " & tempFileName
'        Application.LoadFromText obj_type_num, obj_name, tempFileName
'
'    Else
'
'        logger "ImportObject", "DEBUG", "Load data from " & file_path
'        Application.LoadFromText obj_type_num, obj_name, file_path
'    End If
'
'    logger "ImportObject", "DEBUG", "> imported"
'
'end_:
'    If Len(tempFileName) > 0 Then
'        DelIfExist tempFileName
'    End If
'
'    Exit Sub
'err:
'    logger "ImportObject", "CRITICAL", "Unable to import " & obj_name & "[" & err.Description & "]"
'    'GoTo end_  ' > on error, don't delete the file (debugging purpose)
'End Sub

Public Sub SanitizeFile(ByVal filepath As String)
' cleans the file from unnecessary lines

    Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    '  Setup Block matching Regex.
    Dim rxBlock As Object
    Set rxBlock = CreateObject("VBScript.RegExp")
    rxBlock.ignoreCase = False
    
    '  Match PrtDevNames / Mode with or  without W
    Dim srchPattern As String
    srchPattern = "PrtDev(?:Names|Mode)[W]?"
    
    If (AggressiveSanitize = True) Then
      '  Add and group aggressive matches
        srchPattern = "(?:" & srchPattern
        srchPattern = srchPattern & "|GUID|""GUID""|NameMap|dbLongBinary ""DOL"""
        srchPattern = srchPattern & ")"
    End If
    
    '  Ensure that this is the begining of a block.
    srchPattern = srchPattern & " = Begin"
    rxBlock.Pattern = srchPattern

    '  Setup Line Matching Regex.
    Dim rxLine As Object
    Set rxLine = CreateObject("VBScript.RegExp")
    srchPattern = "^\s*(?:"
    srchPattern = srchPattern & "Checksum ="
    srchPattern = srchPattern & "|BaseInfo|NoSaveCTIWhenDisabled =1"
    If (StripPublishOption = True) Then
        srchPattern = srchPattern & "|dbByte ""PublishToWeb"" =""1"""
        srchPattern = srchPattern & "|PublishOption =1"
    End If
    srchPattern = srchPattern & ")"
    rxLine.Pattern = srchPattern
    
    
    Dim isReport As Boolean
    isReport = False

'    Dim dir_name, file_name, obj_name As String
'
'    obj_name = Mid$(filename, 1, InStrRev(filename, ".") - 1)

    Dim InFile As Object
    Set InFile = FSO.OpenTextFile(filepath, iomode:=ForReading, Create:=False, Format:=TristateFalse)
    
    Dim OutFile As Object
    Set OutFile = FSO.CreateTextFile(filepath & ".sanitize", overwrite:=True, unicode:=False)

    Dim getLine As Boolean
    getLine = True
    
    Do Until InFile.AtEndOfStream
        DoEvents
        Dim txt As String
        '
        ' Check if we need to get a new line of text
        If getLine = True Then
            txt = InFile.readline
        Else
            getLine = True
        End If
        
        ' Skip lines starting with line pattern
        If rxLine.test(txt) Then
            Dim rxIndent As Object
            Set rxIndent = CreateObject("VBScript.RegExp")
            rxIndent.Pattern = "^(\s+)\S"
            '
            ' Get indentation level.
            Dim matches As Object
            Set matches = rxIndent.Execute(txt)
            '
            ' Setup pattern to match current indent
            Select Case matches.count
                Case 0
                    rxIndent.Pattern = "^" & vbNullString
                Case Else
                    rxIndent.Pattern = "^(\s{0," & Len(matches(0).SubMatches(0)) & "})"
            End Select
            rxIndent.Pattern = rxIndent.Pattern + "\S"
            '
            ' Skip lines with deeper indentation

            Do Until InFile.AtEndOfStream
                txt = InFile.readline
                If rxIndent.test(txt) Then Exit Do
            Loop
            ' We've moved on at least one line so do get a new one
            ' when starting the loop again.
            getLine = False
        '
        ' skip blocks of code matching block pattern
        ElseIf rxBlock.test(txt) Then
            Do Until InFile.AtEndOfStream
                txt = InFile.readline
                If InStr(txt, "End") Then Exit Do
            Loop
        ElseIf InStr(1, txt, "Begin Report") = 1 Then
            isReport = True
            OutFile.WriteLine txt
        ElseIf isReport = True And (InStr(1, txt, "    Right =") Or InStr(1, txt, "    Bottom =")) Then
            'skip line
            If InStr(1, txt, "    Bottom =") Then
                isReport = False
            End If
        Else
            OutFile.WriteLine txt
        End If
    Loop
    OutFile.Close
    InFile.Close

    FSO.DeleteFile (filepath)

    Dim thisFile As Object
    Set thisFile = FSO.GetFile(filepath & ".sanitize")
    thisFile.Move (filepath)
    
    logger "SanitizeFile", "DEBUG", "> File " & filepath & " sanitized"


End Sub


' Close all open forms.
Public Sub CloseFormsReports()
    On Error GoTo errorHandler
    logger "CloseFormsReports", "DEBUG", "Close any opened form or report"
    
    Dim threshold As Integer
    threshold = 0
    Do While Forms.count > threshold
        If Forms(0).name = "OpenAccess" Then
            threshold = 1
        Else
            DoCmd.Close acForm, Forms(threshold).name
        End If
        'DoEvents
    Loop
    Do While Reports.count > 0
        DoCmd.Close acReport, Reports(0).name
        'DoEvents
    Loop
    
    DoEvents
    Exit Sub

errorHandler:
    logger "CloseFormsReports", "CRITICAL", "Error #" & err.Number & err.Description
End Sub


'errno 457 - duplicate key (& item)
Public Function StrSetToCol(ByVal strSet As String, ByVal delimiter As String) As Collection 'throws errors
    Dim strSetArray() As String
    Dim col As Collection
    
    Set col = New Collection
    strSetArray = Split(strSet, delimiter)
    
    Dim item As Variant
    For Each item In strSetArray
        col.Add item, item
    Next
    
    Set StrSetToCol = col
End Function


' Check if an item or key is in a collection
Public Function InCollection(col As Collection, Optional vItem, Optional vKey) As Boolean
    On Error Resume Next

    Dim vColItem As Variant

    InCollection = False

    If Not IsMissing(vKey) Then
        col.item vKey

        '5 if not in collection, it is 91 if no collection exists
        If err.Number <> 5 And err.Number <> 91 Then
            InCollection = True
        End If
    ElseIf Not IsMissing(vItem) Then
        For Each vColItem In col
            If vColItem = vItem Then
                InCollection = True
                GoTo Exit_Proc
            End If
        Next vColItem
    End If

Exit_Proc:
    Exit Function
Err_Handle:
    Resume Exit_Proc
End Function