-

VB开发的ERP系统

'*    最后修改人  :张洪军
'*    最后修改时间: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