系统_基本函数模块.bas

新世纪ERP设备管理源代码

End Function

Public Function Sub_FillPeriod(Combote As ComboBox, Year As Integer, Period As Integer)            '列表框填充会计期间

    '过程参数;填充列表框,会计年度,默认会计期间

    Dim jsqte As Integer
    With Combote
        .Clear
        For jsqte = 1 To 12
            .AddItem Mid(Trim(Str(10000 + Xtyear)), 2, 4) + "." + Mid(Trim(Str(100 + jsqte)), 2, 2)
        Next jsqte
     
        .Text = Mid(Trim(Str(10000 + Xtyear)), 2, 4) + "." + Mid(Trim(Str(100 + Period)), 2, 2)
    End With

End Function

'//* 功能: 金额小写转换为大写  调用参数:jesj...人民币小写金额
'//* 返回变量: name..人民币大写金额
Public Function Fun_Jezh(Jesj As Double) As String
    
    Dim Name1$, Name2$, Mje1$, Name$
    Dim len_mje1%, k%, Ws%, j%, ws1%, m%
    Dim Bz As Boolean
    Name1 = "壹贰叁肆伍陆柒捌玖"
    Name2 = "分角元拾佰仟万拾佰仟亿拾佰仟"
    Mje1 = Trim(Format(Jesj, "###.00"))
    len_mje1 = Len(Mje1)
    If len_mje1 > 16 Or Jesj < 0.01 Or IsNull(Jesj) Then
        Fun_Jezh = ""
        Exit Function
    End If
    '//取无小数的字符串
    Mje1 = Left(Mje1, len_mje1 - 3) + Right(Mje1, 2)
    len_mje1 = len_mje1 - 1
    k = len_mje1 * 2 - 1
    Ws = Int(Mid(Mje1, 1, 1)) * 2 - 1

    If len_mje1 = 3 And Ws < 0 Then     '//如果金额<1 name=''
        Name = ""
    Else
        If Ws > 0 Then
            Name = MidB(Name1, Ws, 2) + MidB(Name2, k, 2) '//如果金额>=1,转换金额
        End If
    End If
    j = 2
    k = k - 2
    Bz = True
xh1:
    Do While j <= len_mje1 And Bz
        ws1 = Int(Mid(Mje1, j, 1)) * 2 - 1
        If ws1 > 0 Then
            Name = Name + MidB(Name1, ws1, 2) + MidB(Name2, k, 2)
            j = j + 1
            k = k - 2
            GoTo xh1
        End If
        m = 0
xh2:
        Do While ws1 < 0
            If len_mje1 >= 11 Then
                If k < 21 Then
                    m = m + 1
                End If
            End If
            If k = 5 Or (k = 13 And m <= 3) Or k = 21 Then
                Name = Name + MidB(Name2, k, 2)
            End If
            If k = 1 Then
                Name = Name + "整"
                Bz = False
                Exit Do
            End If
            j = j + 1
            k = k - 2
            ws1 = Int(Mid(Mje1, j, 1)) * 2 - 1
            If ws1 < 0 Then
                GoTo xh2
            Else
                If len_mje1 = 3 Then
                    Name = Name + "零"
                Else
                    Name = Name + "零"
                End If
            End If
        Loop
    Loop

    '去掉元和角之间零(1230.32)
    wz1 = InStr(1, Name, "元")
    wz2 = InStr(1, Name, "角")
    If wz1 <> 0 And wz2 <> 0 Then
        wz3 = InStr(wz1, Name, "零")
        If wz3 <> 0 Then
            Name = Mid(Name, 1, wz3 - 1) + Mid(Name, wz3 + 1, Len(Name))
        End If
    End If
    Fun_Jezh = Name

End Function

Public Function FillImageCombo(Combote As ImageCombo, ComboCode As String, AddType As Integer) '填充列表框(ImageCombo)并定位

    '函数参数：列表框(ImageCombo)，ComboCode列表框分组编码
    'AddType 项目填充类型(0-填充索引+内容,无空记录 1-仅填充内容,无空记录 2-填充索引+内容,有空记录 3-仅填充内容,有空记录)

    Dim Rec_Combo As ADODB.Recordset              '填充属性
    Dim Rec_FillText As ADODB.Recordset           '填充内容
    Dim ci As ComboItem
    Dim jsqte As Integer                          '临时计数器
  
    Combote.ComboItems.Clear
    jsqte = 1
  
    '填充列表框内容
    Set Rec_Combo = Cw_DataEnvi.DataConnect.Execute("Select * From Xt_ImageCombo Where combo_code='" + Trim(ComboCode) + "'")
    With Rec_Combo
        Combote.Locked = True
        If AddType = 2 Or AddType = 3 Then
            Set ci = Combote.ComboItems.Add(, "@")
            jsqte = jsqte + 1
        End If
        
        Set Rec_FillText = Cw_DataEnvi.DataConnect.Execute(Trim(.Fields("Sql_String")))
        
        Do While Not Rec_FillText.EOF
            Select Case AddType
                Case 0, 2                              '填充索引+内容
                    Set ci = Combote.ComboItems.Add(, "@" + Trim(Rec_FillText.Fields(Trim(.Fields("ItemKey")))), Trim(Rec_FillText.Fields(Trim(.Fields("ItemKey")))) + " " + Trim(Rec_FillText.Fields(Trim(.Fields("ItemText")))))
                Case 1, 3                              '仅填充记录内容
                    Set ci = Combote.ComboItems.Add(, "@" + Trim(Rec_FillText.Fields(Trim(.Fields("ItemKey")))), Trim(Rec_FillText.Fields(Trim(.Fields("ItemText")))))
            End Select
            jsqte = jsqte + 1
            Rec_FillText.MoveNext
        Loop
        If Combote.ComboItems.Count <> 0 Then
            Combote.ComboItems.Item(1).Selected = True
        End If
    End With

End Function

Public Function GetComboKey(Combote As ImageCombo, KeyOrName As Integer) As String      '取得用户选中列表框项目Key值或内容
  
    '函数参数：列表框(ImageCombo),KeyOrName 0--取项目Key值 1--取选项内容值
    Dim jsqte As Integer        '临时计数器
  
    If KeyOrName = 0 Then
        '去掉首位@
        For jsqte = 1 To Combote.ComboItems.Count
            If Combote.ComboItems(jsqte).Text = Combote.Text Then
                Exit For
            End If
        Next jsqte
        
        If Combote.ComboItems.Count > 0 Then
            GetComboKey = Trim(Mid(Combote.ComboItems(jsqte).Key, 2, Len(Combote.ComboItems(jsqte).Key)))
        End If
    Else
        GetComboKey = Trim(Combote.Text)
    End If
 
End Function

Public Sub Sub_CodeScheme(ItemCodeTe As String, Int_CodeLev As Integer, Int_CodeScheme() As Integer)     '生成相应各级编码长度到数组中(编码方案)

    '函数参数:ItemCodeTe 编码方案代码,Int_CodeLev 返回编码最大级数,Int_CodeScheme() 返回各级编码长度
    'ForExample:会计科目编码:322222  结果:Int_CodeLev=6 Int_CodeScheme()=3 5 7 9 11 13
    
    Dim Rec_CodeScheme As New ADODB.Recordset   '编码方案动态集
    Set Rec_CodeScheme = Cw_DataEnvi.DataConnect.Execute("Select CodeScheme From Gy_CodeScheme Where ItemCode='" & Trim(ItemCodeTe) & "'")
    With Rec_CodeScheme
        If Not .EOF Then
            Int_CodeLev = Len(Trim(.Fields("CodeScheme")))
            ReDim Int_CodeScheme(Int_CodeLev)
            lenjsq = 0
            For jsqte = 1 To Int_CodeLev
                lenjsq = lenjsq + Mid(Trim(.Fields("CodeScheme")), jsqte, 1)
                Int_CodeScheme(jsqte) = lenjsq
            Next jsqte
        End If
        .Close
    End With

End Sub

Public Sub Sub_SetOperStatus(Str_OperStatus As String)                                                   '显示系统操作状态
    
    If Trim(Str_OperStatus) <> "" Then
        XT_Main.StatusBar1.Panels("OperStatus") = Str_OperStatus
    Else
        XT_Main.StatusBar1.Panels("OperStatus") = "就绪"
    End If

End Sub

Public Sub Sub_ReadBillInfo(BillCode As String, Frm_Bill As Form, Var_Bill() As Variant)                 '读入单据整体设计信息(录入)
    
    '参数说明:BillCode 单据编码(索引号) ,Frm_Bill 单据窗体 , VarBill 用来返回单据设计信息

    Dim RecTemp As New ADODB.Recordset                             '临时使用动态集
    ReDim Var_Bill(1 To 5)                                         '返回单据设计信息
    Set RecTemp = Cw_DataEnvi.DataConnect.Execute("Select * From xt_BillDesign Where BillCode='" & Trim(BillCode) & "'")
    With RecTemp
        If Not .EOF Then
            Frm_Bill.Height = .Fields("FormHeight")                   '设置窗体高度
            Frm_Bill.Width = .Fields("FormWidth")                     '设置窗体宽度
            Var_Bill(1) = Trim(.Fields("BillName"))                   '单据描述
            Frm_Bill.Caption = Var_Bill(1)                            '单据描述赋予窗体Caption
            Var_Bill(2) = Trim(.Fields("BillTitle"))                  '单据标题
            Var_Bill(3) = Trim(.Fields("Text_Group_Code"))            '单据所使用文本框组索引号
            Var_Bill(4) = Trim(.Fields("Grid_Code"))                  '单据所使用网格组索引号
            Var_Bill(5) = Trim(.Fields("Print_Code"))                 '单据所使用打印参数索引号
        End If
    End With

End Sub

Public Sub Sub_DPReadBillInfo(BillCode As String, Frm_Bill As Form, Var_Bill() As Variant)               '读入单据整体设计信息(打印)
    
    '参数说明:BillCode  单据编码(索引号)  Frm_Bill 单据窗体  VarBill 用来返回单据设计信息

    Dim RecTemp As New ADODB.Recordset
    ReDim Var_Bill(1 To 3)
  
    Set RecTemp = Cw_DataEnvi.DataConnect.Execute("Select * From xt_BillDesign Where BillCode='" & Trim(BillCode) & "'")
  
    With RecTemp
        If Not .EOF Then
            Frm_Bill.Pict.Height = .Fields("FormHeight") - 375                  '设置窗体高度
            Frm_Bill.Pict.Width = .Fields("FormWidth")                          '设置窗体宽度
            Frm_Bill.Lab_Title = Trim(.Fields("BillName"))                      '单据标题
            Var_Bill(1) = Trim(.Fields("BillName"))                             '单据描述
            Frm_Bill.Caption = Var_Bill(1)                                      '单据描述赋予窗体Caption
            Var_Bill(2) = Trim(.Fields("Text_Group_Code"))                      '单据所使用文本框组索引号
            Var_Bill(3) = Trim(.Fields("Grid_Code"))                            '单据所使用网格组索引号
        End If
    End With

End Sub

Public Sub DPBcwggs(Bcgsgrid As vsFlexGrid, Wggsdm As String)             '保存网格格式(包括网格列宽,网格列顺序)
    
    '过程参数:保存格式网格对象,网格格式代码(网格参数)
    Dim Tsxx As String
    Dim RecTemp As New ADODB.Recordset
    Dim Qslzte As Integer

    Cw_DataEnvi.DataConnect.BeginTrans
    On Error GoTo Swcwcl
    If RecTemp.State = 1 Then RecTemp.Close
    RecTemp.Open "select * from xt_grid where Grid_Code='" + Trim(Wggsdm) + "' order by ColId", Cw_DataEnvi.DataConnect, adOpenDynamic, adLockOptimistic
    With RecTemp
        If Not .EOF Then
            Qslzte = .Fields("BeginCol")
            .MoveNext
        End If
        Do While Not .EOF
            For jsqte = Qslzte To Bcgsgrid.Cols - 1
                If Bcgsgrid.FixedRows = 1 Then
                    If Trim(.Fields("ColTitle1")) = Trim(Bcgsgrid.TextMatrix(0, jsqte)) Then
                        Exit For
                    End If
                Else
                    If Trim(.Fields("ColTitle1")) = Trim(Bcgsgrid.TextMatrix(0, jsqte)) And Trim(.Fields("ColTitle2")) = Trim(Bcgsgrid.TextMatrix(1, jsqte)) Then
                        Exit For
                    End If
                End If
            Next jsqte
            If jsqte <= Bcgsgrid.Cols - 1 Then
                .Fields("ColId") = jsqte - Qslzte + 1
                .Fields("ColWidth") = Bcgsgrid.ColWidth(jsqte)
                .Update
            Else
                GoTo Swcwcl
            End If
            .MoveNext
        Loop
    End With
    Cw_DataEnvi.DataConnect.CommitTrans
    Tsxx = "表格格式保存完毕!"
    Call Xtxxts(Tsxx, 0, 4)
    Exit Sub
Swcwcl:
    Cw_DataEnvi.DataConnect.RollbackTrans
    Tsxx = "存盘过程中出现未知错误,程序自动恢复保存前状态!"
    Call Xtxxts(Tsxx, 0, 1)
    Exit Sub

End Sub

'===================以下为系统权限控制与上机日志控制函数======================'
Public Function Security_Log(gnsy As String, UserCode As String, Optional LogTF As Integer = 3, Optional State As Boolean = True, Optional Msg As Boolean = True) As Boolean   '权限判断和日志

    'Gnsy 功能索引 UserCode 用户编码
    'LogTF (1、判断权限，写日志)、（2、只写日志）、（3、只判断权限）
    'State 状态 (True 进入 false 完成)
    '返回Security_Log=true表示有权限，Security_Log=false表示没有有权限
    'Msg   没有权限时是否提示（True 提示    False不提示）
    Dim Tsxx As String              '系统信息提示
    
   On Error Resume Next
    
    Dim aDo_userGroup As New Recordset
    Dim aDo_gnbm As New Recordset: Dim Ssql As String
    
    Set aDo_gnbm = Cw_DataEnvi.DataConnect.Execute("select * from Xt_xtgnb where gnsy='" & Trim(gnsy) & "'")
     
    If LogTF = 1 Or LogTF = 3 Then
        Set aDo_userGroup = Cw_DataEnvi.DataConnect.Execute("select * from Gy_Czygl where czybm='" & Trim(UserCode) & "'")