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関数みたいなことをする

Posted at

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

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

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

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

    • CallByNameをうまいことする仕組みを入れればできるかも？

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 VarType(Key) = vbString 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

ParseFormat

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

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

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
        ParsedItems(pfText, ExtendParsedItems(ParsedItems)) = Mid(Text, LastIndex)
        ParseMissingBrace = LastIndex + Len(ParsedItems(pfText, UBound(ParsedItems, 2)))
    Case LeftBraceIndex
        If Mid(Text, RightBraceIndex, 2) = "}}" Then
            ParsedItems(pfText, ExtendParsedItems(ParsedItems)) = "}"
            ParseMissingBrace = RightBraceIndex + 2
        Else
            Err.Raise 1, , "Single '}' encountered in format string"
        End If
    Case RightBraceIndex
        If Mid(Text, LeftBraceIndex, 2) = "{{" Then
            ParsedItems(pfText, ExtendParsedItems(ParsedItems)) = "{"
            ParseMissingBrace = LeftBraceIndex + 2
        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
        ParsedItems(pfText, ExtendParsedItems(ParsedItems)) = "{"
        ParseField = LeftBraceIndex + 2
        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
        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
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 Property Let SetVar(ByRef Variable As Variant, ByVal Value As Variant)
    Rem LetとSetを区別なく扱うための処理、関数の副作用的な見た目にすると嫌なのでプロパティとして実装
    Select Case VarType(Value)
    Case vbObject, vbDataObject
        Set Variable = Value
    Case Else
        Variable = Value
    End Select
End Property
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 VarType(Key) = vbString 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
        Select Case VarType(Value)
        Case vbObject, vbDataObject
            Set Convert = Value
        Case Else
            Convert = Value
        End Select
    Case vbString
        Select Case True
        Case Conversion Like "[?]?*"
            Rem NullかNothingだった場合は代理の文字列を設定する、それ以外はそのまま返す
            If IsNull(Value) Or TypeName(Value) = "Nothing" Then
                Convert = Mid(Conversion, 2)
            Else
                Select Case VarType(Value)
                Case vbObject, vbDataObject
                    Set Convert = Value
                Case Else
                    Convert = Value
                End Select
            End If
        Case Else
            Err.Raise 1, , "Unknown conversion specifier " & Conversion
        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
        ParsedItems(pfText, ExtendParsedItems(ParsedItems)) = Mid(Text, LastIndex)
        ParseMissingBrace = LastIndex + Len(ParsedItems(pfText, UBound(ParsedItems, 2)))
    Case LeftBraceIndex
        If Mid(Text, RightBraceIndex, 2) = "}}" Then
            ParsedItems(pfText, ExtendParsedItems(ParsedItems)) = "}"
            ParseMissingBrace = RightBraceIndex + 2
        Else
            Err.Raise 1, , "Single '}' encountered in format string"
        End If
    Case RightBraceIndex
        If Mid(Text, LeftBraceIndex, 2) = "{{" Then
            ParsedItems(pfText, ExtendParsedItems(ParsedItems)) = "{"
            ParseMissingBrace = LeftBraceIndex + 2
        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
        ParsedItems(pfText, ExtendParsedItems(ParsedItems)) = "{"
        ParseField = LeftBraceIndex + 2
        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
    ParsedPlaceholder(pfField) = Field
    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
    End If
    Err.Clear
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?