mainmodule.bas

本公司开发得大请油田人事管理系统c/s结构

Attribute VB_Name = "MainModule"
Option Explicit

Public Const C_APP_NAME = "HRP     "
Public Const C_APP_PUBLISH_DATE = 20010801
'VSFLEXGRID行标志常量
Public Const C_Init = -2
Public Const C_Insert = -1
Public Const C_NoChange = 0
Public Const C_Update = 1

'delete mark
Public Const C_Organ_Have = 0
Public Const C_Organ_Delete_NoUsed = 1
Public Const C_Organ_Delete_Have_Used_Unit = 2
Public Const C_Emp_Have = 0
Public Const C_Emp_Delete_No_Used = 1
Public Const C_Emp_Delete_Have_Used_Remove = 2
Public Const C_Emp_Delete_Have_Used_Unit = 3
'emp Remove
Public Const C_SubStract_Have_InOrgan = 0
Public Const C_SubStract_No_InOrgan = 1
Public Const C_Add_Have_OutOrgan = 2
Public Const C_Add_No_OutOrgan = 3
Public Const C_Inside = 4

'非空项颜色常量
Public Const g_ForeColor4NotNullFields = vbBlue

'全局工人工种编辑数组
Public g_array4WorkerType(1 To 3, 1 To 1000) As Variant
Public g_int4statuse As Long 'when g_int4statuse = 0 : add when g_int4statuse = 1 then : edit
Public g_int4rowstate As Long '全局编辑选择变量

'全局变量
Public G_iIsRegistered As Long
Public g_bIsSave As Boolean
Public g_FSO As New FileSystemObject
Public g_Permission As String '权限全局变量
'全局报表变量
Public g_str4Report As String
Public g_strReportName As String
Public g_str4ReportOrgan As String
Public g_str4OrganEmp As String
Public g_str4CompanyEmp As String
Public g_str4TableEmp As String
Public g_str4ReportTime As String

'是否有Excel
Public g_bHaveExcel As Boolean
Public g_oApp4Export As excel.Application
Public g_oBook4Export As excel.Workbook
Public g_oSheet4Export  As excel.Worksheet

Public Const C_EMP_CARD = "人员卡片"
Public Const C_EMP_BASIC_CARD = "人员基本信息"
Public Const C_EMP_OTHER_CARD = "人员其他信息"

'运行 oConnection4This
Public Function ExcuteSQL(ByVal strSQL As String) As Long
On Error GoTo ERROR_HANDLE
    g_oConnection4This.Execute strSQL
    ExcuteSQL = 0
    Exit Function
ERROR_HANDLE:
    If left(strSQL, 6) Like "delete" Then
        MsgBox "该记录已经和其它表关联,不能删除!", vbCritical, "错误"
        ExcuteSQL = 1
    Else
        MsgBox "数据输入错误！", vbCritical, "错误"
        ExcuteSQL = 2
    End If
End Function

'功能:把数据库字符字段转化成SQL串
Public Function CSQL(ByVal vIn As Variant, Optional ByVal lDataType As Long = 1) As String
'0:数字 1：字符
    If lDataType Then
        CSQL = "'" & Trim(vIn) & "'"
    Else
        If IsNull(vIn) Or vIn = "" Or vIn = " " Then
            CSQL = "NULL"
        Else
            CSQL = "'" & vIn & "'"
        End If
    End If
End Function
' 获得名称
Public Function GetName(ByVal TableName As String, ByVal ReturnFieldName As String, ByVal FirstFieldName As String, ByVal CurrentValue As String) As String
    Dim strSQL As String
    Dim oRs4Name As New ADODB.Recordset
    strSQL = "select " & ReturnFieldName & " from " & TableName & " where " & FirstFieldName & CurrentValue
    oRs4Name.CursorLocation = adUseClient
    oRs4Name.Open strSQL, g_oConnection4This, adOpenKeyset, adLockOptimistic
    
    If oRs4Name.EOF = False Then
        GetName = oRs4Name.Fields(0).Value
    Else
        GetName = ""
    End If
    
    oRs4Name.Close
    Set oRs4Name = Nothing
End Function
'检查权限
Public Function CheckPermission(Name4CurrentForm As String) As String
    Dim strSQL As String
    Dim oRs4Permission As New ADODB.Recordset

    strSQL = "select oprrole_permission from t_permission_char_detail where oprrole_no=" & g_lOprroleNo & " and permission_char_no=(select permission_char_no from t_permission_char where permission_char_form like '" & Name4CurrentForm & "')"
    If oRs4Permission.State = adStateOpen Then oRs4Permission.Close
    oRs4Permission.CursorLocation = adUseClient
    oRs4Permission.Open strSQL, g_oConnection4This
    If oRs4Permission.EOF = False Then
        CheckPermission = oRs4Permission.Fields(0).Value
    Else
        CheckPermission = "0000000"
    End If

    oRs4Permission.Close
    Set oRs4Permission = Nothing
End Function
'检查记录
Public Function CheckVariant(ByVal vIn As Variant) As Variant
      If IsNull(vIn) Then
        CheckVariant = ""
      Else
        CheckVariant = vIn
      End If
End Function
'从recordset 的 no 得到 name
Public Function GetName4No(ByVal TableName As String, ByVal ReturnFieldName As String, ByVal strIndexName As String, ByVal CurrentNo As Variant, Optional ByVal areano As String) As String
    Dim ors4temp As New ADODB.Recordset
    Dim strSQL As String
    If TableName = "t_area" Then
        strSQL = "select " & ReturnFieldName & " from " & TableName & " where " & strIndexName & " like '" & CurrentNo & "'"
    Else
        If Trim(areano) <> "" Then
            strSQL = "select " & ReturnFieldName & " from " & TableName & " where " & strIndexName & " like " & CurrentNo & " and area_no='" & areano & "'"
        Else
            strSQL = "select " & ReturnFieldName & " from " & TableName & " where " & strIndexName & " like " & CurrentNo
        End If
    End If
    ors4temp.Open strSQL, g_oConnection4This
    
    If ors4temp.EOF = False Then
        GetName4No = ors4temp.Fields(0).Value
    Else
        GetName4No = ""
    End If
    areano = ""
    ors4temp.Close
    Set ors4temp = Nothing
End Function
'空值得到零
'1为数量,0为金额
Public Function CheckZero(ByVal TempText As Variant, Optional ByVal lDataType As Long = 1) As Double
    If Trim(TempText) = "" Or IsNull(Trim(TempText)) Or IsEmpty(TempText) Or TempText = 0 Then
        If lDataType = 1 Then
            CheckZero = "0"
        Else
            CheckZero = "0.00"
        End If
    Else
         CheckZero = TempText
    End If
End Function
'*****************************************
'
'名称:ConvertInt2Date
'功能:把整形转化成日期型
'在数据库中,日期型是以整形存储的
'
'*****************************************
Public Function ConvertInt2Date(ByVal intDate As Variant) As String
    If IsNull(intDate) Then
        ConvertInt2Date = ""
    Else
        Dim strTemp As String
        
        strTemp = Trim(CStr(intDate))
        Select Case Len(strTemp)
        Case 4
            intDate = intDate * 10000 + 101
        Case 5
            intDate = intDate * 1000 + 1
        Case 6
            intDate = intDate * 100 + 1
        Case 8
        Case Else
            ConvertInt2Date = ""
            Exit Function
        End Select
        
        If intDate Mod 10000 = 0 Then
            intDate = intDate + 101
        Else
            If intDate Mod 100 = 0 Then
                intDate = intDate + 1
            End If
        End If
        
        strTemp = CStr(intDate)
        ConvertInt2Date = Mid$(strTemp, 1, 4) & "年" & Mid$(strTemp, 5, 2) & "月" & Mid$(strTemp, 7, 2) & "日"
    End If
End Function

'*****************************************
'
'名称:ConvertDate2Int
'功能:把日期型转化成整形
'
'*****************************************
Public Function ConvertDate2Int(ByVal strDate As Variant) As Long
    If Not IsNull(strDate) Then
        If strDate <> "" Then
            ConvertDate2Int = Year(strDate) * 10000 + Month(strDate) * 100 + Day(strDate)
        End If
    End If
End Function
'************
'得到最大编号,注意传NoName时的大小写
'**************
Public Function GetMaxNo(ByVal TableName As String, ByVal NoName As String, Optional ByVal strAddPath As String = "", Optional ByVal bIsEmpRemove As Boolean = False) As Long
    Dim oRs4MaxNo As New ADODB.Recordset
    Dim strSQL As String
    If bIsEmpRemove = True Then
        strSQL = "select max(abs(" & NoName & ")) from  " & TableName & " where " & NoName & "<=-1" & strAddPath
    Else
        strSQL = "select max(" & NoName & ") from  " & TableName & " where " & NoName & ">=1 " & strAddPath
    End If
    
    If oRs4MaxNo.State = adStateOpen Then oRs4MaxNo.Close
    oRs4MaxNo.CursorLocation = adUseClient
    oRs4MaxNo.Open strSQL, g_oConnection4This
    If oRs4MaxNo.EOF = False Then
        If IsNull(oRs4MaxNo.Fields(0).Value) Then
            If bIsEmpRemove = True Then
                GetMaxNo = -1
            Else
                GetMaxNo = 1
            End If
        Else
            If bIsEmpRemove = True Then
                GetMaxNo = -(Abs(CLng(oRs4MaxNo.Fields(0).Value)) + 1)
            Else
                GetMaxNo = CLng(oRs4MaxNo.Fields(0).Value) + 1
            End If
        End If
    Else
        If bIsEmpRemove = True Then
            GetMaxNo = -1
        Else
            GetMaxNo = 1
        End If
    End If
End Function
'*********************
    '限制输入非数字型
'*********************
Public Sub CheckText(KeyAscii As Integer, Optional ByVal dCurrent As Variant, Optional ByVal iPosition As Integer, Optional bIsMoney As Boolean = False)
    If bIsMoney = True Then
        If KeyAscii = 8 Then Exit Sub
'        If Len(dCurrent) >= 14 Then
'            KeyAscii = 0
'            Exit Sub
'        End If

        If Len(dCurrent) >= 7 Then
            KeyAscii = 0
            Exit Sub
        Else
            If Trim(dCurrent) <> "" Then
                If dCurrent > 1000 And KeyAscii <> 46 And Len(dCurrent) = 4 Then KeyAscii = 0: Exit Sub
            End If
        End If
        If KeyAscii = 46 Then
            If Trim(dCurrent) = "" Then
                KeyAscii = 0
                Exit Sub
            End If
            If Fix(dCurrent) <> CDec(dCurrent) Then
                KeyAscii = 0
                Exit Sub
            ElseIf right(dCurrent, 1) = "." Then
                KeyAscii = 0
                Exit Sub
            ElseIf Len(dCurrent) - iPosition >= 3 Then
                KeyAscii = 0
                Exit Sub
            End If
        ElseIf KeyAscii = 45 Then
            If Trim(dCurrent) = "" Then Exit Sub
            If left(dCurrent, 1) = "-" Then
                KeyAscii = 0
                Exit Sub
            End If
            If iPosition <> 0 Then
                KeyAscii = 0
                Exit Sub
            End If
        ElseIf KeyAscii >= 48 And KeyAscii <= 57 Then
            If Len(dCurrent) = 1 Then
                If right(dCurrent, 1) = "0" Then
                    KeyAscii = 0
                    Exit Sub
                End If
            End If
            If Len(dCurrent) = 2 Then
                If left(dCurrent, 1) = "-" And right(dCurrent, 1) = "0" Then
                    KeyAscii = 0
                    Exit Sub
                End If
            End If
            If Len(dCurrent) >= 3 Then
                If Mid(dCurrent, Len(dCurrent) - 2, 1) = "." Then
                    If iPosition >= Len(dCurrent) - 2 Then
                        KeyAscii = 0
                        Exit Sub
                    End If
                End If
            End If
        ElseIf (KeyAscii < 48) Or (KeyAscii > 57) Then
            KeyAscii = 0