frmlogin.frm

VB税控的源代码 主要用于地方税务局的税控引用 有完整的控件和代码

VERSION 5.00
Begin VB.Form frmLogin 
   BorderStyle     =   4  'Fixed ToolWindow
   Caption         =   "登录"
   ClientHeight    =   1680
   ClientLeft      =   45
   ClientTop       =   270
   ClientWidth     =   3855
   BeginProperty Font 
      Name            =   "宋体"
      Size            =   9
      Charset         =   134
      Weight          =   400
      Underline       =   0   'False
      Italic          =   0   'False
      Strikethrough   =   0   'False
   EndProperty
   Icon            =   "frmLogin.frx":0000
   KeyPreview      =   -1  'True
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   NegotiateMenus  =   0   'False
   ScaleHeight     =   1680
   ScaleWidth      =   3855
   ShowInTaskbar   =   0   'False
   StartUpPosition =   2  'CenterScreen
   Tag             =   "网络版（单机版将“服务器地址”改为“数据源名称”）"
   Begin VB.CommandButton Command1 
      Caption         =   "Command1"
      Height          =   315
      Left            =   240
      TabIndex        =   8
      Top             =   930
      Visible         =   0   'False
      Width           =   705
   End
   Begin VB.TextBox txtUserPwd 
      Height          =   315
      IMEMode         =   3  'DISABLE
      Left            =   1620
      PasswordChar    =   "*"
      TabIndex        =   3
      Top             =   600
      Width           =   1965
   End
   Begin VB.ComboBox cboUserId 
      Height          =   300
      ItemData        =   "frmLogin.frx":000C
      Left            =   1620
      List            =   "frmLogin.frx":000E
      TabIndex        =   1
      Text            =   "isa"
      Top             =   150
      Width           =   1965
   End
   Begin VB.CommandButton cmdOk 
      Caption         =   "确定(&O)"
      Default         =   -1  'True
      Height          =   345
      Left            =   1080
      TabIndex        =   6
      Top             =   1080
      Width           =   1125
   End
   Begin VB.CommandButton cmdCancel 
      Cancel          =   -1  'True
      Caption         =   "取消(&C)"
      Height          =   345
      Left            =   2520
      TabIndex        =   7
      Top             =   1080
      Width           =   1125
   End
   Begin VB.Label lblUserPwd 
      AutoSize        =   -1  'True
      Caption         =   "用户密码(&P)："
      Height          =   180
      Left            =   240
      TabIndex        =   2
      Top             =   600
      Width           =   1170
   End
   Begin VB.Label lblDataBaseName 
      AutoSize        =   -1  'True
      Height          =   180
      Left            =   300
      TabIndex        =   5
      Top             =   1740
      Visible         =   0   'False
      Width           =   90
   End
   Begin VB.Label lblServer 
      AutoSize        =   -1  'True
      Height          =   180
      Left            =   300
      TabIndex        =   4
      Top             =   1350
      Visible         =   0   'False
      Width           =   90
   End
   Begin VB.Label lblUserID 
      AutoSize        =   -1  'True
      Caption         =   "用户代号(&U)："
      Height          =   180
      Left            =   240
      TabIndex        =   0
      Top             =   210
      Width           =   1170
   End
End
Attribute VB_Name = "frmLogin"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'''关闭键值函数
Private Declare Function RegCloseKey Lib "advapi32.dll" _
        (ByVal hKey As Long) As Long
        
'''打开键值函数
Private Declare Function RegOpenKeyEx Lib "advapi32.dll" _
         Alias "RegOpenKeyExA" (ByVal hKey As Long, _
         ByVal lpSubKey As String, ByVal ulOptions As Long, _
         ByVal samDesired As Long, phkResult As Long) As Long

'''建立键值函数
Private Declare Function RegCreateKey Lib "advapi32.dll" _
        Alias "RegCreateKeyA" (ByVal hKey As Long, _
        ByVal lpSubKey As String, phkResult As Long) As Long
        
'''设置键值函数
Private Declare Function RegSetValueEx Lib "advapi32.dll" _
        Alias "RegSetValueExA" (ByVal hKey As Long, _
        ByVal lpValueName As String, ByVal Reserved As Long, _
        ByVal dwType As Long, ByVal lpData As String, _
        ByVal cbData As Long) As Long


Private Sub cmdCancel_Click()
    Unload Me
End Sub

Private Sub cmdOK_Click()
    
    
    If bCheckCharacter = False Then
        MsgBox "符号(')是本系统的特殊符号，请您选择别的符号代替它!", vbOKOnly + vbInformation, "提示信息"
        Exit Sub
    End If

    If bJudgeUser = False Then
        MsgBox "请检查您的所输入的信息是否正确!", vbOKOnly, "信息"
        Exit Sub
    Else
        gsUserID = Trim(cboUserID.Text)
    End If
    
    Unload Me
    frmChequeInfo.Show 'vbModal
    
End Sub

Private Function bCheckCharacter() As Boolean
    
    bCheckCharacter = False
    
    If Len(cboUserID.Text) > 0 Then
        If InStr(cboUserID.Text, "'") > 0 Then
            cboUserID.SetFocus
            Exit Function
        End If
    End If
    
    If Len(txtUserPwd.Text) > 0 Then
        If InStr(txtUserPwd.Text, "'") > 0 Then
            txtUserPwd.SetFocus
            Exit Function
        End If
    End If
    
    bCheckCharacter = True
End Function

Private Sub Command1_Click()
    Dim lCrypt As Long
    
'    lCrypt = EncryptFiles("C:\WINDOWS\Desktop\newinfo\13000210854\20021106173139B\archive001.dat", "d:\13000122131233.des")
'    lCrypt = SignFiles("C:\WINDOWS\Desktop\newinfo\13000210854\20021106173139B\archive001.dat", "d:\13000122131233.sgn")
    
'    lCrypt = DecryptFiles("d:\13000122131233.des", "d:\archive001.dat")
End Sub

Private Sub Form_Load()

'    If bConnection = False Then
'        MsgBox "请检查您的数据库,是否在安装路径下!", vbOKOnly, "信息"
'        Exit Sub
'    End If
    
    SetkeyValue                   '''设置TCP/IP
    GetUser                       '''获取用户
    
'    If bGetRegedit = False Then
'        gsRegedit = "R"
'        frmDataReport.Show vbModal
'
'    End If
    
    
'    gbChequeLine = True         '''在线开票的设定，为false不在线开票
End Sub

'=======================================================================
'描    述： 窗体从获取表中获取注册信息
'输    入:  服务器名
'输    出:
'调用关系： Form_Load 调用
'=======================================================================
'编   码:  1   苏江       2002/03/13           创建
'=======================================================================
Private Sub SetkeyValue()
On Error GoTo ErrHandle
    Const HKEY_LOCAL_MACHINE = &H80000002
    Dim resultkey As Long
    Dim lOpenKey As Long
    Dim lRtn As Long
    Dim sSubSec As String
    Dim lCreateKey As Long
    Const REG_SZ = 1
    Dim key As String
    Dim Value As String
    Dim lVallen As Long
    
'    If bGetIP = False Then Exit Sub
    
    sSubSec = "SOFTWARE\Microsoft\MSSQLServer\Client\ConnectTo"
    key = "2"
    Value = "DBMSSOCN," + key + ",1433"             '''数据库打开方式
    Value = "DBMSSOCN,.,1433"
    lVallen = Len(Value) * 2 + 1
    
    lRtn = RegOpenKeyEx(HKEY_LOCAL_MACHINE, "", 0, 2, lOpenKey)
    If lRtn <> 0 Then Exit Sub
    
    lRtn = RegCreateKey(lOpenKey, sSubSec, lCreateKey)
    If lRtn <> 0 Then Exit Sub
    
    lRtn = RegSetValueEx(lCreateKey, key, 0, REG_SZ, _
           Value, lVallen)
    If lRtn <> 0 Then Exit Sub
    
    RegCloseKey (lCreateKey)                '''关闭新建的键
    RegCloseKey (lOpenKey)                  '''关闭打开的BootKey
    
    Exit Sub
ErrHandle:
    MsgBox "如果不能连接数据库，请到HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\MSSQLServer " + _
            "\Client\ConnectTo下建立键值分别为" + CStr(key) + "和" + "DBMSSOCN," + _
             CStr(key) + ",1433", vbInformation, "提示信息!"
End Sub


''连接数据库
'Private Function bConnection() As Boolean
'On Error GoTo err
'    Dim StrSQL As String
'
'    bConnection = False
'    StrSQL = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=D:\支票管理系统\数据库\cheque.mdb;Persist Security Info=False"
''    StrSQL = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=D:\test\db1.mdb;Persist Security Info=False"
'
'    Set gConn = New ADODB.Connection
'
'    gConn.Open StrSQL
'
'    bConnection = True
'    Exit Function
'err:
'    bConnection = False
'End Function


'身份验证
Private Function bJudgeUser() As Boolean
On Error GoTo err
    Dim recUser As ADODB.Recordset
    Dim StrSQL As String
    
    bJudgeUser = False
    If cboUserID.Text = "isa" And txtUserPwd.Text = "23932" Then
        gsUserName = "isa"
        bJudgeUser = True
        Exit Function
    End If
    
    
    Set recUser = New ADODB.Recordset
    StrSQL = "select * from " + gsconTabel + "is_user where userid ='" + cboUserID.Text + "'" + _
              " and userpd = '" + txtUserPwd.Text + "'"
    If recUser.State = 1 Then recUser.Close
    recUser.CursorLocation = adUseClient
    recUser.Open StrSQL, gConn, adOpenStatic, adLockReadOnly
    
    If recUser.RecordCount < 1 Then Exit Function
    '获取用户的名字
    gsUserName = IIf(IsNull(recUser.Fields("username")), "", recUser.Fields("username"))
     
    bJudgeUser = True
    Exit Function
err:
    
End Function

'获取用户
Private Sub GetUser()
    Dim recU As ADODB.Recordset
    Dim StrSQL As String
    
    Set recU = New ADODB.Recordset
    StrSQL = "select userid from " + gsconTabel + "is_user"
    If recU.State = 1 Then recU.Close
    recU.CursorLocation = adUseClient
    recU.Open StrSQL, gConn, adOpenStatic, adLockBatchOptimistic
    
    Do Until recU.EOF
        If Not IsNull(recU.Fields(0).Value) Then
            cboUserID.AddItem recU.Fields(0).Value
        End If
        recU.MoveNext
    Loop
    
End Sub