企业管理

开发平台：
Visual Basic

-：源码内容
							Attribute VB_Name = "XtsyModule"
 '系统私有模块用来放置一些子系统独有的过程与函数
 Public str_Code As String                               '存储列内容参数
 Public Xt_XtJc As Boolean            '系统集成
 Public StartMon As Integer           '开帐月份
 Public LastMon As Integer            '当前年度最后一个月份
 Public Qmclcy As Boolean             '期末是否处理差异
 Public ClrkdKfsc As Boolean          '材料入库单库存管理系统生成
 Public Xtclzg As Boolean             '系统是否处理暂估
 Public Cylzg As Boolean              '差异率计算是否包括本期暂估
 Public LcbckFs As Integer            '零成本出库方式
 Public EvalFs As Integer             '暂估方式
 Public SFjezt As Boolean             '系统处理实发金额自填
 
 '生成凭证的信息
 Public vouchdata() As Variant
 Public vouchz As String
 Public PzRecordCount As Integer
 Public PzDataRow As Integer
 
 Public Price_Flag As Boolean         '单价标记
 Public Edit_Flag As Boolean          '编辑标志
 
 Dim Tsxx As String
 
Public Sub Drxtztcs()                                   '读入系统帐套参数
   
    Dim Ztcsbrec As New ADODB.Recordset
    Dim Rectemp As New ADODB.Recordset
    Dim SqlStr As String
  
    '读入本位币
    SqlStr = "Select ForeignCurrCode,ForeignCurrName from Gy_ForeignCurrency where StandardFlag=1"
    Set Rectemp = Cw_DataEnvi.DataConnect.Execute(SqlStr)
    XtSCurrCode = Trim(Rectemp.Fields("ForeignCurrCode"))
    XtSCurrName = Trim(Rectemp.Fields("ForeignCurrName"))
    
    With Ztcsbrec
        '金额总位数
        .Open "Select * From Gy_AccInformation Where SystemCode='Cwzz'", Cw_DataEnvi.DataConnect, adOpenDynamic, adLockOptimistic
        .MoveFirst
        .Find "itemcode='cwjezws'"
        If Not Ztcsbrec.EOF Then
            Xtjezws = Val(Trim(Ztcsbrec.Fields("itemvalue")))
        End If
        
        '数量总位数
        .MoveFirst
        .Find "itemcode='cwslzws'"
        If Not Ztcsbrec.EOF Then
            Xtslzws = Val(Trim(Ztcsbrec.Fields("itemvalue")))
        End If
   
        '单价总位数
        .MoveFirst
        .Find "itemcode='cwdjzws'"
        If Not Ztcsbrec.EOF Then
            Xtdjzws = Val(Trim(Ztcsbrec.Fields("itemvalue")))
        End If
        
        '金额小数位数
        .MoveFirst
        .Find "itemcode='cwjexsws'"
        If Not Ztcsbrec.EOF Then
            Xtjexsws = Val(Trim(Ztcsbrec.Fields("itemvalue")))
        End If
   
        '数量小数位数
        .MoveFirst
        .Find "itemcode='cwslxsws'"
        If Not Ztcsbrec.EOF Then
            Xtslxsws = Val(Trim(Ztcsbrec.Fields("itemvalue")))
        End If
        
        '单价小数位数
        .MoveFirst
        .Find "itemcode='cwdjxsws'"
        If Not Ztcsbrec.EOF Then
            Xtdjxsws = Val(Trim(Ztcsbrec.Fields("itemvalue")))
        End If
        .Close
    End With
    
   With Rectemp
        If .State = 1 Then .Close
        .Open "Select * From Gy_AccInformation Where SystemCode='chhs'", Cw_DataEnvi.DataConnect, adOpenDynamic, adLockOptimistic
        '期末是否处理差异
        .MoveFirst
        .Find "itemcode='Chhs_Qmclcy'"
        If Not .EOF Then
           If .Fields("itemvalue") = 1 Then
              Qmclcy = True
           Else
              Qmclcy = False
           End If
        End If
        
        '系统是否处理暂估
        .MoveFirst
        .Find "itemcode='Chhs_Xtclzg'"
        If Not .EOF Then
           If .Fields("itemvalue") = 1 Then
              Xtclzg = True
           Else
              Xtclzg = False
           End If
        End If
        
        '差异率计算是否包括暂估
        .MoveFirst
        .Find "itemcode='Chhs_Cylzg'"
        If Not .EOF Then
           If .Fields("itemvalue") = 1 Then
              Cylzg = True
           Else
              Cylzg = False
           End If
        End If
        
        '材料入库单是否是库房系统生成
        .MoveFirst
        .Find "itemcode='Chhs_ClrkdKfsc'"
        If Not .EOF Then
           If .Fields("itemvalue") = 1 Then
              ClrkdKfsc = True
           Else
              ClrkdKfsc = False
           End If
        End If
        
         '系统集成
        .MoveFirst
        .Find "itemcode='chhs_xtjc'"
        If Not .EOF Then
           If .Fields("itemvalue") = 1 Then
              Xt_XtJc = True
           Else
              Xt_XtJc = False
           End If
        End If
         
         '暂估方式
        .MoveFirst
        .Find "itemcode='Chhs_Eval1'"
        If Not .EOF Then
           If .Fields("itemvalue") = 1 Then
              EvalFs = 1
           End If
        End If
        .MoveFirst
        .Find "itemcode='Chhs_Eval2'"
        If Not .EOF Then
           If .Fields("itemvalue") = 1 Then
              EvalFs = 3
           End If
        End If
        .MoveFirst
        .Find "itemcode='Chhs_Eval3'"
        If Not .EOF Then
           If .Fields("itemvalue") = 1 Then
              EvalFs = 3
           End If
        End If
         
         '零成本出库方式
        .MoveFirst
        .Find "itemcode='Chhs_Lcbck1'"
        If Not .EOF Then
           If .Fields("itemvalue") = 1 Then
              LcbckFs = 1
           End If
        End If
        .MoveFirst
        .Find "itemcode='Chhs_Lcbck2'"
        If Not .EOF Then
           If .Fields("itemvalue") = 1 Then
              LcbckFs = 2
           End If
        End If
        .MoveFirst
        .Find "itemcode='Chhs_Lcbck3'"
        If Not .EOF Then
           If .Fields("itemvalue") = 1 Then
              LcbckFs = 3
           End If
        End If
        .MoveFirst
        .Find "itemcode='Chhs_Lcbck4'"
        If Not .EOF Then
           If .Fields("itemvalue") = 1 Then
              LcbckFs = 4
           End If
        End If
        .MoveFirst
        .Find "itemcode='Chhs_Lcbck5'"
        If Not .EOF Then
           If .Fields("itemvalue") = 1 Then
              LcbckFs = 5
           End If
        End If
        
        '系统处理实发金额自填
        .MoveFirst
        .Find "itemcode='Chhs_SFjezt'"
        If Not .EOF Then
           If .Fields("itemvalue") = 1 Then
              SFjezt = True
           Else
              SFjezt = False
           End If
        End If
    End With
  
    '开帐月份
    Set Rectemp = Cw_DataEnvi.DataConnect.Execute("select * from gy_kjrlb where kjyear=" & Xtyear & " and beginflag=1")
    If Not Rectemp.EOF Then
        StartMon = Rectemp.Fields("period")
        Cw_DataEnvi.DataConnect.Execute ("update gy_kjrlb set chhsjzbz=1 where period<" & StartMon & " and kjyear=" & Xtyear)
    Else
        StartMon = 1
    End If
    
    '终止月份
    Set Rectemp = Cw_DataEnvi.DataConnect.Execute("select * from gy_kjrlb where kjyear=" & Xtyear & " order by period desc ")
    If Not Rectemp.EOF Then
        LastMon = Rectemp.Fields("period")
    End If
    
End Sub
Public Function KjMonth(Datestr As Date) As Integer              '当前会计月份  bfy
    Dim Rectemp As Recordset
   
    Set Rectemp = Cw_DataEnvi.DataConnect.Execute("select * from gy_kjrlb where kjyear=" & PGKjYear & " and '" & Format(Datestr, "yyyy-mm-dd") & "' between qsrq and zzrq ")
   
    If Not Rectemp.EOF Then
        KjMonth = Rectemp.Fields("period")
    Else
        Tsxx = "此会计月份不存在!"
        Call Xtxxts(Tsxx, 0, 1)
    End If
   
End Function
Public Function PGKjYear() As Integer              '当前会计年度
    Dim Rectemp As Recordset
   
    Set Rectemp = Cw_DataEnvi.DataConnect.Execute("select * from gy_kjrlb where chhsjzbz=0 order by kjyear,period")
   
    If Not Rectemp.EOF Then
        PGKjYear = Rectemp.Fields("KjYear")
    Else
        Tsxx = "此会计年度不存在!"
        Call Xtxxts(Tsxx, 0, 1)
    End If
   
End Function
Public Function PGNowmon() As Integer              '当前会计月份
    Dim Rectemp As Recordset
   
    Set Rectemp = Cw_DataEnvi.DataConnect.Execute("select * from gy_kjrlb where chhsjzbz=0 order by kjyear,period")
   
    If Not Rectemp.EOF Then
        PGNowmon = Rectemp.Fields("period")
    Else
        Tsxx = "此会计年度不存在!"
        Call Xtxxts(Tsxx, 0, 1)
    End If
   
End Function
Public Function PGEndDate() As String
    
    Dim Rectemp As Recordset
   
    Set Rectemp = Cw_DataEnvi.DataConnect.Execute("select Zzrq from gy_kjrlb where chhsjzbz=0 order by kjyear,period")
   
    If Not Rectemp.EOF Then
        PGEndDate = Rectemp.Fields("Zzrq")
    Else
        Tsxx = "此会计年度不存在!"
        Call Xtxxts(Tsxx, 0, 1)
    End If
End Function
Public Function PGPrevKjYear() As Integer
    
    Dim Rectemp As Recordset
   
    Set Rectemp = Cw_DataEnvi.DataConnect.Execute("select Kjyear from gy_kjrlb where chhsjzbz=1 order by kjyear,period")
   
    If Not Rectemp.EOF Then
        Rectemp.MoveLast
        PGPrevKjYear = Rectemp.Fields("Kjyear")
    Else
        Tsxx = "此会计年度不存在!"
        Call Xtxxts(Tsxx, 0, 1)
    End If
End Function
Public Function PGPrevKjMon() As Integer
    
    Dim Rectemp As Recordset
   
    Set Rectemp = Cw_DataEnvi.DataConnect.Execute("select Period from gy_kjrlb where chhsjzbz=1 order by kjyear,period")
   
    If Not Rectemp.EOF Then
        Rectemp.MoveLast
        PGPrevKjMon = Rectemp.Fields("Period")
    Else
        PGPrevKjMon = 1
    End If
End Function
Public Sub MaccCode(WhCode As String, Mnumber As String, Msort As String)      '设置存货科目、差异科目
                    '仓库编码,存货编码，存货分类
    Dim Rectemp As Recordset
    Dim RecTempFz As Recordset
    Dim Msortcode As String
   
    Set Rectemp = Cw_DataEnvi.DataConnect.Execute("select * from chhs_macc where whcode='" & WhCode & "' ")
    If Not Rectemp.EOF Then
        Rectemp.Find "mnumber='" & Mnumber & "'"
        If Not Rectemp.EOF Then
            Xtfhcs = Trim(Rectemp.Fields("macct"))
            Xtfhcsfz = Trim(Rectemp.Fields("diffacct") & "")
            Exit Sub
        Else
            SqlStr = "SELECT * FROM Gy_CodeScheme WHERE (ItemCode = 'Kf_KfwlflSet')"
            Set RecTempFz = Cw_DataEnvi.DataConnect.Execute(SqlStr)
            If Not RecTempFz.EOF Then
               Msortcode = Left(Trim(RecTempFz.Fields("CodeScheme")), 1)
               Msortcode = Left(Trim(Msort), Val(Msortcode))
            End If
            
            Rectemp.MoveFirst
            Rectemp.Find "msort like '" & Msortcode & "'"
            If Not Rectemp.EOF Then
                Xtfhcs = Trim(Rectemp.Fields("macct"))
                Xtfhcsfz = Trim(Rectemp.Fields("diffacct") & "")
                Exit Sub
            Else
                Rectemp.MoveFirst
                Rectemp.Find "WHCODE = '" & WhCode & "'"
                Xtfhcs = Trim(Rectemp.Fields("macct"))
                Xtfhcsfz = Trim(Rectemp.Fields("diffacct") & "")
                Exit Sub
            End If
        End If
     End If
End Sub
Public Sub DfaccCode(InoutClassCode As String, Deptcode As String, Msort As String, Mnumber As String)     '设置对方科目
                    '收发类别、部门编码,存货分类，存货编码
    Dim Rectemp As Recordset
    Dim RecTempFz As Recordset
    Dim SqlStr As String
    Dim Msortcode As String
    '存货分类顶级编码
    SqlStr = "SELECT * FROM Gy_CodeScheme WHERE (ItemCode = 'Kf_KfwlflSet')"
    Set RecTempFz = Cw_DataEnvi.DataConnect.Execute(SqlStr)
    If Not RecTempFz.EOF Then
       Msortcode = Left(Trim(RecTempFz.Fields("CodeScheme")), 1)
       Msortcode = Left(Trim(Msort), Val(Msortcode))
    End If
    
    '收发类别+部门+存货
    SqlStr = "select * from chhs_dfacc where inoutclasscode='" & InoutClassCode & "' " & _
            " and deptcode='" & Deptcode & "' and mnumber='" & Mnumber & "'"
    Set Rectemp = Cw_DataEnvi.DataConnect.Execute(SqlStr)
    If Not Rectemp.EOF Then
        Xtfhcs = Rectemp.Fields("dfacct")
    Else
        If Trim(InoutClassCode) <> "" Then
            If Trim(Deptcode) <> "" Then
                
                '收发类别+部门+存货分类
                SqlStr = "select * from chhs_dfacc where inoutclasscode='" & InoutClassCode & "' " & _
                        " and deptcode='" & Deptcode & "' and msort like '" & Msortcode & "%' "
                            Set Rectemp = Cw_DataEnvi.DataConnect.Execute(SqlStr)
                Set Rectemp = Cw_DataEnvi.DataConnect.Execute(SqlStr)
                If Not Rectemp.EOF Then
                    Xtfhcs = Rectemp.Fields("dfacct")
                Else
                
                     '收发类别+存货分类
                     SqlStr = "select * from chhs_dfacc where inoutclasscode='" & InoutClassCode & "' " & _
                       " and msort like '" & Msortcode & "%'"
                    Set Rectemp = Cw_DataEnvi.DataConnect.Execute(SqlStr)
                    If Not Rectemp.EOF Then
                        Xtfhcs = Rectemp.Fields("dfacct")
                    Else
                         
                         '收发类别
                        SqlStr = "select * from chhs_dfacc where inoutclasscode='" & InoutClassCode & "'"
                        Set Rectemp = Cw_DataEnvi.DataConnect.Execute(SqlStr)
                        If Not Rectemp.EOF Then
                            Xtfhcs = Rectemp.Fields("dfacct")
                            Exit Sub
                        End If
                        
                        '部门
                        SqlStr = "select * from chhs_dfacc where deptcode='" & Deptcode & "'"
                        Set Rectemp = Cw_DataEnvi.DataConnect.Execute(SqlStr)
                        If Not Rectemp.EOF Then
                            Xtfhcs = Rectemp.Fields("dfacct")
                            Exit Sub
                        End If
                        
                        '存货分类
                        SqlStr = "select * from chhs_dfacc where msort like '" & Msortcode & "%'"
                        Set Rectemp = Cw_DataEnvi.DataConnect.Execute(SqlStr)
                        If Not Rectemp.EOF Then
                            Xtfhcs = Rectemp.Fields("dfacct")
                            Exit Sub
                        End If
                    End If
                End If
            Else
                '收发类别+存货分类
                SqlStr = "select * from chhs_dfacc where inoutclasscode='" & InoutClassCode & "' " & _
                   " and msort like '" & Msortcode & "%'"
                Set Rectemp = Cw_DataEnvi.DataConnect.Execute(SqlStr)
                If Not Rectemp.EOF Then
                    Xtfhcs = Rectemp.Fields("dfacct")
                Else
                     '收发类别
                    SqlStr = "select * from chhs_dfacc where inoutclasscode='" & InoutClassCode & "'"
                    Set Rectemp = Cw_DataEnvi.DataConnect.Execute(SqlStr)
                    If Not Rectemp.EOF Then
                        Xtfhcs = Rectemp.Fields("dfacct")
                        Exit Sub
                    End If
            
                      '存货分类
                    SqlStr = "select * from chhs_dfacc where msort like '" & Msortcode & "%'"
                    Set Rectemp = Cw_DataEnvi.DataConnect.Execute(SqlStr)
                    If Not Rectemp.EOF Then
                        Xtfhcs = Rectemp.Fields("dfacct")
                        Exit Sub
                    End If
              End If
            End If
         Else
            If Trim(Deptcode) <> "" Then
                '部门+存货分类
                SqlStr = "select * from chhs_dfacc where  " & _
                        " deptcode='" & Deptcode & "' and msort like '" & Msortcode & "%' "
                Set Rectemp = Cw_DataEnvi.DataConnect.Execute(SqlStr)
                If Not Rectemp.EOF Then
                    Xtfhcs = Rectemp.Fields("dfacct")
                Else
                    '部门
                    SqlStr = "select * from chhs_dfacc where deptcode='" & Deptcode & "'"
                    Set Rectemp = Cw_DataEnvi.DataConnect.Execute(SqlStr)
                    If Not Rectemp.EOF Then
                        Xtfhcs = Rectemp.Fields("dfacct")
                        Exit Sub
                    End If
                    
                    '存货分类
                    SqlStr = "select * from chhs_dfacc where  msort like '" & Msortcode & "%'"
                    Set Rectemp = Cw_DataEnvi.DataConnect.Execute(SqlStr)
                    If Not Rectemp.EOF Then
                        Xtfhcs = Rectemp.Fields("dfacct")
                    End If
                End If
            Else
                '存货分类
                SqlStr = "select * from chhs_dfacc where msort like '" & Msortcode & "%'"
                Set Rectemp = Cw_DataEnvi.DataConnect.Execute(SqlStr)
                If Not Rectemp.EOF Then
                    Xtfhcs = Rectemp.Fields("dfacct")
                End If
            End If
        End If
    End If
End Sub
Public Function Sub_Records(mDate As Date, mRecrod As String) As Boolean      '单据当天记录集
    Dim RecQuery As Recordset
    Dim SqlStr As String
    
    Sub_Records = True
    SqlStr = "Select InOutMainId from " & mRecrod & " a LEFT OUTER JOIN Gy_Whlimit " & _
            " ON a.WhCode = Gy_Whlimit.WhCode " & _
            " Where  BillDate='" & mDate & "' and Gy_Whlimit.Czybm='" & Xtczybm & "'"
    Set RecQuery = Cw_DataEnvi.DataConnect.Execute(SqlStr)
    If RecQuery.EOF Then
        Sub_Records = False
    End If
    
End Function

						