其他数据库

开发平台：
Visual Basic

BatchSetup.frm：源码内容
							VERSION 5.00
Object = "{6B7E6392-850A-101B-AFC0-4210102A8DA7}#1.3#0"; "COMCTL32.OCX"
Begin VB.Form frmNewCard 
   BackColor       =   &H00C0C0C0&
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "发新卡"
   ClientHeight    =   5295
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   5790
   BeginProperty Font 
      Name            =   "宋体"
      Size            =   10.5
      Charset         =   134
      Weight          =   400
      Underline       =   0   'False
      Italic          =   0   'False
      Strikethrough   =   0   'False
   EndProperty
   Icon            =   "BatchSetup.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   5295
   ScaleWidth      =   5790
   StartUpPosition =   1  '所有者中心
   Begin ComctlLib.StatusBar sbrState 
      Align           =   2  'Align Bottom
      Height          =   315
      Left            =   0
      TabIndex        =   17
      Top             =   4980
      Width           =   5790
      _ExtentX        =   10213
      _ExtentY        =   556
      SimpleText      =   ""
      _Version        =   327682
      BeginProperty Panels {0713E89E-850A-101B-AFC0-4210102A8DA7} 
         NumPanels       =   1
         BeginProperty Panel1 {0713E89F-850A-101B-AFC0-4210102A8DA7} 
            Object.Width           =   10372
            MinWidth        =   10372
            Key             =   "State"
            Object.Tag             =   ""
            Object.ToolTipText     =   "状态提示"
         EndProperty
      EndProperty
      BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
         Name            =   "宋体"
         Size            =   9
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
   End
   Begin VB.Frame fraSetup 
      BeginProperty Font 
         Name            =   "宋体"
         Size            =   9
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   4590
      Left            =   210
      TabIndex        =   10
      Top             =   120
      Width           =   3915
      Begin VB.TextBox txtName 
         Height          =   345
         Left            =   2370
         TabIndex        =   4
         Top             =   2550
         Width           =   1245
      End
      Begin VB.TextBox txtPassWord 
         Height          =   345
         IMEMode         =   3  'DISABLE
         Left            =   2385
         MaxLength       =   6
         PasswordChar    =   "*"
         TabIndex        =   5
         Text            =   "b62307"
         Top             =   3345
         Width           =   1245
      End
      Begin VB.TextBox txtNewPassWord 
         Height          =   345
         Left            =   2385
         MaxLength       =   6
         TabIndex        =   7
         Top             =   3855
         Visible         =   0   'False
         Width           =   1245
      End
      Begin VB.CheckBox chkChangePass 
         Caption         =   "更改密码"
         Enabled         =   0   'False
         Height          =   315
         Left            =   285
         TabIndex        =   6
         Top             =   3870
         Width           =   1230
      End
      Begin VB.TextBox txtSetup 
         Enabled         =   0   'False
         Height          =   345
         Index           =   3
         Left            =   2370
         MaxLength       =   5
         TabIndex        =   3
         Text            =   "0"
         Top             =   1875
         Width           =   1245
      End
      Begin VB.TextBox txtSetup 
         Enabled         =   0   'False
         Height          =   345
         Index           =   2
         Left            =   2370
         MaxLength       =   3
         TabIndex        =   2
         Text            =   "0"
         Top             =   1395
         Width           =   1245
      End
      Begin VB.TextBox txtSetup 
         Height          =   345
         Index           =   1
         Left            =   2370
         MaxLength       =   4
         TabIndex        =   1
         Top             =   825
         Width           =   1245
      End
      Begin VB.TextBox txtSetup 
         Enabled         =   0   'False
         Height          =   345
         Index           =   0
         Left            =   2370
         MaxLength       =   4
         TabIndex        =   0
         Text            =   "WZMG"
         Top             =   345
         Width           =   1245
      End
      Begin VB.Label lblSetup 
         AutoSize        =   -1  'True
         Caption         =   "姓名："
         Height          =   210
         Index           =   4
         Left            =   285
         TabIndex        =   18
         Top             =   2617
         Width           =   630
      End
      Begin VB.Label lblNewPassWord 
         AutoSize        =   -1  'True
         Caption         =   "新密码:"
         Height          =   210
         Left            =   1575
         TabIndex        =   16
         Top             =   3915
         Visible         =   0   'False
         Width           =   735
      End
      Begin VB.Label lblPassWord 
         AutoSize        =   -1  'True
         Caption         =   "IC卡校验密码:"
         Height          =   210
         Left            =   285
         TabIndex        =   15
         Top             =   3405
         Width           =   1365
      End
      Begin VB.Label lblSetup 
         AutoSize        =   -1  'True
         Caption         =   "交易数据(0-65535):"
         Height          =   210
         Index           =   3
         Left            =   285
         TabIndex        =   14
         Top             =   1935
         Width           =   1890
      End
      Begin VB.Label lblSetup 
         AutoSize        =   -1  'True
         Caption         =   "状态代码(0-255):"
         Height          =   210
         Index           =   2
         Left            =   285
         TabIndex        =   13
         Top             =   1455
         Width           =   1680
      End
      Begin VB.Label lblSetup 
         AutoSize        =   -1  'True
         Caption         =   "个人代码(4个字符):"
         Height          =   210
         Index           =   1
         Left            =   285
         TabIndex        =   12
         Top             =   885
         Width           =   1890
      End
      Begin VB.Label lblSetup 
         AutoSize        =   -1  'True
         Caption         =   "IC卡代码(4个字符):"
         Height          =   210
         Index           =   0
         Left            =   285
         TabIndex        =   11
         Top             =   405
         Width           =   1890
      End
   End
   Begin VB.CommandButton cmdExit 
      Caption         =   "退出(&X)"
      Height          =   420
      Left            =   4380
      TabIndex        =   9
      Top             =   780
      Width           =   1155
   End
   Begin VB.CommandButton cmdWrite 
      Caption         =   "写卡(&W)"
      Height          =   420
      Left            =   4380
      TabIndex        =   8
      Top             =   240
      Width           =   1125
   End
End
Attribute VB_Name = "frmNewCard"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Const CID = 0
Const PID = 1
Const SID = 2
Const DATA = 3
Const Emp_Name = 4
'Public mblnIsBatch As Boolean
Const mstrParaErr = "写卡参数不能为空,请输入!"
Const mstrDataErr = "交易数据超出范围(0-65535)!,请重输!"
Const mstrWriteErr = "写卡错误"
Const mstrCIDErr = "IC卡代码必须是4个字符!"
Const mstrPIDErr = "个人代码必须是4个字符!"
Const mstrSIDErr = "状态代码超出范围(0-255)!,请重输!"
Const mstrPSWErr = "IC卡检验密码必须是6个字符!"
Const mstrNoCardErr = "无卡,请插入卡后再操作!"
Const mstrPowerOnErr = "无法上电,请检查电源及其他相关硬件后,再试!"
Const mstrCheckPSWErr = "校验密码不正确"
Const mstrWriteMainErr = "写主存储区错误"
Const mstrChgPswErr = "更改密码错误"
Const mstrReadMainErr = "读主存储区错误"
Const mstrCheckDataErr = "所读数据与所写数据不同错误"
Const mstrSuccessMsg = "写卡成功,请取出卡!"
Const mstrPSWCheck = "检查密码..."
Const mstrWMainCheck = "写主存储区..."
Const mstrRMainCheck = "读主存储区..."
Const mstrChgPSWCheck = "更改密码..."
'Const mstrWriteToDatabase = "正在写数据库..."
Const mstrReady = "等待开始写卡..."
Private Sub chkChangePass_Click()
    If chkChangePass.Value = 1 Then
        lblNewPassWord.Visible = True
        txtNewPassWord.Visible = True
    Else
        lblNewPassWord.Visible = False
        txtNewPassWord.Visible = False
    End If
End Sub
Private Sub chkChangePass_KeyDown(KeyCode As Integer, Shift As Integer)
    If KeyCode = 13 Then
        SendKeyTab KeyCode
    End If
End Sub
Private Sub cmdExit_Click()
    Unload Me
End Sub
Private Sub cmdWrite_Click()
    Dim strTemp As String
    Dim strWrite As String
    Dim strWriteDot As String
    Dim i As Integer
    Dim nRet As Integer
    Dim strEncode As String
    Dim nData(3) As Byte
    Dim strCID As String
    Dim strPID As String
    Dim strSID As String
    Dim strDATA As String
    Dim strPSW As String
    Dim strNewPSW As String
    Dim blnIsToMsg As Boolean
    Dim strMsgTitle As String
    Dim blnIsOpen As Boolean
    
    blnIsOpen = False
    blnIsToMsg = False
    strCID = Trim(txtSetup(CID))
    strPID = Trim(txtSetup(PID))
    strSID = Trim(txtSetup(SID))
    strDATA = Trim(txtSetup(DATA))
    strPSW = Trim(txtPassword)
    If chkChangePass.Value = 1 Then
        strNewPSW = Trim(txtNewPassWord)
    End If
    On Error GoTo WriteErr
    For i = 0 To 3
        If txtSetup(i).Text = "" Then
            MsgBox mstrParaErr, vbInformation, gTitle
            txtSetup(i).SetFocus
            Exit Sub
        End If
    Next i
    
    If Len(strCID) <> 4 Then
        MsgBox mstrCIDErr, vbInformation, gTitle
        txtSetup(CID).SetFocus
        Exit Sub
    End If
    
    If Len(strPID) <> 4 Then
        MsgBox mstrPIDErr, vbInformation, gTitle
        txtSetup(PID).SetFocus
        Exit Sub
    End If
    
    If Val(strSID) < 0 Or Val(strSID) > 255 Then
        MsgBox mstrSIDErr, vbInformation, gTitle
        txtSetup(SID).SetFocus
        Exit Sub
    End If
    
    If Val(strDATA) < 0 Or Val(strDATA) > 65535 Then
        MsgBox mstrDataErr, vbInformation, gTitle
        txtSetup(DATA).SetFocus
        Exit Sub
    End If
    
    If Len(strPSW) <> 6 Then
        MsgBox mstrPSWErr, vbInformation, gTitle
        txtPassword.SetFocus
        Exit Sub
    End If
    
    If OpenComm(gCommPort) <> 0 Then
        MsgBox mstrOpenCommErr, vbInformation, gTitle
        GoTo WriteErr
    End If
    blnIsOpen = True
    
    nRet = CardExist
    If nRet = 0 Then
        MsgBox mstrNoCardErr, vbInformation, gTitle
        Exit Sub
    End If
    
    blnIsToMsg = True
    strWrite = ""
    For i = 1 To 4
        strTemp = Hex(Asc(Mid(strCID, i, 1)))
        strWrite = strWrite & IIf(Len(strTemp) = 1, "0" & strTemp, strTemp)
    Next
    
    For i = 1 To 4
        strTemp = Hex(Asc(Mid(strPID, i, 1)))
        strWrite = strWrite & IIf(Len(strTemp) = 1, "0" & strTemp, strTemp)
    Next
    
    strTemp = Hex(Val(strSID))
    strWrite = strWrite & IIf(Len(strTemp) = 1, "0" & strTemp, strTemp)
    'strEncode = txtSetup(PID) 'Only for Test!!!!!!
    nData(0) = Val(strDATA)  256
    nData(1) = Val(strDATA) Mod 256
    nData(2) = (((Asc(Mid(strPID, 1, 1)) + Asc(Mid(strPID, 2, 1))) Xor nData(0)) + nData(1)) Mod 256
    nData(3) = ((Asc(Mid(strPID, 3, 1)) + Asc(Mid(strPID, 4, 1)) Xor nData(1)) + nData(2)) Mod 256
   
    For i = 0 To 3
        strTemp = Hex(nData(i))
        strWrite = strWrite & IIf(Len(strTemp) = 1, "0" & strTemp, strTemp)
    Next
    
    nRet = PowerOn
    If nRet <> 0 Then
        MsgBox mstrPowerOnErr, vbInformation, gTitle
        Exit Sub
    End If
    
    chgLblState mstrPSWCheck
    
    nRet = IC_PSCCheck(strPSW)
    If nRet <> 0 Then
        strMsgTitle = mstrCheckPSWErr
        GoTo WriteErr
    End If
    
    chgLblState mstrWMainCheck
    
    nRet = IC_WriteMain(dwOffset, dwLength, strWrite)
    If nRet <> 0 Then
        strMsgTitle = mstrWriteMainErr
        GoTo WriteErr
    End If
    strTemp = Space(64)
    strWriteDot = ""
    For i = 1 To Len(txtName.Text)
        nRet = ReadDot(Asc(Mid(txtName.Text, i, 1)), strTemp)
        strWriteDot = strWriteDot & strTemp
    Next
    If Len(strWriteDot) < 192 Then
        strWriteDot = strWriteDot & String(192 - Len(strWriteDot), "0")
    End If
    nRet = IC_WriteMain(dwNameOffset, dwNameLength, strWriteDot)
    If nRet <> 0 Then
        strMsgTitle = mstrWriteMainErr
        GoTo WriteErr
    End If
    If chkChangePass.Value = 1 Then
        chgLblState mstrChgPSWCheck
        nRet = IC_ChangePass(strNewPSW)
        If nRet <> 0 Then
            'MsgBox "Password Change Error"
            strMsgTitle = mstrChgPswErr
            GoTo WriteErr
        End If
    End If
    strTemp = Space(2 * dwLength)
    
    chgLblState mstrRMainCheck
    
    nRet = IC_ReadMain(dwOffset, dwLength, strTemp)
    If nRet <> 0 Then
        strMsgTitle = mstrReadMainErr
        GoTo WriteErr
    End If
    If strTemp <> strWrite Then
        strMsgTitle = mstrCheckDataErr
        Exit Sub
    End If
    nRet = PowerOff
    CloseComm
    blnIsOpen = False
        
    chgLblState mstrReady
    'If mblnIsBatch Then Unload Me
    Exit Sub
WriteErr:
    If blnIsOpen Then
        PowerOff
        CloseComm
    End If
    If blnIsToMsg Then
        Dim strTitle As String
        If isEmpty(strMsgTitle) Then
            strTitle = mstrWriteErr
        Else
            strTitle = strMsgTitle
        End If
        MsgBox strTitle, vbCritical, mstrWriteErr
    End If
    Exit Sub
End Sub
Private Sub chgLblState(strMsg As String)
    With sbrState.Panels(1)
        .Text = strMsg
    End With
End Sub
Private Sub Form_Load()
    sbrState.Panels(1).Width = Me.ScaleWidth
    chgLblState mstrReady
End Sub
Private Sub txtNewPassWord_GotFocus()
    GotFocus txtNewPassWord
End Sub
Private Sub txtNewPassWord_KeyDown(KeyCode As Integer, Shift As Integer)
    If KeyCode = 13 Then
        SendKeyTab KeyCode
    End If
End Sub
Private Sub txtNewPassWord_KeyPress(KeyAscii As Integer)
    KeyAscii = KeyFilter(KeyAscii, True)
End Sub
Private Sub txtPassword_GotFocus()
    GotFocus txtPassword
End Sub
Private Sub txtPassword_KeyDown(KeyCode As Integer, Shift As Integer)
    If KeyCode = 13 Then
        SendKeyTab KeyCode
    End If
End Sub
Private Sub txtSetup_GotFocus(Index As Integer)
    GotFocus txtSetup(Index)
End Sub
Private Sub txtSetup_KeyDown(Index As Integer, KeyCode As Integer, Shift As Integer)
    If KeyCode = 13 Then
        SendKeyTab KeyCode
    End If
End Sub
Private Sub txtSetup_KeyPress(Index As Integer, KeyAscii As Integer)
    Select Case Index
        Case SID, DATA
            KeyAscii = ValiText(KeyAscii, "0123456789", True)
        Case Else
            KeyAscii = KeyFilter(KeyAscii, False)
    End Select
End Sub

						