vba/src/module/Common_File_Utils.bas

Attribute VB_Name = "Common_File_Utils"
Option Explicit
' ============================================================
' Module Name: Write_Common
' Module Desc: CSV write functions
' Module Methods:
'   - GetSaveCSVPath
'   - WriteCSVFromArray
' ============================================================

Function GetSaveCSVPath(Optional ByVal defaultName As String = "") As String
    Dim savePath As String
    savePath = Application.GetSaveAsFilename( _
        FileFilter:="CSV Files (*.csv), *.csv", _
        Title:="Save CSV", _
        InitialFileName:=defaultName)
    
    If savePath = "False" Or savePath = "" Then
        GetSaveCSVPath = ""
        Exit Function
    End If
    
    If InStr(1, savePath, ".csv", vbTextCompare) = 0 Then
        savePath = savePath & ".csv"
    End If
    
    GetSaveCSVPath = savePath
End Function

' Writes a 2D array to a CSV file
Sub WriteCSVFromArray( _
    ByVal filePath As String, _
    ByVal data As Variant, _
    Optional ByVal Charset As String = "shift_jis", _
    Optional ByVal alwaysQuote As Boolean = False _
)
    ' === Input validation ===
    If Not IsArray(data) Then
        Err.Raise 513, , "Input 'data' must be an array."
    End If
    
    Dim numDims As Long
    On Error Resume Next
    numDims = ArrayDimensions(data)
    On Error GoTo 0
    If numDims <> 2 Then
        Err.Raise 514, , "Input array must be 2-dimensional."
    End If
    
    Dim rows As Long, cols As Long
    rows = UBound(data, 1) - LBound(data, 1) + 1
    cols = UBound(data, 2) - LBound(data, 2) + 1
    
    If rows = 0 Or cols = 0 Then Exit Sub ' Empty array, exit early
    
    ' === Build CSV content ===
    Dim outputLines As Collection
    Set outputLines = New Collection
    
    Dim i As Long, j As Long
    Dim rowStr As String
    Dim field As String
    Dim needsQuote As Boolean
    
    For i = LBound(data, 1) To UBound(data, 1)
        Dim fields As Variant
        ReDim fields(1 To cols)
        
        For j = LBound(data, 2) To UBound(data, 2)
            ' Safely convert variant to string
            field = SafeToString(data(i, j))
            
            ' Determine if the field needs quoting (per RFC 4180)
            needsQuote = alwaysQuote Or (InStr(field, """") > 0) Or _
                                       (InStr(field, ",") > 0) Or _
                                       (InStr(field, vbLf) > 0) Or _
                                       (InStr(field, vbCrLf) > 0) Or _
                                       (InStr(field, vbCr) > 0) Or _
                                       (Left(field, 1) = " " Or Right(field, 1) = " ")
            
            If needsQuote Then
                ' Escape double quotes: "" represents a single "
                field = """" & Replace(field, """", """""") & """"
            End If
            field = GetCode(field)
            
            fields(j - LBound(data, 2) + 1) = field
        Next j
        
        rowStr = Join(fields, ",")
        outputLines.Add rowStr
    Next i
    
    ' Concatenate all lines
    Dim finalContent As String
    finalContent = Join(CollectionToArray(outputLines), vbCrLf)
    
    ' === Write to file ===
    Dim stream As Object
    Set stream = CreateObject("ADODB.Stream")
    With stream
        .Type = 2 ' adTypeText
        .Charset = Charset
        .Open
        .WriteText finalContent, 0 ' adWriteChar
        .SaveToFile filePath, 2 ' adSaveCreateOverWrite
        .Close
    End With
End Sub

' Helper function: safely convert any Variant to a string
Private Function SafeToString(ByVal v As Variant) As String
    On Error Resume Next
    If IsNull(v) Or IsEmpty(v) Then
        SafeToString = ""
    Else
        SafeToString = CStr(v)
    End If
    On Error GoTo 0
End Function

' Helper function: get the number of dimensions of an array (1, 2, ...)
Private Function ArrayDimensions(arr As Variant) As Long
    Dim dimCount As Long
    On Error GoTo ExitPoint
    Do
        dimCount = dimCount + 1
        Dim tmp As Long
        tmp = UBound(arr, dimCount)
    Loop
ExitPoint:
    ArrayDimensions = dimCount - 1
End Function

' Helper function: convert a Collection to a 1D array (for use with Join)
Private Function CollectionToArray(col As Collection) As Variant
    If col.Count = 0 Then
        CollectionToArray = Array()
        Exit Function
    End If
    
    Dim arr() As String
    ReDim arr(1 To col.Count)
    Dim i As Long
    For i = 1 To col.Count
        arr(i) = col(i)
    Next i
    CollectionToArray = arr
End Function

' ============================================================
' Module Name: Read_Common
' Module Desc: CSV read functions
' Module Methods:
'   - SelectCSVFile
'   - ReadCSVAs2DArrayStrict
'   - ParseCSVLines
' ============================================================

Function SelectCSVFile() As String
    Dim fileDialog As FileDialog
    Set fileDialog = Application.FileDialog(msoFileDialogFilePicker)
    
    With fileDialog
        .Filters.Clear
        .Filters.Add "CSV Files", "*.csv"
        .AllowMultiSelect = False
        If .Show <> -1 Then
            SelectCSVFile = ""
            Exit Function
        End If
        SelectCSVFile = .SelectedItems(1)
    End With
End Function

' Read a CSV file and return its content as a strict 2D array (1-based).
' All rows must have the same number of columns as the first row.
' If the file is empty and defaultColumnCount > 0, returns an empty 2D array with zero rows and defaultColumnCount columns.
' Parameters:
'   filePath:           Full path to the CSV file.
'   charset:            Text encoding (e.g., "cp932", "utf-8").
'   defaultColumnCount: Optional. Used only if CSV has no rows. Must be >= 0.
Function ReadCSVAs2DArrayStrict( _
    ByVal filePath As String, _
    ByVal expectedColumnCount As Long, _
    Optional ByVal charset As String = "cp932", _
    Optional ByVal hasHeader As Boolean = False) As Variant

    ' === validate expectedColumnCount ===
    If expectedColumnCount <= 0 Then
        Err.Raise 5001, , "expectedColumnCount must be >= 1."
    End If
    
    If Dir(filePath) = "" Then
        Err.Raise 5002, , "File not found: " & filePath
    End If

    ' === read csv file ===
    Dim stream As Object
    Set stream = CreateObject("ADODB.Stream")
    With stream
        .Type = 2 ' adTypeText
        .charset = charset
        .Open
        .LoadFromFile filePath
        Dim textContent As String
        textContent = .ReadText
        .Close
    End With

    ' === standardize ===
    textContent = Replace(textContent, vbCrLf, vbLf)
    textContent = Replace(textContent, vbCr, vbLf)

    ' === transfer into collection ===
    Dim lines As Collection
    Set lines = ParseCSVLines(textContent)

    ' === validate empty ===
    If lines.Count = 0 Then
        Err.Raise 5003, , "CSV file is empty."
    End If

    If lines.Count = 1 Then
        If hasHeader Then
            Err.Raise 5005, , "CSV file data is empty."
        End If
    End If

    ' === loop the row, validate column count ===
    Dim i As Long
    For i = 1 To lines.Count
        Dim rowArr As Variant
        rowArr = lines(i)
        Dim actualCols As Long
        actualCols = UBound(rowArr) - LBound(rowArr) + 1
        
        If actualCols <> expectedColumnCount Then
            Err.Raise 5004, , "Row " & i & ": Expected " & expectedColumnCount & " columns, got " & actualCols & "."
        End If
    Next i

    Dim result As Variant
    Dim startRow As Long
    If hasHeader Then
        startRow = 2
    Else
        startRow = 1
    End If

    ReDim result(startRow To lines.Count, 1 To expectedColumnCount)

    For i = startRow To lines.Count
        rowArr = lines(i)
        Dim j As Long
        For j = LBound(rowArr) To UBound(rowArr)
            result(i, j - LBound(rowArr) + 1) = rowArr(j)
        Next j
    Next i

    ReadCSVAs2DArrayStrict = result
End Function

' Helper function: Parse CSV text into collection of string arrays (zero-based per row)
Private Function ParseCSVLines(ByVal csvText As String) As Collection
    Set ParseCSVLines = New Collection
    Dim length As Long: length = Len(csvText)
    If length = 0 Then Exit Function
    
    Dim i As Long: i = 1
    Dim currentField As String
    Dim currentRow As Collection: Set currentRow = New Collection
    Dim inQuotes As Boolean
    Dim c As String
    
    Do While i <= length
        c = Mid$(csvText, i, 1)
        Select Case c
            Case """"
                If inQuotes Then
                    If i < length And Mid$(csvText, i + 1, 1) = """" Then
                        currentField = currentField & """"
                        i = i + 2
                    Else
                        inQuotes = False
                        i = i + 1
                    End If
                Else
                    inQuotes = True
                    i = i + 1
                End If
            Case ","
                If inQuotes Then
                    currentField = currentField & c
                    i = i + 1
                Else
                    ' Clean field before adding
                    currentField = Trim(currentField)
                    currentField = Replace(currentField, vbCr, "")
                    currentField = Replace(currentField, vbLf, "")
                    currentRow.Add currentField
                    currentField = ""
                    i = i + 1
                End If
            Case vbLf
                If inQuotes Then
                    currentField = currentField & c
                    i = i + 1
                Else
                    currentRow.Add currentField
                    Dim arr() As String
                    If currentRow.Count > 0 Then
                        ReDim arr(0 To currentRow.Count - 1)
                        Dim k As Long
                        For k = 1 To currentRow.Count
                            arr(k - 1) = currentRow(k)
                        Next k
                    End If
                    ParseCSVLines.Add arr
                    Set currentRow = New Collection
                    currentField = ""
                    inQuotes = False
                    i = i + 1
                End If
            Case Else
                currentField = currentField & c
                i = i + 1
        End Select
    Loop
    
    ' Handle last row without trailing newline
    If currentField <> "" Or currentRow.Count > 0 Then
        ' Clean field before adding
        currentField = Trim(currentField)
        currentField = Replace(currentField, vbCr, "")
        currentField = Replace(currentField, vbLf, "")
        currentRow.Add currentField
        Dim lastArr() As String
        If currentRow.Count > 0 Then
            ReDim lastArr(0 To currentRow.Count - 1)
            Dim m As Long
            For m = 1 To currentRow.Count
                lastArr(m - 1) = currentRow(m)
            Next m
        End If
        ParseCSVLines.Add lastArr
    End If
End Function