企业管理

开发平台：
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    =   6990
   ClientLeft      =   3150
   ClientTop       =   855
   ClientWidth     =   7080
   Icon            =   "通用查询窗体.frx":0000
   KeyPreview      =   -1  'True
   LinkTopic       =   "Form5"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   MousePointer    =   4  'Icon
   ScaleHeight     =   6990
   ScaleWidth      =   7080
   ShowInTaskbar   =   0   'False
   StartUpPosition =   2  '屏幕中心
   Begin MSComctlLib.ProgressBar PB_CheckStatus 
      Height          =   375
      Left            =   150
      TabIndex        =   24
      Top             =   3030
      Visible         =   0   'False
      Width           =   6690
      _ExtentX        =   11800
      _ExtentY        =   661
      _Version        =   393216
      Appearance      =   1
      Scrolling       =   1
   End
   Begin VB.TextBox Text1 
      Enabled         =   0   'False
      Height          =   765
      IMEMode         =   1  'ON
      Left            =   315
      MultiLine       =   -1  'True
      ScrollBars      =   2  'Vertical
      TabIndex        =   23
      Top             =   5880
      Width           =   6555
   End
   Begin VSFlex8Ctl.VSFlexGrid vsFG_Choose 
      Height          =   2955
      Left            =   4005
      TabIndex        =   3
      Top             =   375
      Width           =   2865
      _ExtentX        =   5054
      _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            =   4665
      TabIndex        =   12
      Top             =   6690
      Width           =   1120
   End
   Begin MSComctlLib.TreeView TV_PreField 
      Height          =   2955
      Left            =   165
      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            =   3360
      TabIndex        =   21
      TabStop         =   0   'False
      Top             =   930
      Width           =   525
   End
   Begin VB.Frame Fm_Cond 
      Caption         =   "条件选择"
      Height          =   1095
      Left            =   195
      TabIndex        =   22
      Top             =   3420
      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          =   270
         Left            =   5407
         TabIndex        =   18
         TabStop         =   0   'False
         Top             =   735
         Width           =   500
      End
      Begin VB.CommandButton Cmd_R 
         Caption         =   ")"
         Height          =   270
         Left            =   5985
         TabIndex        =   19
         TabStop         =   0   'False
         Top             =   735
         Width           =   500
      End
      Begin VB.CommandButton Cmd_Add 
         Caption         =   "添加条件(A)"
         Height          =   300
         Left            =   255
         TabIndex        =   14
         TabStop         =   0   'False
         Top             =   735
         Width           =   1300
      End
      Begin VB.CommandButton Cmd_Clear 
         Caption         =   "清除条件(L)"
         Height          =   300
         Left            =   1633
         TabIndex        =   15
         TabStop         =   0   'False
         Top             =   735
         Width           =   1300
      End
      Begin VB.CommandButton Cmd_Or 
         Caption         =   "或者(H)"
         Height          =   300
         Left            =   4209
         TabIndex        =   17
         TabStop         =   0   'False
         Top             =   735
         Width           =   1120
      End
      Begin VB.CommandButton Cmd_And 
         Caption         =   "并且(B)"
         Height          =   300
         Left            =   3011
         TabIndex        =   16
         TabStop         =   0   'False
         Top             =   735
         Width           =   1120
      End
      Begin MSComctlLib.ImageCombo ImgCmb_Relation 
         Height          =   315
         Left            =   2940
         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            =   4005
         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            =   1275
         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            =   4650
         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            =   3360
      TabIndex        =   20
      TabStop         =   0   'False
      Top             =   525
      Width           =   525
   End
   Begin VB.TextBox Txt_Query 
      Height          =   1200
      IMEMode         =   1  'ON
      Left            =   330
      MultiLine       =   -1  'True
      ScrollBars      =   2  'Vertical
      TabIndex        =   11
      Top             =   4620
      Width           =   6555
   End
   Begin VB.CommandButton Cmd_Cancel 
      Cancel          =   -1  'True
      Caption         =   "取消(&C)"
      Height          =   300
      Left            =   5835
      TabIndex        =   13
      Top             =   6690
      Width           =   1120
   End
   Begin VB.Label Lab_Note 
      AutoSize        =   -1  'True
      Caption         =   "待选项目(&S)"
      Height          =   180
      Index           =   0
      Left            =   240
      TabIndex        =   0
      Top             =   90
      Width           =   990
   End
   Begin VB.Label Lab_Note 
      AutoSize        =   -1  'True
      Caption         =   "查询项目(&X)"
      Height          =   180
      Index           =   1
      Left            =   4950
      TabIndex        =   2
      Top             =   120
      Width           =   990
   End
   Begin VB.Label Lab_Note 
      Caption         =   "显示条件 &T"
      Height          =   1050
      Index           =   5
      Left            =   105
      TabIndex        =   10
      Top             =   4620
      Width           =   225
   End
End
Attribute VB_Name = "Query_Frm"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'**************************************************************************************************
'*    模 块 名 称 :通用查询
'*    功 能 描 述 :
'*    程序员姓名  :张洪军
'*    最后修改人  :张洪军
'*    最后修改时间:2001/12/13
'*    备        注:程序中所有依实际情况自定义部分均用[>> <<]括起,注意此种录入需要修改"Sub Scdqfl"
'*
'*    1.每次调入外部功能窗体，均要加锁ChangeLock=True,窗体关闭后解锁ChangeLock=false
'*
'*    3.Lab_OperStatus 用此标签来标识单据录入状态(默认值为1) 1-浏览 2-修改
'**************************************************************************************************
 
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()
    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()
    
'    InitView Me.TV_PreField
    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
    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)
    On Error GoTo ErrCtrl
    Dim i As Integer
    '第1列：表的物理名
    '第2列：表的用户名
    '第3列：字段的物理名
    '第4列：字段的帮助信息
    '第5列：字段的用户名
    
    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

						