+

VB开发的ERP系统

            End If
        Else
            Tsxx = "该单据可能被其他用户删除!"
            Call Xtxxts(Tsxx, 0, 4)
            Exit Sub
        End If
    End With
       
    '<<]
    On Error GoTo ErrTemp
    Cw_DataEnvi.DataConnect.BeginTrans
        '将单据写入审核标识
        Cw_DataEnvi.DataConnect.Execute ("Update Xs_ReturnMoney Set Checker='" & Xtczy & "',checkerdate='" & Xtrq & "' Where ReturnMoneyID=" & Val(Lab_BillId.Caption))
    Cw_DataEnvi.DataConnect.CommitTrans
    
    '写入系统操作员
    LrText(18).Text = Xtczy
    Tsxx = "审核完毕!"
    Call Xtxxts(Tsxx, 0, 4)
    
    '设置审核弃审按钮状态
    Call Sub_CheckStatus
    
    '标识单据发生变化
    Bln_BillChange = True
    Exit Sub
    
ErrTemp:
    Cw_DataEnvi.DataConnect.RollbackTrans
    Tsxx = "审核时出错，数据被恢复！"
    Call Xtxxts(Tsxx, 0, 1)
End Sub

Private Sub Sub_AbandonCheck()          '弃 审
    Dim RecTemp As New ADODB.Recordset
    Dim Sqlstr As String
    '判断用户是否有此功能执行权限,如有则写上机日志(进入)
    If Not Security_Log(Str_RightCheck, Xtczybm, 1, True) Then
        Exit Sub
    End If
    '[>>
    Sqlstr = "Select Checker,capitalreturnmoney,capitalremainmoney From Xs_ReturnMoney Where ReturnMoneyID='" & Val(Lab_BillId.Caption) & "'"
    Set RecTemp = Cw_DataEnvi.DataConnect.Execute(Sqlstr)
    With RecTemp
        If Not .EOF Then
            If Trim(.Fields("Checker") & "") = "" Then
                Tsxx = "该单据未审核确认,不能弃审!"
                Call Xtxxts(Tsxx, 0, 4)
                Exit Sub
            End If
            If Val(.Fields("capitalreturnmoney")) <> Val(.Fields("capitalremainmoney")) Then
                Tsxx = "该回款单已核销,不能弃审!"
                Call Xtxxts(Tsxx, 0, 4)
                Exit Sub
            End If
        Else
            Tsxx = "该单据可能被其他用户删除!"
            Call Xtxxts(Tsxx, 0, 4)
            Exit Sub
        End If
    End With
       
    '<<]
    On Error GoTo ErrTemp
    Cw_DataEnvi.DataConnect.BeginTrans
        '将单据清除审核标识
        Cw_DataEnvi.DataConnect.Execute ("Update Xs_ReturnMoney Set Checker='' Where ReturnMoneyID=" & Val(Lab_BillId.Caption))
    Cw_DataEnvi.DataConnect.CommitTrans
    
    '清空单据审核人
    LrText(18).Text = ""
    Tsxx = "弃审完毕!"
    Call Xtxxts(Tsxx, 0, 4)
    
    '设置审核弃审按钮状态
    Call Sub_CheckStatus
    
    '标识单据发生变化
    Bln_BillChange = True
    Exit Sub
    
ErrTemp:
    Cw_DataEnvi.DataConnect.RollbackTrans
    Tsxx = "弃审时出错，数据被恢复!"
    Call Xtxxts(Tsxx, 0, 1)
End Sub

Private Function Fun_AllowEdit() As Boolean                      '判断当前单据是否允许编辑或删除
  
    Dim RecTemp As New ADODB.Recordset     '临时使用动态集
    Fun_AllowEdit = False
    Sqlstr = "Select Checker From Xs_ReturnMoney Where ReturnMoneyID=" & Val(Lab_BillId.Caption)
    Set RecTemp = Cw_DataEnvi.DataConnect.Execute(Sqlstr)
    With RecTemp
        If Not .EOF Then
            If Trim(.Fields("Checker") & "") <> "" Then
                Tsxx = "该单据已审核确认,不能修改或删除!"
                Call Xtxxts(Tsxx, 0, 4)
                Exit Function
            End If
            End If
    End With
    Fun_AllowEdit = True

End Function
'[>>===================以上为根据实际业务需要自定义过程区域=============================<<]

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

'************以下为文本框录入处理程序(固定不变部分)*************'
Private Sub Wbklrwbcl(Index As Integer)    '文本框录入事后处理程序
  
    '以下为依据实际情况自定义部分[
  
    Dim RsTemp As New ADODB.Recordset
    
    If Trim(LrText(Index).Text) = "" Then LrText(Index).Tag = ""
    If Index = 10 Then
        Set RsTemp = Cw_DataEnvi.DataConnect.Execute("select * from Gy_ForeignCurrency where ForeignCurrcode='" & LrText(Index).Tag & "'")
        If Not RsTemp.EOF Then
            LrText(11).Tag = RsTemp.Fields("convertflag")       '计算方式
            LrText(11).Text = RsTemp.Fields("AccRate")          '汇率
        Else
            LrText(11).Text = ""
            LrText(11).Tag = ""
        End If
    End If
    
    If Index = 3 Then
        TempSql = "select Gy_Customer.*,PersonName,DeptName from Gy_Customer left outer join Gy_Person on Gy_Customer.PersonCode=Gy_Person.PersonCode " & _
                    " left outer join Gy_Department on Gy_Customer.DeptCode=Gy_Department.DeptCode where CusCode='" & Trim(LrText(3).Tag) & "'"
        Set RsTemp = Cw_DataEnvi.DataConnect.Execute(TempSql)
        With RsTemp
            If Not .EOF Then
                If Trim(LrText(5).Text) = "" Then
                    LrText(5).Text = Trim(.Fields("DeptName") & "")         '部门
                    LrText(5).Tag = Trim(.Fields("DeptCode") & "")
                End If
                If Trim(LrText(6).Text) = "" Then
                    LrText(6).Text = Trim(.Fields("PersonName") & "")       '销售员
                    LrText(6).Tag = Trim(.Fields("PersonCode") & "")
                End If
                If Trim(LrText(7).Text) = "" Then
                    LrText(7).Text = Trim(.Fields("bank") & "")             '开户行
                End If
                If Trim(LrText(8).Text) = "" Then
                    LrText(8).Text = Trim(.Fields("bankaccount") & "")      '银行帐号
                End If
            Else
                LrText(5).Text = ""         '部门
                LrText(5).Tag = ""
                LrText(6).Text = ""         '销售员
                LrText(6).Tag = ""
                LrText(7).Text = ""         '开户行
                LrText(8).Text = ""         '银行帐号
            End If
        End With
    End If
   
    ']以上为依据实际情况自定义部分
  
End Sub

Private Sub LrText_Change(Index As Integer)
    
    '屏蔽程序改变控制
    If TextChangeLock Then
        Exit Sub
    End If
    
    TextValiJudgeLock(Index) = False    '打开有效性判断锁
    
    '限制字段录入长度
          
    TextChangeLock = True  '加锁(防止执行Lrtext_Change)
    Call TextChangeLimit(LrText(Index), Textint(Index, 1))  '去掉无效字符
     
    Select Case Textint(Index, 1)
        Case 8, 11      '金额型
            Call Sjgskz(LrText(Index), Xtjezws - Xtjexsws - 1, Xtjexsws)
        Case 9, 12      '数量型
            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)                                                '文本框失去焦点

    '显示相应信息但不能进行有效性判断
    Call Wbklrwbcl(Index)
  
End Sub

Private Sub Ydcommand1_MouseDown(Index As Integer, Button As Integer, Shift As Integer, x As Single, y As Single)     '按钮提供帮助

    '文本框处于非录入状态时不允许调入帮助
    If Not LrText(Index).Enabled Then
        Exit Sub
    End If
   
    Call Text_Help(Index)

End Sub

Private Sub Text_Help(Index As Integer)                                                       '录入字段帮助
    
    If Not Textboolean(Index, 1) 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
   
    LrText(Index).SetFocus

End Sub

Private Sub TextShow(Index As Integer)        '文本框得到焦点,显示相应信息

    '填写文本框得到焦点,进行相应信息处理程序
   
End Sub

Private Sub Wbkcsh()                          '录入文本框初始化

    Dim Int_TabIndex As Integer         'Tab焦点计数器
  
    '单据录入中文本框焦点由0开始
    LrText(0).TabIndex = 0
  
    '最大录入文本框索引值
    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 Jsqte <> 0 Then
                Load LrText(Jsqte)
                Load TsLabel(Jsqte)
           
                '判断录入文本框是否显示
                If Textboolean(Jsqte, 4) Then
                    LrText(Jsqte).Visible = True
                    TsLabel(Jsqte).Visible = True
                End If
            
                '判断文本框是否可编辑
                If Textboolean(Jsqte, 5) Then
                    LrText(Jsqte).Enabled = True
                Else
                    LrText(Jsqte).Enabled = False
                End If
                
                '判断文本框是否提供帮助
                If Textboolean(Jsqte, 1) Then
                    If Not Textboolean(Jsqte, 3) Then
                        Load Ydcommand1(Jsqte)
                    End If
                End If
            End If
           
           '初始化其内容
            TextChangeLock = True
            LrText(Jsqte).Text = ""
            LrText(Jsqte).Tag = ""
            LrText(Jsqte).MaxLength = Textint(Jsqte, 5)
            TextChangeLock = False
        
            '设置文本框位置及大小,并设置相应标签内容及其位置
            LrText(Jsqte).Move Textint(Jsqte, 13), Textint(Jsqte, 12), Textint(Jsqte, 11), Textint(Jsqte, 10)
            TsLabel(Jsqte).Caption = Textstr(Jsqte, 7) & ":"
            TsLabel(Jsqte).Move Textint(Jsqte, 13) - TsLabel(Jsqte).Width - 20, Textint(Jsqte, 12) + (Textint(Jsqte, 10) - TsLabel(Jsqte).Height) / 2 - 30
            
            '判断文本框是否