371 lines
11 KiB
QBasic
371 lines
11 KiB
QBasic
' ============================================================
|
|
' Common Functions
|
|
' ============================================================
|
|
|
|
Function CleanCSVField(ByVal field As Variant) As String
|
|
If IsEmpty(field) Or IsNull(field) Then
|
|
CleanCSVField = ""
|
|
Exit Function
|
|
End If
|
|
|
|
Dim result As String
|
|
result = Trim(CStr(field))
|
|
|
|
If Len(result) >= 2 Then
|
|
If Left(result, 1) = """" And Right(result, 1) = """" Then
|
|
result = Mid(result, 2, Len(result) - 2)
|
|
result = Replace(result, """""", """")
|
|
End If
|
|
End If
|
|
|
|
CleanCSVField = result
|
|
End Function
|
|
|
|
Function ValidateCSVColumnCount(ByVal lines As Variant, ByVal expectedColumns As Long) As Boolean
|
|
ValidateCSVColumnCount = True
|
|
|
|
Dim lineNum As Long
|
|
Dim dataArray As Variant
|
|
Dim validRowCount As Long
|
|
validRowCount = 0
|
|
|
|
For lineNum = 0 To UBound(lines)
|
|
If Trim(lines(lineNum)) <> "" Then
|
|
dataArray = Split(lines(lineNum), ",")
|
|
If UBound(dataArray) + 1 <> expectedColumns Then
|
|
MsgBox "CSV line " & (lineNum + 1) & " has " & (UBound(dataArray) + 1) & " columns. Expected " & expectedColumns & ".", vbExclamation
|
|
ValidateCSVColumnCount = False
|
|
Exit Function
|
|
End If
|
|
validRowCount = validRowCount + 1
|
|
End If
|
|
Next lineNum
|
|
|
|
If validRowCount = 0 Then
|
|
MsgBox "No valid data in CSV.", vbExclamation
|
|
ValidateCSVColumnCount = False
|
|
End If
|
|
End Function
|
|
|
|
Function GetLastDataRow(ByVal ws As Worksheet, ByVal columnNum As Long) As Long
|
|
GetLastDataRow = ws.Cells(ws.Rows.Count, columnNum).End(xlUp).Row
|
|
End Function
|
|
|
|
Sub ClearDataRows(ByVal ws As Worksheet, ByVal startRow As Long, ByVal columnNum As Long)
|
|
Dim lastRow As Long
|
|
lastRow = ws.Cells(ws.Rows.Count, columnNum).End(xlUp).Row
|
|
|
|
If lastRow >= startRow Then
|
|
ws.Range(ws.Cells(startRow, 1), ws.Cells(lastRow, 20)).ClearContents
|
|
End If
|
|
End Sub
|
|
|
|
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
|
|
|
|
|
|
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
|
|
|
|
Sub WriteCSVFile(ByVal filePath As String, ByVal content As String)
|
|
Dim stream As Object
|
|
Set stream = CreateObject("ADODB.Stream")
|
|
With stream
|
|
.Type = 2
|
|
.Charset = "shift_jis"
|
|
.Open
|
|
.WriteText content, 0
|
|
.SaveToFile filePath, 2
|
|
.Close
|
|
End With
|
|
End Sub
|
|
|
|
|
|
Function ReadCSVFile(ByVal filePath As String, Optional ByVal charset As String = "shift_jis") As Variant
|
|
If filePath = "" Then
|
|
ReadCSVFile = Array()
|
|
Exit Function
|
|
End If
|
|
|
|
Dim stream As Object
|
|
Dim textContent As String
|
|
|
|
Set stream = CreateObject("ADODB.Stream")
|
|
With stream
|
|
.Type = 2
|
|
.Charset = charset
|
|
.Open
|
|
.LoadFromFile filePath
|
|
textContent = .ReadText
|
|
.Close
|
|
End With
|
|
|
|
ReadCSVFile = Split(textContent, vbLf)
|
|
End Function
|
|
|
|
' Read a CSV file and return its content as a strict 2D array (1-based).
|
|
' The function ensures all rows have the same number of columns as the first row.
|
|
' If any row has a different column count, an error is raised immediately.
|
|
' Parameters:
|
|
' filePath: Full path to the CSV file.
|
|
' charset: Text encoding (e.g., "cp932" for Shift-JIS, "utf-8" for UTF-8).
|
|
Function ReadCSVAs2DArrayStrict(ByVal filePath As String, Optional ByVal charset As String = "cp932") As Variant
|
|
' Check if file exists
|
|
If filePath = "" Or Dir(filePath) = "" Then
|
|
Err.Raise vbObjectError + 1001, , "File not found: " & filePath
|
|
End If
|
|
|
|
' Read entire file using ADODB.Stream with specified character set
|
|
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
|
|
|
|
' Handle empty file
|
|
If textContent = "" Then
|
|
Err.Raise vbObjectError + 1002, , "CSV file is empty"
|
|
End If
|
|
|
|
' Normalize line breaks to vbLf (\n)
|
|
textContent = Replace(textContent, vbCrLf, vbLf)
|
|
textContent = Replace(textContent, vbCr, vbLf)
|
|
|
|
' Parse CSV lines into a collection of string arrays
|
|
Dim lines As Collection
|
|
Set lines = ParseCSVLines(textContent)
|
|
|
|
If lines.Count = 0 Then
|
|
Err.Raise vbObjectError + 1003, , "No valid rows parsed from CSV"
|
|
End If
|
|
|
|
' Determine expected column count from the first row
|
|
Dim expectedCols As Long
|
|
Dim firstRow As Variant
|
|
firstRow = lines(1)
|
|
expectedCols = UBound(firstRow) - LBound(firstRow) + 1
|
|
|
|
If expectedCols <= 0 Then
|
|
Err.Raise vbObjectError + 1004, , "First row contains no fields"
|
|
End If
|
|
|
|
' Validate every row has exactly expectedCols columns
|
|
Dim i As Long
|
|
For i = 1 To lines.Count
|
|
Dim currentRow As Variant
|
|
currentRow = lines(i)
|
|
Dim actualCols As Long
|
|
actualCols = UBound(currentRow) - LBound(currentRow) + 1
|
|
|
|
If actualCols <> expectedCols Then
|
|
Err.Raise vbObjectError + 1005, , _
|
|
"CSV row column count mismatch!" & vbCrLf & _
|
|
"Expected columns: " & expectedCols & vbCrLf & _
|
|
"Row " & i & " has " & actualCols & " columns."
|
|
End If
|
|
Next i
|
|
|
|
' Build 1-based 2D result array (no padding needed due to strict validation)
|
|
Dim result As Variant
|
|
ReDim result(1 To lines.Count, 1 To expectedCols)
|
|
|
|
For i = 1 To lines.Count
|
|
currentRow = lines(i)
|
|
Dim j As Long
|
|
For j = LBound(currentRow) To UBound(currentRow)
|
|
result(i, j - LBound(currentRow) + 1) = currentRow(j)
|
|
Next j
|
|
Next i
|
|
|
|
ReadCSVAs2DArrayStrict = result
|
|
End Function
|
|
|
|
' Parse CSV text into a Collection of string arrays, respecting RFC 4180 rules.
|
|
' Handles quoted fields, commas/line breaks inside quotes, and escaped quotes ("").
|
|
' Input: CSV text with normalized line endings (vbLf only).
|
|
' Output: Collection where each item is a zero-based array of field strings.
|
|
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
|
|
' Check for escaped quote ("")
|
|
If i < length And Mid$(csvText, i + 1, 1) = """" Then
|
|
currentField = currentField & """"
|
|
i = i + 2 ' Skip both quotes
|
|
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
|
|
' End of field
|
|
currentRow.Add currentField
|
|
currentField = ""
|
|
i = i + 1
|
|
End If
|
|
|
|
Case vbLf
|
|
If inQuotes Then
|
|
currentField = currentField & c
|
|
i = i + 1
|
|
Else
|
|
' End of row
|
|
currentRow.Add currentField
|
|
' Convert collection to array
|
|
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
|
|
' Reset for next row
|
|
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 if file doesn't end with newline
|
|
If currentField <> "" Or currentRow.Count > 0 Then
|
|
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
|
|
|
|
Sub SortDataRows(Optional ByVal sortColumn As Long = 3)
|
|
Dim ws As Worksheet
|
|
Dim lastRow As Long
|
|
Dim startRow As Long
|
|
Dim sortOrder As Long
|
|
|
|
Set ws = ActiveSheet
|
|
startRow = 7
|
|
lastRow = GetLastDataRow(ws, sortColumn)
|
|
|
|
If lastRow < startRow Then
|
|
MsgBox "No data to sort.", vbExclamation
|
|
Exit Sub
|
|
End If
|
|
|
|
' Determine sort order based on first row's current state
|
|
Dim currentFirst As String
|
|
Dim nextFirst As String
|
|
currentFirst = Trim(ws.Cells(startRow, sortColumn).Value)
|
|
nextFirst = Trim(ws.Cells(startRow + 1, sortColumn).Value)
|
|
|
|
If currentFirst <> "" And nextFirst <> "" Then
|
|
If currentFirst > nextFirst Then
|
|
sortOrder = xlAscending
|
|
Else
|
|
sortOrder = xlDescending
|
|
End If
|
|
Else
|
|
sortOrder = xlAscending
|
|
End If
|
|
|
|
ws.Range(ws.Cells(startRow, 1), ws.Cells(lastRow, 20)).Sort _
|
|
Key1:=ws.Cells(startRow, sortColumn), _
|
|
Order1:=sortOrder, _
|
|
Header:=xlNo
|
|
End Sub
|
|
|
|
Sub ToggleAutoFilter(Optional ByVal filterRow As Long = 6)
|
|
Dim ws As Worksheet
|
|
Set ws = ActiveSheet
|
|
|
|
' Check if auto filter is already on
|
|
If ws.AutoFilterMode Then
|
|
ws.AutoFilterMode = False
|
|
Else
|
|
If filterRow >= 1 Then
|
|
ws.Rows(filterRow).AutoFilter
|
|
End If
|
|
End If
|
|
End Sub
|
|
|
|
Sub AutoFitColumnWidth(Optional ByVal fitColumnStart As Long = 2, Optional ByVal fitColumnEnd As Long = 9)
|
|
Dim ws As Worksheet
|
|
Set ws = ActiveSheet
|
|
|
|
If fitColumnStart <= fitColumnEnd Then
|
|
ws.Range(ws.Columns(fitColumnStart), ws.Columns(fitColumnEnd)).AutoFit
|
|
End If
|
|
End Sub
|