vba:メールを受信時、在席管理へ登録する

Option Explicit

Public Function updateDb(receivedTime, SenderName, body)
On Error GoTo ErrHandler
    
    Dim rdate As Date: rdate = Format$(receivedTime, "yyyy-mm-dd")
    
    Dim wno$:
    wno = Trim(val(getTextValue("社員名：", body)))
    'wno = Trim(val(SenderName))
    
    Dim cn As ADODB.Connection: Set cn = getDbConServer()   'サーバへの接続
    Dim rs As ADODB.Recordset
    Set rs = GFC_GetRs(cn, False, _
        "select ID from [DT]..m社員 where ネットワーク名=?", wno)
    If rs.EOF Then
        rs.Close
        Debug.Print "NOT FOUND : " & receivedTime & SenderName
        
        wno = Trim(val(SenderName))
        
        Set rs = GFC_GetRs(cn, False, _
                  "select ID from [DT]..m社員 where ネットワーク名=?", wno)
        If rs.EOF Then
            rs.Close
            Exit Function
        End If       
    End If
    
    Dim wSid%: wSid% = rs!ID
    rs.Close
    
    Const sql$ = "select * from [ZAI]..外出 where 日付=? and 社員ID=?"
    Set rs = GFC_GetRs(cn, True, sql, CDate(rdate), wSid)
    If rs.EOF Then
        rs.AddNew
        rs!日付 = rdate
        rs!社員ID = wSid
    End If
    
    If getTextValue("出勤欠勤：", body) = "欠勤" Then 'add 2021-1-14
        rs("行先1") = "休み"
        GoTo LBL11
    End If
    
    Debug.Print gNz(rs!外出予定時刻, "")
    If gNz(rs!外出予定時刻, "") = "" Then
        rs!外出予定時刻 = getTextValue("外出予定時刻：", body)
    End If
    If gNz(rs!戻り予定時刻, "") = "" Then
        rs!戻り予定時刻 = getTextValue("戻り予定時刻：", body)
    End If
    
    Dim i
    For i = 1 To 4
        If gNz(rs("行先" & i), "") = "" Then
            rs("行先" & i) = getTextValue("行き先" & i & "：", body)
        End If
        If gNz(rs("目的" & i), "") = "" Then
            rs("目的" & i) = getTextValue("目的" & i & "：", body)
        End If
        If gNz(rs("開始予定時刻" & i), "") = "" Then
            rs("開始予定時刻" & i) = getTextValue("開始時刻" & i & "：", body)
        End If
        If i = 1 Then
            If gNz(rs("備考"), "") = "" Then
                rs("備考") = getTextValue("備考" & i & "：", body)
            End If
        Else
            If gNz(rs("備考" & i), "") = "" Then
                rs("備考" & i) = getTextValue("備考" & i & "：", body)
            End If
        End If
    Next i
LBL11:
    rs!戻り = gNz(rs!戻り, 0)    
    rs.Update
    cn.Close
    Exit Function

ErrHandler:
    Dim erNum: erNum = Err.Number: Dim erMsg$: erMsg = "checkMail:" & Err.Description
    Debug.Print erMsg
    'Err.Raise Number:=erNum, Description:=erMsg
End Function


’Teamsへ通知
’
Public Function PostTemas(pmsg$, uri$)
On Error GoTo ErrHandler
    Debug.Print pmsg$
'HTTPリクエストオブジェクト
    Dim objXmlHttp As Object
    Set objXmlHttp = CreateObject("Microsoft.XMLHTTP")

    'POSTでオープン、、なんか変な感じ
    objXmlHttp.Open "POST", uri$, False

    'httpヘッダの設定
    objXmlHttp.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"

    Const c_msg = "{'text':'$test'}"
    Dim smsg As Variant: smsg = Replace(c_msg, "$test", pmsg$)
    smsg = Replace(smsg, vbCrLf, "<BR>")
    
    'パラメータの送信
    objXmlHttp.Send smsg
    
    'Dim res '返り値のXMLを取得（今回は未使用なのでコメントアウト
    'Set res = objXmlHttp.responseXML
    Exit Function
ErrHandler:
    Dim erNum: erNum = Err.Number: Dim erMsg$: erMsg = "checkMail:" & Err.Description & erNum
    Debug.Print erMsg: Err.Raise Number:=erNum, Description:=erMsg

End Function


’メール文面からパラメタを取得する
’
Public Function getTextValue(findss, tartgets) As String
    Dim rets: rets = InStr(tartgets, findss)
    If rets = 0 Then
        Exit Function
    End If
    rets = rets + Len(findss)
    
    Dim rete: rete = InStr(rets, tartgets, vbCrLf)
    If rete = 0 Then
        getTextValue = Trim(Mid$(tartgets, rets))
    Else
        rete = rete - rets
        getTextValue = Trim(Mid$(tartgets, rets, rete))
    
    End If
End Function