VB开发的ERP系统

    WglrGrid.Redraw = False

    SqlStr = "Select A.Objectcode,ObjectName,UnitName,Quantity,ThmonCost,TranEngSign,TranEngSign1 From Cb_ObjectComplete A " _
                & "Left Outer Join (Select ObjectCode,ObjectName,UnitName From Cb_CostObject A " _
                & "Left Outer Join Gy_UnitSet B On A.MeasureUnitCode=B.UnitCode) B On A.ObjectCode=B.ObjectCode " _
                & "Where Year='" + CStr(PrivateYear) + "' And Period='" + CStr(PrivateMm) + "'"
                
    Set RecTemp = Cw_DataEnvi.DataConnect.Execute(SqlStr)
    With RecTemp
        WglrGrid.Rows = WglrGrid.FixedRows
     
        If .EOF Then
            WglrGrid.Redraw = True
            Exit Sub
        End If
     
        jsqte = WglrGrid.FixedRows
        Do While Not .EOF
            WglrGrid.AddItem ""
            '[>>显示
            WglrGrid.TextMatrix(jsqte, 0) = "*"                                                                 '行标识
            WglrGrid.TextMatrix(jsqte, Sydz("002", GridStr(), Szzls)) = Trim(.Fields("Objectcode"))             '对象编码
            WglrGrid.TextMatrix(jsqte, Sydz("003", GridStr(), Szzls)) = Trim(.Fields("ObjectName") & "")        '对象名称
            WglrGrid.TextMatrix(jsqte, Sydz("004", GridStr(), Szzls)) = Trim(.Fields("UnitName") & "")          '计量单位
            WglrGrid.TextMatrix(jsqte, Sydz("005", GridStr(), Szzls)) = Trim(.Fields("Quantity") & "")          '数量
            WglrGrid.TextMatrix(jsqte, Sydz("006", GridStr(), Szzls)) = Trim(.Fields("ThmonCost") & "")         '实际成本
            If TranClassCode = "01" Then
                If Trim(.Fields("TranEngSign") & "") = "" Or Trim(.Fields("TranEngSign") & "") = False Then
                    WglrGrid.TextMatrix(jsqte, Sydz("007", GridStr(), Szzls)) = False                           '结转标志(生产成本)
                Else
                    WglrGrid.TextMatrix(jsqte, Sydz("007", GridStr(), Szzls)) = True                            '结转标志(生产成本)
                End If
            Else
                If Trim(.Fields("TranEngSign1") & "") = "" Or Trim(.Fields("TranEngSign1") & "") = False Then
                    WglrGrid.TextMatrix(jsqte, Sydz("007", GridStr(), Szzls)) = False                           '结转标志(产成品)
                Else
                    WglrGrid.TextMatrix(jsqte, Sydz("007", GridStr(), Szzls)) = True                            '结转标志(产成品)
                End If
            End If
            '<<]
            WglrGrid.RowHeight(jsqte) = Sjhgd
            .MoveNext
            jsqte = jsqte + 1
        Loop
    End With
    
    '将网格刷新解禁(Fixed)
    WglrGrid.Redraw = True
    
End Sub
Private Sub Tlb_Action_ButtonClick(ByVal Button As MSComctlLib.Button)             '用户点击工具条
     
    '屏蔽文本框,下拉组合框有效性判断,即在网格单元内录入数据时,点帮助信息等,不执行文本框等验证,即不执行YdText或YdCombo的LostFocus事件.
    Valilock = True
    
    '屏蔽网格失去焦点产生的有效性判断
    Changelock = True
    Select Case Button.Key
        Case "ymsz"                                          '页面设置
            Dyymctbl.Show 1
        Case "yl"                                            '预 览
             Call bbyl(True)
        Case "dy"                                            '打 印
             Call bbyl(False)
        Case "define"                                        '定 义
            
        Case "run"                                           '结 转
            
            '判断用户是否有此功能执行权限,如有则写上机日志(进入)
            If Not Security_Log(Str_RightEdit, Xtczybm, 1, True) Then
                Exit Sub
            End If
        
            Select Case TranClassCode
            Case "01"
                Call Run1       '结转生产成本
            Case "02"
                Call Run2       '结转产成品
            End Select
            
        Case "bz"                                            '帮 助
            Call F1bz
        Case "fh"                                            '退 出
            Unload Me
    End Select
    '解 锁
    Valilock = False
    Changelock = False
End Sub
Private Sub Form_KeyUp(KeyCode As Integer, Shift As Integer)                     '支持热键操作，更确切地讲，是工具栏热键
    If Shift = 2 Then   'Ctrl的位屏蔽值=2
        Select Case UCase(Chr(KeyCode))
            Case "P"                   'Ctrl+P 打印
                If Tlb_Action.Buttons("dy").Enabled Then Call bbyl(False)
        End Select
    End If
End Sub
Private Sub xswbk()                       '在当前选中单元显示文本框,列表框,帮助按钮(通用)
    Dim Wbkpy As Integer, Wbkpy1 As Integer '文本框偏移量
    
    '如果单据操作状态为浏览状态则不能显示录入载体
    If Trim(Lab_OperStatus.Caption) = "1" Then Exit Sub
    
    '显示文本框前返回有效行列（解决滚动条问题）
    Call Xldqh
    Call Xldql
    
    '隐藏文本框,帮助按钮,列表组合框
    Call Ycwbk
    
    With WglrGrid
        Dqlrwgh = .Row
        Dqlrwgl = .Col
        If Not GridBoolean(.Col, 1) Or .Row < .FixedRows Then Exit Sub
        Wbkpy = 30
        Wbkpy1 = 15
        If GridBoolean(.Col, 3) Then        '若是下拉列表录入
            YdCombo.Left = .CellLeft + .Left + Wbkpy
            YdCombo.Top = .CellTop + .Top + Wbkpy
            YdCombo.Width = .CellWidth - Wbkpy1
            Call Wbkcl                          '主要是在下拉列表框可用之前填充下拉列表框
            YdCombo.Visible = True
            YdCombo.SetFocus
            Ydcommand.Visible = False
            Ydtext.Visible = False
        Else
            If GridBoolean(.Col, 2) Then        '是否提供帮助
                Ydcommand.Left = .Left + .CellLeft + .CellWidth - Ydcommand.Width + Wbkpy
                Ydcommand.Top = .Top + .CellTop + .CellHeight - Ydcommand.Height + Wbkpy
                Ydcommand.Visible = True
            Else
                Ydcommand.Visible = False
            End If
            Ydtext.Left = .CellLeft + .Left + Wbkpy
            Ydtext.Top = .CellTop + .Top + Wbkpy
            If Ydcommand.Visible Then
                If Sfblbzkd Then
                    Ydtext.Width = .CellWidth - Ydcommand.Width
                Else
                    Ydtext.Width = .CellWidth - Wbkpy1
                End If
            Else
                Ydtext.Width = .CellWidth - Wbkpy1
            End If
            Ydtext.Height = .CellHeight - Wbkpy1
            If GridInt(.Col, 2) <> 0 Then
                Ydtext.MaxLength = GridInt(.Col, 2)
            Else
                Ydtext.MaxLength = 3000
            End If
            ' 主要是Zdlrqnr = Trim(.Text)即将网格单元的内容赋予文本框，并且记录网格编辑之前的内容
            '为是否对该单元的内容进行字段有效判断加锁Yxxpdlock = False
            Call Wbkcl
            Ydtext.Visible = True
            Ydtext.SetFocus
        End If
        Dqtoprow = .TopRow
        Dqleftcol = .LeftCol
        
        '重置锁值
        Valilock = False
        Wbkbhlock = False
    End With
End Sub
Private Sub Lrsjhx()                                                   '文本框录入数据回写
    With WglrGrid
        If YdCombo.Visible Then .Text = Trim(YdCombo.Text)
        If Ydtext.Visible Then .Text = Trim(Ydtext.Text)
        
        '(如果字段录入内容发生变化,则打开有效性判断锁)
        If Zdlrqnr <> Trim(.Text) Then
            Yxxpdlock = False
            Hyxxpdlock = False
        End If
        '如果字段录入内容不为空则写数据行有效性标志
        If Len(Trim(.Text)) <> 0 Then
            Call Xyxhbz(.Row)
        End If
        '隐藏文本框,帮助按钮,列表组合框
        Call Ycwbk
    End With
End Sub
Private Sub Wbkcl()                                                 '文本框录入之前处理(根据实际情况)
    Dim xswbrr As String
    With WglrGrid
        Zdlrqnr = Trim(.Text)
        xswbrr = Trim(.Text)
        If GridBoolean(.Col, 3) Then   '列表框录入
            
            '填充列表框程序
            Call FillCombo(YdCombo, GridStr(.Col, 5), xswbrr, 0)
        Else
            Wbkbhlock = True
            
            '====以下为用户自定义
            Ydtext.Text = xswbrr
            '====以上为用户自定义
            
            Wbkbhlock = False
            Ydtext.SelStart = Len(Ydtext.Text)
        End If
    End With
End Sub
Private Function sjzdyxxpd(Dqpdwgh As Long, Dqpdwgl As Long)        '录入数据字段有效性判断,同时进行字段录入事后处理
    Dim Str_JudgeText As String  '临时有效性判断字段内容
    Dim Coljsq As Long           '临时列计数器
    With WglrGrid
        '非录入状态有效性为合法
        If Yxxpdlock Or .Row < .FixedRows Then
            sjzdyxxpd = True
            Exit Function
        End If
        Str_JudgeText = Trim(.TextMatrix(Dqpdwgh, Dqpdwgl))
    End With
    
    Select Case GridStr(Dqpdwgl, 1)
        '以下为自定义部分[
        '以上为自定义部分]
    End Select
    
     '根据转帐性质，判断按转帐科目号取项目大类还是按来源科目取项目大类
    '字段录入正确后为零字段清空
    Call Qkwlzd(Dqpdwgh, Dqpdwgl)
    sjzdyxxpd = True
    Yxxpdlock = True
    Exit Function
Lrcwcl:    '录入错误处理
    With WglrGrid
        Call Xtxxts(Tsxx, 0, 1)
        Changelock = True
        .Select Dqpdwgh, Dqpdwgl
        If GridBoolean(.Col, 1) = True Then
            Changelock = False
            Call xswbk
            sjzdyxxpd = False
        End If
    End With
    Exit Function
End Function
Private Function Sjhzyxxpd(ByVal Yxxpdh As Long) As Boolean                  '录入数据行有效性判断,同时进行行处理
    Dim Lrywlz As Long
    Dim RecTemp As New ADODB.Recordset     '临时使用动态集
    Dim Bln_AssVali As Boolean             '辅助核算错误
    Dim Bj As Boolean                       '辅助项有效性标志
    Dim Rowjsq As Long
    With WglrGrid
    
        '判断行是否为空和无效数据行清除
        If Yxxpdh > (.Rows - .FixedRows) Then Exit Function
        If .TextMatrix(Yxxpdh, 0) <> "*" Then
            Sjhzyxxpd = True
            Exit Function
        Else
            If pdhwk(Yxxpdh) And Yxxpdh + 1 <= .Rows - 1 Then
                If .TextMatrix(Yxxpdh + 1, 0) <> "*" Then
                    Changelock = True
                    .RemoveItem Yxxpdh
                    If .Rows < Pmbcsjhs + .FixedRows + Fzxwghs + 1 Then
                    .AddItem ""
                    .RowHeight(.Rows - 1) = Sjhgd
                    End If
                    Changelock = False
                    Sjhzyxxpd = True
                    Exit Function
                End If
            End If
        End If
        
        '行没有发生变化则不进行有效性判断
        If Hyxxpdlock Then
            Sjhzyxxpd = True
            Exit Function
        End If
  
        '以下为自定义部分[
        '1.放置行有效性判断程序

        '首先进行为空判断(固定不变)
        For jsqte = Qslz To .Cols - 1
            If (GridInt(jsqte, 5) = 1 And Len(Trim(.TextMatrix(Yxxpdh, jsqte))) = 0) Or (GridInt(jsqte, 5) = 2 And Val(Trim(.TextMatrix(Yxxpdh, jsqte))) = 0) Then
                Tsxx = GridStr(jsqte, 2)
                Lrywlz = jsqte
                GoTo Lrcwcl
                Exit For
            End If
        Next jsqte
                
        '2.放置行处理程序
      
        '以上为自定义部分]
    End With
    Sjhzyxxpd = True
    Hyxxpdlock = True
    Exit Function
Lrcwcl:      '录入错误处理
    With WglrGrid
        Call Xtxxts(Tsxx, 0, 1)
        
        Changelock = True
        .Select Yxxpdh, Lrywlz
        Changelock = False
        Sjhzyxxpd = False
        Exit Function
    End With
End Function
Private Function Fun_AllowEdit() As Boolean                      '判断当前定义是否允许编辑或删除
    Fun_AllowEdit = True
End Function
'===================以 下 程 序 为 通 用 部 分 ,一 般 不 需 更 改======================='
Private Sub Lrzdbz()                                             '录入字段帮助
    If Not Ydcommand.Visible Then
        Exit Sub
    End If
    Valilock = True         '为防止按ydText中帮助按纽时，引起ydText的LostFocus事件。
    With WglrGrid
        '[>>会计科目编码帮助单独处理
        Select Case .Col
            Case Sydz("002", GridStr(), Szzls), Sydz("006", GridStr(), Szzls)
                Xtcdcs = Trim(Ydtext.Text)
                PZ_FrmKjkmcz.Show 1
                If Len(Xtfhcs) <> 0 Then
                    Ydtext.Text = Xtfhcs