modmain.bas

VB6.0编写的医院影像系统

Attribute VB_Name = "modMain"
Option Explicit

'版本类型常数
Public Enum USVersionConstants
    USReport = 1            '报告版
    USStandard = 2          '标准版
    USPro = 3               '专业版
    USImage = 4             '图像版
    USFull = 5              '完全版
End Enum

'指示服务器/客户机类型的常数
Public Enum USUtilizeTypeConstants
    USServer = 1            '服务器
    USClient = 2            '客户端
    USAll = 99              'Power用户，均可
End Enum


'控制版本的全局变量
Public USV As New USVersion       '控制版本的类
Public RPS As Integer             '控制选择打印的格式

'一些全局变量
Public gstrDBType As String         '数据库的类型字符串(ACCESS, MSDE, MSSQL, ORACLE, SYBSQL等)
Public gstrDateQuote As String      '日期类型的括号(ACCESS为"#"，SQL SERVER为单引号)


Public Const gstrHeartSplit = "心脏:" & vbCrLf      '心脏模版的分割符


'Sub Main()
'
'    '-----------------------
'    '系统的启动次序
'    '-----------------------
'
'    IniDog
'    NullCheck
'
'    '先定义当前版本
'    USV.Version = USFull
''    USV.Version = USImage
''    USV.Version = USPro
''    USV.Version = USStandard
''    USV.Version = USReport
'
'    '定义客户机/服务器类型
'    USV.UtilizeType = USClient
''    USV.UtilizeType = USServer
''    USV.UtilizeType = USAll
'
'    '再定义打印的报告格式
''    RPS = 1            '有边框
'    RPS = 2            '无边框
'
'    '设置并读取INI文件
'    IniUS.FileName = App.Path & "\US.INI"
'    ReadIni
'
'    frmSplash.Show
'    DoEvents
'
'    '连接数据库
'    Dim Ret As Integer
'    If Not ConnectDB Then
'        '数据库联接出错
'        Ret = MsgBox("数据库配置不准确，现在重新配置吗？" & vbCrLf & vbCrLf & "选择「是」则进入数据库配置窗口； 选择「否」则退出程序。", vbYesNo + vbQuestion, "提示")
'        If Ret = vbYes Then
'            frmDBSet.Show vbModal
'            If Not frmDBSet.bCancel And frmDBSet.bChanged Then
'                MsgBox "您修正了数据库的配置，重新运行后新的配置将生效！", vbOKOnly + vbInformation, "提示"
'                FuncExit
'            Else
'                MsgBox "系统记录的数据库配置不正确，而您并未调其配置，因此程序将不能连接到数据库！ " & vbCrLf & vbCrLf & "现在程序将退出，您可以在下次运行程序时重新调整数据库配置。", vbOKOnly + vbInformation, "提示"
'                FuncExit
'            End If
'        Else
'            FuncExit    '不正确配置数据库就不允许进入系统
'        End If
'    End If
'
''    CheckBackup
'
'    frmLogin.Show vbModal
'    If Not frmLogin.OK Then
'        '登录失败，退出应用程序
'        FuncExit
'        End
'    End If
'    Unload frmLogin
'
''    UserName = "DREAM"
''    UserType = "超级管理员"
''    UserType = "一般用户"
''    UserType = "系统管理员"
'
'    '显示启动屏幕
'    Screen.MousePointer = vbHourglass
'    SetFormOnTop frmSplash
'    IniSystem
'    frmSplash.Refresh
'
'    Load frmMain
'
'    ShowTaskBar False
'    frmMain.Show
'
'    Screen.MousePointer = vbNormal
'
'    Unload frmSplash
'
'End Sub
'
'Public Function ConnectDB() As Boolean
'
'    '----------------------------------------
'    '连接到指定的数据库
'    '----------------------------------------
'
'    On Error GoTo ErrHandle
'
'    Dim strConnUS As String
'    Dim strConnData As String
'
''    strConnUS = IniUS.GetString("DataBase", "USConnection", vbNullString)
''    strConnData = IniUS.GetString("DataBase", "DataConnection", vbNullString)
'
'    '确定数据库的类型
'    gstrDBType = IniUS.GetString("DataBase", "DBType")
'
'
'    '连接各全局记录集，并根据数据库类型设置全局变量
'    Select Case gstrDBType
'        Case "ACCESS"
'            '替换可能出现的常量
'            strConnUS = Replace(strConnUS, "%AppPath%", App.Path, , , vbTextCompare)
'            strConnData = Replace(strConnData, "%AppPath%", App.Path, , , vbTextCompare)
'            ConnUS.Open EnPassWord(strConnUS)
'            ConnData.Open EnPassWord(strConnData)
'            gstrDateQuote = "#"
'        Case "MSSQL"
'            strConnUS = MakeSQLConnectionString(IniUS.GetString("DataBase", "MSSQL_SERVER_NAME"), IniUS.GetString("DataBase", "MSSQL_USER_NAME"), DeCrypt(IniUS.GetString("DataBase", "MSSQL_PASSWORD")), IniUS.GetString("DataBase", "MSSQL_DATABASE_NAME"))
'            ConnUS.Open strConnUS
'            Set ConnData = ConnUS
'            gstrDateQuote = "'"
'    End Select
'
'    '打开几个公用的记录集
'    Set rsUS_Report = OpenRS("SELECT * FROM US_REPORT", "Data")
'    Set rsSickInfo = OpenRS("SELECT * FROM SICK_INFO", "Data")
'    'Set rsUS_ReportSick = OpenRS("SELECT US_REPORT.*, SICK_INFO.SICK_BIRTH FROM US_REPORT LEFT OUTER JOIN SICK_INFO ON US_REPORT.SICK_NO = SICK_INFO.SICK_NO ", "Data")
'    Set rsUS_ReportSick = OpenRS("SELECT * FROM US_REPORT", "Data")
'
'
'    '如果返回的记录集有为空，则引发错误
'    If rsUS_Report Is Nothing Or rsSickInfo Is Nothing Or rsUS_ReportSick Is Nothing Then GoTo ErrHandle
'
'    ConnectDB = True
'    Exit Function
'
'ErrHandle:
'
'    '连接过程中出现错误
'    ConnectDB = False
'
'End Function

Public Sub IniSystem()

    '------------------
    '执行系统的初始化
    '------------------

    US_KEY_ITEMDETAIL = vbKeyF5
    US_KEY_POPORGANTEMP = vbKeyF6
    US_KEY_NEWREPORT = vbKeyF2
    US_KEY_SAVEREPORT = vbKeyF3
    US_KEY_CANCELREPORT = vbKeyEscape
    US_KEY_CANCEL = vbKeyEscape
    US_KEY_ADD = vbKeyF2
    US_KEY_COVER = vbKeyF3
    US_KEY_OK = vbKeyF2
    US_KEY_PRINT = vbKeyF8
    US_KEY_PRINTPREVIEW = vbKeyF7

    US_STR_COMBSPLIT = ";"
    US_STR_TEMPSPLIT = "|"
    US_STR_DIRSPLIT = "|"


    '加入报告检索项目
    IniReportItems

End Sub

Public Sub ReadIni()

    '------------------------
    '从INI文件读取数据
    '------------------------

    On Error GoTo ErrHandle

    gbValidate = IniUS.GetString("Report", "AutoValidate", False)

    gintPreviewFrameRate = IniUS.GetString("Video", "PreviewFrameRate", 24)
    gintFrameRate = IniUS.GetString("Video", "FrameRate", 24)
    glngFrameLimit = IniUS.GetString("Video", "FrameLimit", 0)
    glngTimeLimit = IniUS.GetString("Video", "TimeLimit", 0)
    gintVideoWidth = IniUS.GetString("Video", "VideoWidth", 352)
    gintVideoHeight = IniUS.GetString("Video", "VideoHeight", 288)
    gintStillWidth = IniUS.GetString("Video", "StillWidth", 704)
    gintStillHeight = IniUS.GetString("Video", "StillHeight", 576)
    gintBrightness = IniUS.GetString("Video", "Brightness", 50)
    gintContrast = IniUS.GetString("Video", "Contrast", 50)
    gintHue = IniUS.GetString("Video", "Hue", 50)
    gintSaturation = IniUS.GetString("Video", "Saturation", 50)
    gstrVideoCodec = IniUS.GetString("Video", "VideoCodec", "WINX")
    gintVideoCompressRate = IniUS.GetString("Video", "VideoCompressRate", 2)
    gintStillImageType = IniUS.GetString("Video", "StillImageType", 0)
    gintStillImageFormat = IniUS.GetString("Video", "StillImageFormat", 0)
    gintVideoSource = IniUS.GetString("Video", "VideoSource", 2)


    '图象文件不从INI读取,而是取程序所在目录的下的相应目录
    'gstrTempDir = IniUS.GetString("Picture", "TempDir", App.Path & "\TEMP")

    gstrTempDir = App.Path & "\TEMP"
    gstrImageDir = IniUS.GetString("Picture", "ImageDir", App.Path & "\MEDIA")
    gstrBackupDir = IniUS.GetString("Picture", "BackupDir", App.Path & "\BACKUP")
    gstrServerImageDir = IniUS.GetString("Picture", "ServerImageDir")

    '读取工作站标识
    gstrWorkStationID = IniUS.GetString("StartUp", "WorkStationID", "1")

    With FSO

        If Not (.FolderExists(gstrImageDir)) Then gstrImageDir = App.Path & "\MEDIA"
        If Not (.FolderExists(gstrBackupDir)) Then gstrBackupDir = App.Path & "\BACKUP"

        '如果相应目录不存在,则创建
        If Not (.FolderExists(gstrTempDir)) Then .CreateFolder gstrTempDir
        If Not (.FolderExists(gstrImageDir)) Then .CreateFolder gstrImageDir
        If Not (.FolderExists(gstrBackupDir)) Then .CreateFolder gstrBackupDir

    End With

    IniUS.PutString "Picture", "TempDir", gstrTempDir
    IniUS.PutString "Picture", "ImageDir", gstrImageDir
    IniUS.PutString "Picture", "BackupDir", gstrBackupDir

    '释放对象
    Exit Sub

ErrHandle:
    '出现错误的处理
    MsgBox "在初始化路径过程中出现错误,请检查初始化文件中路径的设置!", vbOKOnly + vbExclamation, "错误"
    FuncExit

End Sub

Public Sub FuncExit()

    '---------------------
    '退出程序
    '---------------------

    Dim rs As ADODB.Recordset
    Dim frm As Form

    Dim cFile As File
    Dim strFileName As String

    On Error Resume Next

    Screen.MousePointer = vbHourglass

    '删除在TEMP目录下的文件
'    For Each cFile In FSO.GetFolder(gstrTempDir).Files
'        strFileName = cFile.Name
'        Set cFile = Nothing
'        FSO.DeleteFile strFileName, True
'    Next cFile

    '先释放整个TEMP目录，再重新创建以达到清空文件的目的
    FSO.DeleteFolder gstrTempDir, True
    FSO.CreateFolder gstrTempDir

    '执行退出的过程
'    For Each frm In Forms
'        Unload frm
'    Next frm

    '释放对象
    Set cFile = Nothing
    ShowTaskBar True

    Screen.MousePointer = vbNormal
    End

End Sub

Public Sub CheckBackup()

    '---------------------------------
    '检查是否需要备份
    '---------------------------------

'    Dim StartDate As Date
'    Dim LastWarnDay As Date
'    Dim Interval As Integer
'
'
'    If IniUS.GetString("StartUp", "StartDate") = "" Then
'        IniUS.PutString "StartUp", "StartDate", Date
'        Exit Sub
'    End If
'
'    If IniUS.GetString("StartUp", "Interval") = "" Then
'        IniUS.PutString "StartUp", "Interval", 7
'        Exit Sub
'    End If
'
'    StartDate = IniUS.GetString("StartUp", "StartDate")
'    Interval = IniUS.GetString("StartUp", "Interval")
'    LastWarnDay = IniUS.GetString("StartUp", "LastWarnDay", "1980-01-01")

    '如果本日未提醒,则提醒是否备份
'    If DateDiff("d", StartDate, Date) >= Interval And LastWarnDay <> Date Then
'        Backup
'    End If

End Sub

Public Sub Backup()

    '------------------------
    '备份数据文件
    '------------------------

'    Dim FS As New FileSystemObject
'    Dim iAnswer As Integer
'
'    On Error GoTo ErrBackup
'
'    iAnswer = MsgBox("您是否备份当前数据库及声像文件?", vbInformation + vbYesNo, "提示")
'
'    If iAnswer = vbNo Then
'
'        IniUS.PutString "StartUp", "LastWarnDay", Date
'        Exit Sub
'
'    Else
'
'        '确认当前路径是否存在
'        If FSO.FolderExists(gstrBackupDir) = False Then
'            MsgBox "未发现所指定的备份路径, 请在选项中核查已经指定了正确的备份路径!", vbInformation + vbOKOnly, "数据备份错误"
'            Exit Sub
'        End If
'
'        FS.CopyFile App.Path & "\US.mdb", gstrBackupDir & "\US.mdb", True
'        FS.CopyFile App.Path & "\USDATA.mdb", gstrBackupDir & "\USDATA.mdb", True
'        FS.CopyFolder gstrImageDir, gstrBackupDir & "\MEDIA", True
'
'        IniUS.PutString "StartUp", "StartDate", Date
'
'    End If
'
'    MsgBox "备份成功!", vbInformation + vbOKOnly, "备份"
'    Exit Sub
'
'ErrBackup:
'
'    MsgBox "系统在备份过程中出现错误:" & Err.Description, vbInformation, "备份"

End Sub

Public Function Account_Age(BirthDay As Date, DiagDay As Date) As Integer
    Account_Age = DateDiff("yyyy", BirthDay, DiagDay)
    If Account_Age <= 0 Then
        Account_Age = DateDiff("m", BirthDay, DiagDay)
        If Account_Age <= 0 Then
            Account_Age = DateDiff("w", BirthDay, DiagDay)
            If Account_Age <= 0 Then
                Account_Age = DateDiff("d", BirthDay, DiagDay)
                frmReport.cboAgeUnit.Text = "日"
            Else
                frmReport.cboAgeUnit.Text = "周"
            End If
        Else
            frmReport.cboAgeUnit.Text = "月"
        End If
    Else
        frmReport.cboAgeUnit.Text = "岁"
    End If
End Function

Public Function Account_BirthDay(SickAge As String, SickUnit As String) As Date
    Dim Birth_Year As Integer
    Dim Birth_Month As Integer
    Select Case SickUnit
        Case "岁"
            Account_BirthDay = str(Year(frmReport.txtDiagDay.Value) - SickAge) & "-01-01"
        Case "月"
            Birth_Year = Year(frmReport.txtDiagDay.Value)
            Birth_Month = Month(frmReport.txtDiagDay.Value)
            While Birth_Month < Val(SickAge)
                Birth_Month = Birth_Month + 12
                Birth_Year = Birth_Year - 1
            Wend
            If str(Birth_Month - SickAge) = 0 Then
                Account_BirthDay = str(Birth_Year) & "-" & "01" & "-01"
            Else
                Account_BirthDay = str(Birth_Year) & "-" & str(Birth_Month - SickAge) & "-01"
            End If
        Case "周"
            Account_BirthDay = frmReport.txtDiagDay.Value - SickAge * 7
        Case "日"
            Account_BirthDay = frmReport.txtDiagDay.Value - SickAge
        Case Else
    End Select
End Function