modstartbase.bas

ERP管理系统源代码erp 管理系统源代码

Attribute VB_Name = "modStartBase"
Option Explicit

Public Const g_strREG_SERVER_KEY = "SOFTWARE\Shanghai YiXing Tech. Ltd. Co. \CyCRM\1.21\Server"
Public Const g_strREG_MSSQL_SETUP_KEY = "SOFTWARE\Microsoft\MSSQLServer\Setup"

'''''''''''''''''''''''''''''''''''''''''''''''''''
' 错误信息
Dim m_tagErrInfo As TYPE_ERRORINFO

Private Type BROWSEINFO
    hOwner As Long
    pidlRoot As Long
    pszDisplayName As String
    lpszTitle As String
    ulFlags As Long
    lpfn As Long
    lParam As Long
    iImage As Long
End Type

Public g_strLoginEmpCode As String          '登陆者的员工编号
Public g_intLoginDeptType As Integer        '登陆者的部门类型，当为“系统管理员”时 = -1
'***********************************************************************************
Dim m_strUserName As String
Dim m_strComputerName As String

Public bolDBStatus As Boolean
Public dbMyDB As ADODB.Connection
Public dbShapeDB As ADODB.Connection

Public Const GW_CHILD As Long = 5&
Public Const GW_HWNDNEXT As Long = 2&

Private Const BIF_RETURNONLYFSDIRS = &H1
Private Const BIF_DONTGOBELOWDOMAIN = &H2
Private Const BIF_STATUSTEXT = &H4
Private Const BIF_RETURNFSANCESTORS = &H8
Private Const BIF_BROWSEFORCOMPUTER = &H1000
Private Const BIF_BROWSEFORPRINTER = &H2000

Public Declare Function GetComputerName Lib "kernel32" Alias _
                "GetComputerNameA" (ByVal lpbuffer As String, ByRef nSize As Long) As Long

Public Declare Function SHBrowseForFolder Lib "shell32.dll" Alias _
                "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Public Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias _
                "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Public Declare Function GetWindow& Lib "user32" (ByVal hwnd&, ByVal wCmd&)
Public Declare Function GetDesktopWindow& Lib "user32" ()
Public Declare Function GetWindowText& Lib "user32" Alias "GetWindowTextA" _
                                    (ByVal hwnd&, ByVal lpString$, ByVal cch&)
Public Declare Function ShowWindow& Lib "user32" (ByVal hwnd&, ByVal nCmdShow&)
Public Declare Function GetPrivateProfileString Lib "kernel32" Alias _
                        "GetPrivateProfileStringA" (ByVal lpApplicationName _
                        As String, ByVal lpKeyName As Any, ByVal lpDefault _
                        As String, ByVal lpReturnedString As String, ByVal _
                        nSize As Long, ByVal lpFileName As String) As Long
Public Declare Function WritePrivateProfileString Lib "kernel32" Alias _
                        "WritePrivateProfileStringA" (ByVal lpApplicationName _
                        As String, ByVal lpKeyName As Any, ByVal lpString As Any, _
                        ByVal lpFileName As String) As Long
Public Declare Function SetForegroundWindow Lib "User32.lib" Alias "SetForegroundWindowA" (ByVal hAppWindow&) As Boolean

Public Sub main()
    On Error GoTo ERROR_EXIT
    Dim strUserName$, strUserPassword$, strUserDatabase$, strUserDatasource$
    Dim sNextFile As String, Leng As Integer, i As Integer
    Dim r As clsRegistry, Subkey As String, sINIFile As String
    
    m_strUserName = "Tony"

    Set r = New clsRegistry
    
    Subkey = "SOFTWARE\Shanghai YiXing Tech. Ltd. Co. \KF_ERP\1.21\Client"
    sNextFile = r.GetValue(eHKEY_LOCAL_MACHINE, Subkey, "Path")
    sNextFile = RemoveNullChar(sNextFile)
    If sNextFile = "" Then
        sINIFile = App.Path & "\KF_ERP.INI"
        SetErrorLogFile App.Path
    Else
        AddDirSep sNextFile
        sINIFile = sNextFile & "KF_ERP.INI"
        Dim strLogFile As String, dFileLen As Double
        strLogFile = r.GetValue(eHKEY_LOCAL_MACHINE, Subkey, "Logfile")
        dFileLen = CDbl(r.GetValue(eHKEY_LOCAL_MACHINE, Subkey, "Logsize"))
        If strLogFile = "" Then
            SetErrorLogFile sNextFile
        Else
            SetErrorLogFile sNextFile, strLogFile, dFileLen / 1024
        End If
    End If
    Leng = CInt(sGetINI(sINIFile, "User", "Count", 0))
    If Leng = 0 Then GoTo ERROR_EXIT

    For i = 1 To Leng
        strUserDatabase = sGetINI(sINIFile, "Settings", "DBName" & i, "?")
        strUserDatasource = sGetINI(sINIFile, "Settings", "DBSource" & i, "?")
        strUserName = sGetINI(sINIFile, "Settings", "DBLogin" & i, "sa")
        strUserPassword = sGetINI(sINIFile, "Settings", "DBPassword" & i, "")
    Next i
    
    '保存数据库连接信息
    dbDataConnectSet strUserName, strUserPassword, strUserDatabase, strUserDatasource
    If Not OpenDB() Then GoTo ERROR_EXIT
    If Not InitBaseUseInfo() Then GoTo ERROR_EXIT
    frmLogin.Show
    
    Exit Sub
ERROR_EXIT:
    m_tagErrInfo.strErrDate = Format(Now, "yyyy-mm-dd hh:mm:ss")
    m_tagErrInfo.strErrFile = "modStartBase"
    m_tagErrInfo.strErrFunc = "Main"
    m_tagErrInfo.nErrNum = Err.Number
    m_tagErrInfo.strErrDesc = Error(Err.Number) & "主窗体启动函数。"
    If Err.Number <> 0 Then Err.Clear
    modErrorInfo.WriteErrLog m_tagErrInfo
End Sub

Public Function sGetINI(sINIFile As String, sSection As String, sKey _
                        As String, sDefault As String)
    On Error GoTo ERROR_EXIT
    Dim sTemp As String * 256
    Dim nLength As Integer
    
    sTemp = Space$(256)
    nLength = GetPrivateProfileString(sSection, sKey, sDefault, sTemp, _
            255, sINIFile)
    sGetINI = Left$(sTemp, nLength)
    Exit Function
ERROR_EXIT:
    m_tagErrInfo.strErrDate = Format(Now, "yyyy-mm-dd hh:mm:ss")
    m_tagErrInfo.strErrFile = "modStartup"
    m_tagErrInfo.strErrFunc = "sGetINI"
    m_tagErrInfo.nErrNum = Err.Number
    m_tagErrInfo.strErrDesc = Error(Err.Number) & "读INI文件失败。"
    If Err.Number <> 0 Then Err.Clear
    modErrorInfo.WriteErrLog m_tagErrInfo
    
    sGetINI = ""
End Function

Public Function sWriteINI(sINIFile As String, sSection As String, sKey _
                As String, sValue As String)
    On Error GoTo ERROR_EXIT
    Dim n As Integer
    Dim sTemp As String
    
    sTemp = sValue
     'Replace any CR/LF characters with spaces
    For n = 1 To Len(sValue)
        If Mid$(sValue, n, 1) = vbCr Or Mid$(sValue, n, 1) = vbLf _
        Then Mid$(sValue, n) = ""
    Next n
    
    n = WritePrivateProfileString(sSection, sKey, sTemp, sINIFile)
    Exit Function
ERROR_EXIT:
    m_tagErrInfo.strErrDate = Format(Now, "yyyy-mm-dd hh:mm:ss")
    m_tagErrInfo.strErrFile = "modStartup"
    m_tagErrInfo.strErrFunc = "sWriteINI"
    m_tagErrInfo.nErrNum = Err.Number
    m_tagErrInfo.strErrDesc = Error(Err.Number) & "写INI文件失败。"
    If Err.Number <> 0 Then Err.Clear
    modErrorInfo.WriteErrLog m_tagErrInfo
End Function

'***********************************************************************************************************
' 数据检查公共函数
'   1.CHECK_TextBox_String  检查‘字符串型’ TextBox 控件中的数据
'   2.CHECK_TextBox_Int     检查‘整数型’ 　TextBox 控件中的数据
'   3.CheckString           检查字符串
'   4.CheckInt              检查整数
'   5.CheckSng              检查单精度数值
' Added by Jack Xu 2001.8.1

'*************************************************
' 检查‘字符串型’ TextBox 控件中的数据是否符合要求
' 参数：
'   [IN]txtObject   As TextBox      TextBox object
'   [IN]MinLen      As Integer      最短字符长度
'   [IN]MaxLen      As Integer      最长字符长度
'   [IN]fChnAs2     As Boolean      是否一个中文算两个字符长度
' 检查条件： MinLen <= TextBox的字符串长度 <= MaxLen
Public Function CHECK_TextBox_String( _
    txtObject As TextBox, _
    Optional MinLen = 0, _
    Optional MaxLen = 10, _
    Optional fChnAs2 = False _
) As Boolean
    On Error GoTo ERROR_EXIT
    If Not IsObject(txtObject) Then
        GoTo ERROR_EXIT
    End If
    
    CHECK_TextBox_String = CheckString(CStr(Trim(txtObject.Text)), MinLen, MaxLen, fChnAs2)
    Exit Function
ERROR_EXIT:
    m_tagErrInfo.strErrDate = Format(Now, "yyyy-mm-dd hh:mm:ss")
    m_tagErrInfo.strErrFile = "modStartup"
    m_tagErrInfo.strErrFunc = "CHECK_TextBox_String"
    m_tagErrInfo.nErrNum = Err.Number
    m_tagErrInfo.strErrDesc = Error(Err.Number)
    If Err.Number <> 0 Then Err.Clear
    modErrorInfo.WriteErrLog m_tagErrInfo
    
    CHECK_TextBox_String = False
End Function

'*************************************************
' 检查‘整数型’ TextBox 控件中的数据是否符合要求
' 检查条件： Min <= TextBox的数值 <= Max
' VB 的  Long 和 SQL 的 INT 类型的取值范围为[-2147483648,2147483647]
Public Function CHECK_TextBox_Int( _
    txtObject As TextBox, _
    Optional Min = -2147483648#, _
    Optional Max = 2147483647 _
) As Boolean

    On Error GoTo ERROR_EXIT
    If Not IsObject(txtObject) Or txtObject.Text = "" Then
        GoTo ERROR_EXIT
    End If
    
    CHECK_TextBox_Int = CheckInt(CInt(Trim(txtObject.Text)), Min, Max)
    Exit Function
ERROR_EXIT:
    m_tagErrInfo.strErrDate = Format(Now, "yyyy-mm-dd hh:mm:ss")
    m_tagErrInfo.strErrFile = "modStartup"
    m_tagErrInfo.strErrFunc = "CHECK_TextBox_Int"
    m_tagErrInfo.nErrNum = Err.Number
    m_tagErrInfo.strErrDesc = Error(Err.Number)
    If Err.Number <> 0 Then Err.Clear
    modErrorInfo.WriteErrLog m_tagErrInfo
    
    CHECK_TextBox_Int = False
End Function

'**********************************************
'   3.CheckString           检查字符串
' 参数：
'   [IN]strText     As String       目标字符串
'   [IN]MinLen      As Integer      最短字符长度
'   [IN]MaxLen      As Integer      最长字符长度
'   [IN]fChnAs2     As Boolean      是否一个中文算两个字符长度
' 检查条件： MinLen <= TextBox的字符串长度 <= MaxLen
' 注意中文字占两个字长
Public Function CheckString( _
    strText As String, _
    Optional MinLen = 0, _
    Optional MaxLen = 10, _
    Optional fChnAs2 = False _
) As Boolean
    On Error GoTo ERROR_EXIT
    Dim nLen As Integer, i As Integer
    Dim ch As String
    ' 计算字长
    nLen = 0
    If fChnAs2 Then
        '一个中文字为2个字长
        For i = 1 To Len(CStr(strText))
            nLen = nLen + 1
            ch = Mid(CStr(strText), i, 1)
            If Asc(ch) > 127 Or Asc(ch) < 0 Then
                nLen = nLen + 1
            End If
        Next
    Else
        nLen = Len(CStr(strText))
    End If
    
    If nLen > CSng(MaxLen) Or nLen < CSng(MinLen) Then
        GoTo ERROR_EXIT
    End If
    
    CheckString = True
    Exit Function
ERROR_EXIT:
    m_tagErrInfo.strErrDate = Format(Now, "yyyy-mm-dd hh:mm:ss")
    m_tagErrInfo.strErrFile = "modStartup"
    m_tagErrInfo.strErrFunc = "CheckString"
    m_tagErrInfo.nErrNum = Err.Number
    m_tagErrInfo.strErrDesc = Error(Err.Number)
    If Err.Number <> 0 Then Err.Clear
    modErrorInfo.WriteErrLog m_tagErrInfo