reader.frm

图书管理系统．一个具有多功能的图书馆里系统

Attribute VB_Exposed = False
Dim WithEvents adoPrimaryRS As ADODB.Recordset
Attribute adoPrimaryRS.VB_VarHelpID = -1
Private Const MARGIN_SIZE = 60      ' 单位为缇
' 能列排序变量
Private m_iSortCol As Integer
Private m_iSortType As Integer
' 列拖拽变量
Private m_bDragOK As Boolean
Private m_iDragCol As Integer
Private xdn As Integer, ydn As Integer
Private Sub Conn_Data()
  On Error GoTo ConErr
  Dim sSql As String
   sSql = "select 读者工号,读者姓名,性别,工作单位,家庭住址,联系电话,登记日期,备注 from user Order by 读者工号"
  Set adoPrimaryRS = New ADODB.Recordset
  adoPrimaryRS.Open sSql, tsdata.db, adOpenStatic, adLockOptimistic

  '绑定文本框到数据提供者
   Set MSHFlexGrid1.DataSource = adoPrimaryRS
    With MSHFlexGrid1
        .Redraw = False
        ' 设置网格列宽度
        .ColWidth(0) = -1
        .ColWidth(1) = -1
        .ColWidth(2) = -1
        .ColWidth(3) = -1
        .ColWidth(4) = -1
        .ColWidth(5) = -1
        .ColWidth(6) = -1
        .ColWidth(7) = -1

        ' 设置网格样式
        .AllowBigSelection = True
        .FillStyle = flexFillRepeat
        ' 将标头作成粗体
        .Row = 0
        .Col = 0
        .RowSel = .FixedRows - 1
        .ColSel = .Cols - 1
        .CellFontBold = True
        ' 隔列变灰
        For i = .FixedCols To .Cols() - 1 Step 2
            .Col = i
            .Row = .FixedRows
            .RowSel = .Rows - 1
            .CellBackColor = &HC0C0C0   ' 浅灰
        Next i
        .AllowBigSelection = False
        .FillStyle = flexFillSingle
        .Redraw = True
    End With
      For Each oText In Me.Text1
    Set oText.DataSource = adoPrimaryRS
  Next

 'For i = 0 To 6
 '  Text1(i) = adoPrimaryRS.Fields(i)
' Next
ConErr:
End Sub
Private Sub Save_Data()
  'On Error GoTo ConErr
  Dim i As Integer
  Dim sSql As String
  Set adoPrimaryRS = Nothing
   sSql = "select 读者工号,读者姓名,性别,工作单位,家庭住址,联系电话,登记日期,备注 from user Order by 读者工号"
  Set adoPrimaryRS = New ADODB.Recordset
  adoPrimaryRS.Open sSql, tsdata.db, adOpenStatic, adLockOptimistic
  adoPrimaryRS.AddNew
  For i = 0 To 6
  adoPrimaryRS.Fields(i) = Text1(i).Text
  Next
  adoPrimaryRS.Update
End Sub

Private Sub CmdAddNew_Click()
  On Error GoTo AddErr
  Dim i As Integer
  adoPrimaryRS.AddNew
  For i = 0 To 5
     Text1(i) = ""
  Next i
  Text1(2) = "男"
   Text1(6) = Date
  Text1(0).SetFocus
 SetTxt_BackColor 0
 SetButtons False
  Exit Sub
AddErr:
  MsgBox Err.Description
End Sub
Private Sub cmdCancel_Click()
 On Error Resume Next
  adoPrimaryRS.CancelUpdate
  Set adoPrimaryRS = Nothing
  Conn_Data
  If mvBookMark > 0 Then
    adoPrimaryRS.Bookmark = mvBookMark
    adoPrimaryRS.MovePrevious
  Else
    adoPrimaryRS.MoveFirst
  End If
  SetButtons True
End Sub
Private Sub CmdDel_Click()
  On Error GoTo UpdateErr
  adoPrimaryRS.Delete
   Conn_Data
  Exit Sub
UpdateErr:
  MsgBox Err.Description

End Sub
Private Sub cmdExit_Click()
 Unload Me
End Sub

Private Sub CmdModi_Click()
  On Error GoTo AddErr
  Text1(0).SetFocus
 SetTxt_BackColor 0
  Exit Sub
AddErr:
  MsgBox Err.Description

End Sub

Private Sub CmdSave_Click()
  On Error GoTo UpdateErr
  Save_Data
   Conn_Data
    SetButtons True
    Exit Sub
UpdateErr:
  MsgBox Err.Description
End Sub
Private Sub Cmdprev_Click()
On Error GoTo GoPrevError
  If Not adoPrimaryRS.BOF Then adoPrimaryRS.MovePrevious
  If adoPrimaryRS.BOF And adoPrimaryRS.RecordCount > 0 Then
    Beep
    '已到最后返回
    adoPrimaryRS.MoveFirst
  End If
  '显示当前记录
 For i = 0 To 6
   Text1(i) = adoPrimaryRS.Fields(i)
 Next
  Exit Sub

GoPrevError:
  
End Sub
Private Sub cmdNext_Click()
 On Error GoTo GoNextError
  If Not adoPrimaryRS.EOF Then adoPrimaryRS.MoveNext
  If adoPrimaryRS.EOF And adoPrimaryRS.RecordCount > 0 Then
    Beep
     '已到最后返回
    adoPrimaryRS.MoveLast
  End If
  '显示当前记录
 For i = 0 To 6
   Text1(i) = adoPrimaryRS.Fields(i)
 Next

  Exit Sub
GoNextError:
  

End Sub
Private Sub Form_Load()
 Conn_Data
 End Sub

Private Sub MSHFlexGrid1_DragDrop(Source As Control, X As Single, Y As Single)
'-------------------------------------------------------------------------------------------
' 网格中 DragDrop, MouseDown, MouseMove, 和 MouseUp 事件代码能进行列拖拽
'-------------------------------------------------------------------------------------------

    If m_iDragCol = -1 Then Exit Sub    ' 现在不能拖拽
    If MSHFlexGrid1.MouseRow <> 0 Then Exit Sub

    With MSHFlexGrid1
        .Redraw = False
        .ColPosition(m_iDragCol) = .MouseCol

        .FillStyle = flexFillRepeat
        .Col = 0
        .Row = .FixedRows
        .RowSel = .Rows - 1
        .ColSel = .Cols - 1
        .CellBackColor = &HFFFFFF
        Dim iLoop As Integer
        For iLoop = .FixedCols To .Cols() - 1 Step 2
            .Col = iLoop
            .Row = .FixedRows
            .RowSel = .Rows - 1
            .CellBackColor = &HC0C0C0
        Next iLoop
        .FillStyle = flexFillSingle

        .Redraw = True
    End With

End Sub

Private Sub MSHFlexGrid1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
'-------------------------------------------------------------------------------------------
' 网格中 DragDrop, MouseDown, MouseMove, 和 MouseUp 事件代码能进行列拖拽
'-------------------------------------------------------------------------------------------
    If MSHFlexGrid1.MouseRow <> 0 Then Exit Sub
    xdn = X
    ydn = Y
    m_iDragCol = -1     ' 清除拖拽标志
    m_bDragOK = True
End Sub

Private Sub MSHFlexGrid1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
'-------------------------------------------------------------------------------------------
' 网格中 DragDrop, MouseDown, MouseMove, 和 MouseUp 事件代码能进行列拖拽
'-------------------------------------------------------------------------------------------

    ' 测试是否能够开始拖拽
    If Not m_bDragOK Then Exit Sub
    If Button <> 1 Then Exit Sub                        ' 错误按钮
    If m_iDragCol <> -1 Then Exit Sub                   ' 已经开始拖拽
    If Abs(xdn - X) + Abs(ydn - Y) < 50 Then Exit Sub   ' 移得不够
    If MSHFlexGrid1.MouseRow <> 0 Then Exit Sub         ' 必须拖拽标头

    ' 如果到达这则开始拖拽
    m_iDragCol = MSHFlexGrid1.MouseCol
    MSHFlexGrid1.Drag vbBeginDrag

End Sub

Private Sub MSHFlexGrid1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
'-------------------------------------------------------------------------------------------
' 网格中 DragDrop, MouseDown, MouseMove, 和 MouseUp 事件代码能进行列拖拽
'------------------------------------------------------------------------------------------
    m_bDragOK = False
End Sub
Private Sub MSHFlexGrid1_DblClick()
'-------------------------------------------------------------------------------------------
' 网格的 DblClick 事件代码能进行列排序
'-------------------------------------------------------------------------------------------
    Dim i As Integer
    ' 仅在单击固定行时进行排序
    If MSHFlexGrid1.MouseRow >= MSHFlexGrid1.FixedRows Then Exit Sub
    i = m_iSortCol                  ' 保存旧列
    m_iSortCol = MSHFlexGrid1.Col   ' 设置新列
    ' 递增排序类型
    If i <> m_iSortCol Then
        ' 如果在新的列上单击鼠标，开始升序排序
        m_iSortType = 1
    Else
        ' 如果在相同列单击鼠标，则进行升序和降序排序的转换。
        m_iSortType = m_iSortType + 1
    If m_iSortType = 3 Then m_iSortType = 1
    End If
    DoColumnSort
End Sub

Sub DoColumnSort()
'-------------------------------------------------------------------------------------------
' 作 Exchange-type 排序在列 m_iSortCol
'-------------------------------------------------------------------------------------------
    With MSHFlexGrid1
        .Redraw = False
        .Row = 1
        .RowSel = .Rows - 1
        .Col = m_iSortCol
        .Sort = m_iSortType
        .Redraw = True
    End With
End Sub
Private Sub SetTxt_BackColor(Index As Integer)
  Dim i As Integer
  For i = 0 To 6
     Text1(i).BackColor = &H80000005
  Next i
  Text1(Index).BackColor = &H80FF80
End Sub
Private Sub SetButtons(MBoo As Boolean)
 CmdAddNew.Visible = MBoo
 CmdSave.Visible = Not MBoo
 cmdCancel.Visible = Not MBoo
 CmdModi.Visible = MBoo
End Sub
Private Sub Text1_Click(Index As Integer)
SetTxt_BackColor Index
End Sub
Private Sub Text1_DblClick(Index As Integer)
 CaleFrm.Text1 = 4
 Me.Enabled = False
End Sub

Private Sub Text1_KeyPress(Index As Integer, KeyAscii As Integer)
If KeyAscii = 13 Then
  If Index < 0 Or Index > 6 Then Exit Sub
   Index = Index + 1
   SetTxt_BackColor Index
   Text1(Index).SetFocus
End If
End Sub