frmgrupe.frm

大量优秀的vb编程

VERSION 5.00
Begin VB.Form frmGrupe 
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "组别信息"
   ClientHeight    =   4380
   ClientLeft      =   48
   ClientTop       =   336
   ClientWidth     =   3744
   Icon            =   "frmGrupe.frx":0000
   LinkTopic       =   "Form1"
   MDIChild        =   -1  'True
   ScaleHeight     =   4380
   ScaleWidth      =   3744
   ShowInTaskbar   =   0   'False
   Begin VB.CommandButton cmdGDelete 
      Caption         =   "删除"
      Height          =   255
      Left            =   960
      TabIndex        =   15
      Top             =   3960
      Width           =   1095
   End
   Begin VB.CommandButton cmdGExit 
      Caption         =   "退出"
      Height          =   255
      Left            =   2040
      TabIndex        =   14
      Top             =   3960
      Width           =   855
   End
   Begin VB.CommandButton cmdGAdd 
      Caption         =   "添加"
      Height          =   255
      Left            =   120
      Style           =   1  'Graphical
      TabIndex        =   13
      Top             =   3960
      Width           =   852
   End
   Begin VB.CommandButton cmdGLast 
      Height          =   255
      Left            =   3360
      Picture         =   "frmGrupe.frx":000C
      Style           =   1  'Graphical
      TabIndex        =   12
      Top             =   3480
      Width           =   255
   End
   Begin VB.CommandButton cmdGFirst 
      Height          =   255
      Left            =   120
      Picture         =   "frmGrupe.frx":010E
      Style           =   1  'Graphical
      TabIndex        =   11
      Top             =   3480
      Width           =   255
   End
   Begin VB.CommandButton cmdNext 
      Height          =   255
      Left            =   3120
      Picture         =   "frmGrupe.frx":0210
      Style           =   1  'Graphical
      TabIndex        =   10
      Top             =   3480
      Width           =   255
   End
   Begin VB.CommandButton cmdPrev 
      Height          =   255
      Left            =   360
      Picture         =   "frmGrupe.frx":0312
      Style           =   1  'Graphical
      TabIndex        =   9
      Top             =   3480
      Width           =   255
   End
   Begin VB.TextBox txtGCurent 
      BeginProperty Font 
         Name            =   "MS Sans Serif"
         Size            =   7.8
         Charset         =   0
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   285
      Left            =   720
      TabIndex        =   8
      Top             =   3480
      Width           =   2295
   End
   Begin VB.ListBox lstG 
      Height          =   1668
      Left            =   120
      TabIndex        =   4
      Top             =   1680
      Width           =   3372
   End
   Begin VB.TextBox txtDenG 
      Height          =   285
      Left            =   1320
      TabIndex        =   3
      Top             =   1320
      Width           =   2172
   End
   Begin VB.TextBox txtCodG 
      Height          =   285
      Left            =   1320
      TabIndex        =   2
      Top             =   960
      Width           =   2172
   End
   Begin VB.TextBox txtCodD 
      Height          =   285
      Left            =   1320
      TabIndex        =   1
      Top             =   600
      Width           =   2172
   End
   Begin VB.ComboBox cmbD 
      Height          =   276
      ItemData        =   "frmGrupe.frx":0414
      Left            =   1320
      List            =   "frmGrupe.frx":0416
      TabIndex        =   0
      Top             =   240
      Width           =   2175
   End
   Begin VB.Label lblDom 
      Caption         =   "类别信息"
      BeginProperty Font 
         Name            =   "MS Sans Serif"
         Size            =   9.6
         Charset         =   0
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   252
      Left            =   120
      TabIndex        =   16
      Top             =   240
      Width           =   1212
   End
   Begin VB.Label lblDenG 
      Caption         =   "组别名称"
      BeginProperty Font 
         Name            =   "MS Sans Serif"
         Size            =   9.6
         Charset         =   0
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   252
      Left            =   120
      TabIndex        =   7
      Top             =   1320
      Width           =   972
   End
   Begin VB.Label lblCodG 
      Caption         =   "组别编号"
      BeginProperty Font 
         Name            =   "MS Sans Serif"
         Size            =   9.6
         Charset         =   0
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   252
      Left            =   120
      TabIndex        =   6
      Top             =   960
      Width           =   852
   End
   Begin VB.Label lblCodD 
      Caption         =   "类别编号"
      BeginProperty Font 
         Name            =   "MS Sans Serif"
         Size            =   9.6
         Charset         =   0
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   252
      Left            =   120
      TabIndex        =   5
      Top             =   600
      Width           =   972
   End
End
Attribute VB_Name = "frmGrupe"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim rs1 As Recordset
Dim bookm As String
Dim nr_inreg As Long
Dim savemode As Boolean
Dim setdeschis As Boolean


Private Sub cmbD_Click()
Dim sir As String
Dim cd As Long 'codul domeniului
sir = cmbD.Text
On Error Resume Next
Set rs = db.OpenRecordset("SELECT * FROM domenii " & "WHERE den_dom = " & "'" & sir & "'", dbOpenDynaset)
cd = rs("cod_dom")
Set rs1 = db.OpenRecordset("SELECT * FROM grupe " & "WHERE cod_dom = " & cd & " ORDER BY den_gr", dbOpenDynaset)
txtCodD.Text = rs("cod_dom")

''''In cazul in care nu avem inreg. intr-un anumit domeniu
''''va fi nevoie de introducerea unei prime inregistari
If (rs1.EOF = True And rs1.BOF = True) Then
  Call ClearControls
  Call DisableControls
  txtCodG.SetFocus
  lstG.Clear
  txtGCurent.Text = ""
  cmdGDelete.Enabled = False
  savemode = True  'adaugam o inregistrare
  Exit Sub
End If
''''''
txtCodG.Text = CStr(rs1("cod_gr"))
txtDenG.Text = rs1("den_gr")
lstG.Clear
Do While Not rs1.EOF
 lstG.AddItem rs1("den_gr")
 rs1.MoveNext
Loop
'''''
nr_inreg = rs1.RecordCount
rs1.MoveFirst
bookm = rs1.Bookmark
Call EnableControls
lstG.Selected(rs.AbsolutePosition) = True
txtGCurent.Text = "编号 " & rs1.AbsolutePosition + 1 & " 总计 " & rs1.RecordCount
cmdGDelete.Enabled = True
setdeschis = True
End Sub

Private Sub cmdGAdd_Click()
Call ClearControls
Call DisableControls
txtCodG.SetFocus
savemode = True
End Sub

Private Sub cmdGDelete_Click()
If rs1.RecordCount = 1 Then
    Call DisableControls
    savemode = True
End If
If rs1.EOF = True And rs1.BOF = True Then
 savemode = True
 MsgBox "No current record !", vbCritical + vbOKOnly
 Exit Sub
End If
On Error Resume Next
rs1.Delete
Call ClearControls 'stergem continutul controalelor
rs1.MoveFirst
'''''''''''''''
'''''In cazul in care dorim sa stergem prima inregistrare in Recordset
'''''vom atribui variabilei bookm, Bookmark-ul inreg. urmatoare
'''''pentru a putea folosi drept index de pornire pentru lstG
If lstG.ListIndex = 0 Then bookm = rs1.Bookmark

lstG.RemoveItem (lstG.ListIndex) 'Stergem articolul din lista

lstG.Refresh
lstG.Selected(rs1.AbsolutePosition) = True
txtGCurent.Text = "编号 " & rs1.AbsolutePosition + 1 & " 总计 " & rs1.RecordCount

End Sub

Private Sub cmdGExit_Click()
If setdeschis = True Then
 rs1.Close
 Set rs1 = Nothing
 Unload Me
End If
Unload Me
End Sub

Private Sub cmdGFirst_Click()
 rs1.MoveFirst
 txtCodG.Text = rs1("cod_gr")
 txtDenG.Text = rs1("den_gr")
 lstG.Selected(rs1.AbsolutePosition) = True
 txtGCurent.Text = "编号 " & rs1.AbsolutePosition + 1 & " 总计 " & rs1.RecordCount
End Sub

Private Sub cmdGLast_Click()
rs1.MoveLast
 txtCodG.Text = rs1("cod_gr")
 txtDenG.Text = rs1("den_gr")
 lstG.Selected(rs1.AbsolutePosition) = True
 txtGCurent.Text = "编号 " & rs1.AbsolutePosition + 1 & " 总计 " & rs1.RecordCount
End Sub

Private Sub cmdNext_Click()
If Not rs1.EOF Then
  rs1.MoveNext
 If rs1.EOF Then Exit Sub
  txtCodG.Text = rs1("cod_gr")
  txtDenG.Text = rs1("den_gr")
  lstG.Selected(rs1.AbsolutePosition) = True 'indexul prop. Selected porneste de la 0 !
  txtGCurent.Text = "编号 " & rs1.AbsolutePosition + 1 & " 总计 " & rs1.RecordCount
End If
End Sub

Private Sub cmdPrev_Click()
If Not rs1.BOF Then
 rs1.MovePrevious
 If rs1.BOF Then Exit Sub
 txtCodG.Text = rs1("cod_gr")
 txtDenG.Text = rs1("den_gr")
 lstG.Selected(rs1.AbsolutePosition) = True
 txtGCurent.Text = "编号 " & rs1.AbsolutePosition + 1 & " 总计 " & rs1.RecordCount
End If
End Sub

Private Sub Form_Load()
Set rs = db.OpenRecordset("domenii", dbOpenDynaset) 'Trebuie specificat tipul Dynaset (implicit, setul de inreg. foloseste dbOpenTabel), deoarece proprietatea AbsolutePosition a obiectului rs nu ar merge altfel !!!
Do While Not rs.EOF
 cmbD.AddItem rs("den_dom")
 rs.MoveNext
Loop
savemode = False
Call DisableControls 'initial controalele de traversare a Recordset-ului sunt dezactivate
txtCodD.Locked = True 'nu avem nevoie de modificarea codului domeniului
setdeschis = False
cmdGDelete.Enabled = False
End Sub



Private Sub lstG_Click()
Dim sir As String
Dim ind As Integer

If savemode = True Then  'in cazul in care renuntam sa mai
   savemode = False      'adaugam o noua inreg., mutaindu-ne
   Call EnableControls   'pe o alta inreg, facem savemode=False
End If

ind = lstG.ListIndex
sir = lstG.List(ind)
'''''''''
rs1.Move ind, bookm

txtCodG.Text = rs1("cod_gr")
txtDenG.Text = rs1("den_gr")
txtGCurent.Text = "编号 " & ind + 1 & " 总计 " & rs1.RecordCount
End Sub

Private Sub DisableControls()
cmdGFirst.Enabled = False
cmdPrev.Enabled = False
cmdNext.Enabled = False
cmdGLast.Enabled = False
cmdGAdd.Enabled = False
End Sub

Private Sub EnableControls()
cmdGFirst.Enabled = True
cmdPrev.Enabled = True
cmdNext.Enabled = True
cmdGLast.Enabled = True
cmdGAdd.Enabled = True
End Sub

Private Sub ClearControls()
txtCodG.Text = ""
txtDenG.Text = ""
End Sub

Private Sub txtCodG_KeyDown(KeyCode As Integer, Shift As Integer)
If KeyCode = vbKeyReturn Then Call Save
End Sub


Private Sub Save()
If savemode = True Then
  rs1.AddNew  'adaugam o inegistrare
  Else: rs1.Edit 'modificam o inregistrare
End If
'''''''''
If (Len(Trim(txtCodG.Text)) <> 0 And (Len(Trim(txtDenG.Text)) <> 0)) Then
    On Error GoTo ERR
    rs1("cod_dom") = CLng(txtCodD.Text)
    rs1("cod_gr") = CLng(txtCodG.Text)
    rs1("den_gr") = txtDenG.Text
    rs1.Update
    rs1.Bookmark = rs1.LastModified
    ''''
    If savemode = True Then
      lstG.AddItem rs1("den_gr") 'adaugam in ListView ultima inreg. adaugata
      Else: lstG.List(lstG.ListIndex) = rs1("den_gr")
    End If
    '''''
    lstG.Refresh
    ''''
    rs1.MoveFirst
    bookm = rs1.Bookmark
    lstG.Selected(rs1.AbsolutePosition) = True
    nr_inreg = rs1.RecordCount
    txtGCurent.Text = "编号 " & rs1.AbsolutePosition + 1 & " 总计 " & rs1.RecordCount
    Call EnableControls
    savemode = False
    cmdGDelete.Enabled = True
 Else: Exit Sub
End If
ERR:
 If ERR.Number = 3022 Then
  MsgBox "Duplicate record !", vbCritical + vbOKOnly
  Exit Sub
 End If
End Sub

Private Sub txtCodG_KeyPress(KeyAscii As Integer)
Dim strValid As String
strValid = "0123456789"
    If InStr(strValid, Chr(KeyAscii)) = 0 Then
        KeyAscii = 0
    End If
End Sub

Private Sub txtDenG_KeyDown(KeyCode As Integer, Shift As Integer)
If KeyCode = vbKeyReturn Then Call Save
End Sub