modstartup.bas

排队分诊管理系统源代码！该代码使用VB6开发环境

Attribute VB_Name = "modStartup"
Option Explicit

Public Const PauseTime = 30                     '网络连接时间 - 1秒

Dim m_tagErrInfo    As TYPE_ERRORINFO

Public m_bLogin     As Boolean                  '登录是否成功

Public m_strServer  As String                   '纪录服务器名称
Public m_iPort      As Integer                  '服务端口号

Public m_strUser    As String                   '用户工号
Public m_strOld     As String                   '用户工号明文
Public m_strPass    As String                   '用户密码

Public Const g_strREG_SERVER_KEY = "SOFTWARE\Shanghai YiXing Tech. Ltd. Co. \CyQueue\1.21\Client"

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

Public Const GCL_HCURSOR = -12

Public Declare Function ClipCursor Lib "user32" (lpRect As Any) As Long
Public Declare Function DestroyCursor Lib "user32" (ByVal hCursor As Any) As Long
Public Declare Function LoadCursorFromFile Lib "user32" Alias "LoadCursorFromFileA" _
                        (ByVal lpFileName As String) As Long
Public Declare Function SetClassLong Lib "user32" Alias "SetClassLongA" _
                        (ByVal hWnd As Long, ByVal nIndex As Long, _
                        ByVal dwNewLong As Long) As Long
Public Declare Function GetClassLong Lib "user32" Alias "GetClassLongA" _
                        (ByVal hWnd As Long, ByVal nIndex As Long) As Long

Public Declare Function GetDesktopWindow& Lib "user32" ()
Public Declare Function GetWindow& Lib "user32" (ByVal hWnd&, ByVal wCmd&)
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 SetForegroundWindow Lib "User32.lib" Alias "SetForegroundWindowA" (ByVal hAppWindow&) As Boolean
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 Sub Main()
    On Error GoTo ERROR_EXIT
    Const sBaseCaption As String = "排队系统服务端登录"
    Const sBaseCaption1 As String = "frmQueue"
    
    If App.PrevInstance = True Then
          
        Dim hAppWindow&, sTemp$
        hAppWindow = GetWindow(GetDesktopWindow(), GW_CHILD)
      
        Do
            sTemp = String$(180, False)
            Call GetWindowText(hAppWindow, sTemp, 179)
  
            If InStr(sTemp, sBaseCaption) Then
                ActivatePrevInstance (hAppWindow) '使以前的窗口活动
                Exit Do
            End If
        
            If InStr(sTemp, sBaseCaption1) Then
                ActivatePrevInstance (hAppWindow) '使以前的窗口活动
            Exit Do
            End If
  
        ' 获得下一个子窗体
            hAppWindow = GetWindow(hAppWindow, GW_HWNDNEXT)
        Loop
    Else
        '第一次运行时
        frmLogin.Show
    End If
    Exit Sub
ERROR_EXIT:
    m_tagErrInfo.strErrDate = Format(Now, "yyyy-mm-dd hh:mm:ss")
    m_tagErrInfo.strErrFile = "modStartup"
    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

Private Sub ActivatePrevInstance(ByVal hAppWindow&)
    On Error Resume Next
    
    Call ShowWindow(hAppWindow, 9) 'SW_RESTORE = 9 <WinUser.h>
    '使窗口活动
    Call SetForegroundWindow(hAppWindow)
End Sub

'**********************************
' 去掉字符中的空字符及以后的字符
Public Function RemoveNullChar(ByVal str As String) As String
    On Error Resume Next
    Dim i As Integer
    Dim strTemp As String
    
    strTemp = str
    i = InStr(strTemp, vbNullChar)
    If i > 0 Then strTemp = Left(strTemp, i - 1)
    RemoveNullChar = strTemp
End Function

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