企业管理

开发平台：
Visual Basic

：源码内容
							VERSION 5.00
Object = "{D76D7128-4A96-11D3-BD95-D296DC2DD072}#1.0#0"; "VSOCX7.OCX"
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "mscomctl.ocx"
Begin VB.Form Query_Frm 
   BackColor       =   &H80000004&
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "通用查询窗体"
   ClientHeight    =   7080
   ClientLeft      =   3150
   ClientTop       =   855
   ClientWidth     =   6885
   HelpContextID   =   2212015
   Icon            =   "公用_查询.frx":0000
   KeyPreview      =   -1  'True
   LinkTopic       =   "Form5"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   MousePointer    =   4  'Icon
   ScaleHeight     =   7080
   ScaleWidth      =   6885
   ShowInTaskbar   =   0   'False
   StartUpPosition =   2  '屏幕中心
   Begin MSComctlLib.ProgressBar PB_CheckStatus 
      Height          =   375
      Left            =   45
      TabIndex        =   23
      Top             =   3015
      Visible         =   0   'False
      Width           =   6690
      _ExtentX        =   11800
      _ExtentY        =   661
      _Version        =   393216
      Appearance      =   1
      Scrolling       =   1
   End
   Begin VSFlex8Ctl.VSFlexGrid vsFG_Choose 
      Height          =   2955
      Left            =   3900
      TabIndex        =   3
      Top             =   360
      Width           =   2895
      _ExtentX        =   5106
      _ExtentY        =   5212
      Appearance      =   1
      BorderStyle     =   1
      Enabled         =   -1  'True
      BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
         Name            =   "宋体"
         Size            =   9
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      MousePointer    =   0
      BackColor       =   -2147483643
      ForeColor       =   -2147483640
      BackColorFixed  =   -2147483633
      ForeColorFixed  =   -2147483630
      BackColorSel    =   -2147483635
      ForeColorSel    =   -2147483634
      BackColorBkg    =   -2147483636
      BackColorAlternate=   -2147483643
      GridColor       =   -2147483633
      GridColorFixed  =   -2147483632
      TreeColor       =   -2147483632
      FloodColor      =   192
      SheetBorder     =   -2147483642
      FocusRect       =   1
      HighLight       =   1
      AllowSelection  =   -1  'True
      AllowBigSelection=   -1  'True
      AllowUserResizing=   0
      SelectionMode   =   1
      GridLines       =   1
      GridLinesFixed  =   2
      GridLineWidth   =   1
      Rows            =   0
      Cols            =   10
      FixedRows       =   0
      FixedCols       =   0
      RowHeightMin    =   0
      RowHeightMax    =   0
      ColWidthMin     =   0
      ColWidthMax     =   0
      ExtendLastCol   =   0   'False
      FormatString    =   ""
      ScrollTrack     =   0   'False
      ScrollBars      =   3
      ScrollTips      =   0   'False
      MergeCells      =   0
      MergeCompare    =   0
      AutoResize      =   -1  'True
      AutoSizeMode    =   0
      AutoSearch      =   0
      MultiTotals     =   -1  'True
      SubtotalPosition=   1
      OutlineBar      =   0
      OutlineCol      =   0
      Ellipsis        =   0
      ExplorerBar     =   0
      PicturesOver    =   0   'False
      FillStyle       =   0
      RightToLeft     =   0   'False
      PictureType     =   0
      TabBehavior     =   0
      OwnerDraw       =   0
      Editable        =   0   'False
      ShowComboButton =   -1  'True
      WordWrap        =   0   'False
      TextStyle       =   0
      TextStyleFixed  =   0
      OleDragMode     =   0
      OleDropMode     =   0
      DataMode        =   0
      VirtualData     =   -1  'True
   End
   Begin VB.CommandButton Cmd_OK 
      Caption         =   "确定(&O)"
      Height          =   300
      Left            =   4485
      TabIndex        =   12
      Top             =   6690
      Width           =   1120
   End
   Begin MSComctlLib.TreeView TV_PreField 
      Height          =   2955
      Left            =   60
      TabIndex        =   1
      Top             =   360
      Width           =   3090
      _ExtentX        =   5450
      _ExtentY        =   5212
      _Version        =   393217
      Style           =   7
      Appearance      =   1
   End
   Begin VB.CommandButton Cmd_Remove 
      Caption         =   "<"
      BeginProperty Font 
         Name            =   "宋体"
         Size            =   10.5
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   300
      Left            =   3255
      TabIndex        =   21
      TabStop         =   0   'False
      Top             =   915
      Width           =   525
   End
   Begin VB.Frame Fm_Cond 
      Caption         =   "条件选择"
      Height          =   1140
      Left            =   90
      TabIndex        =   22
      Top             =   3405
      Width           =   6690
      Begin MSComctlLib.ImageCombo ImgCmb_Field 
         Height          =   315
         Left            =   150
         TabIndex        =   5
         Top             =   345
         Width           =   2505
         _ExtentX        =   4419
         _ExtentY        =   556
         _Version        =   393216
         ForeColor       =   -2147483640
         BackColor       =   -2147483643
      End
      Begin VB.CommandButton Cmd_L 
         Caption         =   "("
         Height          =   300
         Left            =   5434
         TabIndex        =   18
         TabStop         =   0   'False
         Top             =   735
         Width           =   500
      End
      Begin VB.CommandButton Cmd_R 
         Caption         =   ")"
         Height          =   300
         Left            =   6045
         TabIndex        =   19
         TabStop         =   0   'False
         Top             =   735
         Width           =   500
      End
      Begin VB.CommandButton Cmd_Add 
         Caption         =   "添加条件(A)"
         Height          =   300
         Left            =   150
         TabIndex        =   14
         TabStop         =   0   'False
         Top             =   735
         Width           =   1300
      End
      Begin VB.CommandButton Cmd_Clear 
         Caption         =   "清除条件(L)"
         Height          =   300
         Left            =   1561
         TabIndex        =   15
         TabStop         =   0   'False
         Top             =   735
         Width           =   1300
      End
      Begin VB.CommandButton Cmd_Or 
         Caption         =   "或者(H)"
         Height          =   300
         Left            =   4203
         TabIndex        =   17
         TabStop         =   0   'False
         Top             =   735
         Width           =   1120
      End
      Begin VB.CommandButton Cmd_And 
         Caption         =   "并且(B)"
         Height          =   300
         Left            =   2972
         TabIndex        =   16
         TabStop         =   0   'False
         Top             =   735
         Width           =   1120
      End
      Begin MSComctlLib.ImageCombo ImgCmb_Relation 
         Height          =   315
         Left            =   2947
         TabIndex        =   7
         Top             =   345
         Width           =   810
         _ExtentX        =   1429
         _ExtentY        =   556
         _Version        =   393216
         ForeColor       =   -2147483640
         BackColor       =   -2147483643
      End
      Begin MSComctlLib.ImageCombo ImgCmb_Value 
         Height          =   315
         Left            =   4050
         TabIndex        =   9
         Top             =   345
         Width           =   2505
         _ExtentX        =   4419
         _ExtentY        =   556
         _Version        =   393216
         ForeColor       =   -2147483640
         BackColor       =   -2147483643
      End
      Begin VB.Label Lab_Note 
         AutoSize        =   -1  'True
         Caption         =   "项目(&M)"
         Height          =   180
         Index           =   2
         Left            =   960
         TabIndex        =   4
         Top             =   150
         Width           =   630
      End
      Begin VB.Label Lab_Note 
         AutoSize        =   -1  'True
         Caption         =   "关系(&R)"
         Height          =   180
         Index           =   3
         Left            =   3105
         TabIndex        =   6
         Top             =   150
         Width           =   630
      End
      Begin VB.Label Lab_Note 
         AutoSize        =   -1  'True
         Caption         =   "比较值(&V)"
         Height          =   180
         Index           =   4
         Left            =   4710
         TabIndex        =   8
         Top             =   150
         Width           =   810
      End
   End
   Begin VB.CommandButton Cmd_Choose 
      Caption         =   ">"
      BeginProperty Font 
         Name            =   "宋体"
         Size            =   10.5
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   300
      Left            =   3255
      TabIndex        =   20
      TabStop         =   0   'False
      Top             =   510
      Width           =   525
   End
   Begin VB.TextBox Txt_Query 
      Height          =   1800
      IMEMode         =   1  'ON
      Left            =   75
      MultiLine       =   -1  'True
      ScrollBars      =   2  'Vertical
      TabIndex        =   11
      Top             =   4800
      Width           =   6705
   End
   Begin VB.CommandButton Cmd_Cancel 
      Cancel          =   -1  'True
      Caption         =   "取消(&C)"
      Height          =   300
      Left            =   5655
      TabIndex        =   13
      Top             =   6690
      Width           =   1120
   End
   Begin VB.Label Lab_Note 
      AutoSize        =   -1  'True
      Caption         =   "待选项目(&S)"
      Height          =   180
      Index           =   0
      Left            =   60
      TabIndex        =   0
      Top             =   90
      Width           =   990
   End
   Begin VB.Label Lab_Note 
      AutoSize        =   -1  'True
      Caption         =   "查询项目(&X)"
      Height          =   180
      Index           =   1
      Left            =   3900
      TabIndex        =   2
      Top             =   90
      Width           =   990
   End
   Begin VB.Label Lab_Note 
      AutoSize        =   -1  'True
      Caption         =   "显示条件(&T)"
      Height          =   180
      Index           =   5
      Left            =   105
      TabIndex        =   10
      Top             =   4575
      Width           =   990
   End
End
Attribute VB_Name = "Query_Frm"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'******************************************************************
'*    模 块 名 称 :查询条件
'*    功 能 描 述 :
'*    程序员姓名  :苗鹏
'*    最后修改人  :苗鹏
'*    最后修改时间:2002/01/10
'*    备        注:
'******************************************************************
Dim cQuerys As New CQuery
Dim sFieldOld As String '用以判断是否应该刷新所选字段的值
Public sSqlWhere As String  '返回Where语句
Public collTableName As Collection '用以返回查询条件需要的表
Public bChecked As Boolean
Public QueryTableSql As String
Private Function InitRelation(ImgCmb As ImageCombo) '添加操作符
    With ImgCmb.ComboItems
        .Add , , "="
        .Add , , ">"
        .Add , , "<"
        .Add , , "<>"
        .Add , , ">="
        .Add , , "<="
        .Add , , "Like"
    End With
End Function
Private Sub Cmd_Add_Click() '加入查询条件
    Dim s As String
    s = Me.ImgCmb_Field.Text & " " & Me.ImgCmb_Relation.Text & " " & Me.ImgCmb_Value.Text
    With Me.Txt_Query
        If .SelLength <> 0 Then
            .Text = ReplByPos(.Text, s, .SelStart + 1, .SelStart + .SelLength + 1)
        Else
            .Text = .Text & " " & s
        End If
    End With
End Sub
Private Sub Cmd_And_Click() '加入And
    With Me.Txt_Query
        If .SelLength <> 0 Then
            .Text = ReplByPos(.Text, "并且", .SelStart + 1, .SelStart + .SelLength + 1)
        Else
            .Text = .Text & " " & "并且"
        End If
    End With
End Sub
Private Sub Cmd_Cancel_Click() '退出
    bChecked = False
    sFieldOld = ""
    Unload Me
End Sub
Private Sub Cmd_Choose_Click() '选择字段
    Call TV_PreField_DblClick
End Sub
Private Sub Cmd_Clear_Click() '清空条件
    Me.Txt_Query.Text = ""
End Sub
Private Sub Cmd_L_Click() '左括号
    With Me.Txt_Query
        If .SelLength <> 0 Then
            .Text = ReplByPos(.Text, "(", .SelStart + 1, .SelStart + .SelLength + 1)
        Else
            .Text = .Text & " " & "("
        End If
    End With
    
End Sub
Private Sub Cmd_OK_Click() '验证条件
    Set cQuerys.PB_CheckStatus = Me.PB_CheckStatus
    If cQuerys.CheckFormula(Me.Txt_Query) = True Then
        Me.sSqlWhere = cQuerys.FormulaSys
        cQuerys.GetTableName Me.collTableName
        bChecked = True
    Else
        bChecked = False
        Me.PB_CheckStatus.Visible = False
        Exit Sub
    End If
    Me.PB_CheckStatus.Visible = False
    sFieldOld = ""
    Unload Me
End Sub
Private Sub Cmd_Or_Click() '添加或者
    On Error GoTo ErrCtrl
    With Me.Txt_Query
        If .SelLength <> 0 Then
            .Text = ReplByPos(.Text, "或者", .SelStart + 1, .SelStart + .SelLength + 1)
        Else
            .Text = .Text & " " & "或者"
        End If
    End With
    Exit Sub
ErrCtrl:
    Dim smsg As String
    Dim smsgSys As String
    smsg = GetError(Err.Number)
    smsgSys = Err.Number & Err.Description & "!"
    MsgBox IIf(smsg = "", smsgSys, smsg), vbOKOnly + vbCritical
End Sub
Private Sub Cmd_R_Click() '添加右括号
    On Error GoTo ErrCtrl
    With Me.Txt_Query
        If .SelLength <> 0 Then
            .Text = ReplByPos(.Text, ")", .SelStart + 1, .SelStart + .SelLength + 1)
        Else
            .Text = .Text & " " & ")"
        End If
    End With
    Exit Sub
ErrCtrl:
    Dim smsg As String
    Dim smsgSys As String
    smsg = GetError(Err.Number)
    smsgSys = Err.Number & Err.Description & "!"
    MsgBox IIf(smsg = "", smsgSys, smsg), vbOKOnly + vbCritical
End Sub
Private Sub Cmd_Remove_Click() '删除字段
    Call vsFG_Choose_DblClick
End Sub
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer) '快捷方式
    If Shift = 4 Then '按住Alt
        Select Case KeyCode
            Case 190 '>
                Call Cmd_Choose_Click
            Case 188 '<
                Call Cmd_Remove_Click
            Case 57 '(
                Call Cmd_L_Click
            Case 48 ')
                Call Cmd_R_Click
            Case 65 'A
                Call Cmd_Add_Click
            Case 66 'B
                Call Cmd_And_Click
            Case 72 'H
                Call Cmd_Or_Click
            Case 76 'L
                Call Cmd_Clear_Click
        End Select
    End If
    
End Sub
Private Sub Form_Load()
    '初始化树
    Call InitView(Me.TV_PreField, QueryTableSql)
    '初始化网格
    InitGrid Me.vsFG_Choose
    '初始化关系
    InitRelation Me.ImgCmb_Relation
End Sub
Private Sub Form_Unload(Cancel As Integer)
    Set cQuerys = Nothing
End Sub
Private Sub ImgCmb_Field_Click() '填充字段的可能值
    With Me.ImgCmb_Field
        If .SelectedItem Is Nothing Then
            Exit Sub
        End If
        If Trim(sFieldOld) <> Trim(.SelectedItem.Key) Then
            FillImgCmb .SelectedItem.Tag, Me.ImgCmb_Value
            sFieldOld = .SelectedItem.Key
        End If
        Me.ImgCmb_Value.Text = ""
    End With
End Sub
Private Function FillImgCmb(sTag As String, ImgCmb As ImageCombo) '填充ImgCmb，Text＝Name ,Tag＝Code
    On Error GoTo ErrCtrl
    
    Dim s As String
    Dim sID As String
    Dim sTable As String
    Dim sCode As String
    Dim sName As String
    Dim rs As New ADODB.Recordset
    Dim Item As ComboItem
    
    With ImgCmb
        .ComboItems.Clear
        If Trim(sTag) = "" Then
            Exit Function
        End If
        '取得帮助编码
        GetFieldHelp Me.ImgCmb_Field.SelectedItem.Tag, sID, sTable, sCode, sName
        '判断是否有帮助
        If Trim(sID) = "0" Then
            s = UCase("SELECT #sTable.#sCode AS TCode ,#sTable.#sName AS TName FROM #sTable  ")
        Else
            s = UCase("SELECT #sTable.#sCode AS TCode ,#sTable.#sName AS TName FROM #sTable  WHERE SortID='" & sID & "'")
        End If
        s = Replace(s, UCase("#sTable"), UCase(sTable))
        s = Replace(s, UCase("#sCode"), UCase(sCode))
        s = Replace(s, UCase("#sName"), UCase(sName))
        Set rs = Cw_DataEnvi.DataConnect.Execute(s)
        '如果有帮助,添加可能值
        Do While Not rs.EOF()
            Set Item = .ComboItems.Add(, , Trim(rs!TName & ""))
            Item.Tag = Trim(rs!TCode & "")
            rs.MoveNext
        Loop
        rs.Close
    End With
    Set rs = Nothing
    Set Item = Nothing
    Exit Function
ErrCtrl:
    Set rs = Nothing
    Set Item = Nothing
    Dim smsg As String
    Dim smsgSys As String
    smsg = GetError(Err.Number)
    smsgSys = Err.Number & Err.Description & "!"
    MsgBox IIf(smsg = "", smsgSys, smsg), vbOKOnly + vbCritical
End Function
Private Sub TV_PreField_BeforeLabelEdit(Cancel As Integer)
    Cancel = True
End Sub
Private Function ChooseItem(tv As TreeView, vs As vsFlexGrid, ImgCmb As ImageCombo) '选择字段
    On Error GoTo ErrCtrl
    
    Dim nod As Node
    Dim i As Integer
    Dim Item As ComboItem
    Set nod = tv.SelectedItem
    
    If Not nod.Parent Is Nothing Then
        '添加网格
        i = nod.Parent.Index
        With vs
            .AddItem ""
            .TextMatrix(.Rows - 1, 0) = nod.Parent.Key
            .TextMatrix(.Rows - 1, 1) = nod.Parent.Text
            .TextMatrix(.Rows - 1, 2) = nod.Key
            .TextMatrix(.Rows - 1, 3) = nod.Text
            .TextMatrix(.Rows - 1, 4) = nod.Tag
            .TextMatrix(.Rows - 1, 5) = nod.Parent.Text & "." & nod.Text
        End With
        '添加下拉框
        With ImgCmb
            Set Item = .ComboItems.Add(, nod.Key, nod.Parent.Text & "." & nod.Text)
            Item.Tag = nod.Tag
        End With
        '删除节点
        If nod.Parent.Children = 1 Then
            tv.Nodes.Remove nod.Index
            tv.Nodes.Remove i
        Else
            tv.Nodes.Remove nod.Index
        End If
    End If
    Set nod = Nothing
    Exit Function
    
ErrCtrl:
    Dim smsg As String
    Dim smsgSys As String
    smsg = GetError(Err.Number)
    smsgSys = Err.Number & Err.Description & "!"
    MsgBox IIf(smsg = "", smsgSys, smsg), vbOKOnly + vbCritical
End Function
Private Function RemoveItem(vs As vsFlexGrid, tv As TreeView, ImgCmb As ImageCombo) '删除字段
    On Error GoTo ErrCtrl
    
    Dim nod As Node
    '删除ImgCmb
    With ImgCmb
        .ComboItems.Remove (Trim(vs.TextMatrix(vs.Row, 2)))
        .Text = ""
    End With
    '增加树节点
    With Me.TV_PreField
        
        If Not IsNodeExist(Trim(vs.TextMatrix(vs.Row, 0)), Me.TV_PreField) Then
            Set nod = tv.Nodes.Add("R", tvwChild, Trim(vs.TextMatrix(vs.Row, 0)), Trim(vs.TextMatrix(vs.Row, 1)))
            Set nod = tv.Nodes.Add(Trim(vs.TextMatrix(vs.Row, 0)), tvwChild, Trim(vs.TextMatrix(vs.Row, 2)), Trim(vs.TextMatrix(vs.Row, 3)))
            nod.Tag = Trim(vs.TextMatrix(vs.Row, 4))
        Else
            Set nod = tv.Nodes.Add(Trim(vs.TextMatrix(vs.Row, 0)), tvwChild, Trim(vs.TextMatrix(vs.Row, 2)), Trim(vs.TextMatrix(vs.Row, 3)))
            nod.Tag = Trim(vs.TextMatrix(vs.Row, 4))
        End If
        '删除当前行
        vs.RemoveItem (vs.Row)
    End With
    Exit Function
    
ErrCtrl:
    Dim smsg As String
    Dim smsgSys As String
    smsg = GetError(Err.Number)
    smsgSys = Err.Number & Err.Description & "!"
    MsgBox IIf(smsg = "", smsgSys, smsg), vbOKOnly + vbCritical
End Function
Private Function InitGrid(vs As vsFlexGrid) '初始化网格
    '第1列：表的物理名
    '第2列：表的用户名
    '第3列：字段的物理名
    '第4列：字段的帮助信息
    '第5列：字段的用户名
    On Error GoTo ErrCtrl
    
    Dim i As Integer
    With vs
        .Cols = 6
        For i = 0 To .Cols - 2
            .ColHidden(i) = True
        Next i
        .ColWidth(.Cols - 1) = .Width - 100
    End With
    Exit Function
    
ErrCtrl:
    Dim smsg As String
    Dim smsgSys As String
    smsg = GetError(Err.Number)
    smsgSys = Err.Number & Err.Description & "!"
    MsgBox IIf(smsg = "", smsgSys, smsg), vbOKOnly + vbCritical
End Function
Private Sub TV_PreField_DblClick()
    If Me.TV_PreField.SelectedItem Is Nothing Then
        Exit Sub
    End If
    If Me.TV_PreField.SelectedItem.Children = 0 Then
        ChooseItem Me.TV_PreField, Me.vsFG_Choose, Me.ImgCmb_Field
    End If
End Sub
Private Sub TV_PreField_KeyPress(KeyAscii As Integer)
    If KeyAscii = 13 Then
        Call TV_PreField_DblClick
    End If
End Sub
Private Sub vsFG_Choose_DblClick()
    If Me.vsFG_Choose.Rows > 0 Then
        RemoveItem Me.vsFG_Choose, Me.TV_PreField, Me.ImgCmb_Field
    End If
End Sub
Private Sub vsFG_Choose_KeyPress(KeyAscii As Integer)
    If KeyAscii = 13 Then
        Call vsFG_Choose_DblClick
    End If
End Sub

						