【pleasanter/VBA】エクスポート⑧出力される日付を文字列ではなく日付時刻型で出したい

エクセルVBAでプリザンターから情報取得、シリーズ。第8回です。

前回までVBAでエクスポートする方法をあれこれやってきました。今回はちょっと閑話休題番外編みたいな感じ。
プリザンターからVBAでエクスポートすると、日付の部分が 2023-08-15T16:09:21 のようになります。（APItypeでKeyValuesを指定した場合は日付型で出ましたが）
で、Tってなんなん？・・・というと、Timeを表しているのかもだけど、JsonConverterモジュールを使うとそうなっちゃうのかなあ、と思っております。
で、日付時刻型で出てくれた方がありがたいので、vbaコード内で日付時刻型に変換する方法をやってみたいと思います。
プリザンターも何も関係なくただ文字列の日付時刻をシリアル値に変換するってだけの話なんですけどね。。。

なお、VBAでのエクスポートのやり方、フィルター条件のやりかた、は割愛しますので、前回までの記事を参照してください。

※おことわり
2023年8月時点の情報です。プリザンターのバージョンは 1.3.20.0 です。Google Chrome でやっています。
javascript,html,cssともに初心者です。調べながら、やってみながら、きっとこうすればいいんだ！という感じで書いていますので、間違っている場合、効率的な書き方ではない可能性が大いにあります。間違ってるよ！とか、こうしたほうがいいよ！ということがありましたら、コメント等で教えていただけると大変ありがたいです。

１．変換せずに出力した場合
２．文字列を日付時刻型に変換するFunctionを作成する
３．最後に

１．変換せずに出力した場合

以下のコードで出力します。

Sub pleasanter_export14()
    
    Const myApikey As String = "abcde12345"
       
    Dim jsonRequest     As Dictionary
    Dim parseResponse   As Dictionary
    Dim httpRequest     As Object
    
    Set jsonRequest = New Dictionary
    
    jsonRequest.Add "ApiVersion", "1.1"
    jsonRequest.Add "ApiKey", myApikey
    'jsonRequest.Add "View", New Dictionary
    
    Set httpRequest = CreateObject("msxml2.xmlhttp")
    
    httpRequest.Open "POST", "http://localhost/api/items/426/get"
    httpRequest.setRequestHeader "Content-Type", "application/json;charset=utf-8"
    
    httpRequest.send JsonConverter.ConvertToJson(jsonRequest)
    
    Do While httpRequest.readyState < 4
        DoEvents
    Loop

    Set parseResponse = JsonConverter.ParseJson(httpRequest.responseText)
    
    If parseResponse("Response")("Data").Count <= 0 Then
        MsgBox "なし"
        Exit Sub
    End If
    
    Dim responseData As Variant
    Dim i As Long: i = 2
    For Each responseData In parseResponse("Response")("Data")
        With ActiveSheet
            .Cells(i, 1).Value = responseData("Title")
            .Cells(i, 2).Value = responseData("DateHash")("DateA")
            .Cells(i, 3).Value = responseData("UpdatedTime")
        End With
        i = i + 1
    Next

    MsgBox "出力完了"

End Sub

出力結果は以下のようになりました。

ちなみに日付Aの書式は「年月日」です。

2行目のタイトル200の日付Aが「1899-12-30T00:00:00」となっていますね。
これは実はこのレコードの日付A欄が空欄なのです。
空欄だと「1899-12-30T00:00:00」とでるので注意が必要です。

２．文字列を日付時刻型に変換するFunctionを作成する

（１）Cdate（日付だけ）

変換する文字列は 2023-08-15T16:09:21 のような形です。
日付だけ取り出したい場合は、左から10文字を取り出して、CDateに突っ込みます。

Function strDateToDate(ByVal str As String) As Date
    '日付だけ
    strDateToDate = CDate(Left(str, 10))
End Function

なお、日付欄が空欄の場合、 1899-08-15T00:00:00 のようにでるので、文字列の左4文字が「1899」の場合の処理も追加しておきます。
その場合空白を返したいのでstrDateToDateの返却の型はVariantにしておきます。

Function strDateToDate(ByVal str As String) As Variant
    '日付だけ
    If Val(Left(str, 4)) < 1900 Then    '日付欄が空欄の場合の対応
        strDateToDate = ""　　　　
    Else
        strDateToDate = CDate(Left(str, 10))
    End If
End Function

これを先ほどのコードの出力個所に埋め込みます。

出力結果。空欄の処理もちゃんとできましたね。そして日付だけが返っています。

（２）Cdate（日付時刻）

同じくCDateで文字列（2023-08-15T16:09:21）から日付時刻を取り出します。
Replace関数で「T」をスペースに置換してからCDateにかけています。

Function strDateToDate(ByVal str As String) As Variant
    '日付時刻
    If Val(Left(str, 4)) < 1900 Then
        strDateToDate = ""
    Else
        strDateToDate = CDate(Replace(str, "T", " "))
    End If
End Function

結果はこうなりました（B・C列の書式設定は事前にyyyy/mm/dd hh:mm:ssにしています）

（３）DateSerial、TimeSerialを利用する

chatGTPさんに聞いたら、DateSerial、TimeSerialを使った方法も教えてくれました。

Function strDateToDate(ByVal str As String) As Variant
    
    Dim dateParts() As String
    Dim timeParts() As String
    Dim dateTimeValue As Date
    
    If Left(str, 4) < 1900 Then
        strDateToDate = ""
    Else
        dateParts = Split(Split(str, "T")(0), "-")
        timeParts = Split(Split(str, "T")(1), ":")
        
        dateTimeValue = DateSerial(CInt(dateParts(0)), CInt(dateParts(1)), CInt(dateParts(2))) + _
                        TimeSerial(CInt(timeParts(0)), CInt(timeParts(1)), CInt(timeParts(2)))
        
        strDateToDate = dateTimeValue
    End If
End Function

chatGPT先生、変数名の付け方も粋ですね。いくらきいても「は？バカじゃない」みたいな顔されないからいいわ～。

結果は上記（２）と同じでした。

ちょっと解説をすると

dateParts = Split(Split(str, “T”)(0), “-“)
timeParts = Split(Split(str, “T”)(1), “:”)

Split(str, “T”)(0)　Split(str, “T”)(1)
Split(str, “T”) で「T」で文字列を分割して前半部分をと後半部分にわけています。
すると [ “2023-08-15” , “16:09:21” ] のようなイメージの配列になります。
Split(str, “T”)(0)　が　前半部分の “2023-08-15”
Split(str, “T”)(1)　が　後半部分の “16:09:21”

さらにそれを日付部分は「-」で [ “2023” , “08” , “15” ]に分割。
時刻部分は「：」で [ “16” , “09” , “21” ]に分割。

それぞれ、用意してあった配列dateParts、timePartsに代入します。

DateSerialで年月日の文字列を日付型に変換（CIntで文字列を数値にしていますね）
DateSerial(CInt(dateParts(0)), CInt(dateParts(1)), CInt(dateParts(2)))

TimeSerialで年月日の文字列を日付型に変換（CIntで文字列を数値にしています）
TimeSerial(CInt(TimeParts(0)), CInt(TimeParts(1)), CInt(TimeParts(2)))

このそれぞれの結果を足しています。
連結しているわけではなく足しています。
シリアル値にすると、2023/8/15 16:9:21 は 45153.6731597222 になるようです。
DateSerialの結果 45153 と、TimeSerialの結果 0.6731597222 を足し合わせています。

で、返しています。

（４）正規表現を使った方法

わざわざ正規表現を使わなくってもよいのですが、いま特訓中なので。。。
Microsoft VBScript Regular Expressions 5.5を参照設定しています。

'参照設定：Microsoft VBScript Regular Expressions 5.5

Function strDateToDate(ByVal str As String) As Variant
    
    If Val(Left(str, 4)) < 1900 Then
        strDateToDate = ""
        Exit Function
    End If
    
    '正規表現クラスオブジェクト
    Dim re As RegExp
    Set re = New RegExp
    
    '検索条件設定
    re.Global = True        '検索範囲(True：文字列の最後まで検索）
    re.IgnoreCase = True    '大文字小文字の区別（True：区別しない）
    re.Pattern = "(\d{4})-(\d{2})-(\d{2})T(\d{2}):(\d{2}):(\d{2})"      '検索パターン"
    
    '検索結果を受け取るMatchesコレクション
    Dim Matches As MatchCollection
    Set Matches = re.Execute(str)
    
    '日付時刻型変数でいったん受け取る
    Dim dateTimeValue As Date
    
    If Matches.Count > 0 Then
        Dim match As match
        Set match = Matches.Item(0)
        
        Dim subMatches As Variant
        Set subMatches = match.subMatches
        With subMatches
            dateTimeValue = DateSerial(.Item(0), .Item(1), .Item(2)) + _
                                TimeSerial(.Item(3), .Item(4), .Item(5))
        End With
    End If
    
    strDateToDate = dateTimeValue
End If

こちらも結果は（２）と同じです。

これも途中からの部分はchatGPT先生に聞きました。

解説すると長くなるので割愛します。

苦労したところは、
ヒットしたアイテムの中の一つ目を取り出す
Set Matches = re.Execute(str)

その中からsubMatchesプロパティを取り出すところ
Set match = Matches.Item(0)
Set subMatches = match.subMatches
subMatches.Item(0)
subMatches.Item(1)
・・・

正規表現については自分で書いたこちらを見ながらやりました（もう忘れていた）
https://mwkexcelfriend.com/excel-vba-regexp/