0byt3m1n1
Path:
C:
/
BACKUPS
/
Biometric Backup
/
KELTRON
/
COSEC V14R4.1
/
Setup
/
API Samples
/
VB 6.0
/
[
Home
]
File: apiHelper.cls
VERSION 1.0 CLASS BEGIN MultiUse = -1 'True Persistable = 0 'NotPersistable DataBindingBehavior = 0 'vbNone DataSourceBehavior = 0 'vbNone MTSTransactionMode = 0 'NotAnMTSObject END Attribute VB_Name = "apiHelper" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = True Attribute VB_PredeclaredId = False Attribute VB_Exposed = False Attribute VB_Ext_KEY = "SavedWithClassBuilder6" ,"Yes" Attribute VB_Ext_KEY = "Top_Level" ,"Yes" Public strORG As String Public strBRC As String Public strDPT As String Public strSEC As String Public strGRD As String Public strCTG As String Public strDSG As String Public strUser As String Public Enum DataFormat Text xml End Enum Public Enum DeviceListOption All Panel Door Group End Enum Public Enum HTTPOperation Request response ErrorResponse End Enum Public Event HttpOperations(operation As HTTPOperation, Data As String) Public BaseAddress As String Public LoginID As String Public Password As String Private Function HTTPRequest(Url As String) As APIResponse Dim apiresponseobj As New APIResponse Dim HttpClientObj As New HttpClient On Error GoTo RequestError HttpClientObj.username = LoginID HttpClientObj.Password = Password RaiseEvent HttpOperations(Request, BaseAddress + "/" + Url) Dim checkdata As Boolean If (HttpClientObj.HttpGet(BaseAddress + "/" + Url)) Then apiresponseobj.Data = HttpClientObj.ResponseText checkdata = True Else checkdata = False apiresponseobj.Data = HttpClientObj.StatusText End If RaiseEvent HttpOperations(response, apiresponseobj.Data) If (apiresponseobj.Data <> "" And checkdata = True) Then If (InStr(apiresponseobj.Data, "success:") = 1 Or InStr(apiresponseobj.Data, "failed:") = 1) Then If (InStr(apiresponseobj.Data, "success:") = 1) Then apiresponseobj.IsSuccess = True End If Dim tmpMsg As String tmpMsg = Mid(apiresponseobj.Data, InStr(apiresponseobj.Data, ":") + 1) apiresponseobj.SuccessFailMessage = tmpMsg apiresponseobj.Data = "" Else If (InStr(apiresponseobj.Data, "<?xml") = 1 Or InStr(apiresponseobj.Data, "<NewDataSet") = 1 Or InStr(apiresponseobj.Data, "<Document") = 1) Then apiresponseobj.IsSuccess = True apiresponseobj.Format = xml Else apiresponseobj.IsSuccess = True apiresponseobj.Format = Text End If End If Else apiresponseobj.IsSuccess = False End If Set HTTPRequest = apiresponseobj Exit Function RequestError: RaiseEvent HttpOperations(ErrorResponse, err.Description) End Function Public Function Ping(ByRef Error As String) As Boolean Error = "" Dim apiresponseobj As APIResponse Set apiresponseobj = HTTPRequest("") If (apiresponseobj.IsSuccess = False) Then Error = apiresponseobj.SuccessFailMessage Ping = False Else strORG = "Organization" strBRC = "Branch" strDPT = "Department" strSEC = "Section" strCTG = "Category" strGRD = "Grade" strDSG = "Designation" strUser = "User" Dim strORGCode As String Dim strBRCCode As String Dim strDPTCode As String Dim strSECCode As String Dim strCTGCode As String Dim strGRDCode As String Dim strDSGCode As String Dim strUserCode As String strORGCode = "ORG" strBRCCode = "BRC" strDPTCode = "DPT" strSECCode = "SEC" strCTGCode = "CTG" strGRDCode = "GRD" strDSGCode = "DSG" strUserCode = "USR" Dim APIResponse As APIResponse Set APIResponse = GetGroupNameList(xml) If (Not APIResponse Is Nothing) Then If (Trim(APIResponse.Data) <> "") Then 'If (apiResponse.Format = xml) Then Dim rs As ADODB.Recordset Set rs = Form1.apiHelperObj.RecordSetFromXMLString(APIResponse.Data) While rs.EOF = False Dim strcode As String strcode = rs("code") Select Case (UCase(strcode)) Case strORGCode: strORG = rs("aliasName") Case strBRCCode: strBRC = rs("aliasName") Case strDPTCode: strDPT = rs("aliasName") Case strSECCode: strSEC = rs("aliasName") Case strGRDCode: strGRD = rs("aliasName") Case strCTGCode: strCTG = rs("aliasName") Case strDSGCode: strDSG = rs("aliasName") Case strUserCode: strUser = rs("aliasName") End Select rs.MoveNext Wend rs.Close Set rs = Nothing 'End If End If If (APIResponse.IsSuccess) Then If (Trim(APIResponse.SuccessFailMessage) = "") Then Form1.ShowMessage "Request completed", True Else Form1.ShowMessage APIResponse.SuccessFailMessage, True End If Else Form1.ShowMessage APIResponse.SuccessFailMessage, False End If End If Ping = True End If End Function Public Function SaveUser(objUserParam As UserAPIParameters) As APIResponse Dim actionURL As String actionURL = strUser + "?action=set" actionURL = actionURL + ";id=" + objUserParam.id If (objUserParam.reference_code <> "") Then actionURL = actionURL + ";reference-code=" + objUserParam.reference_code End If actionURL = actionURL + ";name=" + objUserParam.username If (objUserParam.short_name <> "") Then actionURL = actionURL + ";short-name=" + objUserParam.short_name End If If (objUserParam.active <> "") Then actionURL = actionURL + ";active=" + objUserParam.active End If If (objUserParam.date_of_birth <> "") Then actionURL = actionURL + ";date-of-birth=" + objUserParam.date_of_birth End If If (objUserParam.official_phone <> "") Then actionURL = actionURL + ";official-phone=" + objUserParam.official_phone End If If (objUserParam.official_extension <> "") Then actionURL = actionURL + ";official-extension=" + objUserParam.official_extension End If If (objUserParam.official_cell <> "") Then actionURL = actionURL + ";official-cell=" + objUserParam.official_cell End If If (objUserParam.official_email <> "") Then actionURL = actionURL + ";official-email=" + objUserParam.official_email End If If (objUserParam.pin <> "") Then actionURL = actionURL + ";pin=" + objUserParam.pin End If If (objUserParam.card_1 <> "") Then If (objUserParam.card_1 = "0") Then actionURL = actionURL + ";card-1=" Else actionURL = actionURL + ";card-1=" + objUserParam.card_1 End If End If If (objUserParam.card_2 <> "") Then If (objUserParam.card_2 = "0") Then actionURL = actionURL + ";card-2=" Else actionURL = actionURL + ";card-2=" + objUserParam.card_2 End If End If If (objUserParam.access_validity_date <> "") Then actionURL = actionURL + ";access-validity-date=" + objUserParam.access_validity_date End If If (objUserParam.organization <> "") Then actionURL = actionURL + ";" + strORG + "=" + objUserParam.organization If (objUserParam.branch <> "") Then actionURL = actionURL + ";" + strBRC + "=" + objUserParam.branch If (objUserParam.department <> "") Then actionURL = actionURL + ";" + strDPT + "=" + objUserParam.department If (objUserParam.designation <> "") Then actionURL = actionURL + ";" + strDSG + "=" + objUserParam.designation If (objUserParam.section <> "") Then actionURL = actionURL + ";" + strSEC + "=" + objUserParam.section If (objUserParam.category <> "") Then actionURL = actionURL + ";" + strCTG + "=" + objUserParam.category If (objUserParam.grade <> "") Then actionURL = actionURL + ";" + strGRD + "=" + objUserParam.grade Set SaveUser = HTTPRequest(actionURL) End Function Public Function GetUser(UserID As String, ByRef err As String) As UserAPIParameters Dim actionURL As String actionURL = strUser + "?action=get;id=" + UserID + ";format=xml" Dim resultData As APIResponse Set resultData = HTTPRequest(actionURL) Dim objUserAPIParam As New UserAPIParameters If (resultData.Format = xml) Then Dim rs As New ADODB.Recordset Set rs = RecordSetFromXMLString(resultData.Data) If (rs.EOF = False) Then objUserAPIParam.id = rs("id") objUserAPIParam.reference_code = rs("reference-code") objUserAPIParam.username = rs("name") objUserAPIParam.short_name = rs("short-name") objUserAPIParam.active = rs("active") objUserAPIParam.date_of_birth = rs("date-of-birth") objUserAPIParam.official_phone = rs("official-phone") objUserAPIParam.official_extension = rs("official-extension") objUserAPIParam.official_cell = rs("official-cell") objUserAPIParam.official_email = rs("official-email") objUserAPIParam.pin = rs("pin") objUserAPIParam.card_1 = rs("card-1") objUserAPIParam.card_2 = rs("card-2") objUserAPIParam.access_validity_date = rs("access-validity-date") objUserAPIParam.organization = rs(strORG) objUserAPIParam.branch = rs(strBRC) objUserAPIParam.department = rs(strDPT) objUserAPIParam.designation = rs(strDSG) objUserAPIParam.section = rs(strSEC) objUserAPIParam.category = rs(strCTG) objUserAPIParam.grade = rs(strGRD) objUserAPIParam.device = rs("device") Set GetUser = objUserAPIParam End If If (Not rs Is Nothing) Then rs.Close End If End If err = resultData.SuccessFailMessage End Function Public Function GetGroupNameList(Format As DataFormat) As APIResponse Dim resultData As APIResponse Dim formatstr As String If Format = Text Then formatstr = "text" Else formatstr = "xml" End If Set resultData = HTTPRequest("group-rename-list?action=get;format=" + formatstr) Set GetGroupNameList = resultData End Function Public Function GetOrganization(Format As DataFormat) As APIResponse Dim resultData As APIResponse Dim formatstr As String If Format = Text Then formatstr = "text" Else formatstr = "xml" End If Set resultData = HTTPRequest(strORG + "?action=get;format=" + formatstr) Set GetOrganization = resultData End Function Public Function GetBranch(Format As DataFormat) As APIResponse Dim resultData As APIResponse Dim formatstr As String If Format = Text Then formatstr = "text" Else formatstr = "xml" End If Set resultData = HTTPRequest(strBRC + "?action=get;format=" + formatstr) Set GetBranch = resultData End Function Public Function GetDepartment(Format As DataFormat) As APIResponse Dim resultData As APIResponse Dim formatstr As String If Format = Text Then formatstr = "text" Else formatstr = "xml" End If Set resultData = HTTPRequest(strDPT + "?action=get;format=" + formatstr) Set GetDepartment = resultData End Function Public Function GetDesignation(Format As DataFormat) As APIResponse Dim resultData As APIResponse Dim formatstr As String If Format = Text Then formatstr = "text" Else formatstr = "xml" End If Set resultData = HTTPRequest(strDSG + "?action=get;format=" + formatstr) Set GetDesignation = resultData End Function Public Function GetSection(Format As DataFormat) As APIResponse Dim resultData As APIResponse Dim formatstr As String If Format = Text Then formatstr = "text" Else formatstr = "xml" End If Set resultData = HTTPRequest(strSEC + "?action=get;format=" + formatstr) Set GetSection = resultData End Function Public Function GetCategory(Format As DataFormat) As APIResponse Dim resultData As APIResponse Dim formatstr As String If Format = Text Then formatstr = "text" Else formatstr = "xml" End If Set resultData = HTTPRequest(strCTG + "?action=get;format=" + formatstr) Set GetCategory = resultData End Function Public Function GetGrade(Format As DataFormat) As APIResponse Dim resultData As APIResponse Dim formatstr As String If Format = Text Then formatstr = "text" Else formatstr = "xml" End If Set resultData = HTTPRequest(strGRD + "?action=get;format=" + formatstr) Set GetGrade = resultData End Function Public Function GetDevice(listOption As DeviceListOption, Format As DataFormat) As APIResponse Dim resultData As APIResponse Dim formatstr As String If Format = Text Then formatstr = "text" Else formatstr = "xml" End If Dim lstOptStr As String If (listOption = All) Then lstOptStr = "all" ElseIf (listOption = Door) Then lstOptStr = "door" ElseIf (listOption = Group) Then lstOptStr = "group" ElseIf (listOption = Panel) Then lstOptStr = "panel" End If Set resultData = HTTPRequest("device?action=get;type=" + lstOptStr + ";format=" + formatstr) Set GetDevice = resultData End Function Public Function AssignDevice(device As String, id As String) As APIResponse Dim resultData As APIResponse Set resultData = HTTPRequest("device?action=assign;device=" + device + ";id=" + id) Set AssignDevice = resultData End Function Public Function RevokeDevice(device As String, id As String) As APIResponse Dim resultData As APIResponse Set resultData = HTTPRequest("device?action=revoke;device=" + device + ";id=" + id) Set RevokeDevice = resultData End Function Public Function GetEventACS(index As Long, count As Long, Format As DataFormat) As APIResponse Dim formatstr As String If Format = Text Then formatstr = "text" Else formatstr = "xml" End If Dim resultData As APIResponse Set resultData = HTTPRequest("event-acs?action=get;index=" + CStr(index) + ";count=" + CStr(count) + ";format=" + formatstr) Set GetEventACS = resultData End Function Public Function GetEventTA(index As Long, count As Long, Format As DataFormat) As APIResponse Dim formatstr As String If Format = Text Then formatstr = "text" Else formatstr = "xml" End If Dim resultData As APIResponse Set resultData = HTTPRequest("event-ta?action=get;index=" + CStr(index) + ";count=" + CStr(count) + ";format=" + formatstr) Set GetEventTA = resultData End Function Public Function GetAttendanceDaily(fromDate As String, toDate As String, range As String, id As String, Format As DataFormat) As APIResponse Dim actionURL As String Dim formatstr As String If Format = Text Then formatstr = "text" Else formatstr = "xml" End If If (range <> "all") Then actionURL = "attendance-daily?action=get;date-range=" + fromDate + "-" + toDate + ";range=" + range + ";id=" + id + ";format=" + formatstr Else actionURL = "attendance-daily?action=get;date-range=" + fromDate + "-" + toDate + ";range=" + range + ";format=" + formatstr End If Dim resultData As APIResponse Set resultData = HTTPRequest(actionURL) Set GetAttendanceDaily = resultData End Function Public Function GetAttendanceMonthly(month As Integer, year As Integer, range As String, id As String, dtformat As DataFormat) As APIResponse Dim actionURL As String Dim formatstr As String If dtformat = Text Then formatstr = "text" Else formatstr = "xml" End If If (range <> "all") Then actionURL = "attendance-monthly?action=get;month-year=" + Format(month, "0#") + Format(year, "000#") + ";range=" + range + ";id=" + id + ";format=" + formatstr Else actionURL = "attendance-monthly?action=get;month-year=" + Format(month, "0#") + Format(year, "000#") + ";range=" + range + ";format=" + formatstr End If Dim resultData As APIResponse Set resultData = HTTPRequest(actionURL) Set GetAttendanceMonthly = resultData End Function Public Function RecordSetFromXMLString(xmlStr As String) As ADODB.Recordset Dim docResponse As MSXML2.DOMDocument Dim nlstTable As MSXML2.IXMLDOMNodeList Dim lngRow As Long Dim lngCol As Long Set docResponse = New MSXML2.DOMDocument With docResponse .async = False .loadXML xmlStr .setProperty "SelectionLanguage", "XPath" 'Set nlstTable = .selectNodes("") End With Dim rs As New ADODB.Recordset rs.ActiveConnection = Nothing rs.CursorLocation = adUseClient rs.LockType = adLockBatchOptimistic Dim tableName As String tableName = docResponse.documentElement.firstChild.nodeName Dim item As MSXML2.IXMLDOMElement Dim x As Integer For x = 1 To docResponse.documentElement.firstChild.childNodes.length Set item = docResponse.documentElement.firstChild.childNodes.item(x - 1) rs.fields.Append item.nodeName, adVarChar, 200 Next rs.open Dim y As Integer Dim colitem As MSXML2.IXMLDOMElement For x = 1 To docResponse.documentElement.childNodes.length Set item = docResponse.documentElement.childNodes.item(x - 1) rs.AddNew For y = 1 To item.childNodes.length Set colitem = item.childNodes(y - 1) rs.fields(colitem.nodeName) = colitem.Text Next rs.Update Next rs.MoveFirst Set RecordSetFromXMLString = rs End Function