VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "clsImExSpecs"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'---------------------------------------------------------------------------------------
' Module    : clsImExSpecs
' Author    : Mike Wolfe
' Source    : https://nolongerset.com/
' Date      : 1/16/2012 - 12/5/2023 23:56
' Purpose   : Class to dynamically create/modify import/export specifications at run-time.
' EnumPrefix: _ies (cls[I]m[E]x[S]pecs)
' Usage     : To generate code to copy, copy and run the following in the immediate window:
'               Set a = New clsImExSpecs: a.SpecName = "DepAcctImport": a.GenerateCode
'---------------------------------------------------------------------------------------
Option Compare Database
Option Explicit

Private mDb As DAO.Database
Private mSpecName As String
Private mSpecID As Long
Private mSpecAtt As typeSpecAttributes
Private mColNum As Long
Private mIncColumns As String

'Spec attributes
Private Type typeSpecAttributes
    DateDelim As String
    DateFourDigitYear As Boolean
    DateLeadingZeros As Boolean
    DateOrder As imexDateOrder
    DecimalPoint As String
    FieldSeparator As String
    FileType As imexFileType
    SpecType As imexSpecType
    StartRow As Long
    TextDelim As String
    TimeDelim As String
End Type

Public Enum imexDateOrder
    ies_DMY = 0
    ies_DYM
    ies_MDY
    ies_MYD
    ies_YDM
    ies_YMD
End Enum

Public Enum imexSpecType
    ies_Delimited = 1
    ies_FixedWidth = 2
End Enum

Public Enum imexIndexType
    ies_NoIndex = 0
    ies_IndexDupesAllowed = 1
    ies_IndexNoDupes = 2
End Enum

'This enum is a list of commonly used "FileType" field values (i.e., code pages);
'   they correspond to the Code Page drop down in the Specification settings dialog box
'This is not intended to be an exhaustive list; rather, you should add to it
'   as needed over time
'IMPORTANT: Any additions that you make to this Enum require associated changes
'   to the FileTypeToString() function found below in this class module
Public Enum imexFileType
    'CodePage 437 is OEM United States; see http://msdn.microsoft.com/en-us/library/aa752010.aspx
    '  usually shown as "ANSI" encoding in Notepad++ because 437 is usually the active Windows code page; see: http://stackoverflow.com/a/21317382
    ies_EncodeOEM_US = 437          'Appears as "OEM United States" in the Code Page dropdown
    ies_EncodeUTF8 = -535           'Appears as "Unicode (UTF-8)" in the Code Page dropdown
    ies_EncodeUCS2_LE_BOM = 1200    'Appears as "Unicode" in the Code Page dropdown
    ies_EncodeWin1252 = 1252        'Appears as "Western European (Windows)" in the Code Page dropdown
End Enum

Public Property Get SpecName() As String
    SpecName = mSpecName
End Property

Public Property Get SpecID() As Long
    SpecID = mSpecID
End Property

Public Property Let SpecName(ByVal sSpecName As String)
    On Error GoTo Err_SpecName

    If Len(sSpecName) = 0 Then Err.Raise 5, "clsImExSpecs", "'SpecName' cannot be zero-length string"
    mSpecName = sSpecName
    mSpecID = Nz(DLookup("SpecID", "MSysImExSpecs", "SpecName=" & Qt(mSpecName)), 0)
    If mSpecID = 0 Then
        'Create a new spec
        mDb.Execute "INSERT INTO MSysImExSpecs (SpecName) VALUES (" & Qt(mSpecName) & ")", _
                    dbFailOnError
        mSpecID = mDb.OpenRecordset("SELECT @@IDENTITY")(0)
        UpdateSpecAttributes
    End If

Exit_SpecName:
    Exit Property
Err_SpecName:
    Select Case Err.Number
    Case Else
        LogErr Err, Errors, "clsImExSpecs", "SpecName", elReraise, sSpecName
    End Select
    Resume Exit_SpecName
End Property

Public Property Get DateDelim() As String: DateDelim = mSpecAtt.DateDelim: End Property
Public Property Let DateDelim(Value As String)
    mSpecAtt.DateDelim = Value
    UpdateSpecAttributes
End Property

Public Property Get DateFourDigitYear() As Boolean: DateFourDigitYear = mSpecAtt.DateFourDigitYear: End Property
Public Property Let DateFourDigitYear(Value As Boolean)
    mSpecAtt.DateFourDigitYear = Value
    UpdateSpecAttributes
End Property

Public Property Get DateLeadingZeros() As Boolean: DateLeadingZeros = mSpecAtt.DateLeadingZeros: End Property
Public Property Let DateLeadingZeros(Value As Boolean)
    mSpecAtt.DateLeadingZeros = Value
    UpdateSpecAttributes
End Property

Public Property Get DateOrder() As imexDateOrder: DateOrder = mSpecAtt.DateOrder: End Property
Public Property Let DateOrder(Value As imexDateOrder)
    mSpecAtt.DateOrder = Value
    UpdateSpecAttributes
End Property

Public Property Get DecimalPoint() As String: DecimalPoint = mSpecAtt.DecimalPoint: End Property
Public Property Let DecimalPoint(Value As String)
    mSpecAtt.DecimalPoint = Value
    UpdateSpecAttributes
End Property

Public Property Get FieldSeparator() As String: FieldSeparator = mSpecAtt.FieldSeparator: End Property
Public Property Let FieldSeparator(Value As String)
    mSpecAtt.FieldSeparator = Value
    UpdateSpecAttributes
End Property

Public Property Get FileType() As imexFileType: FileType = mSpecAtt.FileType: End Property
Public Property Let FileType(Value As imexFileType)
    mSpecAtt.FileType = Value
    UpdateSpecAttributes
End Property

Public Property Get SpecType() As imexSpecType: SpecType = mSpecAtt.SpecType: End Property
Public Property Let SpecType(Value As imexSpecType)
    mSpecAtt.SpecType = Value
    UpdateSpecAttributes
End Property

Public Property Get StartRow() As Long: StartRow = mSpecAtt.StartRow: End Property
Public Property Let StartRow(Value As Long)
    mSpecAtt.StartRow = Value
    UpdateSpecAttributes
End Property

Public Property Get TextDelim() As String: TextDelim = mSpecAtt.TextDelim: End Property
Public Property Let TextDelim(Value As String)
    mSpecAtt.TextDelim = Value
    UpdateSpecAttributes
End Property

Public Property Get TimeDelim() As String: TimeDelim = mSpecAtt.TimeDelim: End Property
Public Property Let TimeDelim(Value As String)
    mSpecAtt.TimeDelim = Value
    UpdateSpecAttributes
End Property

Private Function Qt(Text As Variant) As String 'vv
Const QtMark As String = """"
    'We gain a small performance boost by declaring the quotation marks as a constant because they
    '  get resolved at compile time rather than run time
    'We also replace double quotes in the string with escaped double quotes so that data
    '  containing double quotes do not blow up our SQL statements
    If IsNull(Text) Or IsEmpty(Text) Then
        Qt = "Null"
    Else
        Qt = QtMark & Replace(Text, QtMark, """""") & QtMark
    End If
End Function '^^

Private Function ies_Bool(Bool As Boolean) As String
    If Bool Then
        ies_Bool = "-1"
    Else
        ies_Bool = "0"
    End If
End Function

Private Sub Class_Initialize()
    Set mDb = CurrentDb
    'set default spec attributes; we will expose these on an as-needed basis
    With mSpecAtt
        .DateDelim = "/"
        .DateFourDigitYear = True
        .DateLeadingZeros = False
        .DateOrder = ies_MDY
        .DecimalPoint = "."
        .FieldSeparator = ","
        .FileType = ies_EncodeOEM_US  'generally what Notepad++ shows as "ANSI" encoding
        .SpecType = ies_Delimited
        .StartRow = 1
        .TextDelim = """"
        .TimeDelim = ":"
    End With
End Sub

Private Sub UpdateSpecAttributes()
    If mSpecID = 0 Then Exit Sub
    
    With mSpecAtt
        Dim SQLString As String
        SQLString = "UPDATE MSysImExSpecs SET " & _
                    "  DateDelim=" & Qt(.DateDelim) & _
                    ", DateFourDigitYear=" & ies_Bool(.DateFourDigitYear) & _
                    ", DateLeadingZeros=" & ies_Bool(.DateLeadingZeros) & _
                    ", DateOrder=" & .DateOrder & _
                    ", DecimalPoint=" & Qt(.DecimalPoint) & _
                    ", FieldSeparator=" & Qt(.FieldSeparator) & _
                    ", FileType=" & .FileType & _
                    ", SpecType=" & .SpecType & _
                    ", StartRow=" & .StartRow & _
                    ", TextDelim=" & Qt(.TextDelim) & _
                    ", TimeDelim=" & Qt(.TimeDelim) & _
                    " WHERE SpecID=" & mSpecID
        mDb.Execute SQLString, dbFailOnError
    End With
End Sub

Public Sub AddCol(FieldName As String, DataType As DAO.DataTypeEnum, _
                  Optional IndexType As imexIndexType = ies_NoIndex, _
                  Optional Start As Long = 0, _
                  Optional Width As Long = 1, _
                  Optional SkipColumn As Boolean = False, _
                  Optional Attributes As Long = 0)
Dim SQLString As String, FieldExists As Boolean, Crit As String
Dim StartNum As Long
    On Error GoTo Err_AddCol

    Crit = "SpecID=" & mSpecID & " AND " & _
           "FieldName=" & Qt(FieldName)
    FieldExists = (DCount("*", "MSysImExColumns", Crit) > 0)
    If Start = 0 Then
        mColNum = mColNum + 1
        StartNum = mColNum
    Else
        StartNum = Start
    End If

    If FieldExists Then
        'Update existing field
        SQLString = "UPDATE MSysImExColumns SET " & _
                    "  Attributes=" & Attributes & _
                    ", DataType=" & DataType & _
                    ", IndexType=" & IndexType & _
                    ", SkipColumn=" & ies_Bool(SkipColumn) & _
                    ", Start=" & StartNum & _
                    ", Width=" & Width & _
                    "  WHERE " & Crit
    Else
        'Add new field
        SQLString = "INSERT INTO MSysImExColumns " & _
                    "(Attributes, DataType, FieldName, IndexType, SkipColumn, SpecID, Start, Width) " & _
                    "VALUES (" & _
                    Join(Array(Attributes, DataType, Qt(FieldName), _
                               IndexType, ies_Bool(SkipColumn), mSpecID, _
                               StartNum, Width), ",") & _
                               ")"
    End If
    If Len(mIncColumns) = 0 Then
        mIncColumns = Qt(FieldName)
    Else
        mIncColumns = mIncColumns & "," & Qt(FieldName)
    End If
    mDb.Execute SQLString, dbFailOnError
    
Exit_AddCol:
    Exit Sub
Err_AddCol:
    Select Case Err.Number
    Case Else
        LogErr Err, Errors, "clsImExSpecs", "AddCol"
    End Select
    Resume Exit_AddCol
End Sub

'This will raise an error if no columns are configured before it is called;
'   this is by design to prevent accidental deletion of all columns in the spec
'For a specification that defines no columns, this method may be omitted
Public Sub PurgeUnusedColumns()
Dim SQLString As String
    On Error GoTo Err_PurgeUnusedColumns

    If mSpecID = 0 Then GoTo Exit_PurgeUnusedColumns
    If Len(mIncColumns) = 0 Then Throw "You must call .AddCol() at least once before purging columns"
    SQLString = "DELETE FROM MSysImExColumns " & _
                "WHERE SpecID=" & mSpecID & _
                "  AND FieldName Not In (" & mIncColumns & ")"
    mDb.Execute SQLString, dbFailOnError

Exit_PurgeUnusedColumns:
    Exit Sub
Err_PurgeUnusedColumns:
    Select Case Err.Number
    Case Else
        LogErr Err, Errors, "clsImExSpecs", "PurgeUnusedColumns", elReraise, SQLString
    End Select
    Resume Exit_PurgeUnusedColumns
End Sub

Public Sub GenerateCode(Optional ObjName As String = "ImSpec")
    Dim s As String
    s = s & "Sub Define" & Replace(Me.SpecName, " ", "") & "()" & vbCrLf
    s = s & vbTab & "Dim " & ObjName & " AS clsImExSpecs" & vbCrLf
    s = s & vbTab & "Set " & ObjName & " = New clsImExSpecs" & vbCrLf
    s = s & vbTab & "With " & ObjName & vbCrLf
    s = s & vbTab & vbTab & "'Configure specification-wide settings" & vbCrLf
    s = s & vbTab & vbTab & ".SpecName = " & Qt(mSpecName) & vbCrLf
    s = s & GenerateNonDefaultSpecSettings()
    
    Dim IsFixedWidth As String
    IsFixedWidth = (InStr(s, ".SpecType = ies_FixedWidth") > 0)
    
    s = s & vbCrLf
    s = s & vbTab & vbTab & "'Configure individual column settings" & vbCrLf
    Dim IncludeColumnPurge As Boolean
    With mDb.OpenRecordset("SELECT Attributes, DataType, FieldName, IndexType, SkipColumn, SpecID, Start, Width " & _
                           "FROM MSysImExColumns WHERE SpecID=" & mSpecID & " ORDER BY Start", dbOpenForwardOnly)
        Do Until .EOF
            Dim CodeLine As String
            IncludeColumnPurge = True  'Only purge unused columns if the spec contains at least one column
            CodeLine = ".AddCol " & Join(Array(Qt(!FieldName), _
                                               DbTypeToString(!DataType), _
                                               IndexTypeToString(!IndexType)), ", ")

            CodeLine = Trim(CodeLine)
            If Right(CodeLine, 1) = "," Then CodeLine = Left(CodeLine, Len(CodeLine) - 1)
            If IsFixedWidth Then CodeLine = CodeLine & ", Start:=" & !Start & ", Width:=" & !Width
            If !SkipColumn Then CodeLine = CodeLine & ", SkipColumn:=True"
            s = s & vbTab & vbTab & CodeLine & vbCrLf
            .MoveNext
        Loop
    End With
    If IncludeColumnPurge Then s = s & vbTab & vbTab & ".PurgeUnusedColumns" & vbCrLf
    s = s & vbTab & "End With" & vbCrLf
    s = s & "End Sub"
    Debug.Print s
End Sub
Private Function GenerateNonDefaultSpecSettings() As String
    Dim s As String
    With mDb.OpenRecordset("SELECT DateDelim, DateFourDigitYear, DateLeadingZeros, DateOrder, DecimalPoint, " & _
                           "       FieldSeparator, FileType, SpecID, SpecName, SpecType, StartRow, TextDelim, TimeDelim " & _
                           "FROM mSysImExSpecs WHERE SpecID=" & mSpecID, dbOpenForwardOnly)
        If !DateDelim <> mSpecAtt.DateDelim Then s = s & vbTab & vbTab & ".DateDelim = " & Qt(!DateDelim) & vbCrLf
        If !DateFourDigitYear <> mSpecAtt.DateFourDigitYear Then s = s & vbTab & vbTab & ".DateFourDigitYear = " & !DateFourDigitYear & vbCrLf
        If !DateLeadingZeros <> mSpecAtt.DateLeadingZeros Then s = s & vbTab & vbTab & ".DateLeadingZeros = " & !DateLeadingZeros & vbCrLf
        If !DateOrder <> mSpecAtt.DateOrder Then s = s & vbTab & vbTab & ".DateOrder = " & DateOrderToString(!DateOrder) & vbCrLf
        If !DecimalPoint <> mSpecAtt.DecimalPoint Then s = s & vbTab & vbTab & ".DecimalPoint = " & Qt(!DecimalPoint) & vbCrLf
        If !FieldSeparator <> mSpecAtt.FieldSeparator Then s = s & vbTab & vbTab & ".FieldSeparator = " & Qt(!FieldSeparator) & vbCrLf
        If !FileType <> mSpecAtt.FileType Then s = s & vbTab & vbTab & ".FileType = " & FileTypeToString(!FileType) & vbCrLf
        If !SpecType <> mSpecAtt.SpecType Then s = s & vbTab & vbTab & ".SpecType = " & SpecTypeToString(!SpecType) & vbCrLf
        If !StartRow <> mSpecAtt.StartRow Then s = s & vbTab & vbTab & ".StartRow = " & !StartRow & vbCrLf
        If !TextDelim <> mSpecAtt.TextDelim Then s = s & vbTab & vbTab & ".TextDelim = " & Qt(!TextDelim) & vbCrLf
        If !TimeDelim <> mSpecAtt.TimeDelim Then s = s & vbTab & vbTab & ".TimeDelim = " & Qt(!TimeDelim) & vbCrLf
    End With
        
    GenerateNonDefaultSpecSettings = s
End Function

Private Function DbTypeToString(DbType As DataTypeEnum) As String
    Select Case DbType
    Case dbBigInt: DbTypeToString = "dbBigInt"
    Case dbBinary: DbTypeToString = "dbBinary"
    Case dbBoolean: DbTypeToString = "dbBoolean"
    Case dbByte: DbTypeToString = "dbByte"
    Case dbChar: DbTypeToString = "dbChar"
    Case dbCurrency: DbTypeToString = "dbCurrency"
    Case dbDate: DbTypeToString = "dbDate"
    Case dbDecimal: DbTypeToString = "dbDecimal"
    Case dbDouble: DbTypeToString = "dbDouble"
    Case dbFloat: DbTypeToString = "dbFloat"
    Case dbGUID: DbTypeToString = "dbGUID"
    Case dbInteger: DbTypeToString = "dbInteger"
    Case dbLong: DbTypeToString = "dbLong"
    Case dbLongBinary: DbTypeToString = "dbLongBinary"
    Case dbMemo: DbTypeToString = "dbMemo"
    Case dbNumeric: DbTypeToString = "dbNumeric"
    Case dbSingle: DbTypeToString = "dbSingle"
    Case dbText: DbTypeToString = "dbText"
    Case dbTime: DbTypeToString = "dbTime"
    Case dbTimeStamp: DbTypeToString = "dbTimeStamp"
    Case dbVarBinary: DbTypeToString = "dbVarBinary"
    End Select
End Function

Private Function IndexTypeToString(IndexType As imexIndexType) As String
    Select Case IndexType
    Case ies_NoIndex: 'IndexTypeToString = "ies_NoIndex"  'this is the default, so there's no need to specify it
    Case ies_IndexDupesAllowed: IndexTypeToString = "ies_IndexDupesAllowed"
    Case ies_IndexNoDupes: IndexTypeToString = "ies_IndexNoDupes"
    End Select
End Function

Private Function FileTypeToString(FileType As imexFileType) As String
    Select Case FileType
    Case ies_EncodeOEM_US: FileTypeToString = "ies_EncodeOEM_US"
    Case ies_EncodeUTF8: FileTypeToString = "ies_EncodeUTF8"
    Case ies_EncodeUCS2_LE_BOM: FileTypeToString = "ies_EncodeUCS2_LE_BOM"
    Case ies_EncodeWin1252: FileTypeToString = "ies_EncodeWin1252"
    End Select
End Function

Private Function SpecTypeToString(SpecType As imexSpecType) As String
    Select Case SpecType
    Case ies_Delimited: SpecTypeToString = "ies_Delimited"
    Case ies_FixedWidth: SpecTypeToString = "ies_FixedWidth"
    End Select
End Function

Private Function DateOrderToString(DateOrder As imexDateOrder) As String
    Select Case DateOrder
    Case ies_DMY: DateOrderToString = "ies_DMY"
    Case ies_DYM: DateOrderToString = "ies_DYM"
    Case ies_MDY: DateOrderToString = "ies_MDY"
    Case ies_MYD: DateOrderToString = "ies_MYD"
    Case ies_YDM: DateOrderToString = "ies_YDM"
    Case ies_YMD: DateOrderToString = "ies_YMD"
    End Select
End Function