35.txt

图书管理系统源码 Microsoft Visual Basic6.0提供了开发Microsoft Windows应用程序的最迅速、最简捷的方法。”Visual”的意思是“可视化程序设计”

                    cboItem(2).Clear
                    cboItem(3).Clear
                    cboItem(2).AddItem mrcd!bookauthor
                    cboItem(3).AddItem mrcd!bookpub
                    cboItem(2).ListIndex = 0
                    cboItem(3).ListIndex = 0
                    txtItem(5) = mrcd!bookmemo
                    Text1 = mrcd!BookID
                End If
                mrcd.Close
            End If
        ElseIf Index = 6 Then
            cboItem(5).Clear
            txtSQL = "select distinct readername from readers where readertype = '" & Trim(cboItem(6)) & "'"
            Set mrcc = ExecuteSQL(txtSQL, MsgText)
            
            If Not mrcc.EOF Then
                Do While Not mrcc.EOF
                    cboItem(5).AddItem mrcc.Fields(0)
                    mrcc.MoveNext
                Loop
            End If
            cboItem(5).ListIndex = 0
            mrcc.Close
        ElseIf Index = 5 Then
            txtSQL = "select * from readers where readername = '" & Trim(cboItem(5)) & "'"
            Set mrcc = ExecuteSQL(txtSQL, MsgText)
            
            If Not mrcc.EOF Then
                cboItem(4).Clear
                cboItem(4).AddItem mrcc!readerno
                cboItem(4).ListIndex = 0
            End If
            
            mrcc.Close
        End If
    End If
End Sub

Private Sub cboItem_KeyDown(Index As Integer, KeyCode As Integer, Shift As Integer)
    EnterToTab KeyCode
    
End Sub

Private Sub cmdExit_Click()
    If mblChange And cmdSave.Enabled Then
        If MsgBox("保存当前记录的变化吗？", vbOKCancel + vbExclamation, "警告") = vbOK Then
            '保存
            Call cmdSave_Click
        End If
    End If
    Unload Me
End Sub

Private Sub cmdSave_Click()
    Dim intCount As Integer
    Dim sMeg As String
    Dim mrcc As ADODB.Recordset
    Dim MsgText As String
    
    For intCount = 0 To 5 Step 5
        If Trim(cboItem(intCount) & " ") = "" Then
            Select Case intCount
                Case 0
                    sMeg = "书籍名称"
                Case 5
                    sMeg = "读者姓名"
                
            End Select
            sMeg = sMeg & "不能为空！"
            MsgBox sMeg, vbOKOnly + vbExclamation, "警告"
            txtItem(intCount).SetFocus
        
            Exit Sub
        End If
    Next intCount
    
    If Trim(txtItem(0)) = "" Then
          MsgBox "借书日期不能为空！", vbOKOnly + vbExclamation, "警告"
          txtItem(0).SetFocus
          Exit Sub
    End If
    
   
    If IsDate(txtItem(0)) Then
        txtItem(0) = Format(txtItem(0), "yyyy-mm-dd")
    Else
        MsgBox "入库时间应输入日期（yyyy-mm-dd）！", vbOKOnly + vbExclamation, "警告"
        txtItem(0).SetFocus
        Exit Sub
    End If
    
    
    If gintBOmode = 2 Then
        txtSQL = "delete from borrowinfo where borrowno = '" & Trim(txtNo) & "'"
        Set mrcc = ExecuteSQL(txtSQL, MsgText)
    End If
    
    txtSQL = "select * from readertype where typename = '" & Trim(cboItem(6)) & "'"
    Set mrcc = ExecuteSQL(txtSQL, MsgText)
    If Not mrcc.EOF Then
        bookNUM = mrcc.Fields(2)
    End If
    mrcc.Close
    
    txtSQL = "select * from borrowinfo where readername = '" & Trim(cboItem(5)) & "' and returndate is null "
    Set mrcc = ExecuteSQL(txtSQL, MsgText)
    If Not mrcc.EOF Then
        Do While Not mrcc.EOF
            bookNUM = bookNUM - 1
            mrcc.MoveNext
        Loop
    End If
    mrcc.Close
    
    If bookNUM <= 0 Then
        MsgBox "借书数量已经到达极限，不能再借！", vbOKOnly + vbExclamation, "警告"
        Exit Sub
    End If
        
    
    txtSQL = "select * from books where bookid = '" & Trim(Text1) & "' and putup <> 'y'"
    Set mrcc = ExecuteSQL(txtSQL, MsgText)
    If mrcc.EOF Then
        MsgBox "这本书已经借出！", vbOKOnly + vbExclamation, "警告"
        Exit Sub
    End If
    
    txtSQL = "select * from borrowinfo"
    Set mrcc = ExecuteSQL(txtSQL, MsgText)
    mrcc.AddNew
    mrcc.Fields(0) = Trim(txtNo)
    For intCount = 0 To 1
        mrcc.Fields(intCount + 1) = Trim(cboItem(intCount + 4))
    Next intCount
    
    mrcc!BookID = Trim(Text1)
    mrcc!bookname = Trim(cboItem(0))
    mrcc!borrowdate = Trim(txtItem(0))
    mrcc.Fields(7) = Trim(txtItem(1))
    
    mrcc.Update
    mrcc.Close
    
    txtSQL = "select * from books where bookid = '" & Trim(Text1) & "'"
    Set mrcc = ExecuteSQL(txtSQL, MsgText)
    If Not mrcc.EOF Then
        mrcc!putup = "y"
    End If
    mrcc.Update
    mrcc.Close
        
    
    If gintBOmode = 1 Then
        MsgBox "添加借书信息成功!", vbOKOnly + vbExclamation, "添加借书消息"
        Unload Me
        If flagBOedit Then
            Unload frmBorrow
        End If
        frmBorrow.txtSQL = "select borrowno,readerid,readername,bookid,bookname,borrowdate,memo from borrowinfo where returndate is null"
        frmBorrow.Show
    Else
        MsgBox "修改借书信息成功!", vbOKOnly + vbExclamation, "修改借书消息"
        Unload Me
        If flagBOedit Then
            Unload frmBorrow
        End If
        frmBorrow.txtSQL = "select borrowno,readerid,readername,bookid,bookname,borrowdate,memo from borrowinfo where returndate is null"
        frmBorrow.Show
    End If
   
    
End Sub

Private Sub Form_Load()
    Dim sSql As String
    Dim intCount As Integer
    Dim MsgText As String
    
    
        If gintBOmode = 1 Then
            Me.Caption = Me.Caption & "添加"
        
        '初始化客房信息
            txtSQL = "select DISTINCT booktype from books "
            Set mrc = ExecuteSQL(txtSQL, MsgText)
        
            If Not mrc.EOF Then
                
                    Do While Not mrc.EOF
                        cboItem(1).AddItem Trim(mrc.Fields(0))
                        mrc.MoveNext
                    Loop
            Else
                MsgBox "请先进行书籍登记！", vbOKOnly + vbExclamation, "警告"
                cmdSave.Enabled = False
                Exit Sub
            End If
            mrc.Close
            
            txtSQL = "select DISTINCT readertype from readers "
            Set mrc = ExecuteSQL(txtSQL, MsgText)
        
            If Not mrc.EOF Then
                
                    Do While Not mrc.EOF
                        cboItem(6).AddItem Trim(mrc.Fields(0))
                        mrc.MoveNext
                    Loop
            Else
                MsgBox "请先进行读者登记！", vbOKOnly + vbExclamation, "警告"
                cmdSave.Enabled = False
                Exit Sub
            End If
            mrc.Close
            
        
            txtNo = GetRkno
                
        ElseIf gintBOmode = 2 Then
            Me.Caption = Me.Caption & "修改"
            
            Set mrc = ExecuteSQL(txtSQL, MsgText)
            If Not mrc.EOF Then
                txtNo = mrc!borrowno
                cboItem(4).Clear
                cboItem(4).AddItem mrc!readerid
                cboItem(4).ListIndex = 0
                
                cboItem(5).Clear
                cboItem(5).AddItem mrc!readername
                cboItem(5).ListIndex = 0
            
                Text1 = Trim(mrc!BookID)
                cboItem(0).Clear
                cboItem(0).AddItem mrc!bookname
                cboItem(0).ListIndex = 0
                
                txtItem(0) = mrc!borrowdate
                txtItem(1) = mrc.Fields(6)
            End If
            mrc.Close
            
            txtSQL = "select distinct readertype from readers where readerno = '" & Trim(cboItem(4)) & "'"
            Set mrc = ExecuteSQL(txtSQL, MsgText)
            
            If Not mrc.EOF Then
                cboItem(6).Clear
                cboItem(6).AddItem mrc.Fields(0)
                cboItem(6).ListIndex = 0
            End If
            mrc.Close
            
            txtSQL = "select * from books where bookid = '" & Trim(Text1) & "'"
            Set mrc = ExecuteSQL(txtSQL, MsgText)
            
            If Not mrc.EOF Then
                cboItem(1).Clear
                cboItem(1).AddItem mrc!booktype
                cboItem(1).ListIndex = 0
                
                cboItem(2).Clear
                cboItem(2).AddItem mrc!bookauthor
                cboItem(2).ListIndex = 0
                
                cboItem(3).Clear
                cboItem(3).AddItem mrc!bookpub
                cboItem(3).ListIndex = 0
                
                txtItem(5) = mrc!bookmemo
                mrc!putup = " "
                mrc.Update
            End If
            
            mrc.Close
                
        End If
    
        mblChange = False
        
    
    
End Sub

Private Sub Form_Unload(Cancel As Integer)
    gintBOmode = 0
End Sub
Private Sub txtItem_Change(Index As Integer)
    '有变化设置gblchange
    mblChange = True
    
End Sub

Private Sub txtItem_GotFocus(Index As Integer)
    txtItem(Index).SelStart = 0
    txtItem(Index).SelLength = Len(txtItem(Index))
    
End Sub

Private Sub txtItem_KeyDown(Index As Integer, KeyCode As Integer, Shift As Integer)
        EnterToTab KeyCode

End Sub


Private Function GetRkno() As String
    GetRkno = Format(Now, "yymmddhhmmss")
    Randomize
    GetRkno = GetRkno & Int((99 - 10 + 1) * Rnd + 10)
End Function

版本界面：
' Reg Key Security Options...
Const KEY_ALL_ACCESS = &H2003F
                                          

' Reg Key ROOT Types...
Const HKEY_LOCAL_MACHINE = &H80000002
Const ERROR_SUCCESS = 0
Const REG_SZ = 1                         ' Unicode nul terminated string
Const REG_DWORD = 4                      ' 32-bit number


Const gREGKEYSYSINFOLOC = "SOFTWARE\Microsoft\Shared Tools Location"
Const gREGVALSYSINFOLOC = "MSINFO"
Const gREGKEYSYSINFO = "SOFTWARE\Microsoft\Shared Tools\MSINFO"
Const gREGVALSYSINFO = "PATH"


Private Declare Function RegOpenKeyEx Lib "advapi32" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, ByRef phkResult As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, ByRef lpType As Long, ByVal lpData As String, ByRef lpcbData As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32" (ByVal hKey As Long) As Long

Private Sub Form_Load()
  '  lblVersion.Caption = "Version " & App.Major & "." & App.Minor & "." & App.Revision
   ' lblTitle.Caption = App.Title
End Sub



Private Sub cmdSysInfo_Click()
        Call StartSysInfo
End Sub


Private Sub cmdOK_Click()
        Unload Me
End Sub


Public Sub StartSysInfo()
    On Error GoTo SysInfoErr


        Dim rc As Long
        Dim SysInfoPath As String
        

        ' Try To Get System Info Program Path\Name From Registry...
        If GetKeyValue(HKEY_LOCAL_MACHINE, gREGKEYSYSINFO, gREGVALSYSINFO, SysInfoPath) Then
        ' Try To Get System Info Program Path Only From Registry...
        ElseIf GetKeyValue(HKEY_LOCAL_MACHINE, gREGKEYSYSINFOLOC, gREGVALSYSINFOLOC, SysInfoPath) Then
                ' Validate Existance Of Known 32 Bit File Version
                If (Dir(SysInfoPath & "\MSINFO32.EXE") <> "") Then
                        SysInfoPath = SysInfoPath & "\MSINFO32.EXE"
                        

                ' Error - File Can Not Be Found...
                Else
                        GoTo SysInfoErr
                End If
        ' Error - Registry Entry Can Not Be Found...
        Else
                GoTo SysInfoErr
        End If
        

        Call Shell(SysInfoPath, vbNormalFocus)
        

        Exit Sub
SysInfoErr:
        MsgBox "System Information Is Unavailable At This Time", vbOKOnly
End Sub


Public Function GetKeyValue(KeyRoot As Long, KeyName As String, SubKeyRef As String, ByRef KeyVal As String) As Boolean
        Dim i As Long                                           ' Loop Counter
        Dim rc As Long                                          ' Return Code
        Dim hKey As Long                                        ' Handle To An Open Registry Key
        Dim hDepth As Long                                      '
        Dim KeyValType As Long                                  ' Data Type Of A Registry Key
        Dim tmpVal As String                                    ' Tempory Storage For A Registry Key Value
        Dim KeyValSize As Long                                  ' Size Of Registry Key Variable
        '------------------------------------------------------------
        ' Open RegKey Under KeyRoot {HKEY_LOCAL_MACHINE...}
        '------------------------------------------------------------
        rc = RegOpenKeyEx(KeyRoot, KeyName, 0, KEY_ALL_ACCESS, hKey) ' Open Registry Key
        

        If (rc <> ERROR_SUCCESS) Then GoTo GetKeyError          ' Handle Error...
        

        tmpVal = String$(1024, 0)                             ' Allocate Variable Space
        KeyValSize = 1024                                       ' Mark Variable Size
        

        '------------------------------------------------------------
        ' Retrieve Registry Key Value...
        '------------------------------------------------------------
        rc = RegQueryValueEx(hKey, SubKeyRef, 0, KeyValType, tmpVal, KeyValSize)    ' Get/Create Key Value
                                                

        If (rc <> ERROR_SUCCESS) Then GoTo GetKeyError          ' Handle Errors
        

        tmpVal = VBA.Left(tmpVal, InStr(tmpVal, VBA.Chr(0)) - 1)
        '------------------------------------------------------------
        ' Determine Key Value Type For Conversion...
        '------------------------------------------------------------
        Select Case KeyValType                                  ' Search Data Types...
        Case REG_SZ                                             ' String Registry Key Data Type
                KeyVal = tmpVal                                     ' Copy String Value
        Case REG_DWORD                                          ' Double Word Registry Key Data Type
                For i = Len(tmpVal) To 1 Step -1                    ' Convert Each Bit
                        KeyVal = KeyVal + Hex(Asc(Mid(tmpVal, i, 1)))   ' Build Value Char. By Char.
                Next
                KeyVal = Format$("&h" + KeyVal)                     ' Convert Double Word To String
        End Select
        

        GetKeyValue = True                                      ' Return Success
        rc = RegCloseKey(hKey)                                  ' Close Registry Key
        Exit Function                                           ' Exit
        

GetKeyError:    ' Cleanup After An Error Has Occured...
        KeyVal = ""                                             ' Set Return Val To Empty String
        GetKeyValue = False                                     ' Return Failure
        rc = RegCloseKey(hKey)                                  ' Close Registry Key
End Function

Private Sub lblDescription_Click()

End Sub