📄 frmquery.frm
字号:
VERSION 5.00
Object = "{A45D986F-3AAF-4A3B-A003-A6C53E8715A2}#1.0#0"; "ARVIEW2.OCX"
Object = "{065E6FD1-1BF9-11D2-BAE8-00104B9E0792}#3.0#0"; "SSA3D30.OCX"
Begin VB.Form frmQuery
BorderStyle = 3 'Fixed Dialog
Caption = "读开门记录"
ClientHeight = 7515
ClientLeft = 45
ClientTop = 330
ClientWidth = 9000
Icon = "frmQuery.frx":0000
LinkTopic = "Form1"
MaxButton = 0 'False
MDIChild = -1 'True
MinButton = 0 'False
ScaleHeight = 7515
ScaleWidth = 9000
ShowInTaskbar = 0 'False
Begin Threed.SSPanel SSPanel1
Height = 7560
Left = 0
TabIndex = 0
Top = 0
Width = 9015
_ExtentX = 15901
_ExtentY = 13335
_Version = 196610
PictureBackgroundStyle= 2
BevelInner = 1
RoundedCorners = 0 'False
FloodShowPct = -1 'True
Begin Threed.SSCheck chkNew
Height = 255
Left = 3120
TabIndex = 7
Top = 420
Width = 735
_ExtentX = 1296
_ExtentY = 450
_Version = 196610
BackStyle = 1
Caption = "新锁"
Value = 1
End
Begin VB.ComboBox cboArea
Height = 300
Left = 4440
TabIndex = 5
Top = 360
Width = 1815
End
Begin Threed.SSCommand cmdIssue
Height = 465
Left = 360
TabIndex = 1
Top = 240
Width = 1095
_ExtentX = 1931
_ExtentY = 820
_Version = 196610
PictureFrames = 1
BackStyle = 1
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "宋体"
Size = 9.75
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Picture = "frmQuery.frx":000C
Caption = "读卡"
Alignment = 4
ButtonStyle = 3
PictureAlignment= 1
End
Begin DDActiveReportsViewer2Ctl.ARViewer2 arv
Height = 6495
Left = 240
TabIndex = 2
Top = 840
Width = 8535
_ExtentX = 15055
_ExtentY = 11456
SectionData = "frmQuery.frx":08E6
End
Begin Threed.SSCommand cmdUpdate
Height = 465
Left = 1680
TabIndex = 3
Top = 240
Width = 1185
_ExtentX = 2090
_ExtentY = 820
_Version = 196610
PictureFrames = 1
BackStyle = 1
Enabled = 0 'False
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "宋体"
Size = 9.75
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Picture = "frmQuery.frx":0922
Caption = "保存记录"
Alignment = 4
ButtonStyle = 3
PictureAlignment= 1
End
Begin VB.Label Label1
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "单位"
BeginProperty Font
Name = "宋体"
Size = 9.75
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 195
Left = 3960
TabIndex = 6
Top = 480
Width = 390
End
Begin VB.Label Label5
BackStyle = 0 'Transparent
Caption = "Label5"
ForeColor = &H000000FF&
Height = 255
Left = 6360
TabIndex = 4
Top = 360
Width = 2175
End
End
End
Attribute VB_Name = "frmQuery"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim bShowread As Boolean
Dim strNum As Long
Dim Range As Long
Private Sub cmdIssue_Click()
On Error Resume Next
Dim i As Integer
Dim strEmpty As Boolean
Dim cAL As New rsclsAddLock
Dim bndAL As New BindingCollection
If cboArea.Text = "" Then
StatusShow ("请选择使用单位")
Exit Sub
End If
With bndAL
.DataMember = ""
Set .DataSource = cAL
End With
If cAL.RecordCount = 0 Then
StatusShow ("没有开门卡登记")
strEmpty = True
Else
strEmpty = False
End If
captionShow
Dim card As New JalTM.datacard
Dim kcol(0 To 320, 0 To 1) As String
With card
If chkNew.Value = -1 Then
.ISVIP = True
Else
.ISVIP = False
End If
.tread
If .sGetRecordList(kcol()) Then
End If
strNum = .cnt - 1
End With
For i = 0 To 127
If kcol(i, 1) = "" Then
Range = i
Exit For
Else
Range = i
End If
Next
If Range < 1 Then
Exit Sub
End If
Dim tempC As Variant '**********************
Dim tempD As Variant '**********************
Dim h As Integer '***************************
Dim f As Boolean '****************************
Dim tempB As Variant '****************************
ReDim colKR(0 To Range)
For i = 0 To Range - 1
colKR(i).ID = i
tempC = Hex(kcol(i, 0)) '****************
colKR(i).CardNo = tempC '******************
While Len(Trim(tempC)) < 6
tempC = "0" + tempC
Wend
If Not Mid(tempC, 1, 2) = "00" Then
f = True 'key siere number
tempD = Mid(tempC, 5, 2) & Mid(tempC, 3, 2) & Mid(tempC, 1, 2)
Else
f = False
End If
'****************************************************************************
If chkNew.Value = -1 Then
colKR(i).KDatetime = BCDToDate(kcol(i, 1))
Else
colKR(i).KDatetime = BCDToDate1(kcol(i, 1))
End If
colKR(i).CardType = getCardType(kcol(i, 0))
If strEmpty = True Then
colKR(i).UserName = "未登记"
colKR(i).LockArea = cboArea.Text
colKR(i).LockID = "未登记"
Else
If Not cAL.BOF Then
cAL.MoveFirst
Else
End If
If cAL.FindLockNO(Hex(kcol(i, 0))) Then
If cAL.LockArea = Trim(cboArea.Text) Then
colKR(i).UserName = cAL.UserName
colKR(i).LockArea = cboArea.Text
colKR(i).LockID = cAL.LockID
Else
colKR(i).UserName = "未登记"
colKR(i).LockArea = cboArea.Text
colKR(i).LockID = cAL.LockID
End If
Else
colKR(i).UserName = "未登记"
colKR(i).LockArea = cboArea.Text
colKR(i).LockID = "未登记"
End If
End If
' ************************************************
If f Then
colKR(i).CardType = "TM卡序列号"
If Not cAL.BOF Then
cAL.MoveFirst
Else
End If
For h = 1 To cAL.RecordCount
tempB = Mid(cAL.LockID, 11, 6)
If (tempB = tempD) Then
colKR(i).UserName = cAL.UserName
colKR(i).LockID = cAL.LockID
colKR(i).LockArea = cAL.LockArea
Else
' Dim card2 As New JalTM.tmreadtype
' card2.treadtype
' colKR(i).LockID = card2.romid
End If
cAL.MoveNext
Next h
Else
End If
' ************************************************
Next i
If bShowread Then
Unload rptLock
bShowread = False
End If
Load rptLock
AddLockArea
rptLock.fNO = strNum
Set arv.ReportSource = rptLock
bShowread = True
cmdUpdate.Enabled = True
Label5.Caption = ""
Set cAL = Nothing
Set bndAL = Nothing
Set card2 = Nothing
'<EhFooter>
Exit Sub
End Sub
Public Function getCardType(ByVal CardNo As Long) As String
If CardNo = 0 Then
getCardType = "磁卡"
ElseIf CardNo > 0 And CardNo < 13654 Then
getCardType = "普通开门卡"
ElseIf CardNo > 16383 And CardNo < 17750 Then
getCardType = "报警开门卡"
ElseIf CardNo > 20991 And CardNo < 21503 Then
getCardType = "组合开门卡"
Else
getCardType = "未知卡类"
End If
End Function
Public Function getCardType1(ByVal CardNo As Long) As String
If CardNo = 0 Then
getCardType1 = "磁卡"
ElseIf CardNo > 0 And CardNo < 13654 Then
getCardType1 = "普通开门卡"
ElseIf CardNo > 16383 And CardNo < 17750 Then
getCardType1 = "报警开门卡"
ElseIf CardNo > 20991 And CardNo < 21503 Then
getCardType1 = "组合开门卡"
Else
getCardType1 = "未知卡类"
End If
End Function
Public Function BCDToDate(ByVal strBCD As String) As String
On Error GoTo strError
If Len(strBCD) <> 10 Then
BCDToDate = "--------------------"
Exit Function
End If
Dim i As Integer
For i = 1 To 10
If Val("&h" & Mid(strBCD, i, 1)) > 9 Then
BCDToDate = "--------------------"
Exit Function
End If
Next
Dim strYear As String
Dim strMonth As String
Dim strday As String
Dim strhour As String
Dim strminute As String
Dim strSecond As String
strYear = Mid(strBCD, 1, 2)
strMonth = Mid(strBCD, 3, 2)
strday = Mid(strBCD, 5, 2)
strhour = Mid(strBCD, 7, 2)
strminute = Mid(strBCD, 9, 2)
strSecond = "00"
Dim strtemp As String
strtemp = "20" & strYear & "-" & strMonth & "-" & strday & " " & _
strhour & ":" & strminute & ":" & strSecond
' BCDToDate = strtemp
If strtemp = "2000-00-00 00:00:00" Then
BCDToDate = 0
Else
BCDToDate = CDate(strtemp)
End If
Exit Function
strError:
BCDToDate = "---------------------"
Exit Function
End Function
Public Function BCDToDate1(ByVal strBCD As String) As String
On Error GoTo strError
If Len(strBCD) <> 12 Then
BCDToDate1 = "--------------------"
Exit Function
End If
Dim i As Integer
For i = 1 To 13
If Val("&h" & Mid(strBCD, i, 1)) > 9 Then
BCDToDate1 = "--------------------"
Exit Function
End If
Next
Dim strYear As String
Dim strMonth As String
Dim strday As String
Dim strhour As String
Dim strminute As String
Dim strSecond As String
strYear = Mid(strBCD, 1, 2)
strMonth = Mid(strBCD, 3, 2)
strday = Mid(strBCD, 5, 2)
strhour = Mid(strBCD, 7, 2)
strminute = Mid(strBCD, 9, 2)
strSecond = Mid(strBCD, 11, 2)
Dim strtemp As String
strtemp = "20" & strYear & "-" & strMonth & "-" & strday & " " & _
strhour & ":" & strminute & ":" & strSecond
' BCDToDate = strtemp
If strtemp = "2000-00-00 00:00:00" Then
BCDToDate1 = 0
Else
BCDToDate1 = CDate(strtemp)
End If
Exit Function
strError:
BCDToDate1 = "---------------------"
Exit Function
End Function
Private Sub captionShow()
Label5.Caption = "读数据卡，请稍后..."
Label5.Refresh
End Sub
Private Sub cmdUpdate_Click()
On Error Resume Next
Dim cLI As New rsclsLockInfo
Dim bndLI As New BindingCollection
Dim i As Integer
With bndLI
.DataMember = "new"
Set .DataSource = cLI
End With
With cLI
For i = 0 To Range - 1
.AddRecord
.LockTime = colKR(i).KDatetime
.LockID = colKR(i).LockID
.LockNO = colKR(i).CardNo
.LockType = colKR(i).CardType
.LockArea = colKR(i).LockArea
.UserName = colKR(i).UserName
.UpdateBatch
Next i
End With
StatusShow ("保存记录完毕")
Set cLI = Nothing
Set bndLI = Nothing
End Sub
Private Sub Form_Load()
Me.Top = (mainForm.ScaleHeight - Me.Height) / 2
Me.Left = (mainForm.ScaleWidth - Me.Width) / 2
SSPanel1.PictureBackground = mainForm.Pic.Picture
SSPanel1.PictureBackgroundStyle = ssTiled
AddLockArea
Label5.Caption = ""
Label5.Refresh
End Sub
Private Sub AddLockArea()
Dim cAA As New rsclsAddLockArea
Dim bndAA As New BindingCollection
Dim i As Integer
On Error Resume Next
With bndAA
.DataMember = ""
Set .DataSource = cAA
End With
If cAA.RecordCount = 0 Then
StatusShow ("使用单位没有登记")
Set cAA = Nothing
Set bndAA = Nothing
Exit Sub
End If
Dim rsLockArea As ADODB.Recordset
Set rsLockArea = cAA.getRSLockArea
For i = 1 To rsLockArea.RecordCount
cboArea.AddItem rsLockArea.Fields(0).Value
rsLockArea.MoveNext
Next i
Set cAA = Nothing
Set bndAA = Nothing
Set rsLockArea = Nothing
Exit Sub
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -