其他数据库

开发平台：
Visual Basic

frmItem.frm：源码内容
							VERSION 5.00
Object = "{5E9E78A0-531B-11CF-91F6-C2863C385E30}#1.0#0"; "MSFLXGRD.OCX"
Begin VB.Form frmItem 
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "项目管理"
   ClientHeight    =   3720
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   5715
   BeginProperty Font 
      Name            =   "宋体"
      Size            =   10.5
      Charset         =   134
      Weight          =   400
      Underline       =   0   'False
      Italic          =   0   'False
      Strikethrough   =   0   'False
   EndProperty
   Icon            =   "frmItem.frx":0000
   KeyPreview      =   -1  'True
   LinkTopic       =   "Form1"
   LockControls    =   -1  'True
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   3720
   ScaleWidth      =   5715
   ShowInTaskbar   =   0   'False
   StartUpPosition =   1  '所有者中心
   Begin VB.TextBox txtEdit 
      Height          =   345
      Left            =   690
      TabIndex        =   10
      Top             =   1695
      Visible         =   0   'False
      Width           =   1185
   End
   Begin VB.Frame fraName 
      Height          =   930
      Left            =   2910
      TabIndex        =   8
      Top             =   975
      Width           =   2565
      Begin VB.TextBox txtName 
         Height          =   360
         Left            =   960
         TabIndex        =   1
         Top             =   345
         Width           =   1395
      End
      Begin VB.Label Label1 
         AutoSize        =   -1  'True
         BackStyle       =   0  'Transparent
         Caption         =   "名 称:"
         Height          =   210
         Left            =   180
         TabIndex        =   9
         Top             =   420
         Width           =   630
      End
   End
   Begin VB.ComboBox cboTable 
      Height          =   330
      Left            =   2910
      Style           =   2  'Dropdown List
      TabIndex        =   0
      Top             =   510
      Width           =   2565
   End
   Begin VB.Frame fraCmd 
      Height          =   1440
      Left            =   2910
      TabIndex        =   6
      Top             =   2040
      Width           =   2565
      Begin VB.CommandButton cmdEdit 
         Enabled         =   0   'False
         Height          =   435
         Index           =   3
         Left            =   120
         Picture         =   "frmItem.frx":000C
         Style           =   1  'Graphical
         TabIndex        =   2
         Top             =   270
         Width           =   1140
      End
      Begin VB.CommandButton cmdEdit 
         Height          =   435
         Index           =   2
         Left            =   1350
         Picture         =   "frmItem.frx":1DAB
         Style           =   1  'Graphical
         TabIndex        =   5
         Top             =   840
         Width           =   1140
      End
      Begin VB.CommandButton cmdEdit 
         Enabled         =   0   'False
         Height          =   435
         Index           =   1
         Left            =   120
         Picture         =   "frmItem.frx":3C1C
         Style           =   1  'Graphical
         TabIndex        =   4
         Top             =   840
         Width           =   1140
      End
      Begin VB.CommandButton cmdEdit 
         Enabled         =   0   'False
         Height          =   435
         Index           =   0
         Left            =   1350
         Picture         =   "frmItem.frx":5A1C
         Style           =   1  'Graphical
         TabIndex        =   3
         Top             =   270
         Width           =   1140
      End
   End
   Begin MSFlexGridLib.MSFlexGrid msfGrid 
      Height          =   3300
      Left            =   285
      TabIndex        =   7
      Top             =   210
      Width           =   2370
      _ExtentX        =   4180
      _ExtentY        =   5821
      _Version        =   393216
      Cols            =   1
      FixedCols       =   0
      FormatString    =   "<名    称          "
   End
   Begin VB.Label Label2 
      Caption         =   "请选择表名:"
      Height          =   270
      Left            =   2940
      TabIndex        =   11
      Top             =   225
      Width           =   1170
   End
End
Attribute VB_Name = "frmItem"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim mTableName As String
Dim mRst As Recordset
Dim mSql As String
Dim mOldName As String
Private Type ItemStruc
    ID As Long
    TableName As String
    Alias As String
End Type
Dim mATable() As ItemStruc
'*****cmdEdit
Const mAPPEND = 3
Const mDELETE = 0
Const mSAVE = 1
Const mRETURN = 2
'******msfGrid
Const mGridName = 0
Const mGRIDID = 1
Const mGRIDLOG = 2
Const mFormatString = "<名    称          |<ID |<Log"
Const mMsg1 = "名称不能为空,请您输入名称后再试!!"
Const mMsg2 = "请选择表名!!"
Const mMsg3 = "对不起!您不能删除该记录,因该职务员工表在用!"
Const mMsg4 = "对不起!您不能删除该记录,因该请假类型在用!"
Const mMsg5 = "对不起!您不能删除该记录,因该部门还有员工!"
Private Sub IniForm()
    SetGridColor msfGrid
    With msfGrid
        .FormatString = mFormatString
        .ColWidth(mGRIDID) = 0
        .ColWidth(mGRIDLOG) = 0
    End With
    txtEdit.BackColor = gGridBackColor
End Sub
Private Sub cboTable_Click()
    Dim IntID As Long
    With cboTable
        If .ListIndex = -1 Then Exit Sub
        IntID = .ItemData(.ListIndex)
        Dim strTable As String
        strTable = GetTableName(IntID)
        If strTable = Empty Then Exit Sub
        mTableName = strTable
        RefreshGrid strTable
    End With
End Sub
Private Sub RefreshGrid(strTable As String)
    mSql = " select * from " & strTable _
        & " where F_DelFlag=" & gFALSE _
        & " order by ID"
    Set mRst = gDataBase.OpenRecordset(mSql, dbOpenSnapshot)
    Dim Str As String
    Dim intRows As Integer
    Dim intCols As Integer
    While Not mRst.EOF
        intRows = intRows + 1
        Str = Str & Trim(mRst!Name) & vbTab
        Str = Str & CStr(mRst!ID) & vbTab
        Str = Str & gFALSE
        If Not mRst.EOF Then Str = Str & vbCr
        mRst.MoveNext
    Wend
    mRst.Close
    Set mRst = Nothing
    intCols = 3
    intRows = intRows + msfGrid.FixedRows
    ClipToGrid msfGrid, Str, intRows, intCols
    cmdEdit(mDELETE).Enabled = (msfGrid.Rows > msfGrid.FixedRows)
End Sub
Private Sub cboTable_KeyDown(KeyCode As Integer, Shift As Integer)
    If KeyCode = vbKeyReturn Then
        SendKeyTab KeyCode
    End If
End Sub
Private Sub cmdEdit_Click(Index As Integer)
    Select Case Index
        Case mAPPEND
            AppendData
        Case mSAVE
            SaveData
        Case mDELETE
            DeleteData
            cmdEdit(mDELETE).Enabled = (msfGrid.Rows > msfGrid.FixedRows)
        Case mRETURN
            If cmdEdit(mSAVE).Enabled Then
                If MsgBox(gMsg8, vbQuestion + vbYesNo, gTitle) = vbYes Then
                    SaveData
                End If
            End If
            Unload Me
    End Select
End Sub
Private Sub SaveData()
    With msfGrid
        If Not ValidTableName Then Exit Sub
        Dim I As Integer
        Dim strName As String
        Dim lngID As Long
        Dim intLog As Integer
        On Error GoTo SaveErr
        For I = .FixedRows To .Rows - 1
            intLog = CInt(.TextMatrix(I, mGRIDLOG))
            
            If intLog = gTRUE Then
                lngID = Val(.TextMatrix(I, mGRIDID))
                strName = Trim(.TextMatrix(I, mGridName))
                mSql = " Update " & mTableName _
                    & " set Name='" & strName & "'" _
                    & " where ID=" & lngID
                gDataBase.Execute mSql
                .TextMatrix(I, mGRIDLOG) = gFALSE
            End If
        Next
    End With
    cmdEdit(mSAVE).Enabled = False
    Exit Sub
SaveErr:
    MsgBox gMsg5 & vbCrLf & Err.Description, vbExclamation, gTitle
    Err.Clear
End Sub
Private Sub DeleteData()
    Dim IsTrans As Boolean
    With msfGrid
        If .Rows <= .FixedRows Then Exit Sub
        If .row < .FixedRows Then
            MsgBox gMsg4, vbExclamation, gTitle
            Exit Sub
        End If
        Dim tmpStr As String
'        If mTableName = "Title" Then
'            tmpStr = mMsg3
'        ElseIf mTableName = "LeaveType" Then
'            tmpStr = mMsg4
'        ElseIf mTableName = "Department" Then
'            tmpStr = mMsg5
'        End If
'
'        If MsgBox(tmpStr, vbQuestion + vbOKCancel _
'            + vbDefaultButton2, gTitle) = vbCancel Then Exit Sub
        If MsgBox(gMsg10, vbOKCancel + vbQuestion + vbDefaultButton2) = vbCancel Then Exit Sub
        
        Dim lngID As Long
        lngID = Val(.TextMatrix(.row, mGRIDID))
        
        If mTableName = "Title" Then
            mSql = "select * from Employee where TitleID=" _
                & lngID & " order by WorkNo"
        ElseIf mTableName = "LeaveType" Then
            mSql = "select * from Leave where TypeId=" _
                & lngID & " order by WorkNo"
        ElseIf mTableName = "Department" Then
            mSql = "select * from Employee where DeptID=" _
                & lngID & " order by WorkNo"
        End If
        
        Set mRst = gDataBase.OpenRecordset(mSql)
        If mRst.RecordCount > 0 Then
            If mTableName = "Title" Then
                tmpStr = mMsg3
            ElseIf mTableName = "LeaveType" Then
                tmpStr = mMsg4
            ElseIf mTableName = "Department" Then
                tmpStr = mMsg5
            End If
            MsgBox tmpStr, vbExclamation, gTitle
            Exit Sub
        End If
        If Not ValidTableName Then Exit Sub
        On Error GoTo DeleteErr
        BeginTrans
        IsTrans = True
        
'        If mTableName = "LeaveType" Then
'            mSql = "update " & "Leave" & _
'                " set F_DelFlag=" & gTRUE _
'                & " Where TypeID=" & lngID
'        ElseIf mTableName = "Title" Then
'            mSql = "update " & "Employee" & _
'                " set F_DelFlag=" & gTRUE _
'                & " Where TitleID=" & lngID
'        ElseIf mTableName = "Department" Then
'            mSql = "update " & "Employee" & _
'                " set F_DelFlag=" & gTRUE _
'                & " Where DeptID=" & lngID
'        End If
'        gDataBase.Execute mSql
        
        mSql = "update " & mTableName & _
            " set F_DelFlag=" & gTRUE _
            & " Where ID=" & lngID
        gDataBase.Execute mSql
        CommitTrans
        IsTrans = False
        
        If .Rows = .FixedRows + 1 Then
            .Rows = .FixedRows
        Else
            .RemoveItem .row
        End If
        
    End With
    mSql = ""
    Exit Sub
DeleteErr:
    If IsTrans Then Rollback
    MsgBox gMsg6 & vbCrLf & Err.Description, vbExclamation, gTitle
    Err.Clear
End Sub
Private Function ValidTableName() As Boolean
    ValidTableName = True
    If mTableName = "" Then
        MsgBox mMsg2, vbInformation, gTitle
        cboTable.SetFocus
        ValidTableName = False
        Exit Function
    End If
End Function
Private Sub AppendData()
    Dim strName As String
    strName = Trim(txtName)
    If strName = Empty Then
        MsgBox mMsg1, vbInformation, gTitle
        txtName.SetFocus
        Exit Sub
    End If
    
    If Not ValidTableName Then Exit Sub
    
    On Error GoTo AppendErr
    mSql = " select * from " & mTableName _
        & " where Name='" & strName & "'" _
        & " and F_DelFlag=" & gFALSE
    Set mRst = gDataBase.OpenRecordset(mSql)
    If mRst.RecordCount > 0 Then
        MsgBox gMsg3, vbExclamation, gTitle
        txtName.SetFocus
        Exit Sub
    End If
    
    mSql = "Insert into " & mTableName & "(Name)" _
        & " values('" & strName & "')"
    gDataBase.Execute mSql
    RefreshGrid mTableName
    txtName = ""
    txtName.SetFocus
    Exit Sub
AppendErr:
    MsgBox gMsg7 & vbCrLf & Err.Description, vbExclamation, gTitle
    Err.Clear
End Sub
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
    Dim AltDown As Boolean
    AltDown = (Shift And vbAltMask) > 0
    If AltDown Then
        Select Case KeyCode
            Case vbKeyA
                cmdEdit_Click mAPPEND
            Case vbKeyS
                cmdEdit_Click mSAVE
            Case vbKeyD
                cmdEdit_Click mDELETE
            Case vbKeyR
                cmdEdit_Click mRETURN
        End Select
    End If
    
    If KeyCode = vbKeyF2 Then
        cmdEdit_Click mSAVE
    End If
    If KeyCode = 27 Then
        cmdEdit_Click mRETURN
    End If
End Sub
Private Sub Form_Load()
    IniForm
    IniCbo
End Sub
Private Function GetTableName(IntID As Long) As String
    GetTableName = Empty
    Dim I As Integer
    For I = 0 To UBound(mATable)
        If mATable(I).ID = IntID Then
            GetTableName = Trim(mATable(I).TableName)
            Exit For
        End If
    Next
End Function
Private Sub IniCbo()
    ReDim mATable(0)
    Dim IntLen As Integer
    mATable(0).ID = 0
    mSql = "select F_ID,F_TableName,F_ItemName from T_Struct order by F_ID "
    Set mRst = gDataBase.OpenRecordset(mSql, dbOpenSnapshot)
    While Not mRst.EOF
        IntLen = UBound(mATable)
        IntLen = IntLen + 1
        ReDim Preserve mATable(IntLen)
        With mATable(IntLen)
            .ID = mRst!F_ID
            .TableName = IIf(IsNull(mRst!F_TableName), "", Trim(mRst!F_TableName))
            .Alias = IIf(IsNull(mRst!F_ItemName), "", Trim(mRst!F_ItemName))
        End With
        mRst.MoveNext
    Wend
    mRst.Close
    Set mRst = Nothing
    
    Dim I As Integer
    If UBound(mATable) > 0 Then
        For I = 1 To UBound(mATable)
            With mATable(I)
                cboTable.AddItem .Alias
                cboTable.ItemData(cboTable.NewIndex) = .ID
            End With
        Next
        cboTable.ListIndex = 0
    End If
    cmdEdit(mAPPEND).Enabled = (cboTable.ListCount > 0)
End Sub
Private Sub msfGrid_DblClick()
    With msfGrid
        If .MouseRow = 0 Then Exit Sub
        If .Rows <= .FixedRows Then Exit Sub
        mOldName = Trim(.TextMatrix(.row, mGridName))
        SetTxtPosition msfGrid, txtEdit
    End With
End Sub
Private Sub msfGrid_KeyDown(KeyCode As Integer, Shift As Integer)
    If KeyCode = vbKeyReturn Then
        msfGrid_DblClick
    End If
End Sub
Private Sub txtEdit_GotFocus()
    GotFocus txtEdit
End Sub
Private Sub txtEdit_KeyDown(KeyCode As Integer, Shift As Integer)
    Select Case KeyCode
        Case vbKeyReturn
            Dim strName As String
            strName = Trim(txtEdit)
            If strName = Empty Then Exit Sub
            txtEdit.Visible = False
            If mOldName <> strName Then
                With msfGrid
                    .TextMatrix(.row, mGridName) = strName
                    .TextMatrix(.row, mGRIDLOG) = gTRUE
                End With
                If Not cmdEdit(mSAVE).Enabled Then cmdEdit(mSAVE).Enabled = True
            End If
            msfGrid.SetFocus
        Case vbKeyDown, vbKeyUp
            txtEdit.Visible = False
            KeyDownByUpDown msfGrid, KeyCode
            msfGrid.SetFocus
    End Select
End Sub
Private Sub txtEdit_LostFocus()
    txtEdit.Visible = False
End Sub
Private Sub txtName_GotFocus()
    GotFocus txtName
End Sub
Private Sub txtName_KeyDown(KeyCode As Integer, Shift As Integer)
    If KeyCode = vbKeyReturn Then
        SendKeyTab KeyCode
    End If
End Sub

						