searcharch.frm

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

         BackStyle       =   0  'Transparent
         Caption         =   "档案编号："
         Height          =   255
         Left            =   120
         TabIndex        =   14
         Top             =   840
         Width           =   1065
      End
   End
   Begin VB.Image imgSplitter 
      Height          =   4785
      Left            =   2280
      MousePointer    =   9  'Size W E
      Top             =   30
      Width           =   150
   End
End
Attribute VB_Name = "frmSearchArch"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Const sglSplitLimit = 500
Dim mbMoving As Boolean

Public mArchiveID As Long
Public mCustomerName As String

Private Function mCreateString() As String
'生成查询字符串

Dim sNo         As String
Dim sName       As String
Dim sAddress    As String
Dim sTel        As String
Dim sSql        As String

On Error GoTo ErrHandle

    sNo = Trim(txtArchiveNo)
    sName = Trim(txtCustomerName)
    sAddress = Trim(txtAddress)
    sTel = Trim(txtTelephone)
    
    If sNo = "" And sName = "" And sAddress = "" And sTel = "" Then
        mCreateString = ""
        Exit Function
    End If
    
    sSql = ""
    If sNo <> "" Then sSql = sSql & " A.A_No like '%" & sNo & "%' and "
    If sName <> "" Then sSql = sSql & " CT_Name like '%" & sName & "%' and "
    If sTel <> "" Then sSql = sSql & " CT_Telephone like '%" & sTel & "%' and "
    If sAddress <> "" Then sSql = sSql & " CT_Address like '%" & sAddress & "%' and "
    
    sSql = Mid(sSql, 1, Len(sSql) - 4)

    mCreateString = "Where " & sSql
    

Exit Function
ErrHandle:
    mCreateString = ""
End Function


Private Sub mClear()
'清空控件值

    txtArchiveNo.Text = ""
    txtCustomerName.Text = ""
    txtTelephone.Text = ""
    txtAddress.Text = ""

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
    Call mShowData("where A.A_ClassID=0")
    mbShowClass = True
    
Exit Function
ErrShow:
    mbShowClass = False
    gShowMsg "显示客户类别时出错，frmMain.mShowClass()"
End Function

Private Sub mShowData(ByVal SQLWhere As String)
'*************************************************
'
'显示相应的数据
'
'*************************************************

    Dim Rs          As New ADODB.Recordset
    Dim sSql        As String
    Dim lKey        As Long
    Dim i           As Integer
    Dim J           As Integer
    
On Error GoTo errShowData
    
    
        vsf.Rows = 2
        vsf.Clear flexClearScrollable, flexClearEverything

'<编号     |客户名称           |地址               |产品类别   |电话           |传真           |备注"


        sSql = "Select A.A_ID,A.A_NO,CT_Name,CT_Address,CT_ProductType,CT_Telephone,CT_Fax,CT_Memo from Customers CT inner join Archives A on A.A_ID=CT.CT_AID  " & SQLWhere
        Screen.MousePointer = vbHourglass
        Rs.Open sSql, CN
        Screen.MousePointer = vbDefault

        If Rs.EOF = False Then
            i = 0
            Rs.MoveFirst
            Do Until Rs.EOF
                i = i + 1
                If i = vsf.Rows Then vsf.Rows = i + 1
                
                For J = 0 To vsf.Cols - 1
                    vsf.TextMatrix(i, J) = IIf(IsNull(Rs(J + 1)), "", Rs(J + 1))
                Next J
                vsf.RowData(i) = IIf(IsNull(Rs!A_ID), 0, CStr(Rs!A_ID))
                Rs.MoveNext
            Loop
        End If
        Rs.Close
Exit Sub

errShowData:
    Screen.MousePointer = vbDefault
    gShowMsg "显示数据时出错，frmModelClass.mShowData()"
End Sub

Private Sub cmdCancle_Click()
    Unload Me
End Sub

Private Sub cmdOK_Click()
    mArchiveID = vsf.RowData(vsf.Row)
    mCustomerName = vsf.TextMatrix(vsf.Row, 1)
    Me.Hide
End Sub

Private Sub cmdSearch_Click()
Dim sTmp As String

    sTmp = mCreateString
    If sTmp = "" Then
        MsgBox "请输入查询条件！！！", vbInformation + vbOKOnly, "提示"
        Exit Sub
    Else
        Call mShowData(sTmp)
    End If
    
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()
    Center Me
    Me.KeyPreview = True
    vsf.Cols = 7
    vsf.FormatString = "<编号     |客户名称           |地址               |产品类别   |电话           |传真           |备注"
    Call mClear
    Call mbShowClass
End Sub

Private Sub imgSplitter_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    With imgSplitter
        picSplitter.Move .Left, .Top, .Width \ 2, .Height - 20
    End With
    picSplitter.Visible = True
    mbMoving = True
End Sub

Private Sub imgSplitter_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Dim sglPos As Single
    

    If mbMoving Then
        sglPos = X + imgSplitter.Left
        If sglPos < sglSplitLimit Then
            picSplitter.Left = sglSplitLimit
        ElseIf sglPos > Me.Width - sglSplitLimit Then
            picSplitter.Left = Me.Width - sglSplitLimit
        Else
            picSplitter.Left = sglPos
        End If
    End If
End Sub

Private Sub imgSplitter_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    SizeControls picSplitter.Left
    picSplitter.Visible = False
    mbMoving = False
End Sub

Sub SizeControls(X As Single)
    
    On Error Resume Next
    If X < 1500 Then X = 1500
    If X > (Me.Width - 1500) Then X = Me.Width - 1500
    
    tvClass.Width = X
    picSearch.Width = X
    imgSplitter.Left = X
    vsf.Left = X + 40
    
    tvClass.Left = 0
    tvClass.Top = 0
    tvClass.Height = Me.ScaleHeight - picBar.Height - 50
    
    picSearch.Left = 0
    picSearch.Top = 0
    picSearch.Height = tvClass.Height
    
    vsf.Top = tvClass.Top
    vsf.Left = tvClass.Width + 50
    vsf.Width = Me.ScaleWidth - tvClass.Width - 50
    vsf.Height = tvClass.Height
    
    imgSplitter.Top = tvClass.Top
    imgSplitter.Height = tvClass.Height
    
End Sub


Private Sub Form_Resize()

    On Error Resume Next
    If Me.Width < 3000 Then Me.Width = 3000
    SizeControls imgSplitter.Left

End Sub

Private Sub Option1_Click(Index As Integer)
    If Index = 0 Then
        tvClass.ZOrder (0)
    Else
        picSearch.ZOrder (0)
    End If
End Sub

Private Sub picBar_Resize()
    cmdOK.Left = picBar.Width - cmdOK.Width - 50
    cmdCancle.Left = cmdOK.Left - cmdCancle.Width - 10
End Sub

Private Sub picSearch_Resize()
    txtArchiveNo.Width = picSearch.Width - 300
    txtCustomerName.Width = txtArchiveNo.Width
    txtTelephone.Width = txtArchiveNo.Width
    txtAddress.Width = txtArchiveNo.Width
End Sub

Private Sub tvClass_NodeClick(ByVal Node As MSComctlLib.Node)
    If Node.Key <> "" Then
        Call mShowData("where  A_ClassID=" & CLng(Mid(Node.Key, 3)))
    End If

End Sub