企业管理

开发平台：
Visual Basic

：源码内容
							Attribute VB_Name = "XtjbModule"
'系统基本模块(主要用来放置公用函数及模块)
                
'系统信息
Public XtMenuList As String    '系统菜单功能编码
'系统日期
Public Xtkjqjgs As Integer     '用户设定会计期间个数
Public Xtyear As Integer       '用户进入系统选择年度
Public Xtmm As Integer         '用户进入系统选择会计期间
Public Xtrq As Date            '系统日期
Public Xtrlbz As String        '系统日历标志
'系统往返参数值
Public Xtcdcs As String        '系统传递参数值(专门用来传递帮助信息)
Public Xtcdcsfz As String      '系统传递参数值(辅助信息)
Public Xtfhcs As String        '系统返回参数值(专门用来传递帮助信息)
Public Xtfhcsfz As String      '系统返回参数值(辅助信息)
'系统通用编码参照代码
Public Xtbmczdm As String      '系统通用编码参照代码
'(系统等待调用窗体)
Public XtCxgnsm As String      '调用程序功能说明
Public Xtczy As String         '系统使用操作员
Public Xtczybm As String       '系统操作员编码
Public Xtztbm As String        '系统帐套编码
Public Xtdwm As String         '系统打开帐套单位
'帐套基本参数
Public Xtjezws As Integer      '金额总位数
Public Xtslzws As Integer      '数量总位数
Public Xtdjzws As Integer      '单价总位数
Public Xtjexsws As Integer     '金额小数位数
Public Xtslxsws As Integer     '数量小数位数
Public Xtdjxsws As Integer     '单价小数位数
Public XtSCurrCode As String   '本位币编码
Public XtSCurrName As String   '本位币名称
'其它全局变量
Public Unload_TF As Boolean    '窗体是否卸载
Public P_RecordCount As Integer '记录条数
Public YesNo_str As String
Public SsqlHelp As String
Public P_Code As String: Public P_Name As String  '编码、名称
Public AddExit_TF As Boolean '添加或编辑状态
Public P_Ssql As String  'Sql 语句
'系统传递单据ID
Public XT_BillID As Long
'引用API函数
Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long
'======================以下为打印文本内容格式输出控制过程函数======================='
Public Function Fun_FormatOutPut(InputText As String, OutPutLen As Integer) As String               '文本内容按一定标准格式输出(主要用于打印使用)
  
    '参数说明:InputText 需要格式化的文本内容 OutPutLen 输出文本占用长度(包括加空格)
    Fun_FormatOutPut = Trim(InputText) + Space(OutPutLen - Strcdcs(Trim(InputText), OutPutLen))
  
End Function
Public Function Strcdcs(Lrcsstr As String, Lrzdcd As Integer) As Integer                            '测量并限制字符串长度(汉字与字符区分)
   
    '参数说明:Lrcsstr 需要测量和限制输出的字符串 Lrzdcd 限制输出长度
  
    lrtextlong = Len(Trim(Lrcsstr))
    lrcscd = 0
    For Jsqte = 1 To lrtextlong
        lrcszf = Mid(Lrcsstr, Jsqte, 1)
        lrzzcd = lrcscd
        If Asc(lrcszf) >= 0 And Asc(lrcszf) <= 255 Then
            lrcscd = lrcscd + 1
        Else
            lrcscd = lrcscd + 2
        End If
        If lrcscd > Lrzdcd Then
            lrstrjqcd = Jsqte - 1
            Lrcsstr = Mid(Lrcsstr, 1, lrstrjqcd)
            Strcdcs = lrzzcd
            Exit Function
        Else
            Strcdcs = lrcscd
        End If
    Next Jsqte
End Function
'======================以下为文本录入内容格式输入控制过程函数======================='
Public Sub Lrfzszxz(Sjwb As TextBox, lrzfasc As Integer)              '文本框录入整数值(负)限制
   
    '输入参数：sjwb 录入限制文本框 lrzfasc 用户录入字符Ascii码值
    If Not ((lrzfasc >= Asc("0") And lrzfasc <= Asc("9")) Or lrzfasc = vbKeyBack Or (Chr(lrzfasc) = "-" And Sjwb.SelStart = 0)) Then
        lrzfasc = 0
    End If
End Sub
Public Sub Lrzszxz(lrzfasc As Integer)                                '文本框录入整数值(正)限制
    '输入参数：lrzfasc 用户录入字符Ascii码值
    If Not ((lrzfasc >= Asc("0") And lrzfasc <= Asc("9")) Or lrzfasc = vbKeyBack) Then
        lrzfasc = 0
    End If
End Sub
Public Sub Lrszzfxz(lrzfasc As Integer)                               '文本框录入数字及字符限制
    
    '输入参数：lrzfasc 用户录入字符Ascii码值
    If Not ((lrzfasc >= Asc("0") And lrzfasc <= Asc("9")) Or (lrzfasc >= Asc("a") And lrzfasc <= Asc("z")) Or (lrzfasc >= Asc("A") And lrzfasc <= Asc("Z")) Or lrzfasc = vbKeyBack) Then
        lrzfasc = 0
    End If
End Sub
Public Sub Lrfhzxz(lrzfasc As Integer)                                '文本框录入非汉字限制
    
    '输入参数：lrzfasc 用户录入字符Ascii码值
    If Not ((lrzfasc >= 0 And lrzfasc <= 255) Or lrzfasc = vbKeyBack) Then
        lrzfasc = 0
    End If
End Sub
Public Sub Lrrqxz(lrzfasc As Integer)                                 '文本框录入日期限制
    
    '输入参数：lrzfasc 用户录入字符Ascii码值
    If Not ((lrzfasc >= Asc("0") And lrzfasc <= Asc("9")) Or Chr(lrzfasc) = "-" Or lrzfasc = vbKeyBack) Then
        lrzfasc = 0
    End If
    
End Sub
Public Sub Lrxszxz(Sjwb As TextBox, lrzfasc As Integer)               '文本框录入带有小数位及正负号数值字段
  
    If Not ((Chr(lrzfasc) >= "0" And Chr(lrzfasc) <= "9") Or (Chr(lrzfasc) = "." And InStr(1, Sjwb.Text, ".") = 0) Or lrzfasc = vbKeyBack Or (Chr(lrzfasc) = "-" And Sjwb.SelStart = 0)) Then
        lrzfasc = 0
    End If
End Sub
Public Sub Lrxzszxz(Sjwb As TextBox, lrzfasc As Integer)              '文本框录入带有小数位正>=0数值字段
    
    If Not ((Chr(lrzfasc) >= "0" And Chr(lrzfasc) <= "9") Or (Chr(lrzfasc) = "." And InStr(1, Sjwb.Text, ".") = 0) Or lrzfasc = vbKeyBack) Then
        lrzfasc = 0
    End If
End Sub
Public Sub Sjgskz(Sjwb As TextBox, zsws As Integer, xsws As Integer)  '保证数值录入字段录入格式
    '输入参数:sjwb 录入限制文本框 zsws 数值录入限制整数位数 xsws 数值录入限制小数位数
   
   Dim bccrd%
   Dim Ws, Zswstr, Xswstr As String
   Dim B_fu As Boolean
   Dim sjzws As Integer
   bccrd = Sjwb.SelStart
   B_fu = False
   
    Ws = InStr(1, Sjwb, "-")
    If Ws > 0 Then Sjwb = Mid(Sjwb, Ws)
   If Left(Sjwb, 1) = "-" Then
      B_fu = True
      zsws = zsws - 1
      Zswstr = Mid(Sjwb, 2)
   Else
      Zswstr = Mid(Sjwb, 1)
   End If
   
   Ws = InStr(1, Zswstr, ".")                   '整数位数+1
   
    If Ws > 0 Then
        If zsws > Ws - 1 Then
            Zswstr = Mid(Zswstr, 1, Ws - 1) + Mid(Zswstr, Ws, xsws + 1)
        Else
            Zswstr = Mid(Zswstr, 1, zsws) + Mid(Zswstr, Ws, xsws + 1)
            Ws = InStr(1, Zswstr, ".")                   '整数位数+1
        End If
        Ws = Len(Zswstr) - Ws                   '小数位数
        If Left(Zswstr, 1) = "." Then
            bccrd = bccrd + 1
            Zswstr = "0" & Zswstr
        End If
        If Ws < xsws Then
           Zswstr = Format(Zswstr, "#0." + String(Ws, "0"))
        Else
           Zswstr = Format(Zswstr, "#0." + String(xsws, "0"))
        End If
   Else
      Zswstr = Mid(Zswstr, 1, zsws)
      Zswstr = Format(Zswstr)
   End If
   
   If B_fu Then Zswstr = "-" & Zswstr
   Sjwb = Zswstr
   Sjwb.SelStart = bccrd
End Sub
Public Sub InputFieldLimit(Ydtextte As TextBox, Zdsjlxte As Integer, KeyAsciite As Integer)     '录入字段事中控制程序
    '函数参数:录入限制文本框,字段数据类型,录入字符
    Select Case Zdsjlxte
        Case 1                                  '1-录入(Ascii0-255)
            Call Lrfhzxz(KeyAsciite)
        Case 2
            Call Lrszzfxz(KeyAsciite)             '2-录入(0-9,a-z,A-Z)
        Case 3
            Call Lrfzszxz(Ydtextte, KeyAsciite)   '3-录入整数值(正负)
        Case 4
            Call Lrzszxz(KeyAsciite)              '4-录入整数值(正)
        Case 5, 8, 9
            Call Lrxszxz(Ydtextte, KeyAsciite)    '5-录入小数值(正负) 8-金额型(正负) 9-数量型（正负）
        Case 6, 10, 11, 12
            Call Lrxzszxz(Ydtextte, KeyAsciite)   '6-录入小数值(正) 10-单价型 11-金额型(正) 12-数量型（正）
        Case 7
            Call Lrrqxz(KeyAsciite)               '7-录入日期
    End Select
End Sub
Public Sub TextChangeLimit(Ydtextte As TextBox, Zdsjlxte As Integer)      '文本框字段录入控制(事后、防止用户采用粘贴录入)
    '函数参数:录入限制文本框,字段数据类型
    
    Dim Str_JudgeStr As String      '判断字符
    Dim Jsqte As Integer            '临时使用计数器
    Dim Str_Result As String        '结果字符串
    Dim KeyAsciite As Integer
    
    Str_Result = ""
    
    For Jsqte = 1 To Len(Trim(Ydtextte.Text))
        Str_JudgeStr = Mid(Trim(Ydtextte.Text), Jsqte, 1)
        KeyAsciite = Asc(Str_JudgeStr)
    
        If Str_JudgeStr = "'" Then
           Str_JudgeStr = ""
        End If
        
        Select Case Zdsjlxte
            Case 1                                           '1-录入(Ascii0-255)
                Call Lrfhzxz(KeyAsciite)
                If KeyAsciite = 0 Then
                   Str_JudgeStr = ""
                End If
            Case 2
                Call Lrszzfxz(KeyAsciite)                    '2-录入(0-9,a-z,A-Z)
                If KeyAsciite = 0 Then
                   Str_JudgeStr = ""
                End If
            Case 4, 6, 10, 11, 12
                If Str_JudgeStr = "-" Then                   '录入数值(正)
                   Str_JudgeStr = ""
                End If
        End Select
        Str_Result = Str_Result + Str_JudgeStr
     Next Jsqte
     
     If Str_Result <> Trim(Ydtextte.Text) Then
        Ydtextte.Text = Str_Result
        Ydtextte.SelStart = Len(Ydtextte.Text)
     End If
End Sub
'==============================================================================='
Public Function Xtxxts(xttsxx As String, xttslb As Integer, Tbtslb As Integer)          '系统信息提示
    
    msgtitle = "百利/ERP5.0-质量系统"
    Select Case xttslb
        Case 0    '确定
            Xtxxts = MsgBox(xttsxx, Tbtslb * 16, msgtitle)
        Case 1    'YES/NO
           Xtxxts = MsgBox(xttsxx, vbYesNo + Tbtslb * 16, msgtitle)
        Case 2    '确定/取消
           Xtxxts = MsgBox(xttsxx, vbOKCancel + Tbtslb * 16, msgtitle)
        Case Else
           Xtxxts = "9"
    End Select
End Function
Public Function Kjjdzy(Zyjdzs As Integer) As Boolean                                    '控件焦点转移(针对回车键)
    
    Kjjdzy = False
    
    On Error GoTo Cwcl
    
    If Screen.ActiveControl.TabIndex <= Zyjdzs - 1 Then
        Kjjdzy = True
        SendKeys "{tab}"
    End If
    Exit Function
Cwcl:
    Resume Next         '有些对象不支持TabIndex属性
End Function
Public Sub Pbwxzf(Zfc As Integer)                                                       '录入时屏蔽"'"
    
    If Chr(Zfc) = "'" Then
        Zfc = 0
    End If
End Sub
'======================以下为对网格操作基本函数========================'
Public Sub BzWgcsh(Xsgrid As vsFlexGrid, Wgdmte As String, GridInf() As Variant, GridBoolean() As Boolean, GridInt() As Integer, GridStr() As String)          '标准网格初始化模块
  
    '过程参数为:Xsgrid 生成网格对象名称,Wgdmte 网格参数编码,GridInf()返回网格设置信息(返回整体信息)
    'GridBoolean() 网格列属性(返回布尔型信息),GridInt() 网格列属性(返回整型信息),GridStr() 网格列属性(返回字符型信息)
      
    Dim wglbt() As String                      '网格显示列标题
    Dim Wgxsls As Long                         '网格显示(主操作)列数
    Dim gdls As Long                           '网格固定列数
    Dim Gdhs As Long                           '网格固定行数(标题行数)
    Dim Gdhgd As Double                        '网格固定行高度
    Dim wglkd() As Double                      '每列默认字符个数
    Dim wglzz() As Integer                     '网格列组织形式
    Dim zdxsgs() As String                     '数值字段显示格式
    Dim Sfhide() As Boolean                    '网格列是否隐藏
    Dim Sfhxz As Boolean                       '网格列是否行选中
    Dim Qslz As Long                           '网格隐藏(非操作显示)列数
    Dim Sjhgd As Double                        '网格数据行高度
    Dim Wglsfkydpx As Integer                  '网格列是否可移动及排序
    Dim wgxsrec As New ADODB.Recordset         '网格显示动态集
    
    ReDim GridInf(1 To 7)                      '整个网格设置信息
    Set wgxsrec = Cw_DataEnvi.DataConnect.Execute("SELECT * FROM xt_grid WHERE Grid_Code ='" + Wgdmte + "' ORDER BY ColId")
    With wgxsrec
        If .EOF And .BOF Then
            Exit Sub
        Else
            .MoveFirst
        End If
   
        '如果网格为单据则设置网格大小、位置
        If .Fields("GridType") = 1 Then
            Xsgrid.Height = .Fields("GridHeight") '网格高度
            Xsgrid.Width = .Fields("Gridwidth")   '网格宽度
            Xsgrid.Top = .Fields("GridTop")       '网格上边距
            Xsgrid.Left = .Fields("GridLeft")     '网格左边距
        End If
   
        Qslz = .Fields("BeginCol")                '网格隐藏(非操作显示)列数
        Sjhgd = .Fields("DataRowHeight")          '网格数据行高度
   
        GridInf(1) = Qslz                         '起始列值
        GridInf(2) = Sjhgd                        '数据行高度
        GridInf(3) = .Fields("KeepDataRows")      '屏幕保持数据行数
        GridInf(4) = .Fields("AssistantRows")     '辅助项网格行数(例如:合计行)
        If .Fields("SaveHelpWidth_Flag") Then     '是否保留帮助宽度(字段提供帮助时,是否为按钮保留空间)
            GridInf(5) = True
        Else
            GridInf(5) = False
        End If
        If .Fields("DeleteRowAsk_Flag") Then      '删除有效记录行是否提示
            GridInf(6) = True
        Else
            GridInf(6) = False
        End If
        If .Fields("ShowSumGrid_Flag") Then       '是否显示合计网格
            GridInf(7) = True
        Else
            GridInf(7) = False
        End If
      
        Wgxsls = .RecordCount - 1                 '网格显示(主操作)列数(原.Fields("wgxsls"))
        gdls = .Fields("FixCols")                 '网格固定列数
        Gdhs = .Fields("FixRows")                 '网格固定行数(标题行数)
        Gdhgd = .Fields("FixRowHeight")           '网格固定行高度
        Wglsfkydpx = .Fields("explorerbar")       '网格列是否可移动及排序
   
        If .Fields("SelectRow_Flag") Then         '是否行选中
            Sfhxz = True
        End If
   
        ReDim wglbt(Gdhs - 1, Wgxsls + Qslz - 1)  '网格显示列标题
        ReDim wglkd(Qslz + Wgxsls - 1)            '每列默认字符个数
        ReDim zdxsgs(Qslz + Wgxsls - 1)           '数值字段标志
        ReDim wglzz(Qslz + Wgxsls - 1)            '网格列组织形式
        ReDim Sfhide(Qslz + Wgxsls - 1)           '网格列是否显示
        ReDim GridBoolean(Qslz + Wgxsls - 1, 1 To 6)   '网格列属性(布尔型)
        ReDim GridStr(Qslz + Wgxsls - 1, 1 To 20)      '网格列信息(字符型)
        ReDim GridInt(Qslz + Wgxsls - 1, 1 To 7)       '网格列信息(整型)
   
        .MoveNext
        Jsqte = 0
        
        Do While Not .EOF
            wglkd(Qslz + Jsqte) = .Fields("ColWidth")                  '网格列宽度限制
            If Not IsNull(.Fields("ColTitle1")) Then
                wglbt(0, Qslz + Jsqte) = Trim(.Fields("ColTitle1"))      '网格列标题1
            End If
            If Not IsNull(.Fields("ColTitle2")) And Gdhs >= 2 Then     '网格列标题2
                wglbt(1, Qslz + Jsqte) = Trim(.Fields("ColTitle2"))
            End If
            If Not IsNull(.Fields("ColTitle3")) And Gdhs >= 3 Then     '网格列标题3
                wglbt(2, Qslz + Jsqte) = Trim(.Fields("ColTitle3"))
            End If
            If .Fields("ColFormat") Then                               '字段显示格式(千分符)
                If .Fields("Text_Int_Length") <> 0 Then
                    zdxsgs(Qslz + Jsqte) = "#,##0." + String(.Fields("Text_deci_Length"), "0")
                Else
                    zdxsgs(Qslz + Jsqte) = "#,##0.00"
                End If
                Select Case .Fields("Text_Data_Type")
                    Case 8, 11  '金额
                        zdxsgs(Qslz + Jsqte) = "#,##0." + String(Xtjexsws, "0")
                    Case 9, 12  '数量
                        zdxsgs(Qslz + Jsqte) = "#,##0." + String(Xtslxsws, "0")
                    Case 10     '单价
                        zdxsgs(Qslz + Jsqte) = "#,##0." + String(Xtdjxsws, "0")
                End Select
            Else
                If .Fields("Text_Int_Length") <> 0 Then
                    zdxsgs(Qslz + Jsqte) = "##0." + String(.Fields("Text_deci_Length"), "0")
                End If
            End If
            wglzz(Qslz + Jsqte) = .Fields("ColAlignment")              '网格列组织形式
            
            If .Fields("ColHidden") Then                               '网格列是否隐藏
                Sfhide(Qslz + Jsqte) = True
            End If
            If .Fields("Edit_Flag") Then                               '网格列是否可编辑
                GridBoolean(Qslz + Jsqte, 1) = True
            End If
            If .Fields("Help_Flag") Then                               '网格列是否提供帮助
                GridBoolean(Qslz + Jsqte, 2) = True
            End If
            If .Fields("Combo_Flag") Then                              '网格列是否列表框录入
                GridBoolean(Qslz + Jsqte, 3) = True
            End If
            If .Fields("ColSum_Flag") Then                             '网格列是否合计
                GridBoolean(Qslz + Jsqte, 4) = True
            End If
            If .Fields("Zero_Empty_Flag") Then                         '网格内容为零是否清空
                GridBoolean(Qslz + Jsqte, 5) = True
            End If
            If .Fields("BooleanFlag") Then                             '网格列是否为布尔型
                GridBoolean(Qslz + Jsqte, 6) = True
            End If
            If Not IsNull(.Fields("Text_Data_Type")) Then              '字段数据类型
                GridInt(Qslz + Jsqte, 1) = .Fields("Text_Data_Type")
            End If
            If Not IsNull(.Fields("Text_Length")) Then                 '字段录入长度
                GridInt(Qslz + Jsqte, 2) = .Fields("Text_Length")
            End If
            If Not IsNull(.Fields("Text_Int_Length")) Then             '字段整数位长度
                GridInt(Qslz + Jsqte, 3) = .Fields("Text_Int_Length")
            End If
            If Not IsNull(.Fields("Text_Deci_Length")) Then            '字段小数位长度
                GridInt(Qslz + Jsqte, 4) = .Fields("Text_Deci_Length")
            End If
            If Not IsNull(.Fields("NotAllowEmpty_Type")) Then          '字段不允许为空或为零
                GridInt(Qslz + Jsqte, 5) = .Fields("NotAllowEmpty_Type")
            End If
            If Not IsNull(.Fields("Help_Type")) Then                   '帮助类型
                GridInt(Qslz + Jsqte, 6) = .Fields("Help_Type")
            End If
            If Not IsNull(.Fields("HelpReturnValue")) Then             '帮助返回值(0-显示返回编码 1-显示返回名称)
                GridInt(Qslz + Jsqte, 7) = .Fields("HelpReturnValue")
            End If
            GridStr(Qslz + Jsqte, 1) = Trim(.Fields("ColIndex") & "")    '网格列索引值
            GridStr(Qslz + Jsqte, 2) = Trim(.Fields("EmptyMessage") & "") '字段为空提示信息
            GridStr(Qslz + Jsqte, 3) = Trim(.Fields("Help_Code") & "")    '通用帮助编码
            GridStr(Qslz + Jsqte, 4) = Trim(.Fields("FieldsName") & "")   '连接字段(通用帮助)
            GridStr(Qslz + Jsqte, 5) = Trim(.Fields("Combo_Code") & "")   '列表框编码
    
            .MoveNext
            Jsqte = Jsqte + 1
        Loop
    End With
   
    '网格列组织形式
   
    With Xsgrid
        .BackColorFixed = &H8000000F                                     '固定行背景色
        .Rows = Gdhs
        .FixedRows = Gdhs                                                '固定行数
        .Cols = Qslz + Wgxsls
        .FixedCols = gdls                                                '固定列数
        .AllowUserResizing = flexResizeBoth
        .MergeCells = flexMergeFixedOnly                                 '合并单元形式
        If Sfhxz Then
            .SelectionMode = flexSelectionByRow
        Else
            .FocusRect = flexFocusHeavy
            .ForeColorSel = &H80000008
            .BackColorSel = &H80000005
        End If
        .ExplorerBar = Wglsfkydpx                                        '网格列是否可移动及排序
        .ScrollTips = True
        .WordWrap = True
     
        '填 充 网 格 标 题
        For Rowjsq = 0 To .FixedRows - 1
            .MergeRow(Rowjsq) = True
            .RowHeight(Rowjsq) = Gdhgd
            For Coljsq = Qslzte To .Cols - 1
                .TextMatrix(Rowjsq, Coljsq) = wglbt(Rowjsq, Coljsq)
                Next Coljsq
        Next Rowjsq
     
       '数 据 网 格 高 度
       For Rowjsq = .FixedRows To .Rows - 1
           .RowHeight(Rowjsq) = Sjhgd
       Next Rowjsq
       '定 义 录 入 字 段 属 性
       For Coljsq = 0 To .Cols - 1
           If Coljsq < Qslz Or Sfhide(Coljsq) Then
               .ColHidden(Coljsq) = True
           Else
               .ColHidden(Coljsq) = False
           End If
           .MergeCol(Coljsq) = True
           .ColWidth(Coljsq) = wglkd(Coljsq)
           .ColAlignment(Coljsq) = wglzz(Coljsq)
           If Len(zdxsgs(Coljsq)) <> 0 Then
               .ColFormat(Coljsq) = zdxsgs(Coljsq)
           End If
           If GridBoolean(Coljsq, 6) Then
               .ColDataType(Coljsq) = flexDTBoolean
           End If
           .FixedAlignment(Coljsq) = 4
       Next Coljsq
   End With
End Sub
Public Sub Bcwggs(Bcgsgrid As vsFlexGrid, Wggsdm As String, GridStr() As String)            '保存网格格式(包括网格列宽,网格列顺序)
  
    '过程参数:Bcgsgrid 保存格式网格对象,Wggsdm 网格格式代码(网格参数),GridStr() 从中取网格列索引信息
  
    Dim RecTemp As New ADODB.Recordset               '临时使用动态集
    Dim Qslzte As Integer                            '起始列值
    Dim Tsxx As String                               '系统信息提示
  
    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 Trim(.Fields("ColIndex")) = Trim(GridStr(Jsqte, 1)) Then
                    Exit For
                End If
            Next Jsqte
            If Jsqte <= Bcgsgrid.Cols - 1 Then
                .Fields("ColId") = Jsqte - Qslzte + 1
                .Fields("ColWidth") = Bcgsgrid.ColWidth(Jsqte)
                .Update
            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 Sub Hfmrgs(Bcgsgrid As vsFlexGrid, Wggsdm As String, GridStr() As String)            '恢复网格默认列宽
    
    '过程参数:保存格式网格对象,网格格式代码(网格参数),GridStr() 从中取网格列索引信息
    Dim RecTemp As New ADODB.Recordset   '临时使用动态集
    Dim Qslzte As Integer                '起始列值
    Dim Tsxx As String                   '系统提示信息
  
    Cw_DataEnvi.DataConnect.BeginTrans
    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
    
    On Error GoTo Swcwcl
  
    With RecTemp
        If Not .EOF Then
            Qslzte = .Fields("BeginCol")
            .MoveNext
        End If
        Do While Not .EOF
            For Jsqte = Qslzte To Bcgsgrid.Cols - 1
                If Trim(.Fields("ColIndex")) = Trim(GridStr(Jsqte, 1)) Then
                    Exit For
                End If
            Next Jsqte
            If Jsqte <= Bcgsgrid.Cols - 1 Then
                Bcgsgrid.ColWidth(Jsqte) = .Fields("DefaultColWidth")
                .Fields("ColWidth") = .Fields("DefaultColWidth") + 0
                .Update
            End If
            .MoveNext
        Loop
    End With
    Cw_DataEnvi.DataConnect.CommitTrans
    Exit Sub
Swcwcl:
    Cw_DataEnvi.DataConnect.RollbackTrans
    Tsxx = "恢复过程中出现未知错误,程序自动恢复保存前状态!"
    Call Xtxxts(Tsxx, 0, 1)
    Exit Sub
End Sub
Public Sub Szxsxm(SzgsGrid As vsFlexGrid, Wggsdm As String)        '设置网格显示项目
   
    '过程参数:调整显示项目网格对象,网格格式代码(网格参数)
    Xtcdcs = Wggsdm
    XT_BgxsxmszFrm.Show 1                '调整网格显示项目
    Call Cxxswg(SzgsGrid, Wggsdm)        '重新定义网格显示
End Sub
Public Sub Cxxswg(Bcgsgrid As vsFlexGrid, Wggsdm As String)        '根据用户定义显示项目重新显示网格
  
    '过程参数:调整显示项目网格对象,网格格式代码(网格参数)
  
    Dim RecTemp As New ADODB.Recordset   '查询数据表动态集
    Dim Qslzte As Integer
    Dim Tsxx As String
    Set RecTemp = Cw_DataEnvi.DataConnect.Execute("select * from xt_grid where Grid_Code='" + Trim(Wggsdm) + "' order by ColId")
    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
                If .Fields("ColHidden") Then
                    Bcgsgrid.ColHidden(Jsqte) = True
                Else
                    Bcgsgrid.ColHidden(Jsqte) = False
                End If
            End If
            .MoveNext
        Loop
    End With
End Sub
Public Function Sydz(Zdbmte As String, GridStr() As String, Szzls As Integer) As Integer   '网格索引对照表(用来对照网格物理与逻辑顺序关系)
    
    '函数参数:索引编码,网格列属性(字符型),网格列最大数组下标值
    Sydz = 0
    For Jsqte = 0 To Szzls
        If Trim(GridStr(Jsqte, 1)) = Zdbmte Then
            Sydz = Jsqte
            Exit Function
        End If
    Next Jsqte
End Function
Public Function FnBln_RefreshArray(int_StartCol As Long, int_FinishCol As Long, GridStr() As String, GridInf()) As Boolean     '网格列交换后数组做相应变换函数
  
    '功能： 实现网格的列移动
    '说明：本函数是在模式工程的基础上创建的，请确认你的窗体中的网格是通过
    '     BzWgcsh(CxbbGrid, GridCode, GridInf(), GridBoolean(), GridInt(), GridStr()) 函数来定义的
    '参数：int_StartCol——网格开始移动列
    '参数：int_FinishCol——网格移动结束列
    '参数：GridStr()——网格的信息数组
    '思路：对于要移动的网格来说，所有的信息都保存在几个系统数组中，其中GridStr（）数组保存着逻辑定位和
    '      物理定位之间的转换关系，使我们可以通过逻辑值找到物理值,由于我们通常通过逻辑值来定位网格的
    '      物理列（sydz(zdbmte as String,GridStr() as String,szzls as Integer)函数），所以我们只需要
    '      改变GridStr()数组中物理列和逻辑列之间的对应关系，从而达到改变列的目的。
    '扩展：虽然本程序只是针对数据显示网格而作，但是此程序给大家提供了一个思路，通过交换GridBoolean()、
    '      GridInt()、网格列标题wglbt()等数组，就可以实现输入的列移动
  
    On Error GoTo Err_Ctrl
 
    Dim int_temp As Integer
    Dim Str_Temp() As String '用来保存移动开始列的GridStr()信息
    Dim i, j As Long
  
    '如果结束列小于用户定义网格开始列，则结束列=用户定义网格开始列
    '因为开始列以前的列都是隐藏列，由于要把当前开始移动列移动到隐藏列上
    '所以控件自动把隐藏列变为显示列，这样在刷新数据时，会把隐藏列上的数据
    '显示出来，并且，由于开始列以前的隐藏列在XT_Grid中，不对应逻辑值，所以在保存
    '网格格式时会出错
    If int_StartCol > int_FinishCol Then
        If int_FinishCol < GridInf(1) Then int_FinishCol = GridInf(1)
    Else
        If Col < GridInf(1) Then Col = GridInf(1)
    End If
  
    '保存移动开始列的GridStr()信息
    ReDim Str_Temp(0, UBound(GridStr, 2))
    For j = 1 To UBound(GridStr, 2)
        Str_Temp(0, j) = GridStr(int_StartCol, j)
    Next
    
    '[[在此加入你的代码，保存当前开始移动列的其他信息]]
    '依次移动各列的信息
    If int_StartCol < int_FinishCol Then
        For i = int_StartCol To int_FinishCol - 1
            For j = 1 To UBound(GridStr, 2)
                GridStr(i, j) = GridStr(i + 1, j)
            Next j
        Next i
    Else
        For i = int_StartCol To int_FinishCol + 1 Step -1
            For j = 1 To UBound(GridStr, 2)
                GridStr(i, j) = GridStr(i - 1, j)
            Next j
        Next i
    End If
    
    '[[在此加入你的代码，依照上面的代码格式，移动列的其他信息]]
    '恢复开始移动列的信息到结束列上
    For j = 1 To UBound(GridStr, 2)
        GridStr(int_FinishCol, j) = Str_Temp(0, j)
    Next j
  
    '[[在此加入你的代码，恢复开始移动列的其他信息到结束列上]]
    FnBln_RefreshArray = True
    Exit Function
Err_Ctrl:
    FnBln_RefreshArray = False
End Function
'========================以上为网格操作基本函数==============================='
Public Sub Drwbkxx(Wbklrbmte As String, Textvar() As Variant, Textboolean() As Boolean, Textint() As Integer, Textstr() As String)   '读入文本框录入信息
   
    '过程参数:输入参数 Wbklrbmte 文本框录入信息组索引号
    '         输出参数 Textvar() Textboolean() Textint() Textstr 文本框信息
   
    Dim Wbklrbrec As ADODB.Recordset      '文本框录入表动态集
    Dim Zdszxb As Integer                 '最大数组下标
    Dim text_indexte As Integer           '文本框索引值
   
    ReDim Textvar(1 To 1)
    Set Wbklrbrec = Cw_DataEnvi.DataConnect.Execute("SELECT * FROM Xt_text_input WHERE Text_Group_Code ='" + Wbklrbmte + "' ORDER BY Text_index")
    With Wbklrbrec
        If Not (.BOF And .EOF) Then
            .MoveLast
            Zdszxb = .Fields("text_index")
            Textvar(1) = Zdszxb
            ReDim Textboolean(0 To Zdszxb, 1 To 5)
            ReDim Textint(0 To Zdszxb, 1 To 14)
            ReDim Textstr(0 To Zdszxb, 1 To 7)
            .MoveFirst
        Else
            Exit Sub
        End If
        Do While Not .EOF
            text_indexte = .Fields("text_index")
            
            If .Fields("help_flag") Then                                 '是否提供帮助
                Textboolean(text_indexte, 1) = True
            End If
            If .Fields("Help_ManuFlag") Then                             '手工设置帮助按钮
                Textboolean(text_indexte, 3) = True
            End If
            If .Fields("Visible") Then                                   '文本框是否显示
                Textboolean(text_indexte, 4) = True
            End If
            If .Fields("Enabled") Then                                   '文本框是否可编辑
                Textboolean(text_indexte, 5) = True
            End If
      
            If Not IsNull(.Fields("text_data_type")) Then                '字段数据类型
                Textint(text_indexte, 1) = .Fields("text_data_type")
            End If
            If Not IsNull(.Fields("help_type")) Then                     '帮助类型
                Textint(text_indexte, 2) = .Fields("help_type")
            End If
            If Not IsNull(.Fields("show_code_name")) Then                '帮助返回值显示类型
                Textint(text_indexte, 3) = .Fields("show_code_name")
            End If
            If Not IsNull(.Fields("judge_type")) Then                    '有效性判断类型
                Textint(text_indexte, 4) = .Fields("judge_type")
            End If
            If Not IsNull(.Fields("text_length")) Then                   '字段录入长度
                Textint(text_indexte, 5) = .Fields("text_length")
            End If
            If Not IsNull(.Fields("text_int_length")) Then               '数值字段整数位长度
                Textint(text_indexte, 6) = .Fields("text_int_length")
            End If
            If Not IsNull(.Fields("text_deci_length")) Then              '数值字段小数位长度
                Textint(text_indexte, 7) = .Fields("text_deci_length")
            End If
            If Not IsNull(.Fields("NotAllowEmpty_Type")) Then            '字段不允许为空或为零
                Textint(text_indexte, 8) = .Fields("NotAllowEmpty_Type")
            End If
            If Not IsNull(.Fields("Judge_Time")) Then                    '文本框有效性判断时刻
                Textint(text_indexte, 9) = .Fields("Judge_Time")
            End If
            If Not IsNull(.Fields("TextHeight")) Then                    '文本框高度
                Textint(text_indexte, 10) = .Fields("TextHeight")
            End If
            If Not IsNull(.Fields("TextWidth")) Then                     '文本框宽度
                Textint(text_indexte, 11) = .Fields("TextWidth")
            End If
            If Not IsNull(.Fields("TextTop")) Then                       '文本框距离顶端高度
                Textint(text_indexte, 12) = .Fields("TextTop")
            End If
            If Not IsNull(.Fields("TextLeft")) Then                      '文本框左端距离
                Textint(text_indexte, 13) = .Fields("TextLeft")
            End If
            If Not IsNull(.Fields("TabIndex")) Then                      '文本框焦点顺序
                Textint(text_indexte, 14) = .Fields("TabIndex")
            End If
         
            Textstr(text_indexte, 1) = Trim(.Fields("text_index") & "")       '文本框对应索引值
            Textstr(text_indexte, 2) = Trim(.Fields("text_field_code") & "")  '文本框对应编码字段
            Textstr(text_indexte, 3) = Trim(.Fields("text_field_name") & "")  '文本框对应名称字段
            Textstr(text_indexte, 4) = Trim(.Fields("help_code") & "")        '通用帮助编码
            Textstr(text_indexte, 5) = Trim(.Fields("judge_base") & "")       '字段有效性判断依据
            Textstr(text_indexte, 6) = Trim(.Fields("error_message") & "")    '字段录入错误提示信息
            Textstr(text_indexte, 7) = Trim(.Fields("text_name") & "")        '文本框名称
               
            .MoveNext
        Loop
    End With
End Sub
Public Function Mmjm(Srmm As String) As String                                              '密码加密对照模块
   
    Dim Zfcte As Integer
    Mmjm = ""
    For Jsqte = 1 To Len(Srmm)
        Zfcte = Asc(Mid(Srmm, Jsqte, 1)) + Asc(Mid(Srmm, Len(Srmm) - Jsqte + 1, 1)) + Len(Srmm) + Jsqte
        Mmjm = Mmjm + Trim(Str(Zfcte))
    Next Jsqte
End Function
Public Sub F1bz()                                                                           '发送F1键
    SendKeys "{F1}"
End Sub
Public Sub Textyx(Textte As TextBox)                                                        '文本框有效
    
    Textte.Enabled = True
    Textte.BackColor = &H80000005
End Sub
Public Sub Textwx(Textte As TextBox)                                                        '文本框无效
   
    Textte.Enabled = False
    Textte.BackColor = &HC0C0C0
End Sub
Public Sub Drbmhelp(bzlx As Integer, Helpbm As String, Scdwnr As String)                    '调入编码参照窗体
    
    '函数参数:帮助类型(0-通用型 1-日期型 2-特殊型),帮助编码,首次定位内容
    Dim XT_TybmczFrmte As New XT_TybmczFrm
    
    On Error GoTo ErrHandle
    Xtcdcs = Scdwnr
    Xtfhcs = ""
    Xtfhcsfz = ""
    Select Case bzlx
        Case 0
            Xtbmczdm = Trim(Helpbm)
            XT_TybmczFrmte.Show 1
            Xtbmczdm = ""
        Case 1
            XT_calendar.Show 1
        Case 2
            Select Case Helpbm
            
            End Select
    End Select
    
ErrHandle:
End Sub
Public Sub Drbmbj(Helpbm As String)                                                         '调入编码参照编辑窗体
    
    Select Case Helpbm
        'Case "gy_dept"             '部门编辑
        'JC_BmszFrm.Show 1
   End Select
End Sub
'===================以下为固定项列表框处理函数========================'
Public Function FillCombo(Combote As ComboBox, Lbkbmte As String, Dwnr As String, AddType As Integer) As String   '填充列表框并定位
    '函数参数：列表框，列表框分组编码，定位内容,填充类型(0-无空记录  1-有空记录(1个空格) )
    Dim Lbknrrec As ADODB.Recordset
  
    '填充列表框内容
    Set Lbknrrec = Cw_DataEnvi.DataConnect.Execute("select * from xt_combolist where combo_code='" + Trim(Lbkbmte) + "' order by item_index")
    Combote.Clear
    If AddType = 1 Then
        Combote.AddItem " "
    End If
    With Lbknrrec
        Do While Not .EOF
            Combote.AddItem Trim(.Fields("item_content"))
            .MoveNext
        Loop
    End With
    
    '定位列表框内容
    With Combote
        For Jsqte = .ListCount - 1 To 0 Step -1
            If Dwnr = Trim(.List(Jsqte)) Then
                Exit For
            End If
        Next Jsqte
        If Jsqte <> -1 Then
            Combote.Text = .List(Jsqte)
        Else
            If .ListCount <> 0 Then
                .Text = .List(0)
            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
                    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) & "'")
            
        If Mid(aDo_userGroup!AuthorityID, aDo_gnbm!Id, 1) = "1" Then
            Security_Log = True
        Else
            Security_Log = False
        End If
        aDo_userGroup.Close
        Set aDo_userGroup = Nothing
        
        If Security_Log = False Then
            Set aDo_userGroup = Cw_DataEnvi.DataConnect.Execute("select * from System_UserGroupInfo a ,System_UserGroup b where a.groupid=b.groupid and a.userid='" & Trim(UserCode) & "'")
            Do While Not aDo_userGroup.EOF
                If Mid(aDo_userGroup!AuthorityID, aDo_gnbm!Id, 1) = "1" Then
                    Security_Log = True
                    Exit Do
                Else
                    Security_Log = False
                End If
                aDo_userGroup.MoveNext
            Loop
            aDo_userGroup.Close
            Set aDo_userGroup = Nothing
        End If
        If Security_Log = False Then
           If Msg = True Then
                Tsxx = "没有权限,请与管理员联系!   "
                Call Xtxxts(Tsxx, 0, 4)
           End If
        End If
    End If
    '------------------------------------
    If (LogTF = 1 And Security_Log = True) Or LogTF = 2 Then
        If State = True Then
            Ssql = "insert into System_Log(GeginDate,userid,WorkstationName,WorkList,SystemName,NetUserName,State)" _
                & " values(getdate(),'" & UserCode & "','" & MachineName & "','" & Trim("" & aDo_gnbm!gnms) & "','" & "质量系统" & "','" & NTDomainUserName & "','进入')"
        Else
            Ssql = "insert into System_Log(GeginDate,userid,WorkstationName,WorkList,SystemName,NetUserName,State)" _
                & " values(getdate(),'" & UserCode & "','" & MachineName & "','" & Trim("" & aDo_gnbm!gnms) & "','" & "质量系统" & "','" & NTDomainUserName & "','完成')"
        End If
        Cw_DataEnvi.DataConnect.Execute Ssql
    End If
    aDo_gnbm.Close
    Set aDo_gnbm = Nothing
    
End Function
Public Function MachineName() As String                                         '取得当前工作站名
    
    Dim sBuffer As String * 255
    If GetComputerName(sBuffer, 255&) <> 0 Then
        MachineName = Left$(sBuffer, InStr(sBuffer, vbNullChar) - 1)
    Else
        MachineName = "(未知)"
    End If
End Function
Public Function NTDomainUserName() As String                                    '取得当前网络用户名
    
    Dim strBuffer As String * 255
    Dim lngBufferLength As Long
    Dim lngRet As Long
    Dim strTemp As String
    lngBufferLength = 255
    lngRet = GetUserName(strBuffer, lngBufferLength)
    strTemp = UCase(Trim$(strBuffer))
    NTDomainUserName = Left$(strTemp, lngBufferLength - 1)
End Function
Public Function GetPY(a1 As String) As String                                   '返回拼音码字符串
    
    '输入参数:a1 输入字符串
    Dim Jsqte As Long
    Dim t1 As String
    GetPY = ""
    If Len(Trim(a1)) = 0 Then
        Exit Function
    End If
    For Jsqte = 1 To Len(Trim(a1))
        t1 = Mid(a1, Jsqte, 1)
        If Asc(t1) < 0 Then
            If Asc(t1) < Asc("啊") Then
                GetPY = GetPY + t1
                GoTo L1
            End If
            If Asc(t1) >= Asc("啊") And Asc(t1) < Asc("芭") Then
                GetPY = GetPY + "A"
                GoTo L1
            End If
            If Asc(t1) >= Asc("芭") And Asc(t1) < Asc("擦") Then
                GetPY = GetPY + "B"
                GoTo L1
            End If
            If Asc(t1) >= Asc("擦") And Asc(t1) < Asc("搭") Then
                GetPY = GetPY + "C"
                GoTo L1
            End If
            If Asc(t1) >= Asc("搭") And Asc(t1) < Asc("蛾") Then
                GetPY = GetPY + "D"
                GoTo L1
            End If
            If Asc(t1) >= Asc("蛾") And Asc(t1) < Asc("发") Then
                GetPY = GetPY + "E"
                GoTo L1
            End If
            If Asc(t1) >= Asc("发") And Asc(t1) < Asc("噶") Then
                GetPY = GetPY + "F"
                GoTo L1
            End If
            If Asc(t1) >= Asc("噶") And Asc(t1) < Asc("哈") Then
                GetPY = GetPY + "G"
                GoTo L1
            End If
            If Asc(t1) >= Asc("哈") And Asc(t1) < Asc("击") Then
                GetPY = GetPY + "H"
                GoTo L1
            End If
            If Asc(t1) >= Asc("击") And Asc(t1) < Asc("喀") Then
                GetPY = GetPY + "J"
                GoTo L1
            End If
            If Asc(t1) >= Asc("喀") And Asc(t1) < Asc("垃") Then
                GetPY = GetPY + "K"
                GoTo L1
            End If
            If Asc(t1) >= Asc("垃") And Asc(t1) < Asc("妈") Then
                GetPY = GetPY + "L"
                GoTo L1
            End If
            If Asc(t1) >= Asc("妈") And Asc(t1) < Asc("拿") Then
                GetPY = GetPY + "M"
                GoTo L1
            End If
            If Asc(t1) >= Asc("拿") And Asc(t1) < Asc("哦") Then
                GetPY = GetPY + "N"
                GoTo L1
            End If
            If Asc(t1) >= Asc("哦") And Asc(t1) < Asc("啪") Then
                GetPY = GetPY + "O"
                GoTo L1
            End If
            If Asc(t1) >= Asc("啪") And Asc(t1) < Asc("期") Then
                GetPY = GetPY + "P"
                GoTo L1
            End If
            If Asc(t1) >= Asc("期") And Asc(t1) < Asc("然") Then
                GetPY = GetPY + "Q"
                GoTo L1
            End If
            If Asc(t1) >= Asc("然") And Asc(t1) < Asc("撒") Then
                GetPY = GetPY + "R"
                GoTo L1
            End If
            If Asc(t1) >= Asc("撒") And Asc(t1) < Asc("塌") Then
                GetPY = GetPY + "S"
                GoTo L1
            End If
            If Asc(t1) >= Asc("塌") And Asc(t1) < Asc("挖") Then
                GetPY = GetPY + "T"
                GoTo L1
            End If
            If Asc(t1) >= Asc("挖") And Asc(t1) < Asc("昔") Then
                GetPY = GetPY + "W"
                GoTo L1
            End If
            If Asc(t1) >= Asc("昔") And Asc(t1) < Asc("压") Then
                GetPY = GetPY + "X"
                GoTo L1
            End If
            If Asc(t1) >= Asc("压") And Asc(t1) < Asc("匝") Then
                GetPY = GetPY + "Y"
                GoTo L1
            End If
            If Asc(t1) >= Asc("匝") Then
                GetPY = GetPY + "Z"
                GoTo L1
            End If
        Else
            If UCase(t1) <= "Z" And UCase(t1) >= "A" Then
                GetPY = GetPY + UCase(t1)
            Else
                GetPY = t1
            End If
        End If
L1:
    Next Jsqte
End Function
'<<<<<<<<<<<<<<<<<<<<<
Public Function Item_Info()  '项目查询连接
    
    Dim aDo_Item As New Recordset
    Dim Ssql As String
    Set aDo_Item = Cw_DataEnvi.DataConnect.Execute("select * from DEV_item")
    
    With aDo_Item
        Do While Not .EOF
            If !yncode = 1 And Trim(aDo_Item!TableName) = "CorrelationList" Then
                If !YNRoot = 1 Then
                    Ssql = Ssql & ",N_" & !ItemFieldName & "=(select ListName from DEV_CorrelationList c where convert(varchar(18),c.ListCode)=b." & !ItemFieldName & ")"
                Else
                    Ssql = Ssql & ",N_" & !ItemFieldName & "=(select ListName from DEV_CorrelationList c where convert(varchar(18),c.ListCode)=a." & !ItemFieldName & ")"
                End If
                '-----------------
            Else
                If !yncode = 1 Then
                    If !YNRoot = 1 Then
                        Ssql = Ssql & ",N_" & !ItemFieldName & "=(select " & aDo_Item!CloumnName2 & " from " & aDo_Item!TableName & " c where c." & aDo_Item!CloumnName1 & "=b." & !ItemFieldName & ")"
                    Else
                        Ssql = Ssql & ",N_" & !ItemFieldName & "=(select " & aDo_Item!CloumnName2 & " from " & aDo_Item!TableName & " c where c." & aDo_Item!CloumnName1 & "=a." & !ItemFieldName & ")"
                    End If
                End If
            End If
            .MoveNext
        Loop
        Ssql = "select b.dcode,b.tcode,b.lcode,b.dname,b.manage,b.dxh,b.mader,b.zflag,b.mlevel,b.pdate,b.state,b.dno,b.conno,a.*,N_Lcode=(select isname from DEV_ItemSort c where convert(varchar(18),c.isid)=b.lcode)" & Ssql & " FROM DEV_RootInfo a,DEV_main b"
    End With
    Item_Info = Ssql
End Function
'====================单据编号格式化==============
Public Function BillCodeFormat(BillCode As String, Code As String) As String
    BillCode = Trim(BillCode): Code = Trim(Code)
    Dim Profix  As String       '前缀
    Dim Glida As Integer        '流水方式
    Dim CodeLen As Integer      '代码长度
    Dim aDo_re As New Recordset
    Set aDo_re = Cw_DataEnvi.DataConnect.Execute("select * from Gy_BillNumber where BillCode='" & Trim(BillCode) & "'")
    If aDo_re.RecordCount > 0 Then
        Profix = aDo_re!Profix
        Glida = aDo_re!Glida
        CodeLen = aDo_re!CodeLen
    Else
        BillCodeFormat = "": Exit Function
    End If
    aDo_re.Close
    If Len(Code) >= Len(Profix) + CodeLen Then BillCodeFormat = Code: Exit Function
    If Glida = 0 Then
       If Len(Code) >= Len(Profix) Then
          If Profix <> Mid(Code, 1, Len(Profix)) Then
             BillCodeFormat = Profix & String(CodeLen - Len(Code), "0") & Code
          Else
             If Len(Code) = Len(Profix) Then BillCodeFormat = Code: Exit Function
             BillCodeFormat = Profix & String(CodeLen - Len(Code), "0") & Mid(Code, Len(Profix) + 1, Len(Code))
          End If
       Else
          BillCodeFormat = Profix & String(CodeLen - Len(Code), "0") & Code: Exit Function
       End If
    Else
       If Len(Code) >= Len(Profix) Then
          If Profix <> Mid(Code, 1, Len(Profix)) Then
               BillCodeFormat = Profix & Code
             Else
               BillCodeFormat = Code
          End If
       End If
    End If
End Function
'====================单据ID处理==================
Public Function CreatBillID(BillCode As String) As Integer
    '参数说明： BillCode 单据编码
    Dim BillType As String
    Dim aDo_re As New Recordset
    Set aDo_re = Cw_DataEnvi.DataConnect.Execute("select * from Gy_BillNumber where BillCode='" & Trim(BillCode) & "'")
    If aDo_re.RecordCount > 0 Then
        CreatBillID = aDo_re!IDNow
        BillType = aDo_re!BillType
    End If
    aDo_re.Close
    Cw_DataEnvi.DataConnect.Execute "update  Gy_BillNumber set IDNow=IDNow+1 where BillType='" & Trim(BillType) & "'"
End Function
'====================单据编码处理==================
Public Function CreatBillCode(BillCode As String, Optional Add As Boolean = False, Optional KjYear As Integer, Optional Period As Integer, Optional WhCode As String) As String
    '参数说明： BillCode 单据编码，KjYear 会计年度，Period 会计期间，WhCode 仓库编码,Add 编号是累加(True 加，False,否)
    Dim BillCodeMode As Integer '编码方式
    Dim Profix  As String       '前缀
    Dim Glida As Integer        '流水方式
    Dim CodeLen As Integer      '代码长度
    Dim aDo_re As New Recordset
    Set aDo_re = Cw_DataEnvi.DataConnect.Execute("select * from Gy_BillNumber where BillCode='" & Trim(BillCode) & "'")
    With aDo_re
        If .RecordCount > 0 Then
            BillCodeMode = !BillCodeMode
            Profix = !Profix
            Glida = !Glida
            CodeLen = !CodeLen
            .Close
        Else
            Exit Function
        End If
    End With
    
    Select Case BillCodeMode
           Case 0 '单据方式
              '=============
              Select Case Glida
                     Case 0
                          Set aDo_re = Cw_DataEnvi.DataConnect.Execute("select * from Gy_Maxnum where BillCode='" & Trim(BillCode) & "'")
                          If aDo_re.RecordCount < 1 Then '当编号记录没有时
                              Cw_DataEnvi.DataConnect.Execute "insert into Gy_Maxnum(BillCode,NowNumber) VALUES ('" & Trim(BillCode) & "',1)"
                              CreatBillCode = Trim(Profix) & String(CodeLen - 1, "0") & 1
                          Else
                              CreatBillCode = Trim(Profix) & String(CodeLen - Len(aDo_re!NowNumBer), "0") & aDo_re!NowNumBer
                          End If
                          If Add = True Then
                              Cw_DataEnvi.DataConnect.Execute "update Gy_Maxnum set NowNumBer=NowNumBer+1  where BillCode='" & Trim(BillCode) & "'"
                          End If
                          Exit Function
                     Case 1
                          Set aDo_re = Cw_DataEnvi.DataConnect.Execute("select * from Gy_Maxnum where BillCode='" & Trim(BillCode) & "' and KjYear= " & KjYear)
                          If aDo_re.RecordCount < 1 Then '当前年记录没有时
                              Cw_DataEnvi.DataConnect.Execute "insert into Gy_Maxnum(BillCode,Kjyear,NowNumber) VALUES ('" & Trim(BillCode) & "'," & KjYear & ",1)"
                              CreatBillCode = Trim(Profix) & KjYear & String(CodeLen - 1 - Len(Trim(Str(KjYear))), "0") & "1"
                          Else
                              CreatBillCode = Trim(Profix) & KjYear & String(CodeLen - Len(aDo_re!NowNumBer) - Len(Trim(Str(KjYear))), "0") & aDo_re!NowNumBer
                          End If
                          If Add = True Then
                              Cw_DataEnvi.DataConnect.Execute "update Gy_Maxnum set NowNumBer=NowNumBer+1 where BillCode='" & Trim(BillCode) & "' and KjYear= " & KjYear
                          End If
                          Exit Function
                     Case 2
                          Set aDo_re = Cw_DataEnvi.DataConnect.Execute("select * from Gy_Maxnum where BillCode='" & Trim(BillCode) & "' and KjYear= " & KjYear & " and Period=" & Period)
                          If aDo_re.RecordCount < 1 Then '当前年当前期间记录没有时
                              Cw_DataEnvi.DataConnect.Execute "insert into Gy_Maxnum(BillCode,Kjyear,Period,NowNumber) VALUES ('" & Trim(BillCode) & "'," & KjYear & "," & Period & ",1)"
                              CreatBillCode = Trim(Profix) & KjYear & String(2 - Len(Trim(Str(Period))), "0") & Period & String(CodeLen - 1 - Len(Trim(Str(KjYear))) - 2, "0") & "1"
                          Else
                              CreatBillCode = Trim(Profix) & KjYear & String(2 - Len(Trim(Str(Period))), "0") & Period & String(CodeLen - Len(aDo_re!NowNumBer) - Len(Trim(Str(KjYear))) - 2, "0") & aDo_re!NowNumBer
                          End If
                          If Add = True Then
                              Cw_DataEnvi.DataConnect.Execute "update Gy_Maxnum set NowNumBer=NowNumBer+1 where BillCode='" & Trim(BillCode) & "' and KjYear= " & KjYear & " and Period=" & Period
                          End If
                          Exit Function
              End Select
              '==============
          Case 1 '单据+仓库方式
          
              '=============
              Select Case Glida
                     Case 0
                          Set aDo_re = Cw_DataEnvi.DataConnect.Execute("select * from Gy_Maxnum where BillCode='" & Trim(BillCode) & "' and WhCode='" & Trim(WhCode) & "'")
                          If aDo_re.RecordCount < 1 Then '当编号记录没有时
                              Cw_DataEnvi.DataConnect.Execute "insert into Gy_Maxnum(BillCode,WhCode ,NowNumber) VALUES ('" & Trim(BillCode) & "','" & Trim(WhCode) & "',1)"
                              CreatBillCode = Trim(Profix) & Trim(WhCode) & String(CodeLen - 1 - Len(Trim(WhCode)), "0") & 1
                          Else
                              CreatBillCode = Trim(Profix) & Trim(WhCode) & String(CodeLen - Len(aDo_re!NowNumBer) - Len(Trim(WhCode)), "0") & aDo_re!NowNumBer
                          End If
                          If Add = True Then
                              Cw_DataEnvi.DataConnect.Execute "update Gy_Maxnum set NowNumBer=NowNumBer+1 where BillCode='" & Trim(BillCode) & "' and WhCode='" & Trim(WhCode) & "'"
                          End If
                          Exit Function
                     Case 1
                          Set aDo_re = Cw_DataEnvi.DataConnect.Execute("select * from Gy_Maxnum where BillCode='" & Trim(BillCode) & "' and KjYear= " & KjYear & " and WhCode='" & Trim(WhCode) & "'")
                          If aDo_re.RecordCount < 1 Then '当前年记录没有时
                              Cw_DataEnvi.DataConnect.Execute "insert into Gy_Maxnum(BillCode,Kjyear,WhCode,NowNumber) VALUES ('" & Trim(BillCode) & "'," & KjYear & ",'" & Trim(WhCode) & "',1)"
                              CreatBillCode = Trim(Profix) & Trim(WhCode) & KjYear & String(CodeLen - 1 - Len(Trim(Str(KjYear))) - Len(Trim(WhCode)), "0") & "1"
                          Else
                              CreatBillCode = Trim(Profix) & Trim(WhCode) & KjYear & String(CodeLen - Len(aDo_re!NowNumBer) - Len(Trim(Str(KjYear))) - Len(Trim(WhCode)), "0") & aDo_re!NowNumBer
                          End If
                          If Add = True Then
                              Cw_DataEnvi.DataConnect.Execute "update Gy_Maxnum set NowNumBer=NowNumBer+1 where BillCode='" & Trim(BillCode) & "' and KjYear= " & KjYear & " and WhCode='" & Trim(WhCode) & "'"
                          End If
                          Exit Function
                     Case 2
                          Set aDo_re = Cw_DataEnvi.DataConnect.Execute("select * from Gy_Maxnum where BillCode='" & Trim(BillCode) & "' and KjYear= " & KjYear & " and Period=" & Period & " and WhCode='" & Trim(WhCode) & "'")
                          If aDo_re.RecordCount < 1 Then '当前年当前期间记录没有时
                              Cw_DataEnvi.DataConnect.Execute "insert into Gy_Maxnum(BillCode,Kjyear,Period,WhCode,NowNumber) VALUES ('" & Trim(BillCode) & "'," & KjYear & "," & Period & ",'" & Trim(WhCode) & "',1)"
                              CreatBillCode = Trim(Profix) & Trim(WhCode) & KjYear & String(2 - Len(Trim(Str(Period))), "0") & Period & String(CodeLen - 1 - Len(Trim(Str(KjYear))) - 2 - Len(Trim(WhCode)), "0") & "1"
                          Else
                              CreatBillCode = Trim(Profix) & Trim(WhCode) & KjYear & String(2 - Len(Trim(Str(Period))), "0") & Period & String(CodeLen - Len(aDo_re!NowNumBer) - Len(Trim(Str(KjYear))) - 2 - Len(Trim(WhCode)), "0") & aDo_re!NowNumBer
                          End If
                          If Add = True Then
                              Cw_DataEnvi.DataConnect.Execute "update Gy_Maxnum set NowNumBer=NowNumBer+1 where BillCode='" & Trim(BillCode) & "' and KjYear= " & KjYear & " and Period=" & Period & " and WhCode='" & Trim(WhCode) & "'"
                          End If
                          Exit Function
              End Select
              '==============
          
    End Select
End Function
'图形分析
Public Sub Txfxbb(CxbbGrid As vsFlexGrid, ChartCode As String, ParamArray charttype())               '图形分析模块
  '过程参数为:分析网格,图形代码,脚标,分析项目数,分析网格起始行值,分析网格终止行值
  On Error Resume Next
  
  Dim aDo_Char As New Recordset
  Dim Jsqte As Integer
  Dim i As Integer: Dim r As Integer
  Dim h As Integer: Dim s As Integer: h = 0: s = 0
  '---------------------
  Set aDo_Char = Cw_DataEnvi.DataConnect.Execute("select * from XT_GridChart where Chart_Code='" & ChartCode & "'")
  If aDo_Char.RecordCount = 0 Then MsgBox "图形基础设置错误！ ", 16: Exit Sub
    '-----------------------------
  If CxbbGrid.Rows - aDo_Char!grid_Fixedrows < 1 Then
     Exit Sub
  End If
  '---------------------
  XT_TxItem.ChartCode = ChartCode
  Set XT_TxItem.Grid = CxbbGrid
  XT_TxItem.Tag = "F"
  XT_TxItem.Show 1
  If XT_TxItem.Tag <> "T" Then Exit Sub
 
  '---------------------
  With XT_TxfxFrm.Txfxchart
    .Header.Text.Clear
    .Header.Text.Add aDo_Char!Chart_Titlete
    .Footer.Text.Clear
    .RemoveAllSeries
    .Aspect.View3d = False
    
  If XT_TxItem.Check1.Value = 0 Then   '横标统计
            '<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
            For r = 0 To XT_TxItem.Item(0).ListCount - 1
               If XT_TxItem.Item(0).Selected(r) = True Then
               '---------------
                      If UBound(charttype()) > 1 Then '显示的图形类型
                         Select Case charttype(1)
                               Case 1: .AddSeries scBar
                               Case 2: .AddSeries scLine: Case 3: .AddSeries scArea
                               Case 4: .AddSeries scHorizBar: Case 5: .AddSeries scPoint
                               Case 6: .AddSeries scFastLine: Case 7: .AddSeries scFastLine
                         End Select
                      Else
                        .AddSeries scBar
                      End If
                      '------------------'读取数据
                      .Series(s).Marks.Style = smsValue
                      XT_TxItem.Item(0).ListIndex = r: .Series(s).Title = XT_TxItem.Item(0).Text
                      For Jsqte = aDo_Char!grid_Fixedrows To Val(CxbbGrid.Rows - 1)
                         If XT_TxItem.Item(1).Selected(Jsqte - aDo_Char!grid_Fixedrows) = True Then
                          .Series(s).ValueFormat = "#,##0.####"
                          .Series(s).Add Val(CxbbGrid.TextMatrix(Jsqte, XT_TxItem.Item(0).ItemData(r))), CxbbGrid.TextMatrix(Jsqte, aDo_Char!grid_FixedCols - 1), clTeeColor
                          If XT_TxItem.Check2.Value = 0 Then
                            .Series(s).Marks.Visible = False
                          End If
                         End If
                      Next Jsqte
                      s = s + 1
                '---------------
                End If
            Next r
          '<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
    Else
          '竖表统计
          '<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
               For r = 0 To XT_TxItem.Item(1).ListCount - 1
               If XT_TxItem.Item(1).Selected(r) = True Then
               '---------------
                      If UBound(charttype()) > 1 Then '显示的图形类型
                         Select Case charttype(1)
                               Case 1: .AddSeries scBar
                               Case 2: .AddSeries scLine: Case 3: .AddSeries scArea
                               Case 4: .AddSeries scHorizBar: Case 5: .AddSeries scPoint
                               Case 6: .AddSeries scFastLine: Case 7: .AddSeries scFastLine
                         End Select
                      Else
                        .AddSeries scBar
                      End If
                      '------------------'读取数据
                      .Series(s).Marks.Style = smsValue
                      .Series(s).Title = CxbbGrid.TextMatrix(r + aDo_Char!grid_Fixedrows, aDo_Char!grid_FixedCols - 1)
                
                      For Jsqte = aDo_Char!grid_FixedCols To CxbbGrid.Cols - 1
                          If XT_TxItem.Item(0).Selected(Jsqte - aDo_Char!grid_FixedCols) = True Then
                             .Series(s).ValueFormat = "#,##0.####"
                             .Series(s).Add Val(CxbbGrid.TextMatrix(XT_TxItem.Item(1).ItemData(r), Jsqte)), CxbbGrid.TextMatrix(aDo_Char!grid_Fixedrows - 1, Jsqte), clTeeColor
                             If XT_TxItem.Check2.Value = 0 Then
                               .Series(s).Marks.Visible = False
                             End If
                          End If
                      Next Jsqte
                      s = s + 1
                '---------------
                End If
            Next r
            '<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
          
    End If
    
    
  End With
  '
  XT_TxfxFrm.Txcode = ChartCode
  Set XT_TxfxFrm.bbGrid = CxbbGrid
  XT_TxfxFrm.Hide
  XT_TxfxFrm.Show 1
  
End Sub

						