ただ、自分の実力ではインターフェースの実装などで読み切れないところがあったので最小単位に分割してCSV分割機能だけを分離した。勉強のためにいったん載せておく。
なお、StringBuilderクラスについては、別のサイトから転記した
転記元：https://github.com/RelaxTools/Hidennotare/tree/master/src
http://dev-clips.com/clip/vba/stringbuilder-for-vba/
Dim strBuf As String
Dim Row As Collection
Dim Col As Collection
Dim v As Variant
strBuf = "1, Watanabe, Fukushima, 36, ""カンマがあっても,OK""" & vbCrLf & "2, satoh, chiba, 24, ""改行があっても" & vbLf & "OKやで"""
Dim IC As Object
Set IC = New CharCursor
Set Row = CsvParser(strBuf, True)
For Each Col In Row
For Each v In Col
Debug.Print v
Next
Next
End Sub
'--------------------------------------------------------------
' CSVパーサー RFC4180準拠
' コーテーションの有無, デリミタ指定あり
'--------------------------------------------------------------
Public Function CsvParser(ByVal strBuf As String, Optional ByVal Quatation As Boolean = False, Optional ByVal Delimiter As String = ",") As Collection
Const C_QUAT As String = """"
Dim IC As CharCursor
Dim sw As Boolean
Dim blnLineBreak As Boolean
Dim blnItemBreak As Boolean
Dim Col As Collection
Dim Row As Collection
Dim lngQuot As Long
lngQuot = 0
sw = False
Set Row = New Collection
Set IC = New CharCursor
Call IC.NewInstance(strBuf)
'
Do Until IC.Eof
'初期化
Set Col = New Collection
blnLineBreak = False
Do Until IC.Eof Or blnLineBreak
'初期化
Dim SB As StringBuilder
Set SB = New StringBuilder
blnItemBreak = False
Do Until IC.Eof Or blnLineBreak Or blnItemBreak
Select Case IC.Item
Case C_QUAT
'コーテーションありの場合
If Quatation Then
lngQuot = lngQuot + 1
If sw Then
'次の文字がQuatation
If IC.Item(1) = C_QUAT Then
lngQuot = lngQuot + 1
SB.Append C_QUAT
IC.MoveNext
Else
sw = False
End If
Else
sw = True
End If
End If
Case vbCr
If sw Then
SB.Append IC.Item
End If
Case vbLf
If sw Then
SB.Append IC.Item
Else
blnLineBreak = True
End If
Case Delimiter
If sw Then
SB.Append IC.Item
Else
blnItemBreak = True
End If
Case Else
SB.Append IC.Item
End Select
IC.MoveNext
Loop
'列追加処理
Col.Add SB.ToString
Loop
'行追加処理
Row.Add Col
Loop
'ダブルコーテーションが偶数ではない場合
If lngQuot Mod 2 <> 0 Then
' Message.Throw 1, Me, "CsvParser", "Invalid Format(Quotation)"
End If
Set CsvParser = Row
End Function
********************
CharCursorクラス
********************
Private mBuf As String
Private mIndex As Long
Private Sub Class_Initialize()
mIndex = 1
End Sub
Public Function NewInstance(ByVal Source As String) As CharCursor
Dim p As CharCursor
Set p = New CharCursor
mBuf = Source
Set NewInstance = p
NewInstance.MoveFirst
End Function
Public Function Eof() As Boolean
Eof = Len(mBuf) < mIndex
End Function
Public Sub MoveFirst()
mIndex = 1
End Sub
Public Sub MoveNext()
mIndex = mIndex + 1
End Sub
Public Function Item(Optional ByVal opt As Variant) As Variant
Dim lngPos As Long
If IsMissing(opt) Then
opt = 0
End If
lngPos = mIndex + opt
If lngPos < 1 Or lngPos > Len(mBuf) Then
Item = ""
Else
Item = Mid$(mBuf, lngPos, 1)
End If
End Function
-------------------------
StringBuilderクラス
-------------------------
'************************************************************************
'*-----------------------------------------------------------------------
'* Name： StringBuilder (Class Module)
'*-----------------------------------------------------------------------
'* Descriptioin：StringBuilder for VBA
'*-----------------------------------------------------------------------
'* Copyright: HAYs http://dev-clips.com , 2015 All Rights Reserved.
'*-----------------------------------------------------------------------
'* <Update>
'* Date Version Author Memo
'*-----------------------------------------------------------------------
'* 2015.11.25 1.00 HAYs New Release
'************************************************************************
' option
Option Explicit
'************************************************************************
'* variable
'************************************************************************
Private pCapacity As Long
Private pLength As Long
Private mBuffer As String
'************************************************************************
'* class event
'************************************************************************
'*-----------------------------------------------------------------------
'* constructor
'*-----------------------------------------------------------------------
Private Sub Class_Initialize()
pCapacity = 1023
Me.Clear
End Sub
'*-----------------------------------------------------------------------
'* destructor
'*-----------------------------------------------------------------------
Private Sub Class_Terminate()
'clean up
mBuffer = vbNullString
End Sub
'************************************************************************
'* property
'************************************************************************
'*-----------------------------------------------------------------------
'* Capacity
'*-----------------------------------------------------------------------
Friend Property Let Capacity(ByVal NewValue As Long)
'ignore smaller NewValue
If NewValue > pCapacity Then
're-allocate
mBuffer = mBuffer & String(NewValue - pCapacity, vbNullChar)
'save new value
pCapacity = NewValue
End If
End Property
Friend Property Get Capacity() As Long
Capacity = pCapacity
End Property
'*-----------------------------------------------------------------------
'* Length
'*-----------------------------------------------------------------------
Friend Property Let Length(ByVal NewValue As Long)
If NewValue < pLength Then
Mid(mBuffer, NewValue + 1, pLength - NewValue) = _
String$(pLength - NewValue, vbNullChar)
End If
pLength = NewValue
End Property
Friend Property Get Length() As Long
Length = pLength
End Property
'************************************************************************
'* method
'************************************************************************
'*-----------------------------------------------------------------------
'* clear
'*-----------------------------------------------------------------------
Friend Function Clear() As StringBuilder
'initialize length
pLength = 0
'allocate memory
mBuffer = String$(pCapacity, vbNullChar)
'return me
Set Clear = Me
End Function
'*-----------------------------------------------------------------------
'* append
'*-----------------------------------------------------------------------
Friend Function Append(ByRef StringValue As String) As StringBuilder
Dim pos As Long
Dim tmpCap As Long
'set position
pos = pLength + 1
'add new length
pLength = pLength + Len(StringValue)
'check overflow
If pLength > pCapacity Then
'expand capacity *doubles up
tmpCap = pCapacity
Do While tmpCap < pLength
tmpCap = tmpCap * 2
Loop
'save new capacity
Me.Capacity = tmpCap
End If
'append
Mid(mBuffer, pos) = StringValue
'retrun me
Set Append = Me
End Function
'*-----------------------------------------------------------------------
'* insert
'*-----------------------------------------------------------------------
Friend Function Insert(ByRef StringValue As String, _
ByVal position As Long) As StringBuilder
Dim tmpCap As Long
Dim tmpLen As Long
'check position
Select Case position
Case 1 To pLength
Case Is < 1: position = 1
Case Else
Set Insert = Append(StringValue)
Exit Function
End Select
'save length
tmpLen = pLength
'add new length
pLength = pLength + Len(StringValue)
'check overflow
If pLength > pCapacity Then
'expand Capacity *doubles up
tmpCap = pCapacity
Do While tmpCap < pLength
tmpCap = tmpCap * 2
Loop
'save new capacity
Me.Capacity = tmpCap
End If
'slide
Mid(mBuffer, position + Len(StringValue) _
) = Mid$(mBuffer, position, tmpLen)
'insert
Mid(mBuffer, position) = StringValue
'retrun me
Set Insert = Me
End Function
'*-----------------------------------------------------------------------
'* string value
'*-----------------------------------------------------------------------
Friend Function ToString() As String
ToString = Left$(mBuffer, pLength)
End Function
********************
0 件のコメント:
コメントを投稿