2012年3月3日土曜日

Export Array Values To CSV File By VBA



I must export data which over 256 columns to CSV File on Excel for SPSS(PASW).
So I coded By VBA.






'**************************************************
'
'   ファイルを編集する
'   @return void
'   @exception
'
'**************************************************

Public Function GetFreeFileNumber(argExecutedPoint As String, argEditTypeLabel As String, argFilePath As String) As Long
    Dim executedPoint As String
    executedPoint = argExecutedPoint & FPR_MODULE_NAME & "EditFile"
    On Error GoTo ERROR_STEP:

    '//////////////////////////////////////// specific //////////////////////////////////////////////////////////

    Dim freeFileNumber As Long
    Dim isOpened As Boolean
    
    Call RaiseErrorObjectWhenNoUpperDir(executedPoint, "argFilePath", argFilePath)

    freeFileNumber = FreeFile
    
    Select Case argEditTypeLabel
        Case "create"
            Call RaiseErrorObjectWhenSameNameFileExist(executedPoint, "argFilePath", argFilePath)
        Case "overwrite", "add"
            Call RaiseErrorObjectWhenNoFile(executedPoint, "argFilePath", argFilePath)
        Case "createOrOverwrite", "createOrAppendText"
        Case Else
            Call RaiseErrorObjectOfInvalidArgument(executedPoint, "argEditTypeLabel" & argEditTypeLabel)
    End Select
    
    isOpened = True
    Select Case argEditTypeLabel
        Case "create", "overwrite", "createOrOverwrite"
            Open argFilePath For Output Lock Read Write As #freeFileNumber
        Case "add", "createOrAppendText"
            Open argFilePath For Append Lock Read Write As #freeFileNumber
        Case Else
            isOpened = False
    End Select

    GetFreeFileNumber = freeFileNumber
    
    '//////////////////////////////////////// specific //////////////////////////////////////////////////////////

    Exit Function
ERROR_STEP:
    If True = isOpened Then
        Close #freeFileNumber
    End If
    Call ReRaiseErrorObject(executedPoint, Err)
End Function


'**************************************************
'
'   CSV用に値を修正する
'   @return void
'   @exception
'
'**************************************************

Public Sub ModifyValueForCSV(argExecutedPoint As String, ByRef argValueRef As String)
    Dim executedPoint As String
    executedPoint = argExecutedPoint & FPR_MODULE_NAME & "ModifyValueForCSV"
    On Error GoTo ERROR_STEP:

    '//////////////////////////////////////// specific //////////////////////////////////////////////////////////

    Dim doAddQuote As Boolean

    argValueRef = Replace(argValueRef, """", """""")
    If 0 <> InStr(argValueRef, ",") Then
        doAddQuote = True
    Else
        If False = IsNumeric(argValueRef) And 0 <> Len(argValueRef) Then
            doAddQuote = True
        End If
    End If
    If True = doAddQuote Then
        argValueRef = """" & argValueRef & """"
    End If

    '//////////////////////////////////////// specific //////////////////////////////////////////////////////////

    Exit Sub
ERROR_STEP:
    Call ReRaiseErrorObject(executedPoint, Err)
End Sub

'**************************************************
'
'   ファイルを編集する
'   @return void
'   @exception
'
'**************************************************

Public Sub EditCSVFileByDM2Array(argExecutedPoint As String, argEditTypeLabel As String, argFilePath As String, ByRef argArrContentsRef As Variant)
    Dim executedPoint As String
    executedPoint = argExecutedPoint & FPR_MODULE_NAME & "EditCSVFileByDM2Array"
    On Error GoTo ERROR_STEP:

    '//////////////////////////////////////// specific //////////////////////////////////////////////////////////

    Dim freeFileNumber As Long
    Dim isOpened As Boolean
    Dim objSize As New AggregationSizeClass
    Dim arrSize() As aggregationSizeType
    Dim i As Long
    Dim j As Long
    Dim tmpContents As String
    Dim tmpArrOneLine() As String
    
    freeFileNumber = GetFreeFileNumber(executedPoint, argEditTypeLabel, argFilePath)
    isOpened = True
    
    arrSize = objSize.GetSizeArrayOfDM2Aggregation(executedPoint, argArrContentsRef)
    ReDim tmpArrOneLine(arrSize(2).lastIndex)
    
    For i = arrSize(1).firstIndex To arrSize(1).lastIndex
        For j = arrSize(2).firstIndex To arrSize(2).lastIndex
            tmpContents = argArrContentsRef(i, j)
            Call ModifyValueForCSV(executedPoint, tmpContents)
            tmpArrOneLine(j) = tmpContents
        Next j
        Print #freeFileNumber, Join(tmpArrOneLine, ",")
    Next i
    
    Close #freeFileNumber
    isOpened = False

    '//////////////////////////////////////// specific //////////////////////////////////////////////////////////

    Exit Sub
ERROR_STEP:
    If True = isOpened Then
        Close #freeFileNumber
    End If
    Call ReRaiseErrorObject(executedPoint, Err)
End Sub


0 件のコメント: