archivesclass.frm

这个是我以前做的一个客户管理系统.包内已经含有源码和所用到的控件.代码是用VB写的,数据库采用MSSQL的.

VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Begin VB.Form frmArchivesClass 
   Caption         =   "档案类别"
   ClientHeight    =   4980
   ClientLeft      =   60
   ClientTop       =   630
   ClientWidth     =   3630
   Icon            =   "ArchivesClass.frx":0000
   KeyPreview      =   -1  'True
   LinkTopic       =   "Form1"
   ScaleHeight     =   4980
   ScaleWidth      =   3630
   Begin MSComctlLib.ImageList ImageList1 
      Left            =   1680
      Top             =   2850
      _ExtentX        =   1005
      _ExtentY        =   1005
      BackColor       =   -2147483643
      ImageWidth      =   16
      ImageHeight     =   16
      MaskColor       =   16711935
      _Version        =   393216
      BeginProperty Images {2C247F25-8591-11D1-B16A-00C0F0283628} 
         NumListImages   =   2
         BeginProperty ListImage1 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "ArchivesClass.frx":000C
            Key             =   ""
         EndProperty
         BeginProperty ListImage2 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "ArchivesClass.frx":0360
            Key             =   ""
         EndProperty
      EndProperty
   End
   Begin VB.CommandButton cmdOperate 
      Caption         =   "操作..."
      Height          =   345
      Left            =   30
      TabIndex        =   1
      Top             =   4560
      Width           =   1005
   End
   Begin MSComctlLib.TreeView tvClass 
      Height          =   4485
      Left            =   30
      TabIndex        =   0
      Top             =   0
      Width           =   3585
      _ExtentX        =   6324
      _ExtentY        =   7911
      _Version        =   393217
      HideSelection   =   0   'False
      Indentation     =   0
      Style           =   7
      Appearance      =   1
   End
   Begin VB.CommandButton cmdOK 
      Caption         =   "确定"
      Height          =   345
      Left            =   2610
      TabIndex        =   2
      Top             =   4560
      Width           =   1005
   End
   Begin VB.Menu mnuClass 
      Caption         =   "类别"
      Begin VB.Menu mnuClassAdd 
         Caption         =   "新增类别"
      End
      Begin VB.Menu mnuClassModi 
         Caption         =   "修改类别"
      End
      Begin VB.Menu mnuClassDel 
         Caption         =   "删除类别"
      End
      Begin VB.Menu mnuClassDiv 
         Caption         =   "-"
      End
      Begin VB.Menu mnuClassClose 
         Caption         =   "收缩全部"
      End
      Begin VB.Menu mnuClassOpen 
         Caption         =   "展开全部"
      End
   End
End
Attribute VB_Name = "frmArchivesClass"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Public m_bChose     As Boolean  '判断是否是作为选择器

Public m_lClassID   As Long
Public m_sClassName As String
Public m_sClassNo   As String

Dim iClassLevel As Integer


Private Sub cmdOK_Click()
Dim Rst As New ADODB.Recordset
Dim lID As Long
    
    If m_bChose Then
        
        If tvClass.SelectedItem Is Nothing Or tvClass.SelectedItem.Key = "RR0" Then
            MsgBox "请选择客户类别！！！", vbInformation, ""
            Exit Sub
        Else
            lID = CLng(Mid(tvClass.SelectedItem.Key, 3))
            Rst.Open "Select C_Name,C_No,C_ID from Class where C_ID=" & lID, CN
            If Rst.EOF = False Then
                m_lClassID = Rst!C_ID
                m_sClassNo = Rst!C_No
                m_sClassName = Rst!C_Name
            Else
                m_lClassID = 0
                m_sClassName = ""
                m_sClassNo = ""
            End If
            Rst.Close
        End If
        Me.Hide
    Else
        Unload Me
    End If
End Sub

Private Sub cmdOperate_Click()
    PopupMenu mnuClass, , cmdOperate.Left, cmdOperate.Top + cmdOperate.Height
End Sub

Private Sub Form_KeyPress(KeyAscii As Integer)
    If KeyAscii = vbKeyReturn Then
        KeyAscii = 0
        SendKeys "{tab}"
    ElseIf KeyAscii = vbKeyEscape Then
        KeyAscii = 0
        Unload Me
    End If
End Sub

Private Sub Form_Load()
    mnuClass.Visible = False
    Center Me
    Call mbShowClass
    
    
End Sub

Private Sub Form_Resize()
    If Me.WindowState = vbMinimized Or Me.Height < 1000 Then Exit Sub
    tvClass.Left = 0
    tvClass.Top = 0
    tvClass.Height = Me.ScaleHeight - cmdOperate.Height - 100
    tvClass.Width = Me.ScaleWidth
    cmdOperate.Top = tvClass.Height + 50
    cmdOK.Top = cmdOperate.Top
    cmdOK.Left = Me.ScaleWidth - cmdOK.Width
End Sub

Private Function mbShowClass() As Boolean
'********************************
'
'显示客户类别
'
'********************************
Dim tvNodes     As Node
Dim sSql        As String
Dim Rst         As New ADODB.Recordset
    
On Error GoTo ErrShow
    
    tvClass.LabelEdit = tvwManual
    tvClass.ImageList = ImageList1
    tvClass.Nodes.Clear
    
    Set tvNodes = tvClass.Nodes.Add(, , "RR0", "国信客户类别", 2, 2)
    
    sSql = "Select * from Class where C_DelFlag='N' order by C_Level ASC"
    Screen.MousePointer = vbHourglass
    Rst.Open sSql, CN
    Screen.MousePointer = vbDefault
    If Not Rst.EOF Then
        Rst.MoveFirst
        Do Until Rst.EOF
            Select Case Rst("C_Level")
                Case 1
                    Set tvNodes = tvClass.Nodes.Add("RR0", tvwChild, "N1" & Rst("C_ID"), Rst("C_Name"), 1, 2)
                Case 2
                    Set tvNodes = tvClass.Nodes.Add("N1" & Rst("C_P1"), tvwChild, "N2" & Rst("C_ID"), Rst("C_Name"), 1, 2)
                Case 3
                    Set tvNodes = tvClass.Nodes.Add("N2" & Rst("C_P2"), tvwChild, "N3" & Rst("C_ID"), Rst("C_Name"), 1, 2)
                Case 4
                    Set tvNodes = tvClass.Nodes.Add("N3" & Rst("C_P3"), tvwChild, "N4" & Rst("C_ID"), Rst("C_Name"), 1, 2)
                Case 5
                    Set tvNodes = tvClass.Nodes.Add("N4" & Rst("C_P4"), tvwChild, "N5" & Rst("C_ID"), Rst("C_Name"), 1, 2)
            End Select
            Rst.MoveNext
        Loop
    End If
    Rst.Close
    
    tvClass.Nodes("RR0").Expanded = True
    tvClass.Nodes("RR0").Selected = True
    mbShowClass = True
    
Exit Function
ErrShow:
    mbShowClass = False
    gShowMsg "显示客户类别时出错，frmMain.mShowClass()"
End Function

Private Sub mGetNodeInfo(ByVal Node As MSComctlLib.Node)
'****************************************************
'
'Pupose:
'   取得结点的所有父结点及结点的级别，及结点信息
'
'****************************************************

    Dim Rst         As New ADODB.Recordset
    
On Error GoTo errGetNodeInfo

    iClassLevel = 0
    Erase iFather
    
 If Node.Key <> "RR0" Then
 
    iClassLevel = CInt(Mid(Node.Key, 2, 1))
    iClassLevel = iClassLevel + 1
    Select Case iClassLevel     '取得其上的父结点
        Case 1
            
        Case 2
            iFather(1) = Mid(Node.Key, 3)
        Case 3
            iFather(2) = Mid(Node.Key, 3)
            iFather(1) = Mid(Node.Parent.Key, 3)
        Case 4
            iFather(3) = Mid(Node.Key, 3)
            iFather(2) = Mid(Node.Parent.Key, 3)
            iFather(1) = Mid(Node.Parent.Parent.Key, 3)
        Case 5
            iFather(4) = Mid(Node.Key, 3)
            iFather(3) = Mid(Node.Parent.Key, 3)
            iFather(2) = Mid(Node.Parent.Parent.Key, 3)
            iFather(1) = Mid(Node.Parent.Parent.Parent.Key, 3)
    End Select
Else
    iClassLevel = 1
End If

Exit Sub
errGetNodeInfo:
    gShowMsg "取得结点信息时出错，frmModelClass.mGetNodeInfo()"

End Sub

Private Sub DeleteClass()
'*************************************************
'
'删除所选择的客户类别
'
'*************************************************
Dim Rst As New ADODB.Recordset
On Error GoTo Err_Handle
    
    If tvClass.SelectedItem Is Nothing Or tvClass.SelectedItem.Key = "RR0" Then
        MsgBox "请选择要删除的客户类别！！！", vbInformation, ""
    ElseIf tvClass.SelectedItem.Children <> 0 Then
       MsgBox "此客户类别下包含有子类别，删除子类别后方可删除些客户类别！！！", vbInformation, ""
    Else
        Rst.Open "Select Count(*) from Archives where A_ClassID=" & CLng(Mid(tvClass.SelectedItem.Key, 3)), CN
        If Rst(0) = 0 Then
            If MsgBox("您确信要删除此客户类别吗？", vbQuestion + vbYesNo, "") = vbYes Then
                CN.Execute "Update Class set C_Delflag='Y' where C_ID=" & CLng(Mid(tvClass.SelectedItem.Key, 3))
                tvClass.Nodes.Remove tvClass.SelectedItem.Index
            End If
        Else
            MsgBox "些客户类别下包含有客户，删除其下客户后方能删除此客户类别！！！", vbInformation, ""
        End If
        Rst.Close
    End If
    
Exit Sub
Err_Handle:
    gShowMsg "删除客户结点进出错,frmMain.DeleteClass()"
End Sub


Private Sub mnuClassAdd_Click()
    frmClass.mbAdd = True
    frmClass.mFormTitle = "新增客户类别"
    frmClass.mClassLevel = iClassLevel
    frmClass.mClassType = "A"
    frmClass.Show vbModal
End Sub

Private Sub mnuClassClose_Click()
    tvClass.Nodes("RR0").Expanded = False
End Sub

Private Sub mnuClassDel_Click()
    Call DeleteClass
End Sub

Private Sub mnuClassModi_Click()
    
    If tvClass.SelectedItem Is Nothing Or tvClass.SelectedItem.Key = "RR0" Then
        MsgBox "请选择要修改的客户类别！！！", vbInformation, ""
    Else
        frmClass.mbAdd = False
        frmClass.mFormTitle = "修改客户类别"
        frmClass.mC_ID = CLng(Mid(tvClass.SelectedItem.Key, 3))
        frmClass.Show vbModal
    End If
    
    
End Sub

Private Sub mnuClassOpen_Click()
    tvClass.Nodes("RR0").Expanded = True
End Sub

Private Sub tvClass_KeyDown(KeyCode As Integer, Shift As Integer)
    If KeyCode = vbKeyF5 Then
        KeyCode = 0
        Call mbShowClass
    End If
End Sub

Private Sub tvClass_NodeClick(ByVal Node As MSComctlLib.Node)
    Call mGetNodeInfo(Node)
End Sub