LoginSignup
0
0

Delete article

Deleted articles cannot be recovered.

Draft of this article would be also deleted.

Are you sure you want to delete this article?

@towa_skm

VBAでPythonのformat関数みたいなことをする

Last updated at Posted at 2025-07-01

  • Pythonのstring.Formatter.parseっぽいものを作って埋め込み用の情報を集める

  • 位置引数はParamArrayが貧弱なので個人的にやりやすい形で実装

  • 備忘録用なので解説は最小限

  • {item.member}みたいな指定には未対応

    • CallByNameをうまいことする仕組みを入れればできるかも？
    • CallByNameを使って参照できるように拡張した(2025/08/05)

Enumの定義

元のPythonでもIterator[tuple[str, str | None, str | None, str | None]]な形で返ってくるのでそれと同じ形で実装。
どの列がどの役割？というのをわかりやすくするためにEnumを定義。
定義順もPythonのやつに準拠しているのでそういう並び。

Public Enum ParsedField
    pfText
    pfField
    pfSpec
    pfConversion
End Enum

使用例

Pythonのstr.formatとだいたい同じことができるはず。
違うところはコンバージョンが実装次第なところと、位置引数とインデックス指定の引数を混在させることができるところ。

Dim KwArgs As Scripting.Dictionary
Set KwArgs = New Scripting.Dictionary
KwArgs.Add "key", "world"
Debug.Print PyFormat("Hello {key}, Year={0:yyyy}, Month={0:m}, Day={0:d}", Now, KwArgs)
'=> "Hello world, Year=2025, Month=7, Day=2"

PyFormat

Pythonのstr.formatっぽいことをやる関数。
Formatだと名前がかぶるのでPyFormatとしてある。
元の文字列をParseFormatで解析して、Forで回して値を拾いつつ変換したりFormatしてTextsに積んでいく。
フィールドがNullなやつは{}のプレースホルダなので先頭から順番に位置インデックスを割り当てていく。
{0}みたいなやつと混在するとどうのこうのは実装するほうが面倒だったので特にエラーとして扱っていない。
最終的にはTextsをJoinして文字列にまとめてある。


Public Function PyFormat(ByVal Template As String, Optional ByVal Args As Variant, Optional ByVal KwArgs As Scripting.Dictionary) As String
    Dim MergedArgs As Scripting.Dictionary
    Set MergedArgs = MergeArgs(Args, KwArgs)
    Dim ParsedItems() As Variant
    ParsedItems = ParseFormat(Template)
    Dim Texts() As String
    Texts = Split("")
    Dim NextIndex As Long
    Dim i As Long
    For i = LBound(ParsedItems, 1) To UBound(ParsedItems, 1)
        ReDim Preserve Texts(0 To UBound(Texts) + 1) As String
        Texts(UBound(Texts)) = ParsedItems(i, pfText)
        Select Case VarType(ParsedItems(i, pfField))
        Case vbEmpty
            Dim Field As Variant
            Field = Empty
        Case vbNull
            Field = NextIndex
            NextIndex = NextIndex + 1
        Case vbString
            If IsDecimal(ParsedItems(i, pfField)) Then
                Field = CLng(ParsedItems(i, pfField))
            Else
                Field = ParsedItems(i, pfField)
            End If
        End Select
        If IsEmpty(Field) Then
            Dim Converted As Variant
            Converted = Empty
        ElseIf MergedArgs.Exists(Field) Then
            SetVar(Converted) = Convert(MergedArgs(Field), ParsedItems(i, pfConversion))
            ReDim Preserve Texts(0 To UBound(Texts) + 1) As String
            If IsEmpty(ParsedItems(i, pfSpec)) Then
                Texts(UBound(Texts)) = ConvertString(Converted)
            Else
                Texts(UBound(Texts)) = Format(Converted, ParsedItems(i, pfSpec))
            End If
        Else
            Err.Raise 1, , "Key or Index not found: " & Field
        End If
    Next
    PyFormat = Join(Texts, "")
End Function

ConvertString

CStrだとエラーメッセージがよくわからないものだけしか出ないので、もうちょっと情報を増やしたエラーを出す変換関数。

Private Function ConvertString(ByVal Value As Variant) As String
    On Error GoTo Exception
    ConvertString = CStr(Value)
    Exit Function
Exception:
    Err.Raise 1, , "can't convert to string from [" & TypeName(Value) & "] type. original error=" & Err.Description
End Function

SetVar

LetとSetを区別なく扱うための処理。
関数の副作用的な見た目にすると嫌なのでプロパティとして実装。

Private Property Let SetVar(ByRef Variable As Variant, ByVal Value As Variant)
    Select Case VarType(Value)
    Case vbObject, vbDataObject
        Set Variable = Value
    Case Else
        Variable = Value
    End Select
End Property

MergeArgs

位置引数とキーワード引数をひとまとめにする。
位置引数はParamArrayを使うのがいいはずだが、アンパックがない都合で絶妙に使いにくいのでForEachを試みてダメそうなら単体の引数として扱う乱暴な実装。
IsMissingは呼び出し元がOptionalを持っていればちゃんと伝わってくるので問題なく使える。
キーワード引数はStringだけしかどうせ拾えないのでStringに限定して他は捨てる。

Private Function MergeArgs(ByVal Args As Variant, ByVal KwArgs As Scripting.Dictionary) As Scripting.Dictionary
    Dim MergedArgs As Scripting.Dictionary
    Set MergedArgs = New Scripting.Dictionary
    If Not IsMissing(Args) Then
        Rem ForEachできるやつはまとめて引数を与えたものとみなして処理する
        On Error GoTo SingleArg
        Dim Arg As Variant
        For Each Arg In Args
            MergedArgs.Add MergedArgs.Count, Arg
        Next
        GoTo ParseKwArgs
SingleArg:
        MergedArgs.Add 0, Args
    End If
ParseKwArgs:
    If Not KwArgs Is Nothing Then
        Dim Key As Variant
        For Each Key In KwArgs
            Rem 文字列のキーだけを埋め込み用の引数として認める
            If TypeName(Key) = "String" Then
                MergedArgs.Add Key, KwArgs(Key)
            End If
        Next
    End If
    Set MergeArgs = MergedArgs
End Function

IsDecimal

Like "#"を使って各文字と[0-9０-９]とマッチさせて数値っぽく使えるものだけを判定する。

Private Function IsDecimal(ByVal Text As String) As Boolean
    Dim Index As Long
    Do While Index < Len(Text)
        Index = Index + 1
        If Not Mid(Text, Index, 1) Like "#" Then
            Exit Function
        End If
    Loop
    IsDecimal = True
End Function

Convert

Conversionで指定した変換を行う。
Pythonでは!r以外はほとんど使ったことがないが、ここに好きな文字を指定して変換処理を入れられるようにしておけば何かと便利な気がする。
外部からコールバック関数を組み込む実装などと組み合わせればかなりいろいろできそうだが多分そこまでする意味はあまりない。
引数の値を受け取る→Convertする→Formatするの順番で処理を行うことになるのでFormatできる形に変換したり、Format前にオフセット処理をするとかの加工をするために使えそう。

Private Function Convert(ByVal Value As Variant, ByVal Conversion As Variant) As Variant
    Select Case VarType(Conversion)
    Case vbEmpty
        SetVar(Convert) = Value
    Case vbString
        Select Case True
        Case Conversion Like "[?]?*"
            Rem NullかNothingだった場合は代理の文字列を設定する、それ以外はそのまま返す
            Rem {key!?alt}のような形で指定する
            If IsNull(Value) Or TypeName(Value) = "Nothing" Then
                Convert = Mid(Conversion, 2)
            Else
                SetVar(Convert) = Value
            End If
        Case Else
            Err.Raise 1, , "Unknown conversion specifier " & Conversion
        End Select
    End Select
End Function

AccessByDot & ParseAccessor

CallByNameを使って{obj.name}のような形を扱えるようにした。
obj[0]とかもやろうと思えばできるかもしれないが今回は未実装。
引数は5個も扱えれば十分だと判断してそれより多いときは例外を派生させる。

Private Function AccessByDot(ByVal Fields As Variant, ByVal MergedArgs As Scripting.Dictionary) As Variant
    If Not MergedArgs.Exists(Fields(LBound(Fields))) Then
        Err.Raise 1, , "Key or Index not found: " & Fields(LBound(Fields))
    End If
    Dim i As Long
    i = LBound(Fields)
    Dim Current As Variant
    SetVar(Current) = MergedArgs(Fields(i))
    Do
        i = i + 1
        Dim ParsedAccessor() As Variant
        ParsedAccessor = ParseAccessor(Fields(i))
        Select Case UBound(ParsedAccessor)
        Case -1
            Err.Raise 1, , "Invalid Accessor: " & Fields(i)
        Case 0
            SetVar(Current) = CallByName(Current, ParsedAccessor(0), VbGet)
        Case 1
            SetVar(Current) = CallByName(Current, ParsedAccessor(0), VbGet, ParsedAccessor(1))
        Case 2
            SetVar(Current) = CallByName(Current, ParsedAccessor(0), VbGet, ParsedAccessor(1), ParsedAccessor(2))
        Case 3
            SetVar(Current) = CallByName(Current, ParsedAccessor(0), VbGet, ParsedAccessor(1), ParsedAccessor(2), ParsedAccessor(3))
        Case 4
            SetVar(Current) = CallByName(Current, ParsedAccessor(0), VbGet, ParsedAccessor(1), ParsedAccessor(2), ParsedAccessor(3), ParsedAccessor(4))
        Case 5
            SetVar(Current) = CallByName(Current, ParsedAccessor(0), VbGet, ParsedAccessor(1), ParsedAccessor(2), ParsedAccessor(3), ParsedAccessor(4), ParsedAccessor(5))
        Case Else
            Err.Raise 1, , "nest chain over5: " & UBound(ParsedAccessor)
        End Select
    Loop While i < UBound(Fields)
    SetVar(AccessByDot) = Current
End Function
Private Function ParseAccessor(ByVal Accessor As String) As Variant()
    Rem return: [name, ...args]
    Dim ParsedAccessor() As Variant
    ParsedAccessor = VBA.Array()
    Dim Splited() As String
    Splited = Split(Accessor, "(", 2)
    Dim Name As String
    Name = Splited(0)
    ReDim Preserve ParsedAccessor(0 To UBound(ParsedAccessor) + 1) As Variant
    ParsedAccessor(UBound(ParsedAccessor)) = Name
    If UBound(Splited) = 0 Then
        ParseAccessor = ParsedAccessor
        Exit Function
    End If
    Splited = Split(Splited(1), ")")
    Dim RawArgs() As String
    RawArgs = Split(Splited(0), ",")
    Dim RawArg As Variant
    For Each RawArg In RawArgs
        Dim Arg As Variant
        Arg = Trim(RawArg)
        If Arg <> "" Then
            ReDim Preserve ParsedAccessor(0 To UBound(ParsedAccessor) + 1) As Variant
            If IsNumeric(Arg) Then
                Arg = CDbl(Arg)
            End If
            ParsedAccessor(UBound(ParsedAccessor)) = Arg
        End If
    Next
    ParseAccessor = ParsedAccessor
End Function

ParseFormat

Pythonのstring.Formatter.parseみたいなことをする。
タプルのイテレータの代わりに2次元配列を使う。
拡張できる方向の都合で、途中までは縦横を変な感じで大きくするが最後に回転させてわかりやすい配列で返す。
{}のような相対位置のプレースホルダはフィールドをNullとして拾っておく、これは未設定のEmptyとも区別できるしStringやLongでやるよりは後で処理させるときにやりやすいと思う。

基本的には{と}を見付けて、その位置関係にあった処理を行って配列に積んでいく形で実装。
内部で使う一部の処理は関数として切り分けておく。

2025/08/05 エスケープした{{などの扱いに問題があったので修正

Public Function ParseFormat(ByVal Text As String) As Variant()
    Dim ParsedItems() As Variant
    Dim LastIndex As Long
    LastIndex = 1
    Do
        Dim LeftBraceIndex As Long
        LeftBraceIndex = InStr(LastIndex, Text, "{")
        Dim RightBraceIndex As Long
        RightBraceIndex = InStr(LastIndex, Text, "}")
        Select Case True
        Case LeftBraceIndex * RightBraceIndex = 0
            LastIndex = ParseMissingBrace(ParsedItems, Text, LastIndex, LeftBraceIndex, RightBraceIndex)
        Case LeftBraceIndex < RightBraceIndex
            LastIndex = ParseField(ParsedItems, Text, LastIndex, LeftBraceIndex, RightBraceIndex)
        Case LeftBraceIndex > RightBraceIndex
            If Mid(Text, RightBraceIndex, 2) <> "}}" Then
                Err.Raise 1, , "unexpected '}' in field name"
            ElseIf RightBraceIndex = LastIndex Then
                ParsedItems(pfText, ExtendParsedItems(ParsedItems)) = "}"
            Else
                ParsedItems(pfText, ExtendParsedItems(ParsedItems)) = Mid(Text, LastIndex, RightBraceIndex - LastIndex) & "}"
            End If
            LastIndex = RightBraceIndex + 2
        End Select
        DoEvents
    Loop While LastIndex <= Len(Text)
    Dim TransposedItems() As Variant
    ReDim TransposedItems(LBound(ParsedItems, 2) To UBound(ParsedItems, 2), LBound(ParsedItems, 1) To UBound(ParsedItems, 1))
    Dim i As Long
    For i = LBound(ParsedItems, 2) To UBound(ParsedItems, 2)
        Dim j As Long
        For j = LBound(ParsedItems, 1) To UBound(ParsedItems, 1)
            TransposedItems(i, j) = ParsedItems(j, i)
        Next
    Next
    ParseFormat = TransposedItems
End Function

ParseMissingBrace

ブレース({})の片方がない状況で呼び出される処理。
両方が0の場合はそれ以降フィールド用の処理が不要なので最後まで取得する。
片方が0の場合はエスケープされているかチェックして必要であればエラーを出したりテキストを返す。

Private Function ParseMissingBrace(ByRef ParsedItems() As Variant, ByVal Text As String, ByVal LastIndex As Long, LeftBraceIndex As Long, RightBraceIndex As Long) As Long
    Select Case 0
    Case LeftBraceIndex + RightBraceIndex
        Dim Brace As String
        Brace = Mid(Text, LastIndex)
        ParsedItems(pfText, ExtendParsedItems(ParsedItems)) = Brace
        ParseMissingBrace = LastIndex + Len(Brace)
    Case LeftBraceIndex
        If Mid(Text, RightBraceIndex, 2) = "}}" Then
            Brace = Mid(Text, LastIndex, RightBraceIndex - LastIndex + 1)
            ParsedItems(pfText, ExtendParsedItems(ParsedItems)) = Brace
            ParseMissingBrace = LastIndex + Len(Brace) + 1
        Else
            Err.Raise 1, , "Single '}' encountered in format string"
        End If
    Case RightBraceIndex
        If Mid(Text, LeftBraceIndex, 2) = "{{" Then
            Brace = Mid(Text, LastIndex, Len(Text) - LeftBraceIndex)
            ParsedItems(pfText, ExtendParsedItems(ParsedItems)) = Brace
            ParseMissingBrace = LastIndex + Len(Brace) + 1
        Else
            Err.Raise 1, , "Single '{' encountered in format string"
        End If
    End Select
End Function

ParseField

ブレース({})で包まれた中身のための処理。
ただの{{が来た場合は早々にそれで終わらせる。
フィールド内の文字列を取得できた場合は中身の解析処理を呼び出して、その結果を加える。

Private Function ParseField(ByRef ParsedItems() As Variant, ByVal Text As String, ByVal LastIndex As Long, LeftBraceIndex As Long, RightBraceIndex As Long) As Long
    If Mid(Text, LeftBraceIndex, 2) = "{{" Then
        Dim Brace As String
        Brace = Mid(Text, LastIndex, LeftBraceIndex - LastIndex + 1)
        ParsedItems(pfText, ExtendParsedItems(ParsedItems)) = Brace
        ParseField = LastIndex + Len(Brace) + 1
        Exit Function
    End If
    Dim PreText As String
    PreText = Mid(Text, LastIndex, LeftBraceIndex - LastIndex)
    Dim PlaceholderStartIndex As Long
    PlaceholderStartIndex = LeftBraceIndex + 1
    Select Case RightBraceIndex
    Case Is > PlaceholderStartIndex
        Dim Placeholder As String
        Placeholder = Mid(Text, PlaceholderStartIndex, RightBraceIndex - PlaceholderStartIndex)
    Case Is = PlaceholderStartIndex
    Case Else
        Err.Raise 1, , "unexpected '}' in field name"
    End Select
    Dim ParsedPlaceholder() As Variant
    ParsedPlaceholder = ParsePlaceholder(Placeholder)
    Dim ItemIndex As Long
    ItemIndex = ExtendParsedItems(ParsedItems)
    ParsedItems(pfText, ItemIndex) = PreText
    ParsedItems(pfField, ItemIndex) = ParsedPlaceholder(pfField)
    ParsedItems(pfSpec, ItemIndex) = ParsedPlaceholder(pfSpec)
    ParsedItems(pfConversion, ItemIndex) = ParsedPlaceholder(pfConversion)
    ParseField = RightBraceIndex + 1
End Function

ParsePlaceholder

ブレース({})の中身を解析する処理。
先にコロン(:)で区切って一番左側のコロンより左をフィールド+コンバージョンとして扱う。
キーとコンバージョンはエクスクラメーションマーク(!)で区切って、一番左側のエクスクラメーションマークより右をコンバージョンとして扱う。
結果のための配列はVBAの配列の添字が任意の値で指定できるのを利用してEnumの途中の位置を使って定義してあるので具体的には1 To 3の配列を返す。

Private Function ParsePlaceholder(ByVal Placeholder As String) As Variant()
    Dim ParsedPlaceholder(pfField To pfConversion)  As Variant
    Dim PlaceholderParts() As String
    PlaceholderParts = Split(Placeholder, ":")
    Select Case UBound(PlaceholderParts)
    Case 0
        Dim RawField As String
        RawField = PlaceholderParts(LBound(PlaceholderParts))
    Case -1
    Case Else
        RawField = PlaceholderParts(LBound(PlaceholderParts))
        Dim TempSpec As String
        TempSpec = PlaceholderParts(LBound(PlaceholderParts) + 1)
        Dim i As Long
        For i = LBound(PlaceholderParts) + 2 To UBound(PlaceholderParts)
            TempSpec = TempSpec & ":" & PlaceholderParts(i)
        Next
        Dim Spec As Variant
        Spec = TempSpec
    End Select
    If InStr(RawField, "!") = 0 Then
        If RawField = "" Then
            Dim Field As Variant
            Field = Null
        Else
            Field = RawField
        End If
    Else
        Dim FieldParts() As String
        FieldParts = Split(RawField, "!")
        Field = FieldParts(LBound(FieldParts))
        Dim TempConversion As String
        TempConversion = FieldParts(LBound(FieldParts) + 1)
        For i = LBound(FieldParts) + 2 To UBound(FieldParts)
            TempConversion = TempConversion & "!" & FieldParts(i)
        Next
        Dim Conversion As Variant
        Conversion = TempConversion
    End If
    ParsedPlaceholder(pfField) = Field
    ParsedPlaceholder(pfSpec) = Spec
    ParsedPlaceholder(pfConversion) = Conversion
    ParsePlaceholder = ParsedPlaceholder
End Function

ExtendParsedItems

配列の拡張部分を1箇所に押し込みたかったので関数化したもの。
初期化前の配列ではUBoundでどうせエラーが出るのでそこからエラーが起こったかどうかで判定して配列の初期化 or 拡張を行う。
戻り値として新しい配列末尾の添字を返すようにして呼び出し元でUBoundを使わないで済むようにしてある。

Private Function ExtendParsedItems(ByRef ParsedItems() As Variant) As Long
    On Error Resume Next
    Dim CurrentTailIndex As Long
    CurrentTailIndex = UBound(ParsedItems, 2)
    If Err Then
        ReDim ParsedItems(pfText To pfConversion, 0 To 0) As Variant
    Else
        ReDim Preserve ParsedItems(pfText To pfConversion, 0 To CurrentTailIndex + 1) As Variant
        ExtendParsedItems = CurrentTailIndex + 1
    End If
    Err.Clear
End Function
コード全体 
Option Explicit
Public Enum ParsedItemField
    pfText
    pfField
    pfSpec
    pfConversion
End Enum
Public Function PyFormat(ByVal Template As String, Optional ByVal Args As Variant, Optional ByVal KwArgs As Scripting.Dictionary) As String
    Dim MergedArgs As Scripting.Dictionary
    Set MergedArgs = MergeArgs(Args, KwArgs)
    Dim ParsedItems() As Variant
    ParsedItems = ParseFormat(Template)
    Dim Texts() As String
    Texts = Split("")
    Dim NextIndex As Long
    Dim i As Long
    For i = LBound(ParsedItems, 1) To UBound(ParsedItems, 1)
        ReDim Preserve Texts(0 To UBound(Texts) + 1) As String
        Texts(UBound(Texts)) = ParsedItems(i, pfText)
        Select Case VarType(ParsedItems(i, pfField))
        Case vbEmpty
            Dim Field As Variant
            Field = Empty
        Case vbNull
            Field = NextIndex
            NextIndex = NextIndex + 1
        Case vbString
            If IsDecimal(ParsedItems(i, pfField)) Then
                Field = CLng(ParsedItems(i, pfField))
            Else
                Field = ParsedItems(i, pfField)
            End If
        Case vbString + vbArray
            Field = ParsedItems(i, pfField)
        Case Else
            Stop
        End Select
        If IsEmpty(Field) Then
            Dim Converted As Variant
            Converted = Empty
        ElseIf IsArray(Field) Then
            SetVar(Converted) = Convert(AccessByDot(Field, MergedArgs), ParsedItems(i, pfConversion))
        ElseIf MergedArgs.Exists(Field) Then
            SetVar(Converted) = Convert(MergedArgs(Field), ParsedItems(i, pfConversion))
        Else
            Err.Raise 1, , "Key or Index not found: " & Field
        End If
        ReDim Preserve Texts(0 To UBound(Texts) + 1) As String
        If IsEmpty(ParsedItems(i, pfSpec)) Then
            Texts(UBound(Texts)) = ConvertString(Converted)
        Else
            Texts(UBound(Texts)) = Format(Converted, ParsedItems(i, pfSpec))
        End If
    Next
    PyFormat = Join(Texts, "")
End Function
Private Function AccessByDot(ByVal Fields As Variant, ByVal MergedArgs As Scripting.Dictionary) As Variant
    If Not MergedArgs.Exists(Fields(LBound(Fields))) Then
        Err.Raise 1, , "Key or Index not found: " & Fields(LBound(Fields))
    End If
    Dim i As Long
    i = LBound(Fields)
    Dim Current As Variant
    SetVar(Current) = MergedArgs(Fields(i))
    Do
        i = i + 1
        Dim ParsedAccessor() As Variant
        ParsedAccessor = ParseAccessor(Fields(i))
        Select Case UBound(ParsedAccessor)
        Case -1
            Err.Raise 1, , "Invalid Accessor: " & Fields(i)
        Case 0
            SetVar(Current) = CallByName(Current, ParsedAccessor(0), VbGet)
        Case 1
            SetVar(Current) = CallByName(Current, ParsedAccessor(0), VbGet, ParsedAccessor(1))
        Case 2
            SetVar(Current) = CallByName(Current, ParsedAccessor(0), VbGet, ParsedAccessor(1), ParsedAccessor(2))
        Case 3
            SetVar(Current) = CallByName(Current, ParsedAccessor(0), VbGet, ParsedAccessor(1), ParsedAccessor(2), ParsedAccessor(3))
        Case 4
            SetVar(Current) = CallByName(Current, ParsedAccessor(0), VbGet, ParsedAccessor(1), ParsedAccessor(2), ParsedAccessor(3), ParsedAccessor(4))
        Case 5
            SetVar(Current) = CallByName(Current, ParsedAccessor(0), VbGet, ParsedAccessor(1), ParsedAccessor(2), ParsedAccessor(3), ParsedAccessor(4), ParsedAccessor(5))
        Case Else
            Err.Raise 1, , "nest chain over5: " & UBound(ParsedAccessor)
        End Select
    Loop While i < UBound(Fields)
    SetVar(AccessByDot) = Current
End Function
Private Function ParseAccessor(ByVal Accessor As String) As Variant()
    Rem return: [name, ...args]
    Dim ParsedAccessor() As Variant
    ParsedAccessor = VBA.Array()
    Dim Splited() As String
    Splited = Split(Accessor, "(", 2)
    Dim Name As String
    Name = Splited(0)
    ReDim Preserve ParsedAccessor(0 To UBound(ParsedAccessor) + 1) As Variant
    ParsedAccessor(UBound(ParsedAccessor)) = Name
    If UBound(Splited) = 0 Then
        ParseAccessor = ParsedAccessor
        Exit Function
    End If
    Splited = Split(Splited(1), ")")
    Dim RawArgs() As String
    RawArgs = Split(Splited(0), ",")
    Dim RawArg As Variant
    For Each RawArg In RawArgs
        Dim Arg As Variant
        Arg = Trim(RawArg)
        If Arg <> "" Then
            ReDim Preserve ParsedAccessor(0 To UBound(ParsedAccessor) + 1) As Variant
            If IsNumeric(Arg) Then
                Arg = CDbl(Arg)
            End If
            ParsedAccessor(UBound(ParsedAccessor)) = Arg
        End If
    Next
    ParseAccessor = ParsedAccessor
End Function
Private Function ConvertString(ByVal Value As Variant) As String
    On Error GoTo Exception
    ConvertString = CStr(Value)
    Exit Function
Exception:
    Err.Raise 1, , "can't convert to string from [" & TypeName(Value) & "] type. original error=" & Err.Description
End Function
Private Function MergeArgs(ByVal Args As Variant, ByVal KwArgs As Scripting.Dictionary) As Scripting.Dictionary
    Dim MergedArgs As Scripting.Dictionary
    Set MergedArgs = New Scripting.Dictionary
    If Not IsMissing(Args) Then
        On Error GoTo SingleArg
        Dim Arg As Variant
        For Each Arg In Args
            MergedArgs.Add MergedArgs.Count, Arg
        Next
        GoTo ParseKwArgs
SingleArg:
        MergedArgs.Add 0, Args
    End If
ParseKwArgs:
    If Not KwArgs Is Nothing Then
        Dim Key As Variant
        For Each Key In KwArgs
            If TypeName(Key) = "String" Then
                MergedArgs.Add Key, KwArgs(Key)
            End If
        Next
    End If
    Set MergeArgs = MergedArgs
End Function
Private Function IsDecimal(ByVal Text As String) As Boolean
    Dim Index As Long
    Do While Index < Len(Text)
        Index = Index + 1
        If Not Mid(Text, Index, 1) Like "#" Then
            Exit Function
        End If
    Loop
    IsDecimal = True
End Function
Private Function Convert(ByVal Value As Variant, ByVal Conversion As Variant) As Variant
    Select Case VarType(Conversion)
    Case vbEmpty
        SetVar(Convert) = Value
    Case vbString
        Select Case True
        Case Conversion Like "[?]?*"
            If IsNull(Value) Or TypeName(Value) = "Nothing" Then
                Convert = Mid(Conversion, 2)
            Else
                SetVar(Convert) = Value
            End If
        Case Else
            If IsDateTimeOffset(Conversion) Then
                Convert = OffsetDateTime(Value, Conversion)
            Else
                Err.Raise 1, , "Unknown conversion specifier " & Conversion
            End If
        End Select
    End Select
End Function
Public Function ParseFormat(ByVal Text As String) As Variant()
    Dim ParsedItems() As Variant
    Dim LastIndex As Long
    LastIndex = 1
    Do
        Dim LeftBraceIndex As Long
        LeftBraceIndex = InStr(LastIndex, Text, "{")
        Dim RightBraceIndex As Long
        RightBraceIndex = InStr(LastIndex, Text, "}")
        Select Case True
        Case LeftBraceIndex * RightBraceIndex = 0
            LastIndex = ParseMissingBrace(ParsedItems, Text, LastIndex, LeftBraceIndex, RightBraceIndex)
        Case LeftBraceIndex < RightBraceIndex
            LastIndex = ParseField(ParsedItems, Text, LastIndex, LeftBraceIndex, RightBraceIndex)
        Case LeftBraceIndex > RightBraceIndex
            If Mid(Text, RightBraceIndex, 2) <> "}}" Then
                Err.Raise 1, , "unexpected '}' in field name"
            ElseIf RightBraceIndex = LastIndex Then
                ParsedItems(pfText, ExtendParsedItems(ParsedItems)) = "}"
            Else
                ParsedItems(pfText, ExtendParsedItems(ParsedItems)) = Mid(Text, LastIndex, RightBraceIndex - LastIndex) & "}"
            End If
            LastIndex = RightBraceIndex + 2
        End Select
        DoEvents
    Loop While LastIndex <= Len(Text)
    Dim TransposedItems() As Variant
    ReDim TransposedItems(LBound(ParsedItems, 2) To UBound(ParsedItems, 2), LBound(ParsedItems, 1) To UBound(ParsedItems, 1))
    Dim i As Long
    For i = LBound(ParsedItems, 2) To UBound(ParsedItems, 2)
        Dim j As Long
        For j = LBound(ParsedItems, 1) To UBound(ParsedItems, 1)
            TransposedItems(i, j) = ParsedItems(j, i)
        Next
    Next
    ParseFormat = TransposedItems
End Function
Private Function ParseMissingBrace(ByRef ParsedItems() As Variant, ByVal Text As String, ByVal LastIndex As Long, LeftBraceIndex As Long, RightBraceIndex As Long) As Long
    Select Case 0
    Case LeftBraceIndex + RightBraceIndex
        Dim Brace As String
        Brace = Mid(Text, LastIndex)
        ParsedItems(pfText, ExtendParsedItems(ParsedItems)) = Brace
        ParseMissingBrace = LastIndex + Len(Brace)
    Case LeftBraceIndex
        If Mid(Text, RightBraceIndex, 2) = "}}" Then
            Brace = Mid(Text, LastIndex, RightBraceIndex - LastIndex + 1)
            ParsedItems(pfText, ExtendParsedItems(ParsedItems)) = Brace
            ParseMissingBrace = LastIndex + Len(Brace) + 1
        Else
            Err.Raise 1, , "Single '}' encountered in format string"
        End If
    Case RightBraceIndex
        If Mid(Text, LeftBraceIndex, 2) = "{{" Then
            Brace = Mid(Text, LastIndex, Len(Text) - LeftBraceIndex)
            ParsedItems(pfText, ExtendParsedItems(ParsedItems)) = Brace
            ParseMissingBrace = LastIndex + Len(Brace) + 1
        Else
            Err.Raise 1, , "Single '{' encountered in format string"
        End If
    End Select
End Function
Private Function ParseField(ByRef ParsedItems() As Variant, ByVal Text As String, ByVal LastIndex As Long, LeftBraceIndex As Long, RightBraceIndex As Long) As Long
    If Mid(Text, LeftBraceIndex, 2) = "{{" Then
        Dim Brace As String
        Brace = Mid(Text, LastIndex, LeftBraceIndex - LastIndex + 1)
        ParsedItems(pfText, ExtendParsedItems(ParsedItems)) = Brace
        ParseField = LastIndex + Len(Brace) + 1
        Exit Function
    End If
    Dim PreText As String
    PreText = Mid(Text, LastIndex, LeftBraceIndex - LastIndex)
    Dim PlaceholderStartIndex As Long
    PlaceholderStartIndex = LeftBraceIndex + 1
    Select Case RightBraceIndex
    Case Is > PlaceholderStartIndex
        Dim Placeholder As String
        Placeholder = Mid(Text, PlaceholderStartIndex, RightBraceIndex - PlaceholderStartIndex)
    Case Is = PlaceholderStartIndex
    Case Else
        Err.Raise 1, , "unexpected '}' in field name"
    End Select
    Dim ParsedPlaceholder() As Variant
    ParsedPlaceholder = ParsePlaceholder(Placeholder)
    Dim ItemIndex As Long
    ItemIndex = ExtendParsedItems(ParsedItems)
    ParsedItems(pfText, ItemIndex) = PreText
    ParsedItems(pfField, ItemIndex) = ParsedPlaceholder(pfField)
    ParsedItems(pfSpec, ItemIndex) = ParsedPlaceholder(pfSpec)
    ParsedItems(pfConversion, ItemIndex) = ParsedPlaceholder(pfConversion)
    ParseField = RightBraceIndex + 1
End Function
Private Function ParsePlaceholder(ByVal Placeholder As String) As Variant()
    Dim ParsedPlaceholder(pfField To pfConversion)  As Variant
    Dim PlaceholderParts() As String
    PlaceholderParts = Split(Placeholder, ":")
    Select Case UBound(PlaceholderParts)
    Case 0
        Dim RawField As String
        RawField = PlaceholderParts(LBound(PlaceholderParts))
    Case -1
    Case Else
        RawField = PlaceholderParts(LBound(PlaceholderParts))
        Dim TempSpec As String
        TempSpec = PlaceholderParts(LBound(PlaceholderParts) + 1)
        Dim i As Long
        For i = LBound(PlaceholderParts) + 2 To UBound(PlaceholderParts)
            TempSpec = TempSpec & ":" & PlaceholderParts(i)
        Next
        Dim Spec As Variant
        Spec = TempSpec
    End Select
    If InStr(RawField, "!") = 0 Then
        If RawField = "" Then
            Dim Field As Variant
            Field = Null
        Else
            Field = RawField
        End If
    Else
        Dim FieldParts() As String
        FieldParts = Split(RawField, "!")
        Field = FieldParts(LBound(FieldParts))
        Dim TempConversion As String
        TempConversion = FieldParts(LBound(FieldParts) + 1)
        For i = LBound(FieldParts) + 2 To UBound(FieldParts)
            TempConversion = TempConversion & "!" & FieldParts(i)
        Next
        Dim Conversion As Variant
        Conversion = TempConversion
    End If
    If VarType(Field) = vbString Then
        If InStr(Field, ".") = 0 Then
            ParsedPlaceholder(pfField) = Field
        Else
            ParsedPlaceholder(pfField) = Split(Field, ".")
        End If
    Else
        ParsedPlaceholder(pfField) = Field
    End If
    ParsedPlaceholder(pfSpec) = Spec
    ParsedPlaceholder(pfConversion) = Conversion
    ParsePlaceholder = ParsedPlaceholder
End Function
Private Function ExtendParsedItems(ByRef ParsedItems() As Variant) As Long
    On Error Resume Next
    Dim CurrentTailIndex As Long
    CurrentTailIndex = UBound(ParsedItems, 2)
    If Err Then
        ReDim ParsedItems(pfText To pfConversion, 0 To 0) As Variant
    Else
        ReDim Preserve ParsedItems(pfText To pfConversion, 0 To CurrentTailIndex + 1) As Variant
        ExtendParsedItems = CurrentTailIndex + 1
        Debug.Assert Err.Number = 0
    End If
    Err.Clear
End Function
Rem convertに入れるためのやつ
Private Function IsDateTimeOffset(ByVal Text_ As String) As Boolean
    On Error Resume Next
    Dim TempDate As Date
    TempDate = OffsetDateTime(TempDate, Text_)
    IsDateTimeOffset = Err.Number = 0
    On Error GoTo 0
End Function
Private Function OffsetDateTime(ByVal DateTime As Date, ByVal OffsetDefine As String) As Date
    Dim Offsets As Scripting.Dictionary
    Set Offsets = New Scripting.Dictionary
    Dim Key As Variant
    For Each Key In Split("yyyy q m y d w ww h n s", " ")
        Offsets.Add Key, CDbl(0)
    Next
    Dim Offset As Variant
    For Each Offset In Split(LCase(OffsetDefine), ";")
        If Left(Offset, 4) = "yyyy" Then
            Dim Interval As String
            Interval = Left(Offset, 4)
        ElseIf Left(Offset, 2) = "ww" Then
            Interval = Left(Offset, 2)
        Else
            Select Case Left(Offset, 1)
            Case "q", "m", "y", "d", "w", "h", "n", "s"
                Interval = Left(Offset, 1)
            Case Else
                Err.Raise 1, , "インターバルが無効です: '" & Offset & "'"
            End Select
        End If
        Dim Operator As String
        Operator = Mid(Offset, Len(Interval) + 1, 1)
        Select Case Operator
        Case "+"
            Dim Operand As Double
            Operand = CDbl(Mid(Offset, Len(Interval) + 1))
        Case "-"
            Operand = CDbl(Mid(Offset, Len(Interval) + 1))
        Case Else
            Err.Raise 1, , "演算子が無効です: "
        End Select
        Offsets(Interval) = Offsets(Interval) + Operand
    Next
    Dim ReturnDateTime As Date
    ReturnDateTime = DateTime
    For Each Key In Offsets
        If Offsets(Key) <> 0 Then
            ReturnDateTime = DateAdd(Key, Offsets(Key), ReturnDateTime)
        End If
    Next
    OffsetDateTime = ReturnDateTime
End Function
0
0
0

Register as a new user and use Qiita more conveniently

  1. You get articles that match your needs
  2. You can efficiently read back useful information
  3. You can use dark theme
What you can do with signing up
Sign upLogin
0
0

Delete article

Deleted articles cannot be recovered.

Draft of this article would be also deleted.

Are you sure you want to delete this article?