VB开发的ERP系统

'*    程序员姓名  :苗鹏
'*    最后修改人  :苗鹏
'*    最后修改时间: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