系统_基本函数模块.bas

新世纪ERP设备管理源代码

    '思路：对于要移动的网格来说，所有的信息都保存在几个系统数组中，其中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
'    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
    Dim XT_TybmczFrmte As New XT_TybmczFrm
    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

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