VB开发的ERP系统

    With GsToolbar
        .Buttons("bcgs").Enabled = True
        .Buttons("hfmrgs").Enabled = True
        .Buttons("szxsxm").Enabled = True
    End With
    '自定义]
End Sub

Private Sub BcCommand_Click()                                           '保 存
    If Not Bclrsj Then
        Exit Sub
    End If
    If Lrzt = 2 Then   '修改编辑状态
        Call Toolfbjzt
    End If
End Sub

Private Sub QxCommand_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)       '取消
    '避免执行Click程序
    Bln_Cancel = True
    Call Cancel
End Sub

Private Sub QxCommand_Click()                                                                         '取消
    If Bln_Cancel Then
        Bln_Cancel = False
        Exit Sub
    End If
    Call Cancel
End Sub

Private Sub Cancel()                                                                                  '取消
    '文本框加锁
    For Jsqte = 0 To Max_Text_Index
        TextValiJudgeLock(Jsqte) = True  '光标离开不必进行有效性判断
    Next Jsqte
    Call Toolfbjzt
End Sub

Private Sub GsToolbar_ButtonClick(ByVal Button As MSComctlLib.Button)   '表格格式设置(通用)
    Select Case Button.Key
    Case "bcgs"                              '保存表格格式
        Call Bcwggs(CzxsGrid, GridCode, GridStr())
    Case "hfmrgs"                            '恢复默认格式
        Call Hfmrgs(CzxsGrid, GridCode, GridStr())
    Case "szxsxm"                            '设置显示项目
        Call Szxsxm(CzxsGrid, GridCode)
    End Select
End Sub

Private Sub bbyl(bbylte As Boolean)                    '报表打印预览
    Dim Bbzbt$, Bbxbt() As String, bbxbtzzxs() As Integer, Bbxbtgs As Integer
    Dim Bbbwh() As String, Bbbwhzzxs() As Integer, Bbbwhgs As Integer
    Bbxbtgs = 1                                          '报 表 小 标 题 行 数
    Bbbwhgs = 0                                          '报 表 表 尾 行 数
    ReDim Bbxbt(1 To Bbxbtgs)
    ReDim bbxbtzzxs(1 To Bbxbtgs)
    If Bbbwhgs <> 0 Then
        ReDim Bbbwh(1 To Bbbwhgs)
        ReDim Bbbwhzzxs(1 To Bbbwhgs)
    End If
    Bbzbt = ReportTitle
    Bbxbt(1) = " "
    bbxbtzzxs(1) = 0                                     '报表行组织形式(0-居左 1-居中 2-居右)
    Call Scyxsjb(CzxsGrid)                               '生成报表数据
    Call Scdybb(Dyymctbl, Bbzbt, Bbxbt(), bbxbtzzxs(), Bbxbtgs, Bbbwh(), Bbbwhzzxs(), Bbbwhgs, bbylte)
    If Not bbylte Then
        Unload DY_Tybbyldy
    End If
End Sub

'************以下为文本框录入处理程序(固定不变部分)*************'

Private Sub Wbklrwbcl(Index As Integer)    '文本框录入事后处理程序
    
    '以下为依据实际情况自定义部分[
    
    '在此填写文本框录入事后处理程序
    SendKeys "vbtab"
    ']以上为依据实际情况自定义部分
End Sub

Private Sub LrText_Change(Index As Integer)
    
    '屏蔽程序改变控制
    If TextChangeLock Then
        Exit Sub
    End If
    TextValiJudgeLock(Index) = False    '打开有效性判断锁
    '限制字段录入长度
    TextChangeLock = True  '加锁(防止执行Lrtext_Change)
    Select Case Textint(Index, 1)  '文本框索引值
    Case 8           '金额型
        Call Sjgskz(LrText(Index), Xtjezws - Xtjexsws - 1, Xtjexsws)
    Case 9           '数量型
        Call Sjgskz(LrText(Index), Xtslzws - Xtslxsws - 1, Xtslxsws)
    Case 10          '单价型
        Call Sjgskz(LrText(Index), Xtdjzws - Xtdjxsws - 1, Xtdjxsws)
    Case Else        '其他小数类型控制
        If Textint(Index, 6) <> 0 Or Textint(Index, 7) <> 0 Then  '字段小数位个数、整数位个数。
            Call Sjgskz(LrText(Index), Textint(Index, 6), Textint(Index, 7))
        End If
    End Select
    TextChangeLock = False '解锁
End Sub

Private Sub LrText_GotFocus(Index As Integer)                                                 '文本框得到焦点,显示相应信息
    Call TextShow(Index)
    CurTextIndex = Index
    LrText(Index).SelStart = Len(LrText(Index))
End Sub

Private Sub LrText_KeyDown(Index As Integer, KeyCode As Integer, Shift As Integer)            '字段按F2键提供帮助
    Select Case KeyCode
    Case vbKeyF2
        Call Text_Help(Index)
    End Select
End Sub

Private Sub LrText_KeyPress(Index As Integer, KeyAscii As Integer)                            '文本框录入事中控制
    Call InputFieldLimit(LrText(Index), Textint(Index, 1), KeyAscii)
End Sub

Private Sub LrText_LostFocus(Index As Integer)                                                '文本框失去焦点进行有效性判断及相应处理
    If Textint(Index, 9) = 0 Or Textint(Index, 9) = 1 Then '事中判断
        Call TextYxxpd(Index)
    End If
End Sub

Private Sub Ydcommand1_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)     '按钮提供帮助
    Call Text_Help(Index)
End Sub

Private Sub Text_Help(Index As Integer)                                                       '录入字段帮助
    If Not Textboolean(Index, 1) Then
        Exit Sub
    End If
    TextValiJudgeLock(Index) = True   '按帮助按纽时，不进行有效性判断
    
    '先进行有效性判断
    If Not TextYxxpd(CurTextIndex) Then
        Exit Sub
    End If
    Call Drbmhelp(Textint(Index, 2), Textstr(Index, 4), Trim(LrText(Index).Text))  '帮助类型，帮助编码（HelpCode），文本框录入内容
    If Len(Xtfhcs) <> 0 Then
        If Textint(Index, 3) = 1 Then   '如果返回显示名称
            LrText(Index).Text = Xtfhcsfz
            LrText(Index).Tag = Xtfhcs
        Else                            '如果返回显示编码
            LrText(Index).Text = Xtfhcs
            LrText(Index).Tag = Xtfhcsfz
        End If
    End If
    TextValiJudgeLock(Index) = False
    LrText(Index).SetFocus
End Sub

Private Sub TextShow(Index As Integer)        '文本框得到焦点,显示相应信息
    
    '填写文本框得到焦点,进行相应信息处理程序
    '可以填写帮助按纽显示并调整位置。
End Sub

Private Function TextYxxpd(Index As Integer) As Boolean           '文本框有效性判断，数据的正确性
    '可以补充自定义限制
    If TextValiJudgeLock(Index) Then    '=True文本框内容不需进行有效性判断时，退出
        TextYxxpd = True
        Exit Function
    End If
    If Trim(LrText(Index)) = "" Then
        LrText(Index).Tag = ""
        Call Wbklrwbcl(Index)
        TextValiJudgeLock(Index) = True  '文本框内容不需进行有效性判断时，退出
        TextYxxpd = True
        Exit Function
    End If
    Select Case Textint(Index, 4)
    Case 1      '编码型
        SqlStr = Trim(Textstr(Index, 5)) '有效性判断依据有内容时
        SqlStr = Replace(SqlStr, "@", "'" + Trim(LrText(Index).Text) + "'")
        Set RecTemp = Cw_DataEnvi.DataConnect.Execute(SqlStr)
        If RecTemp.EOF Then
            Call Xtxxts(Trim(Textstr(Index, 6)), 0, 1)
            LrText(Index).SetFocus
            Exit Function
        Else
            Select Case Textint(Index, 3) '显示编码还是显示名称
            Case 0 '显示编码
                If Len(Trim(Textstr(Index, 2))) <> 0 Then
                    LrText(Index).Text = Trim(RecTemp.Fields(Trim(Textstr(Index, 2))))
                End If
                If Len(Trim(Textstr(Index, 3) & "")) <> 0 Then
                    LrText(Index).Tag = Trim(RecTemp.Fields(Trim(Textstr(Index, 3))))
                End If
            Case 1 '显示名称
                If Len(Trim(Textstr(Index, 3) & "")) <> 0 Then
                    LrText(Index).Text = Trim(RecTemp.Fields(Trim(Textstr(Index, 3))))
                End If
                If Len(Trim(Textstr(Index, 2))) <> 0 Then
                    LrText(Index).Tag = Trim(RecTemp.Fields(Trim(Textstr(Index, 2))))
                End If
            End Select
        End If
    Case 2      '日期型
        If IsDate(LrText(Index).Text) Then
            LrText(Index).Text = Format(LrText(Index).Text, "yyyy-mm-dd")
        Else
            Tsxx = "非法公历日期!(格式:" + Format(Date, "yyyy-mm-dd") + ")"
            Call Xtxxts(Tsxx, 0, 1)
            LrText(Index).SetFocus
            Exit Function
        End If
    Case 3      '其他类型
    End Select
    TextValiJudgeLock(Index) = True
    TextYxxpd = True
End Function

Public Sub Define()             '定义转帐关系
    
    Dim gnsybm As String      '功能索引编码
    Dim gnsymc As String      '功能索引名称
    If CzxsGrid.Rows = CzxsGrid.FixedRows Then
        Tsxx = "请首先新增转帐过程!"
        Call Xtxxts(Tsxx, 0, 4)
        Exit Sub
    End If
    If Trim(CzxsGrid.TextMatrix(CzxsGrid.Row, Sydz("001", GridStr(), Szzls))) = "" Then
        Tsxx = "请选择转帐过程!"
        Call Xtxxts(Tsxx, 0, 4)
        Exit Sub
    Else
        '为转帐定义窗体传递该转帐过程参数
        CzxsGrid.Tag = CzxsGrid.TextMatrix(CzxsGrid.Row, Sydz("001", GridStr(), Szzls))
        SqlStr = "Select * From Xt_xtgnb where gnmc='" & Xt_Control.tvTreeView.SelectedItem.Text & "'"
        Set RecTemp = Cw_DataEnvi.DataConnect.Execute(SqlStr)
        gnsybm = Trim(RecTemp.Fields("gnsy") & "")
        gnsymc = Trim(RecTemp.Fields("gnmc") & "")
        Select Case gnsybm
        Case "Cwzz_UserDefineTran"                                 '"自定义转帐凭证"
            AutoTran_DefiMy.Show 1
        Case "Cwzz_ProfitTran"                                     '"期间损益结转"
            AutoTran_DefiSy.Show 1
        Case "Cwzz_ModelTran"                                      '"模式结转凭证"
            AutoTran_DefiCus.Show 1
        Case "Cwzz_ExchangeTran"                                   '"汇兑损益凭证"
            AutoTran_DefiExchange.Show 1
        End Select
    End If
    
End Sub

Private Sub Run1()                                          '执行自定义转帐程序
    
    Dim Tj_Main As String                                   '总帐取数公式
    Dim Tj_List As String                                   '明细帐取数公式
    Dim Tj_Ass As String                                    '辅助帐取数公式
    
    Dim jsq As Integer                                      '临时计数器
    Dim i As Integer
    Dim Str_Formula As String                               '公式串
    Dim DestTranOri As String                               '对方汇总数的借贷方向
    Dim lng_OperationNum As Long
    Bln_DeleteFlag = True
    
    If Tran_Pd = False Then
        Exit Sub
    End If
    
    On Error GoTo Err1
    Cw_DataEnvi.DataConnect.BeginTrans
    
    TranCount = TranJsq          '记录生成凭证的个数
    VoidStr = ""         '记录没有数值的空凭证序号
    
    '对转帐列表网格内选中的TranJsq个转帐过程依次生成凭证，写到临时凭证数据表中
    For jsq = 1 To TranJsq
        
        '写临时凭证主表
        lng_OperationNum = CreatBillID("0102")
        Call Save_TempPz_Main(TranVouchClass(jsq), TranNum(jsq), OperationNum, lng_OperationNum)
        
        '对方汇总数的借贷方向
        SqlStr = "Select ccode,TranOri,FormulaString from Cwzz_AutoTranItem where Trancode='" & TranNum(jsq) & "' and TranClass='" & TranClassCode & "' and FormulaString like '%对方汇总数%' Order by AutoTranId"
        Set Rec_AutoTranItem = Cw_DataEnvi.DataConnect.Execute(SqlStr)
        If Rec_AutoTranItem.EOF = False Then
            DestTranOri = Rec_AutoTranItem.Fields("tranori")
        End If
        
        Jhj = 0
        Dhj = 0   '对方汇总金额
        Jhjsl = 0
        Dhjsl = 0
        JhjItemSl = 0
        DhjItemSl = 0
        i = 0
        hjje = 0      '合计金额
        '按转帐定义关系，取每笔转帐数据，写入临时数据辅表中
        SqlStr = "select * from Cwzz_AutoTranItem where Trancode='" & TranNum(jsq) & "' and TranClass='" & TranClassCode & "' and FormulaString not like '%对方汇总数%' ORDER BY AutoTranId"
        Set Rec_AutoTranItem = Cw_DataEnvi.DataConnect.Execute(SqlStr)
        Do While Rec_AutoTranItem.EOF = False
            
            Str_Formula = Trim(Rec_AutoTranItem.Fields("FormulaString"))
            Str_Formula = Fn_Replace(Str_Formula, Chk_Vouch.Value)
            
            SqlStr = "select " & Str_Formula & " as ReturnValue"
            Set RecTemp = Cw_DataEnvi.DataConnect.Execute(SqlStr)
            If RecTemp.EOF = False Then
                Je = IIf(IsNull(RecTemp.Fields("ReturnValue")), 0, RecTemp.Fields("ReturnValue"))