138 lines
4.1 KiB
QBasic
138 lines
4.1 KiB
QBasic
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
|
|
|
|
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 |