i-

VB开发的ERP系统

    If vsFlx_MyReport.Row < vsFlx_MyReport.FixedRows Then
        Exit Sub
    End If
    Tsxx = "请确认是否删除当前记录?"
    Yhanswer = Xtxxts(Tsxx, 2, 2)
    If Yhanswer = 2 Then
        Exit Sub
    End If
    
    '[以下需自定义部分
    Cw_DataEnvi.DataConnect.Execute ("Delete FROM Cwzz_MyReport Where Czybm='" & Xtczybm & "' And QueryCode='" & TextGroupCode & "' And QueryName='" & Trim(vsFlx_MyReport.TextMatrix(vsFlx_MyReport.Row, Sydz("001", GridStr(), Szzls))) & "'")
    '以上为自定义部分]
    
    vsFlx_MyReport.RemoveItem vsFlx_MyReport.Row
    
End Sub

Private Sub Cmd_Save_Click()                     '保存报表查询条件
    Dim tCode As String
    Dim tReturn As String
    
    tCode = Trim(vsFlx_MyReport.TextMatrix(vsFlx_MyReport.Row, Sydz("001", GridStr(), Szzls)))
    
    tReturn = InputBox("请输入我的报表名称:", "报表名称", tCode)
    If Trim(tReturn) = "" Then Exit Sub
    
    SaveReport tReturn
End Sub

'************以下为文本框录入处理程序(固定不变部分)*************'
Private Sub Wbklrwbcl(Index As Integer)    '文本框录入事后处理程序
    
    '以下为依据实际情况自定义部分[
    
    '在此填写文本框录入事后处理程序
    
    ']以上为依据实际情况自定义部分
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))
    
    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 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
            
            '[>>科目级次范围默认为1-6
            LrText(2).Text = 1
            LrText(3).Text = 6
            '[<<完毕
            
            TextChangeLock = False
        End If
        TextValiJudgeLock(Jsqte) = True
    Next Jsqte
End Sub

Private Function TextYxxpd(Index As Integer) As Boolean           '文本框有效性判断
    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



Private Sub SaveReport(sReport As String)
    Dim Rec_MyReport As New ADODB.Recordset     '我的报表动态集
    Dim Yhanswer As Integer
    Dim Jsqte As Integer                        '临时动态计数器
    Dim Sqlstr As String
    
    Yhanswer = 0
    
    '查询连接串
    Sqlstr = "SELECT Distinct QueryName FROM Cwzz_MyReport Where Czybm='" & Xtczybm & "' And QueryCode='" & TextGroupCode & "' And QueryName='" & Trim(sReport) & "'"
    Set Rec_MyReport = Cw_DataEnvi.DataConnect.Execute(Sqlstr)
    With Rec_MyReport
        If Not .EOF Then
            Tsxx = "已有此报表名称,是否覆盖?"
            Yhanswer = Xtxxts(Tsxx, 2, 2)
            If Yhanswer <> 1 Then
                Exit Sub
            End If
        End If
        
        On Error GoTo Swcwcl
        Cw_DataEnvi.DataConnect.BeginTrans
        
        If Yhanswer = 1 Then
            Sqlstr = "Delete FROM Cwzz_MyReport Where Czybm='" & Xtczybm & "' And QueryCode='" & TextGroupCode & "' And QueryName='" & Trim(sReport) & "'"
            Cw_DataEnvi.DataConnect.Execute (Sqlstr)
        End If
        If .State = 1 Then .Close
        .Open "Select * From Cwzz_MyReport Where 1=2", Cw_DataEnvi.DataConnect, adOpenDynamic, adLockOptimistic
        
        For Jsqte = 1 To 8
            .AddNew
            .Fields("Czybm") = Xtczybm
            .Fields("QueryCode") = TextGroupCode
            .Fields("QueryName") = sReport
            
            Select Case Jsqte
            Case 1
                .Fields("Value") = Trim(LrText(0).Text)
            Case 2
                .Fields("Value") = Trim(LrText(1).Text)
            Case 3
                .Fields("Value") = Combo_Class.Text
            Case 4
                .Fields("Value") = Trim(LrText(2).Text)
            Case 5
                .Fields("Value") = Trim(LrText(3).Text)
            Case 6
                .Fields("Value") = Chk_NotBook.Value
            Case 7
                .Fields("Value") = Chk_ClassSum.Value
            Case 8
                .Fields("Value") = Chk_NotOuputZero.Value
                
            End Select
            
            .Update
        Next Jsqte
    End With
    
    Cw_DataEnvi.DataConnect.CommitTrans
    
    '在网格中添加报表名称(非覆盖)
    If Yhanswer <> 1 Then
        With vsFlx_MyReport
            .AddItem ""
            .TextMatrix(.Rows - 1, 0) = Trim(sReport)
        End With
    End If
    
    Tsxx = "报表查询条件保存完毕!"
    Call Xtxxts(Tsxx, 0, 4)
    Exit Sub
    
Swcwcl:
    Cw_DataEnvi.DataConnect.RollbackTrans
    Tsxx = "存盘过程中出现未知错误,程序自动恢复保存前状态!"
    Call Xtxxts(Tsxx, 0, 1)
    Exit Sub
End Sub