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"


' Can we export without closing the form?

' 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

' 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)
    
    If Not VCS_Dir.FileExists(file_path) Then
        logger "ImportObject", "ERROR", "Can't find the file " & file_path
        Exit Sub
    End If
    
    On Error GoTo err
    
    If Ucs2Convert Then
        Dim tempFileName As String
        tempFileName = VCS_File.TempFile()
        VCS_File.ConvertUtf8Ucs2 file_path, tempFileName
        
        Application.LoadFromText obj_type_num, obj_name, tempFileName
        
        Dim FSO As Object
        Set FSO = CreateObject("Scripting.FileSystemObject")
        FSO.DeleteFile tempFileName
    Else
        Application.LoadFromText obj_type_num, obj_name, file_path
    End If
    
    logger "ImportObject", "DEBUG", "Object of type " & obj_type_num & " named " & obj_name & " imported from " & file_path

Exit Sub
err:
    logger "ImportObject", "CRITICAL", "Unable to import the object " & obj_name & " (" & obj_type_num & ")" & "[" & err.Description & "]"
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


' For each *.txt in `Path`, find and remove a number of problematic but
' unnecessary lines of VB code that are inserted automatically by the
' Access GUI and change often (we don't want these lines of code in
' version control).
Public Sub SanitizeTextFiles(ByVal path As String, ByVal Ext As String)

    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"
'Debug.Print srchPattern
    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 & ")"
'Debug.Print srchPattern
    rxLine.Pattern = srchPattern
    Dim filename As String
    filename = dir$(path & "*." & Ext)
    If Len(filename) = 0 Then
        logger "SanitizeTextFiles", "INFO", "> No file to sanitized"
        Exit Sub
    End If
    
    Dim isReport As Boolean
    isReport = False
    
    Do Until Len(filename) = 0
        DoEvents
        Dim obj_name As String
        obj_name = Mid$(filename, 1, InStrRev(filename, ".") - 1)

        Dim InFile As Object
        Set InFile = FSO.OpenTextFile(path & obj_name & "." & Ext, iomode:=ForReading, Create:=False, Format:=TristateFalse)
        Dim OutFile As Object
        Set OutFile = FSO.CreateTextFile(path & obj_name & ".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 (path & filename)

        Dim thisFile As Object
        Set thisFile = FSO.GetFile(path & obj_name & ".sanitize")
        thisFile.Move (path & filename)
        
        logger "SanitizeTextFiles", "DEBUG", "> File " & path & filename & " sanitized"

        filename = dir$()
    Loop

    logger "SanitizeTextFiles", "INFO", "> Files " & path & "*." & Ext & " sanitized"

End Sub

Public Function to_filename(ByVal object_name As String) As String
    ' return a file name for the object's name
    ' 1- access does not accept brackets for object's names
    ' 2- file's names can not contain those caracters:
    ' \ [92]
    ' / [47]
    ' : [58]
    ' * [42]
    ' ? [63]
    ' " [34]
    ' < [60]
    ' > [62]
    ' | [124]
    '
    ' this function replaces caracters which are not allowed for file names by [x],
    'where x is the ascii code of the character
    ' test: "test_\_/_:_*_?_""_<_>_|" should become test_[92]_[47]_[58]_[42]_[63]_[34]_[60]_[62]_[124]
    ' to convert back the string, use to_accessname
    
    Dim result As String
    Dim ascii_code As Variant
    
    result = object_name
    
    For Each ascii_code In Split(ForbiddenCars, ",")
        result = Replace(result, Chr(CInt(ascii_code)), "[" & ascii_code & "]")
    Next

    If result <> object_name Then
        logger "to_filename", "DEBUG", "> Object's name " & object_name & " transformed to " & result
    End If

    to_filename = result
Exit Function
err:
    Call logger("to_filename", "ERROR", "Unable to convert object's name " & object_name & " to file's name")
    to_filename = object_name
End Function

Public Function to_accessname(ByVal file_name As String) As String
On Error GoTo err
    ' return an object name from a file's name
    ' see function 'to_filename' for more informations
    ' test: "test_[92]_[47]_[58]_[42]_[63]_[34]_[60]_[62]_[124]" should become test_\_/_:_*_?_"_<_>_|

    Dim result As String
    Dim ascii_code As Variant
    
    result = file_name
    
    For Each ascii_code In Split(ForbiddenCars, ",")
        result = Replace(result, "[" & ascii_code & "]", Chr(CInt(ascii_code)))
    Next

    If result <> file_name Then
        logger "to_accessname", "DEBUG", "> File's name " & file_name & " transformed to " & result
    End If

    to_accessname = result
Exit Function
err:
    Call logger("to_accessname", "ERROR", "Unable to convert file's name " & file_name & " to access object's name")
    to_accessname = file_name
End Function