系统_基本函数模块.bas

新世纪ERP包装物管理源代码

            End If
        End If
    End With

End Function

Public Function Fun_GetIndex(ComboCodeTe As String, FindText As String) As String                         '查找列表框内容对应索引号

    '函数参数：列表框分组编码，定位内容
    Dim Lbknrrec As ADODB.Recordset
  
    Fun_GetIndex = ""
  
    '填充列表框内容
    Set Lbknrrec = Cw_DataEnvi.DataConnect.Execute("select Item_Index from xt_combolist where combo_code='" & Trim(ComboCodeTe) & "' And Item_Content='" & Trim(FindText) & "'")
  
    With Lbknrrec
        If Not .EOF Then
            Fun_GetIndex = Trim(.Fields("Item_Index"))
        End If
    End With

End Function

Public Function Fun_GetContent(ComboCodeTe As String, FindIndex As String) As String                      '查找列表框索引号对应内容

    '函数参数：列表框分组编码，定位内容
    Dim Lbknrrec As ADODB.Recordset
  
    Fun_GetContent = ""
  
    '填充列表框内容
    Set Lbknrrec = Cw_DataEnvi.DataConnect.Execute("select Item_Content from xt_combolist where combo_code='" & Trim(ComboCodeTe) & "' And Item_Index='" & Trim(FindIndex) & "'")
  
    With Lbknrrec
        If Not .EOF Then
            Fun_GetContent = Trim(.Fields("Item_Content"))
        End If
    End With

End Function

'==========================以上为列表框处理基本函数=========================='
Public Function XtWaitMess(Str_IndexSub)                               '系统功能调用等待提示
    
    '函数参数：系统功能模块索引号
    Xtcdcs = Str_IndexSub
    XT_FrmWaitMess.Show 1

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