form1.frm

sybase 数据库的写法模拟,使用ct_library

VERSION 5.00
Object = "{9CB8745A-43C0-405C-8A08-2F70F8DEBC25}#1.0#0"; "FlexCell.ocx"
Begin VB.Form Form1 
   Caption         =   "Form1"
   ClientHeight    =   4530
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   7245
   LinkTopic       =   "Form1"
   ScaleHeight     =   4530
   ScaleWidth      =   7245
   StartUpPosition =   3  '窗口缺省
   Begin FlexCell.Grid Grid1 
      Height          =   3855
      Left            =   120
      TabIndex        =   3
      Top             =   120
      Width           =   6975
      _ExtentX        =   12303
      _ExtentY        =   6800
      Cols            =   5
      DefaultFontSize =   8.25
      Rows            =   30
   End
   Begin VB.CommandButton cmdQuit 
      Caption         =   "Quit"
      Height          =   315
      Left            =   6120
      TabIndex        =   2
      Top             =   4080
      Width           =   975
   End
   Begin VB.CommandButton cmdSave 
      Caption         =   "Save"
      Height          =   315
      Left            =   5040
      TabIndex        =   1
      Top             =   4080
      Width           =   975
   End
   Begin VB.CommandButton cmdDelete 
      Caption         =   "Delete"
      Height          =   315
      Left            =   3960
      TabIndex        =   0
      Top             =   4080
      Width           =   975
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private mobjConn As adodb.Connection   'Database connection
Private mlngCount As Long              'Deleted records
Private marrDeleted() As Long          'Deleted record ID


Private Sub Form_Load()
    With Grid1
        .Cols = 3
        .Rows = 1
        
        .DisplayFocusRect = False
        .AllowUserResizing = False
        .AllowUserSort = True
        .DisplayRowIndex = True
        .SelectionMode = cellSelectionNone
        .Appearance = Flat
        .ScrollBarStyle = Flat
        .FixedRowColStyle = Flat
        
        '.BackColorFixed = RGB(90, 158, 214)
        '.BackColorFixedSel = RGB(110, 180, 230)
        '.BackColorBkg = RGB(90, 158, 214)
        '.BackColorScrollBar = RGB(231, 235, 247)
        '.BackColor1 = RGB(231, 235, 247)
        '.BackColor2 = RGB(239, 243, 255)
        '.GridColor = RGB(148, 190, 231)
        
        .Column(0).Width = 30
        .Column(1).Width = 100
        .Column(2).Width = 300
        .Column(1).MaxLength = 5
        .Column(2).MaxLength = 50
        .Column(1).Mask = cellUpper
        
        .Cell(0, 1).Text = "Supplier Code"
        .Cell(0, 2).Text = "Supplier Name"
    End With
    
    'Open database connection
    Set mobjConn = New adodb.Connection
    mobjConn.Provider = "Microsoft.Jet.OLEDB.4.0"
    
    If Right(App.Path, "1") = "\" Then
        mobjConn.Open App.Path & "demo.mdb"
    Else
        mobjConn.Open App.Path & "\demo.mdb"
    End If
    
    Call ReadData
    
    cmdDelete.Enabled = False
    cmdSave.Enabled = False
End Sub


Private Sub Form_Unload(Cancel As Integer)
    mobjConn.Close
    Set mobjConn = Nothing
    Set Form1 = Nothing
End Sub


Private Sub cmdDelete_Click()
    If Grid1.ActiveCell.Row > 0 And Grid1.ActiveCell.Row < Grid1.Rows - 1 Then
        If Grid1.Cell(Grid1.ActiveCell.Row, 0).Tag <> "N" Then
            mlngCount = mlngCount + 1
            ReDim Preserve marrDeleted(mlngCount) As Long
            marrDeleted(mlngCount) = Val(Grid1.Cell(Grid1.ActiveCell.Row, 1).Tag)
        End If
        
        Grid1.RemoveItem Grid1.ActiveCell.Row
        
        cmdSave.Enabled = True
        
        Call Grid1_EnterRow(Grid1.ActiveCell.Row)
    End If
End Sub


Private Sub cmdQuit_Click()
    Unload Me
End Sub


Private Sub cmdSave_Click()
    If Not VerifyData(Grid1.ActiveCell.Row) Then
        Exit Sub
    End If
    
    If SaveData() Then
        cmdSave.Enabled = False
        MsgBox "Save successful.", vbExclamation
    End If
End Sub


Private Sub Grid1_EditRow(ByVal Row As Long)
    If Row = Grid1.Rows - 1 Then
        Grid1.AddItem ""
        Grid1.Cell(Row, 0).Tag = "N"
        Grid1.SelStart = 1
        cmdDelete.Enabled = True
    Else
        If Grid1.Cell(Row, 0).Tag <> "N" Then
            Grid1.Cell(Row, 0).Tag = "E"
        End If
    End If
    
    cmdSave.Enabled = True
End Sub


Private Sub Grid1_EnterRow(ByVal Row As Long)
    If Row = 0 Or Row = Grid1.Rows - 1 Then
        cmdDelete.Enabled = False
    Else
        cmdDelete.Enabled = True
    End If
End Sub


Private Sub Grid1_LeaveRow(ByVal Row As Long, Cancel As Boolean)
    If Not VerifyData(Row) Then
        Cancel = True
    End If
End Sub


'---------------------------------------------------------------------
'Function    : ReadData()
'Return Value: True  -- Successfully
'              False -- Failed
'---------------------------------------------------------------------
Private Function ReadData() As Boolean
    Dim rs As New adodb.Recordset
    Dim i As Long
    
    On Error GoTo ErrorHandler
    
    Grid1.Rows = 1
    
    'Retrieve data from database
    rs.CursorLocation = adUseClient
    rs.LockType = adLockReadOnly
    rs.CursorType = adOpenStatic
    rs.Open "select suppliercode & chr(9) & suppliername as Item,ID from supplier order by suppliercode", mobjConn
    
    'No record in recordset
    If rs.RecordCount = 0 Then
        Grid1.AddItem ""
        rs.Close
        Set rs = Nothing
        ReadData = True
        Exit Function
    End If
       
    Screen.MousePointer = 11
    
    'Fetch data from recordset and then fill into the grid
    i = 0
    Do While Not rs.EOF
        i = i + 1
        Grid1.AddItem rs("Item").Value, False
        Grid1.Cell(i, 0).Tag = "U"
        Grid1.Cell(i, 1).Tag = rs("ID").Value
        rs.MoveNext
    Loop
    rs.Close
    Set rs = Nothing
    
    'Add a blank row
    Grid1.AddItem ""
    
    Screen.MousePointer = 0
    
    ReadData = True
    Exit Function
    
ErrorHandler:
    Screen.MousePointer = 0
    MsgBox Err.Description, vbExclamation, "Error"
    Err.Clear
End Function


'---------------------------------------------------------------------
'Function    : SaveData()
'Return Value: True  -- Successfully
'              False -- Failed
'---------------------------------------------------------------------
Public Function SaveData() As Boolean
    Dim strSQL As String
    Dim i As Long
    Dim objRs As New adodb.Recordset
    
    On Error GoTo ErrorHandler
    
    Screen.MousePointer = 11
    
    'Deleted records
    For i = 1 To mlngCount
        strSQL = "delete from supplier where id = " & marrDeleted(i)
        mobjConn.Execute strSQL
    Next i
    mlngCount = 0
    ReDim marrDeleted(0) As Long
    
    For i = 1 To Grid1.Rows - 2
        Select Case Grid1.Cell(i, 0).Tag
        Case "N" 'New records
            strSQL = "insert into supplier(suppliercode,suppliername,loguser,logtype,logdatetime) " & _
                     "values ('" & Replace(Grid1.Cell(i, 1).Text, "'", "''") & "'," & _
                             "'" & Replace(Grid1.Cell(i, 2).Text, "'", "''") & "'," & _
                             "'SA'," & _
                             "'A'," & _
                             "'" & Format(Now(), "yyyy-mm-dd hh:mm:ss") & "')"
            mobjConn.Execute strSQL
            
            'ID
            Set objRs = mobjConn.Execute("select max(id) as id from supplier")
            Grid1.Cell(i, 1).Tag = objRs("id").Value
            objRs.Close
            Set objRs = Nothing
            
        Case "E" 'Edited records
            strSQL = "update supplier " & _
                     "set suppliercode = '" & Replace(Grid1.Cell(i, 1).Text, "'", "''") & "'," & _
                         "suppliername = '" & Replace(Grid1.Cell(i, 2).Text, "'", "''") & "'," & _
                         "loguser = 'SA'," & _
                         "logtype = 'M'," & _
                         "logdatetime = '" & Format(Now(), "yyyy-mm-dd hh:mm:ss") & "' " & _
                     "where id = " & Grid1.Cell(i, 1).Tag
            mobjConn.Execute strSQL
        End Select
        
    Next i
    
    'Set all EditFlag to U
    For i = 1 To Grid1.Rows - 2
        Grid1.Cell(i, 0).Tag = "U"
    Next i
    
    Screen.MousePointer = 0
    SaveData = True
    
    Exit Function
    
ErrorHandler:
    Screen.MousePointer = 0
    MsgBox Err.Description, vbExclamation, "Error: " & Err.Number
    Err.Clear
End Function


'---------------------------------------------------------------------
'Function    : VerifyData()
'Return Value: True  -- Successfully
'              False -- Failed
'---------------------------------------------------------------------
Private Function VerifyData(ByVal Row As Long) As Boolean
    Dim i As Long
    Dim blnFound As Boolean
    Dim strTemp As String
    
    If Row = 0 Or Row = Grid1.Rows - 1 Or Not Grid1.Enabled Then
        VerifyData = True
        Exit Function
    End If
    
    'Check supplier code
    strTemp = UCase(Trim(Grid1.Cell(Row, 1).Text))
    If Len(strTemp) <> 5 Then
        MsgBox "The supplier code is is limited to 5 characters.", vbExclamation
        Exit Function
    End If
    
    blnFound = False
    For i = 1 To Row - 1
        If UCase(Grid1.Cell(i, 1).Text) = strTemp Then
            blnFound = True
            Exit For
        End If
    Next i
    If Not blnFound Then
        For i = Row + 1 To Grid1.Rows - 2
            If UCase(Grid1.Cell(i, 1).Text) = strTemp Then
                blnFound = True
                Exit For
            End If
        Next i
    End If
    If blnFound Then
        MsgBox "Supplier code " & strTemp & " exists already.", vbExclamation
        Exit Function
    End If
            
    'Check supplier name
    If Trim(Grid1.Cell(Row, 2).Text) = "" Then
        MsgBox "Please input supplier name！", vbExclamation
        Exit Function
    End If
    
    VerifyData = True
End Function