Option Compare Database

'======================================
' Main 処理
'======================================
Sub Main()

    '変数
    Dim strHTML As String
    Dim arField()
    Dim DisplayMessage As String

    '定数
    Const strGetURL As String = "http://pc.undo.jp/DspDB_Sample.cgi"
    Const strUpdURL As String = "http://pc.undo.jp/UpdDB_Sample.cgi?myID="
    Const DebugSW As Byte = 1

    strHTML = HttpGetText(strGetURL) 'HTTP結果取得

    DisplayMessage = Bunkai(strHTML, arField) '分解処理

    If DebugSW = 1 Then MsgBox DisplayMessage 'デバッグモードは結果を表示

    '解り易いように個別表示
    MsgBox arField(0, 0) & "=" & arField(1, 0) 'ID
    MsgBox arField(0, 1) & "=" & arField(1, 1) 'TITLE
    MsgBox arField(0, 2) & "=" & arField(1, 2) 'LastDate
    MsgBox arField(0, 3) & "=" & arField(1, 3) 'EndDate
    MsgBox arField(0, 4) & "=" & arField(1, 4) 'Times
    MsgBox arField(0, 5) & "=" & arField(1, 5) 'Sumi

    '処理済に更新しておく
    strHTML = HttpGetText(strUpdURL & arField(1, 0)) '処理済のIDを更新対象にする

    If DebugSW = 1 Then MsgBox strHTML

End Sub

'======================================
' HTTP 処理
'======================================
Function HttpGetText(ByVal strURL As String) As String

    Dim oHttp As Object
    Dim sHTML As String

    'Object作成
    Set oHttp = CreateObject("MSXML2.XMLHTTP")

    'HTML呼び出し(GET)
    oHttp.Open "GET", strURL, False
    oHttp.Send

    'HTMLの取り出し
    sHTML = oHttp.responseText

    'オブジェクトの参照終了
    Set oHttp = Nothing

    'HTML受信
    HttpGetText = sHTML

End Function

'======================================
' 分解処理
'======================================
Function Bunkai(strTEXT, arField) As String

    Dim arWork As Variant '項目名=値の集まり
    Dim arData As Variant '0=項目名,1=値
    Dim N1 As Integer     'カウンター
    Dim N2 As Integer     'カウンター
    Dim DisplayMessage As String '確認用メッセージ

    arWork = Split(strTEXT, "<>") '項目毎に"<>"で分割

    For N1 = LBound(arWork) To UBound(arWork) - 1 '全ての項目を処理する
        ReDim Preserve arField(1, N1)   '項目名と値の配列を用意
        arData = Split(arWork(N1), "=") '項目を項目名と値に"="で分解
        For N2 = LBound(arData) To UBound(arData)
            If N2 = 0 Then arField(0, N1) = arData(0) '先頭は項目名
            If N2 > 0 Then arField(1, N1) = arField(1, N1) & arData(N2) '先頭以外は値
        Next
        DisplayMessage = DisplayMessage & "項目名:" & arField(0, N1) & vbCrLf
        DisplayMessage = DisplayMessage & "項目値:" & arField(1, N1) & vbCrLf & vbCrLf
    Next

    Bunkai = DisplayMessage

End Function