+

VB开发的ERP系统

    End If
    If Lrzt = 2 Then
        Call Toolfbjzt
    End If
End Sub

Private Sub QxCommand_Click()                                                                         '取消
    If DEBUG_FLAG = False Then On Error Resume Next
    If Bln_Cancel Then
        Bln_Cancel = False
        Exit Sub
    End If
    
    Call Cancel
End Sub

Private Sub Cancel()                                                                                  '取消
    If DEBUG_FLAG = False Then On Error Resume Next
    '文本框加锁
    Dim Jsqte
    For Jsqte = 0 To Max_Text_Index
        TextValiJudgeLock(Jsqte) = True
    Next Jsqte
    Call Toolfbjzt
End Sub

Private Sub Scdqjl()                 '删 除 当 前 记 录
    If DEBUG_FLAG = False Then On Error Resume Next
    Dim yhAnswer As Integer
    
    '判断用户是否有此功能执行权限,如有则写上机日志(进入)
    If Not Security_Log(Str_RightEdit, Xtczybm, 1, True) Then
         Exit Sub
    End If
    
    If CzxsGrid.Row < CzxsGrid.FixedRows Then
        Exit Sub
    End If
    Tsxx = "请确认是否删除当前记录?"
    yhAnswer = Xtxxts(Tsxx, 2, 2)
    If yhAnswer = 2 Then
        Exit Sub
    End If
    On Error GoTo Cwcl
    
    '[以下需自定义部分
    Dim temRs As New ADODB.Recordset
    Dim strItem As String
    Dim strItemClass As String
    strItem = CzxsGrid.TextMatrix(CzxsGrid.Row, Sydz("006", GridStr(), Szzls))
    strItemClass = CzxsGrid.TextMatrix(CzxsGrid.Row, Sydz("005", GridStr(), Szzls))
    
    Set temRs = Cw_DataEnvi.DataConnect.Execute("delete from cwfx_ItemGrossProfitSet where ItemClassCode='" & strItemClass & "' AND ItemCode='" & strItem & "'")
    '以上为自定义部分]
    
    CzxsGrid.RemoveItem CzxsGrid.Row
    Exit Sub
Cwcl:
    If Err.Number = -2147217900 Then
        Tsxx = "该编码已经被使用,不能删除!"
        Call Xtxxts(Tsxx, 0, 1)
        Exit Sub
    Else
        Tsxx = "出现未知情况,该编码不能被删除!"
        Call Xtxxts(Tsxx, 0, 1)
        Exit Sub
    End If
End Sub

Private Sub Xgdqjl()                                       '修改当前编码记录
    
    '判断用户是否有此功能执行权限,如有则写上机日志(进入)
    If Not Security_Log(Str_RightEdit, Xtczybm, 1, True, False) Then
        BcCommand.Enabled = False
    End If

    If DEBUG_FLAG = False Then On Error Resume Next
    If CzxsGrid.Row < CzxsGrid.FixedRows Then
        Exit Sub
    End If
    Call Toolbjzt
    Lrzt = 2
    Call Cshlrxx(Lrzt)
    
End Sub

Private Function Cshlrxx(lrztxx As Integer) As Boolean              '初始化录入字段信息
    If DEBUG_FLAG = False Then On Error Resume Next
    Dim Jsqte
    Dim SqlStr As String
    TextChangeLock = True       '关闭Chang事件
    If lrztxx = 1 Then '新增
        For Jsqte = 0 To Max_Text_Index
            If Len(Trim(Textstr(Jsqte, 1))) <> 0 Then
                lrText(Jsqte).Text = ""
                lrText(Jsqte).Tag = ""
            End If
            TextValiJudgeLock(Jsqte) = True
        Next Jsqte
    Else  'else lrztxx=2 修改
        Dim strItemClass As String
        Dim strItem As String
        Dim temRs As New ADODB.Recordset
        strItemClass = CzxsGrid.TextMatrix(CzxsGrid.Row, Sydz("005", GridStr(), Szzls))
        strItem = CzxsGrid.TextMatrix(CzxsGrid.Row, Sydz("006", GridStr(), Szzls))
        Imgebo_ItemClass.Enabled = False
        
        With temRs
            If .State = adStateOpen Then .Close
            SqlStr = "SELECT * FROM cwfx_ItemGrossProfitSet WHERE ItemClassCode='" & strItemClass & "' AND ItemCode='" & strItem & "'"
            temRs.Open SqlStr, Cw_DataEnvi.DataConnect
            If Not (.EOF And .BOF) Then
                lrText(0).Text = Trim(!ItemCode)
                strOldItemCode = lrText(0).Text  '记录末修改前的编码
                Dim I
                For I = 1 To Imgebo_ItemClass.ComboItems.count
                    If Right(Imgebo_ItemClass.ComboItems(I).Key, Len(Imgebo_ItemClass.ComboItems(I).Key) - 1) = Trim(temRs!ItemClasscode) Then
                        Imgebo_ItemClass.Text = Imgebo_ItemClass.ComboItems(I).Text
                        Exit For
                    End If
                Next
            Else
                Tsxx = "记录已被删除!"
                Call Xtxxts(Tsxx, 0, 1)
            End If
            temRs.Close
            Set temRs = Nothing
        End With
    End If
    TextChangeLock = False
End Function

Private Sub Toolbjzt()                                     'Toolbar状态(编辑状态)
    If DEBUG_FLAG = False Then On Error Resume Next
    StTab.TabEnabled(1) = True
    StTab.Tab = 1
    Frame1.Enabled = True
    StTab.TabEnabled(0) = False
    CzxsGrid.Enabled = False
    With SzToolbar
        .Buttons("ymsz").Enabled = False
        .Buttons("dy").Enabled = False
        .Buttons("yl").Enabled = False
        .Buttons("zj").Enabled = False
        .Buttons("xg").Enabled = False
        .Buttons("sc").Enabled = False
    End With
End Sub

Private Sub Toolfbjzt()                                    'Toolbar状态(非编辑状态)
    If DEBUG_FLAG = False Then On Error Resume Next
    StTab.TabEnabled(0) = True
    StTab.Tab = 0
    CzxsGrid.Enabled = True
    Frame1.Enabled = False
    StTab.TabEnabled(1) = False
    Lrzt = 0
    With SzToolbar
        .Buttons("xg").Enabled = True
        .Buttons("sc").Enabled = True
        .Buttons("zj").Enabled = True
        .Buttons("ymsz").Enabled = True
        .Buttons("dy").Enabled = True
        .Buttons("yl").Enabled = True
    End With
End Sub


Private Sub bbyl(bbylte As Boolean)                    '报表打印预览
    If DEBUG_FLAG = False Then On Error Resume Next
    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)    '文本框录入事后处理程序
    
    '以下为依据实际情况自定义部分[
    
    '在此填写文本框录入事后处理程序
    
    ']以上为依据实际情况自定义部分
End Sub


Private Sub LrText_Change(Index As Integer)
    '----------固定不变部分变量声明开始--------------------
    Dim Jsqte
    Dim Int_CodeLev
    Dim CodeLev
    Dim Str_Parent
    Dim RecTemp As New ADODB.Recordset
    '----------固定不变部分变量声明结束-------------------
    '屏蔽程序改变控制
    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
    
    If Index = 0 Then        '核算项目特殊处理
        Xtcdcs = Trim(lrText(Index).Text)
        Xtcdcsfz = GetComboKey(Imgebo_ItemClass, 0)
        XT_ItemHelp.Show 1
    Else
        Call Drbmhelp(Textint(Index, 2), Textstr(Index, 4), Trim(lrText(Index).Text))
    End If
    If Len(Xtfhcs) <> 0 Then
        If Textint(Index, 3) = 1 Then
            lrText(Index).Tag = Xtfhcsfz
            lrText(Index).Text = Xtfhcs
        Else
            lrText(Index).Tag = Xtfhcs
            lrText(Index).Text = Xtfhcsfz
        End If
        
    End If
    TextValiJudgeLock(Index) = False
    lrText(Index).SetFocus
End Sub

Private Sub TextShow(Index As Integer)        '文本框得到焦点,显示相应信息
    
    '填写文本框得到焦点,进行相应信息处理程序
    
End Sub

Private Sub Wbkcsh()                          '录入文本框初始化
    Dim Jsqte As Integer
    
    '最大录入文本框索引值
    Max_Text_Index = Textvar(1)
    
    ReDim TextValiJudgeLock(Max_Text_Index)
    For Jsqte = 0 To Max_Text_Index
        
        If Len(Trim(Textstr(Jsqte, 1))) <> 0 Then
            If Textboolean(Jsqte, 1) Then
                If Jsqte <> 0 And Not Textboolean(Jsqte, 3) Then
                    Load Ydcommand1(Jsqte)
                End If
                Ydcommand1(Jsqte).Visible = True
                Ydcommand1(Jsqte).Move lrText(Jsqte).Left + lrText(Jsqte).Width, lrText(Jsqte).Top
            End If
            TextChangeLock = True
            lrText(Jsqte).Text = ""
            lrText(Jsqte).Tag = ""
            If Textint(Jsqte, 5) <> 0 Then
                lrText(Jsqte).MaxLength = Textint(Jsqte, 5)
            End If
            TextChangeLock = False
        End If
        TextValiJudgeLock(Jsqte) = True
    Next Jsqte
End Sub

Private Function TextYxxpd(Index As Integer) As Boolean           '文本框有效性判断
    '---------------------------------
    Dim Tsxx As String
    
    '---------------------------------
    Dim SqlStr As String
    Dim Findrec As ADODB.Recordset
    
    If TextValiJudgeLock(Index) Then    '文本框内容未曾改变不进行有效性判断
        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 Findrec = Cw_DataEnvi.DataConnect.Execute(SqlStr)
        If Findrec.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(Findrec.Fields(Trim(Textstr(Index, 2))))
                End If
                If Len(Trim(Textstr(Index, 3) & "")) <> 0 Then
                    lrText(Index).Tag = Trim(Findrec.Fields(Trim(Textstr(Index, 3))))
                End If
            Case 1
                If Len(Trim(Textstr(Index, 3) & "")) <> 0 Then
                    lrText(Index).Text = Trim(Findrec.Fields(Trim(Textstr(Index, 3))))
                End If
                If Len(Trim(Textstr(Index, 2))) <> 0 Then
                    lrText(Index).Tag = Trim(Findrec.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