˪-i㦥

VB开发的ERP系统

    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)     '按钮提供帮助
    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 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
        If Textboolean(jsqte, 5) = False Then
            LrText(jsqte).Enabled = 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
  
    '文本框内容为空认为有效,并清空其Tag值
    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")
                If Val(Mid(LrText(Index), 1, 4)) < 1900 Then
                    LrText(Index).Text = "1900" + Mid(LrText(Index), 5, 6)
                End If
            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

    '调用文本框事后处理程序
    Call Wbklrwbcl(Index)
  
    '有效性判断通过则返回True
    TextYxxpd = True
   
End Function
Private Sub ShowBill()
    '调入用户查询结果动态集,并定位该单据
    Sqlstr = "SELECT dbo.RP_Note.*, dbo.Gy_ForeignCurrency.ForeignCurrName AS ForeignCurrName, " & _
            "dbo.Gy_Customer.CusName AS CusName FROM dbo.RP_Note LEFT OUTER JOIN " & _
            " dbo.Gy_ForeignCurrency ON dbo.RP_Note.ForeignCurrCode = dbo.Gy_ForeignCurrency.ForeignCurrCode LEFT OUTER " & _
            " Join dbo.Gy_Customer ON dbo.RP_Note.PSCode = dbo.Gy_Customer.CusCode where NoteId='" & XT_BillID & "'"
    Set RecTemp = Cw_DataEnvi.DataConnect.Execute(Sqlstr)
    LrText(0).Text = RecTemp.Fields("NoteCode")
    LrText(1).Text = RecTemp.Fields("YbSsJe") + Val(RecTemp.Fields("YbInterest") & "")  '票面金额
    LrText(3).Text = Xtrq
    LrText(4).Tag = RecTemp.Fields("PsCode")
    LrText(4).Text = RecTemp.Fields("CusName")
    LrText(2).Tag = RecTemp.Fields("ForeignCurrCode")
    LrText(2).Text = RecTemp.Fields("ForeignCurrName")
    Call Sub_GetAccRate(LrText(2).Tag, Bln_ConVertFlag, Dbl_AccRate)    '取外币记帐汇率，和汇兑方式
    LrText(6).Text = Dbl_AccRate
    
End Sub

Private Function SaveBill() As Boolean       '记录转出数据
    Dim Rec_Bill As New ADODB.Recordset
    Dim JE As Double                        '转出金额
    Dim jsqte As Integer
    Dim Int_Kjyear As Integer                '会计年度
    Dim Int_Period As Integer                '会计期间
    
    '保存其它应收单用变量
    Dim BillCode As String                   '其它应收单单据代码
    Dim OtherBillCode As String              '其它应收单编码
    Dim OtherBillId As Integer               '其它应收单ID
    Dim RecTemp As New ADODB.Recordset       '应收票据记录集

    
    SaveBill = False
    '一.============先对单据内容进行有效性判断==============='
  
    '先进行字段不能为空或不能为零有效性判断(Fixed)
    For jsqte = 0 To Max_Text_Index
        If Textint(jsqte, 8) = 1 Then        '字段不能为空
            If Len(Trim(LrText(jsqte).Text)) = 0 Then
                Tsxx = Textstr(jsqte, 7) & "不能为空!"
                Call Xtxxts(Tsxx, 0, 1)
                LrText(jsqte).SetFocus
                Exit Function
            End If
        Else
            If Textint(jsqte, 8) = 2 Then   '字段不能为零
                If Val(Trim(LrText(jsqte).Text)) = 0 Then
                    Tsxx = Textstr(jsqte, 7) & "不能为零!"
                    Call Xtxxts(Tsxx, 0, 1)
                    LrText(jsqte).SetFocus
                    Exit Function
                End If
            End If
        End If
    Next jsqte
    
    '对需要进行事后判断的文本框录入内容进行有效性判断 (Fixed)
    For jsqte = 0 To Max_Text_Index
        If Textint(jsqte, 9) = 0 Or Textint(jsqte, 9) = 2 Then
            If Not TextYxxpd(jsqte) Then
                Exit Function
            End If
        End If
    Next jsqte

  
    '[>>
        '1.判断单据日期是否有效,如有效同时记录会计年度和会计期间
    If Not Fun_GetPeriod(Trim(LrText(3).Text), Int_Kjyear, Int_Period) Then
        LrText(3).SetFocus
        Exit Function
    End If
        '2.判断汇率
    If Trim(LrText(2).Tag) <> XtSCurrCode Then
       If Val(LrText(6).Text) = 0 Then
          Tsxx = "汇率不能为零!"
          Call Xtxxts(Tsxx, 0, 1)
          LrText(6).SetFocus
          Exit Function
       End If
    Else
       LrText(6).Text = 1
    End If
    
    '<<]
    
   '2.开始存盘
    
    On Error GoTo Swcwcl
    Cw_DataEnvi.DataConnect.BeginTrans
    
    Sqlstr = "SELECT * From Rp_Note where NoteId='" & XT_BillID & "'"
    Set RecTemp = Cw_DataEnvi.DataConnect.Execute(Sqlstr)
    
    
    '增加一张其它应收单
    Sqlstr = "Select * from RP_Note Where NoteId='" & XT_BillID & "'"
    Set RecTemp = Cw_DataEnvi.DataConnect.Execute(Sqlstr)

    BillCode = "0203"   '其它应收单单据编号
    OtherBillCode = CreatBillCode(BillCode, True) '收款单编码
    OtherBillId = CreatBillID(BillCode)           '收款单ID

    If Rec_Bill.State = 1 Then Rec_Bill.Close
    Rec_Bill.Open "Select * From Rp_OtherBill Where 1=2", Cw_DataEnvi.DataConnect, adOpenDynamic, adLockOptimistic
    With Rec_Bill
        .AddNew
        .Fields("OtherBillID") = OtherBillId                                      '单据ID
        .Fields("BillCode") = OtherBillCode                                       '单据编号
        .Fields("SourceBillCode") = Trim(LrText(0).Text)                          '形成该应收单的单据号
        .Fields("BillDate") = CDate(LrText(3).Text)                               '单据日期
        .Fields("ForeignCurrCode") = Trim(LrText(2).Tag)                          '币别编码
        .Fields("YbYsJe") = Val(LrText(5))                                                     '原币金额
        .Fields("AccRate") = Val(LrText(6).Text)                                  '汇率
        If Bln_ConVertFlag Then
            .Fields("BbYsJe") = Val(Format(Val(LrText(5)) / Val(LrText(6).Text), "##." + String(Xtjexsws, "0")))
        Else
            .Fields("BbYsJe") = Val(Format(Val(LrText(5)) * Val(LrText(6).Text), "##." + String(Xtjexsws, "0")))
        End If
        .Fields("PsCode") = LrText(4).Tag                                         '客户编码
    
        .Fields("DeptCode") = RecTemp.Fields("DeptCode")                          '部门编码
        .Fields("PersonCode") = RecTemp.Fields("PersonCode")                      '经办人编码
        .Fields("Digest") = Trim((LrText(7).Text) & "") & "应收票据转出" & Trim(LrText(0).Text)                           '摘要"
        .Fields("Maker") = Xtczy                                                  '制单人
        
        '系统自动保存应收帐款科目
        .Fields("AccCodeArAp") = Fun_InputCodeCustomer(LrText(4).Tag, 0)
        
        '应收票据科目
        If .Fields("BillItemCode") = "01" Then
            .Fields("AccCode") = Fun_GetInputCode("AR_CommNoteAccCode") '商业承兑汇票科目
        Else
            .Fields("AccCode") = Fun_GetInputCode("AR_BankNoteAccCode") '银行承兑汇票科目
        End If
        
        '后台处理
        .Fields("RPFlag") = "AR"                                                  '应收标识
        .Fields("KJYear") = Int_Kjyear                                            '会计年度
        .Fields("Period") = Int_Period                                            '会计期间
        .Fields("BillItemCode") = "20"                                            '单据类型编码
        .Fields("VouchId") = 0                                                    '凭证关联标识
        .Fields("PayCode") = Null                                                 '付款条件
        .Fields("IfBuildVouch") = 1         '目的是该应收单在“选择应收单做凭证时不被选中” '是否生成凭证
        .Fields("IfCancel") = 0                                                   '是否核销
        .Fields("OverStatus") = 0
        .Update
    End With
    
    '写入变动单据表
    If Rec_Bill.State = 1 Then Rec_Bill.Close
    Rec_Bill.Open "Select * From Rp_NoteClose Where 1=2", Cw_DataEnvi.DataConnect, adOpenDynamic, adLockOptimistic
    With Rec_Bill
        .AddNew
        .Fields("NoteId") = XT_BillID                                    '单据号
        .Fields("CloseDate") = CDate(LrText(3).Text)                     '兑现日期
        .Fields("ForeignCurrCode") = Trim(LrText(2).Tag)                 '币别编码
        .Fields("YbCash") = Val(LrText(1))                               '原币金额
        .Fields("YbInterest") = Val(LrText(5))                           '原币利息
        .Fields("AccRate") = Val(LrText(6))                              '记帐汇率
        If Bln_ConVertFlag Then
            .Fields("BbCash") = Val(Format(Val(LrText(1).Text) / Val(LrText(6).Text), "##." + String(Xtjexsws, "0")))
            .Fields("BbInterest") = Val(Format(Val(LrText(6).Text) / Val(LrText(6).Text), "##." + String(Xtjexsws, "0")))
        Else
            .Fields("BbCash") = Val(Format(Val(LrText(1).Text) * Val(LrText(6).Text), "##." + String(Xtjexsws, "0")))
            .Fields("BbInterest") = Val(Format(Val(LrText(1).Text) * Val(LrText(6).Text), "##." + String(Xtjexsws, "0")))
        End If
        .Fields("PsCode") = LrText(4).Tag                                 '客户编码
        .Fields("DeptCode") = Trim(RecTemp.Fields("DeptCode") & "")       '部门编码
        .Fields("PersonCode") = Trim(RecTemp.Fields("PersonCode") & "")   '经办人编码
        .Fields("AccCodeNote") = Trim(RecTemp.Fields("AccCode") & "")     '应收票据科目
        '应收帐款科目
        .Fields("AccCode") = Fun_InputCodeCustomer(LrText(4).Tag, 0)
        
        .Fields("Digest") = Trim(LrText(5).Text)                          '备注
        
        '系统名
        .Fields("RPFlag") = "Ar"
            
        '单据所属的会计期间
        .Fields("KjYear") = Int_Kjyear
        .Fields("Period") = Int_Period
        
        '单据类型
        .Fields("BillItemCode") = "41"
        
        
        '票据利息科目
        .Fields("AccCodeInterest") = Fun_GetInputCode("AR_NoteIntAccCode")  '承兑利息科目
        
        .Fields("BillIdAr") = OtherBillId                                   '其它应收单号
        .Update
        
        '系统读出单据ID写入Lab_BillID
    End With
    
    
    
    
    
    
    
    
    
    
    Cw_DataEnvi.DataConnect.CommitTrans
    Tsxx = "保存完毕！"
    SaveBill = True
    Call Xtxxts(Tsxx, 0, 4)
    Exit Function
Swcwcl:       '数据存盘时出现错误
    Cw_DataEnvi.DataConnect.RollbackTrans
    Tsxx = "存盘过程中出现未知错误,程序自动恢复保存前状态!"
    Call Xtxxts(Tsxx, 0, 1)
    Exit Function
        
End Function