mdlsubmain.bas

本系统可用于医院和专业体检中心的健康体检管理

Attribute VB_Name = "mdlSubMain"
Option Explicit
Public fMainForm As frmMain
 
Const KeyRoot = "HKEY_LOCAL_MACHINE" '注册表根路径
'据目前所知，MSSQL的ODBC驱动程序路径存在两种情况
Const gREGKEYDRIVERLOC = "SOFTWARE\ODBC\ODBCINST.INI\Microsoft SQL Server" 'MSSQL的ODBC驱动程序路径
Const gREGKEYDRIVERLOC_A = "SOFTWARE\ODBC\ODBCINST.INI\SQL Server" 'MSSQL的辅助ODBC驱动程序路径
Const gREGDRIVERSUBKEY = "Driver" '驱动程序子键
Const gREGKEYODBCLOC = "SOFTWARE\ODBC\ODBC.INI\"

'*********************20040417 加入 闻********************************
Public gICSupport As Boolean                '是否有IC卡管理
'*********************20040417 加入完 闻******************************

'*********************20040417 加入 闻********************************
Public gRegister As Boolean                 '是否注册
'*********************20040417 加入完 闻******************************

'*********************20040505 加入 闻********************************
Public gHCGL As Boolean              '是否有耗材管理
'*********************20040505 加入完 闻******************************

'*********************20040505 加入 闻********************************
Public gPay As Boolean              '是否有收费管理
'*********************20040505 加入完 闻******************************

'*********************20040509 加入 闻********************************
Public gKHGL As Boolean              '是否有客户管理
'*********************20040509 加入完 闻******************************

'*********************20040514 加入 闻********************************
Public gBBMB As Boolean              '是否有WORD报表模板生成WORD格式的报表功能
'*********************20040514 加入完 闻******************************

'*********************20040521 加入 闻********************************
Public gQianFu As Boolean              '用于控制千福版本的菜单
'*********************20040521 加入完 闻******************************

'*********************20040521 加入 闻********************************
Public gWWW As Boolean              '用于控制网站数据导出
'*********************20040521 加入完 闻******************************

'*********************20040523 加入 闻********************************
Public gTryVersion As Boolean              '用于控制是否是试用版
'*********************20040523 加入完 闻******************************

'*********************20040523 加入 闻********************************
Public gKHDW As String              '用于控制客户单位
'*********************20040523 加入完 闻******************************

Public ShanXiLis As Boolean   'wxw add 20050718  山西LIS

'版本控制变量
Public g_blnImportExcel As Boolean
Public g_blnPrintGuider As Boolean

Public g_blnConnectRIS As Boolean
Public g_strRISStoredProc As String
Public gstrVersionNumber As String '版本号

Public g_strDevelopCompany As String
Public Const COMPANY_INFO = "北京秉泰软件科技有限公司  服务电话：[phone]"
Private Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long

Public Sub Main()
On Error Resume Next
    Dim Status
    Dim strSQL As String
    Dim strSerial As String
    Dim clsDisk As New CDiskInfo
    Dim intTimes As Integer
    Dim i As Integer
    Dim intRet As Integer
    
    Call InitExceptionHandler
    
    '★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★
    '★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★
    '★★★★★★★★★★★★★★                 ★★★★★★★★★★★★★★
    '★★★★★★★★★★★★★★      版本控制    ★★★★★★★★★★★★★★
    '★★★★★★★★★★★★★★                 ★★★★★★★★★★★★★★
    '★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★
    '★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★
    g_strDevelopCompany = "秉泰"
    gblnBarCode = True '条形码打印
    genuVersion = WLB
    gKHDW = "全部"
    g_blnImportExcel = True
    g_blnPrintGuider = True
    
    If genuVersion = WLB Then
        gstrVersionTitle = "网络版"
    ElseIf genuVersion = ZYB Then
        gstrVersionTitle = "专业版"
    ElseIf genuVersion = BZB Then
        gstrVersionTitle = "标准版"
    ElseIf genuVersion = PJB Then
        gstrVersionTitle = "普及版"
        
        g_blnImportExcel = False
        g_blnPrintGuider = False
    End If
    If genuVersion = WLB Then
        gstrVersionNumber = "4.4"
    Else
        gstrVersionNumber = "4.4"
    End If
    Load frmSplash
    frmSplash.Show
    
'    '对于千福限时
'    If Date > DateValue("2004-11-22") Then
'        MsgBox "对不起，该版本的使用期限已到，请联系北京" & g_strDevelopCompany & "软件科技有限公司", vbExclamation, "警告"
'        GoTo ExitLab
'    End If

    If genuVersion = WLB Then
        Select Case gKHDW
            Case "正清源"
                gLisInterface = True
                gICSupport = False
                gRegister = True
                gHCGL = True
                gKHGL = True
                gBBMB = True
                gWWW = True
                gTiJiao = False         '提交方式,用于千福体检中心
                gQianFu = False
                gTryVersion = False
'                g_enuGuiderType = PuYa          '导引单模式
            Case "千福"
                gLisInterface = False
                gICSupport = False
                gRegister = True
                gHCGL = False
                gPay = True
                gKHGL = False
                gBBMB = True
                gWWW = True
                gTiJiao = True          '提交方式,用于千福体检中心
                gQianFu = True
                gTryVersion = False
'                g_enuGuiderType = QingDaoUniversity              '导引单模式
            Case "无锡"
                gLisInterface = False
                gICSupport = False
                gRegister = True
                gHCGL = True
                gPay = False
                gKHGL = False
                gBBMB = True
                gWWW = True
                gTiJiao = True          '提交方式,用于千福体检中心
                gQianFu = True
                gTryVersion = False
'                g_enuGuiderType = PuYa              '导引单模式
            Case "全部"
                gLisInterface = GetINI(gstrCurrPath & DSNINIFile, "Interface", "ConnectLIS", "")
                gICSupport = False
                gRegister = True
                gHCGL = False
                gPay = True
                gKHGL = False
                gBBMB = True
                gWWW = True
                gTiJiao = True          '提交方式,用于千福体检中心
                gQianFu = True
                gTryVersion = False
'                g_enuGuiderType = PuYa         '导引单模式
                '山西LIS
                ShanXiLis = True
            Case Else
                gLisInterface = False
                gICSupport = True
                gRegister = True
                gHCGL = False
                gKHGL = False
                gBBMB = True
                gWWW = False
                gTiJiao = False       '提交方式,用于千福体检中心
                gQianFu = False
                gTryVersion = False
'                g_enuGuiderType = PuYa         '导引单模式
        End Select
    Else
        gLisInterface = False
        gICSupport = False
        gRegister = True
        gHCGL = False
        gPay = False
        gKHGL = False
        gBBMB = True
        If genuVersion = ZYB Then
            gWWW = True
        Else
            gWWW = False
        End If
        gTiJiao = False       '提交方式,用于千福体检中心
        gQianFu = False
        gTryVersion = False
    End If
    '★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★
    '★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★
    
    SetCurrPath '设置应用程序当前路径
    InitManager '初始化管理类别
    SetReportHeader
    g_blnReLogin = False
    
    '******************************************************************************
    '               以下代码判断数据库是否已经附加到当前数据库
    '               如果没有，调用SQL命令附加数据库
    '*****************************************************************************
'    Screen.MousePointer = VbArrowHourglass
'
'    strServer = GetINI(gstrCurrPath & DSNINIFile, "Database", "Server", "?")
'    If strServer = "?" Then
'        Screen.MousePointer = vbDefault
'        MsgBox "服务器信息已被损坏，程序将用缺省值进行修复！", vbExclamation, "提示"
'        strServer = "(local)"
'        Screen.MousePointer = VbArrowHourglass
'    End If
'
'    Err.Clear
'    Set con = New ADODB.Connection
'    con.ConnectionString = "Provider=SQLOLEDB.1;Integrated Security=SSPI;Persist Security Info=False;Initial Catalog=master;Server=" & strServer
'    con.Open '打开数据库连接
'    If Err.Number <> 0 Then GoTo ErrMsg
'
On Error GoTo ErrMsg
'    strSQL = "select Count(*) from sysdatabases" _
'            & " where name='" & DatabaseName & "'"
'    Set rsTemp = New ADODB.Recordset
'    rsTemp.Open strSQL, con
'    If rsTemp(0) < 1 Then '第一次运行
'        '通过代码附加数据库
'        strSQL = "sp_attach_db @dbname=N'" & DatabaseName & "'," _
'                & "@filename1='" & gstrCurrPath & DatabaseDir & DatabaseName & "_data.mdf'," _
'                & "@filename2='" & gstrCurrPath & DatabaseDir & DatabaseName & "_log.ldf'"
'        con.Execute strSQL
'        '添加到日志
'        AddLog "第一次运行", "成功附加数据库！", OperationLog
'    End If
'    Screen.MousePointer = vbDefault
'    '******************************************************************************
'    '                                   附加完毕！
'    '******************************************************************************
'
'
'    '******************************************************************************
'    '                       以下代码判断数据源是否存在
'    '                       如果不存在，通过直接写注册表来建立ODBC
'    '                       获取ODBC中的数据源名
'    '******************************************************************************
'    strDatabase = GetINI(gstrCurrPath & DSNINIFile, "Database", "DSN", "?")
'    If strDatabase = "?" Then
'        Screen.MousePointer = vbDefault
'        MsgBox "数据源信息已被损坏，程序将用缺省值进行修复！", vbExclamation, "提示"
'        strDatabase = DatabaseName
'        Call WriteINI(gstrCurrPath & DSNINIFile, "Database", "DSN", strDatabase)
'        Screen.MousePointer = VbArrowHourglass
'    End If
'
'    If Not GetKeyValue(HKEY_LOCAL_MACHINE, gREGKEYODBCLOC & strDatabase, "Database", strTemp) Then
'        '获取SQL Server驱动程序路径
'        If GetKeyValue(HKEY_LOCAL_MACHINE, gREGKEYDRIVERLOC, gREGDRIVERSUBKEY, strDriver) Then
'            '成功取得SQL Server驱动程序路径
'            '接下来获取本机用户名
'            'Create a buffer
'CreateODBC:
'            strUserName = String(100, Chr$(0))
'            'Get the username
'            GetUserName strUserName, 100
'            'strip the rest of the buffer
'            strUserName = Left$(strUserName, InStr(strUserName, Chr$(0)) - 1)
'
'            '把ODBC数据源信息写入注册表
'            SaveString HKEY_LOCAL_MACHINE, gREGKEYODBCLOC & strDatabase, "Driver", strDriver
'            SaveString HKEY_LOCAL_MACHINE, gREGKEYODBCLOC & strDatabase, "Server", strServer
'            SaveString HKEY_LOCAL_MACHINE, gREGKEYODBCLOC & strDatabase, "Database", strDatabase
'            SaveString HKEY_LOCAL_MACHINE, gREGKEYODBCLOC & strDatabase, "LastUser", strUserName
'            SaveString HKEY_LOCAL_MACHINE, gREGKEYODBCLOC & strDatabase, "Trusted_Connection", "Yes"
'
'            SaveString HKEY_LOCAL_MACHINE, gREGKEYODBCLOC & "ODBC Data Sources", strDatabase, "SQL Server"
'        Else
'            '如果第一种方式不成功，尝试第二种方式
'            If GetKeyValue(HKEY_LOCAL_MACHINE, gREGKEYDRIVERLOC_A, gREGDRIVERSUBKEY, strDriver) Then
'                '如果成功，跳到写注册表部分
'                GoTo CreateODBC
'            Else
'                '如果仍然失败，则提示后直接退出
'                MsgBox "创建ODBC数据源时出现异常：无法从注册表中获取SQLServer驱动程序路径。请用手工添加！", vbExclamation, "提示"
'                GoTo ExitLab
'            End If
'        End If
'    End If
    '******************************************************************************
    '                              数据源ODBC处理完毕！
    '******************************************************************************
    
'    If App.PrevInstance Then
'        title = App.title
'        Call MsgBox("“智能灌溉系统”已经在运行！", vbExclamation)
'        App.title = "" '如此才不会Avtivate到自己
'        AppActivate title 'activate先前就已行的程式
'        End
'    End If
    
'    Screen.MousePointer = VbArrowHourglass
'    strStartPageName = GetINI(gstrCurrPath & DSNINIFile, "StartPage", "PageName", "")
'    Set frmSplash.imgStartPage.Picture = LoadPicture(gstrCurrPath & StartPage & strStartPageName)
    
'    Load MDIForm1
    
    GetDatabaseParameter 'Get Database Parameter
    
    'Open Connection
    If ConnectDatabase(GCon) = False Then
        '弹出设置数据库服务器地址对话框,请客户设置数据库服务器地址
        If MsgBox("无法连接数据库，需要手动设置连接参数吗？", _
                vbQuestion + vbYesNo + vbDefaultButton1, "询问") = vbYes Then
            If dlgServer.Connection = True Then
                Unload dlgServer
                Set dlgServer = Nothing
                
                '重新获取连接参数
                GetDatabaseParameter 'Get Database Parameter
                '用全局变量去建立连接
                ConnectDatabase GCon
            Else
                '否则直接退出