modcommon.bas

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

Attribute VB_Name = "modCommon"
Option Explicit

Public Const EM_UNDO = &HC7
Public Const GWL_STYLE = (-16)
Public Const WS_HSCROLL = &H100000
Public Const WS_DLGFRAME = &H400000
Public Const WS_VSCROLL = &H200000
Public Const LB_SETITEMHEIGHT = &H1A0

Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Any) As Long
Public Declare Function OSWinHelp% Lib "user32" Alias "WinHelpA" (ByVal hwnd&, ByVal HelpFile$, ByVal wCommand%, dwData As Any)
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Declare Function SendMessageByNum Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Public Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Public Declare Function CreateProcess Lib "kernel32" Alias "CreateProcessA" (ByVal lpApplicationName As String, ByVal lpCommandLine As String, lpProcessAttributes As SECURITY_ATTRIBUTES, lpThreadAttributes As SECURITY_ATTRIBUTES, ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, lpEnvironment As Any, ByVal lpCurrentDriectory As String, lpStartupInfo As STARTUPINFO, lpProcessInformation As PROCESS_INFORMATION) As Long
Public Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Public Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Public Declare Function GetExitCodeProcess Lib "kernel32" (ByVal hProcess As Long, lpExitCode As Long) As Long
Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Public Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long
Public Declare Function SendMessageAny Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal MSG As Long, ByVal wParam As Long, lParam As Any) As Long
Public Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long
Public Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd As Long) As Long
Public Declare Function MoveWindow Lib "user32" (ByVal hwnd As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long
Public Declare Function UpdateWindow Lib "user32" (ByVal hwnd As Long) As Long


'子窗体
Public Const GW_CHILD = 5



Public Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Public Const WM_USER = &H400
Public Const SB_GETRECT = (WM_USER + 10)

Public Declare Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long
Public Const SND_SYNC = &H0
Public Const SND_ASYNC = &H1


Private Const SWP_NOSIZE = &H1
Private Const SWP_NOMOVE = &H2
Private Const HWND_TOPMOST = -1
Private Const HWND_NOTOPMOST = -2

Const SWP_HIDEWINDOW = &H80
Const SWP_SHOWWINDOW = &H40

Public Type SECURITY_ATTRIBUTES
        nLength As Long
        lpSecurityDescriptor As Long
        bInheritHandle As Long
End Type

Public Type STARTUPINFO
        cb As Long
        lpReserved As String
        lpDesktop As String
        lpTitle As String
        dwX As Long
        dwY As Long
        dwXSize As Long
        dwYSize As Long
        dwXCountChars As Long
        dwYCountChars As Long
        dwFillAttribute As Long
        dwFlags As Long
        wShowWindow As Integer
        cbReserved2 As Integer
        lpReserved2 As Long
        hStdInput As Long
        hStdOutput As Long
        hStdError As Long
End Type

Public Type PROCESS_INFORMATION
        hProcess As Long
        hThread As Long
        dwProcessId As Long
        dwThreadID As Long
End Type

'以下是一些常用键的设置
Public US_KEY_ITEMDETAIL As KeyCodeConstants                '弹出项目详细列表
Public US_KEY_POPORGANTEMP As KeyCodeConstants              '弹出器官模板
Public US_KEY_NEWREPORT As KeyCodeConstants                 '新建报告
Public US_KEY_SAVEREPORT As KeyCodeConstants                '保存报告
Public US_KEY_CANCELREPORT As KeyCodeConstants              '取消报告
Public US_KEY_CANCEL As KeyCodeConstants                    '取消
Public US_KEY_ADD As KeyCodeConstants                       '取消
Public US_KEY_COVER As KeyCodeConstants                     '取消
Public US_KEY_OK As KeyCodeConstants                        '确认
Public US_KEY_PRINT As KeyCodeConstants                     '打印
Public US_KEY_PRINTPREVIEW As KeyCodeConstants              '打印预览

'以下是一些常用全局常/变量
Public US_STR_COMBSPLIT As String                           '器官组合分隔符
Public US_STR_TEMPSPLIT As String                           '模板分隔符
Public US_STR_DIRSPLIT As String                            '目录分隔符

'连接数据库的字串
'Public Const STR_ACCESS_US_BASE = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=%ACCESS_DB_DIR%\US.mdb;Persist Security Info=False;Jet OLEDB:Database Password=rich"
'Public Const STR_ACCESS_USDATA_BASE = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=%ACCESS_DB_DIR%\USData.mdb;Persist Security Info=False;Jet OLEDB:Database Password=rich"
Public Const STR_ACCESS_US_BASE = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=%ACCESS_DB_DIR%\US.mdb;Persist Security Info=False"
Public Const STR_ACCESS_USDATA_BASE = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=%ACCESS_DB_DIR%\USData.mdb;Persist Security Info=False"
Public Const STR_MSSQL_US_BASE = "Provider=SQLOLEDB.1;Persist Security Info=False;User ID=%MSSQL_USERID%;Initial Catalog=US;Data Source=%MSSQL_SERVER_NAME%"
Public Const STR_MSSQL_USDATA_BASE = "Provider=SQLOLEDB.1;Persist Security Info=False;User ID=%MSSQL_USERID%;Initial Catalog=USData;Data Source=%MSSQL_SERVER_NAME%"


Public Const US_STR_READY As String = "就绪"                '缺省的状态条显示
Public Const MAX_PRINT_IMAGES = 4                           '最大打印的文件数

'以下是一些全局变量
Public UserName As String
Public UserType As String

Public gstrCombString As String                             '当前的器官组合字串

Public gintPreviewFrameRate As Integer                      '预览频率
Public gintFrameRate As Integer                             '捕捉频率
Public glngFrameLimit As Long                               '帧数限制
Public glngTimeLimit As Long                                '时间限制

Public gintVideoWidth As Integer                            '视频宽度
Public gintVideoHeight As Integer                           '视频高度
Public gintStillWidth As Integer                            '静态图象宽度
Public gintStillHeight As Integer                           '静态图象高度

Public gintContrast As Integer                              '对比度
Public gintBrightness As Integer                            '亮度
Public gintHue As Integer                                   '色度
Public gintSaturation As Integer                            '饱和度

Public gstrVideoCodec As String                             '视频编码
Public gintVideoQuality As Integer                          '视频质量(1~100)
Public gintVideoCompressRate As Integer                     '视频压缩率
Public gintStillImageType As Integer                        '静态图象类型
Public gintStillImageFormat                                 '静态图象格式
Public gintVideoSource As Integer                           '视频来源

Public gbAudioCaptureOn As Boolean                          '是否采集音频
Public gbAudioCaptureStereo As Boolean                      '是否立体声
Public gbAudioCapture8Bit As Boolean                        '是否采用8Bit
Public gintAudioCaptureSampleRate As Long                   '采样的频率

Public gstrTempDir As String                                '临时文件目录
Public gstrImageDir As String                               '图象文件目录
Public gstrBackupDir As String                              '备份文件目录
Public gstrServerImageDir As String                         '网络服务器上的媒体共享媒体文件目录

Public gstrNullWaveFile As String                           '空声音文件的名称
Public gstrWorkStationID As String                          '工作站的名称

Public OrganModelNameChosen As String              '已选器官模板名
Public OrganModelNameChosenStr As String           '已选器官模板名字串
Public TempLoadFlag(20) As Boolean
Public OldTempLoadFlag(20) As Boolean
Public TempOrderNumber As Integer
Public LastTempNumber As Integer

'不同版本权限的约束
Public F_REPORT As Boolean
Public F_VIDEO As Boolean
Public F_IMAGE As Boolean
Public TEMP_STRING As String
Public ORGAN_STRING As String


Public ConnData As New ADODB.Connection                     '到报告数据库的连接
Public ConnUS As New ADODB.Connection                       '到系统库的连接

'以下是全局的RecordSet对象
Public rsUS_Report As ADODB.Recordset
Public rsSickInfo As ADODB.Recordset
Public rsUS_ReportSick As ADODB.Recordset

Public IniUS As New IniFile                                 '本程序的INI文件
Public FSO As New FileSystemObject                          '全局的FSO对象
Public gcolReportItems As New Collection                    '报告检索字段集合

Public InPutArray(10) As Boolean
Public USNO_Old As String
Public USNO As String
Public Report_Index As Integer
Public SearchTip As Boolean                                 '是否有超声提示查询
Public TipAtSerial As Integer                               '超声提示在查询列表中的位置

Public Sub ShowTaskBar(Optional bShow As Boolean = True)

    '-------------------
    '显示任务栏
    '-------------------
    
    Dim hWnd1 As Long
    hWnd1 = FindWindow("Shell_Traywnd", "")
    If bShow Then
        Call SetWindowPos(hWnd1, 0, 0, 0, 0, 0, SWP_SHOWWINDOW)
    Else
        Call SetWindowPos(hWnd1, 0, 0, 0, 0, 0, SWP_HIDEWINDOW)
    End If

End Sub

Public Sub SetFormOnTop(myForm As Object)
    
    '------------------------------
    '将窗体设置为AlwaysOnTop
    '------------------------------
    
    SetWindowPos myForm.hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE
    
End Sub

Public Sub AddField(EName As String, CName As String, Optional FieldType As Integer = -1)
    On Error Resume Next
    
    '--------------------------------
    '向gcolReportItems集合中加入一项
    '--------------------------------
    
    Dim NewRT As New ReportItem
    
    NewRT.EName = EName
    NewRT.CName = CName
    NewRT.FieldType = IIf((FieldType = -1), rsUS_ReportSick(EName).Type, FieldType)
    
    gcolReportItems.Add NewRT, EName
    
End Sub

Public Function RTFromCName(CName As String) As ReportItem
    
    '------------------------
    '由中文名称返回报告项目
    '------------------------
    
    Dim i As Integer
    For i = 1 To gcolReportItems.Count
        If gcolReportItems(i).CName = CName Then
            Set RTFromCName = gcolReportItems(i)
        End If
    Next i
    
End Function

Public Sub IniReportItems()
    
    '----------------------------------
    '加入可以引用的报告项目(用于查询)
    '----------------------------------
    AddField "DIAG_DAY", "诊断日期"
    AddField "DIAG_DOCTOR", "诊断医师"
    AddField "ORGAN_NAME", "检查部位"
    AddField "SICK_NAME", "病人姓名"
    AddField "US_NO", "超声检查号"
    AddField "SICK_BIRTH", "出生日期"
    AddField "SICK_SEX", "病人性别"
    '后为新加条件
    AddField "US_TIP", "超声提示"
    '前为新加条件
    AddField "CHARGE", "诊断费用"
    AddField "CLINIC", "临床诊断"
    AddField "DESCRIBE", "图象描述"
    AddField "ORGAN_NUM", "器官数目"
    AddField "SEND_DOCTOR", "送检医师"
    AddField "SEND_HOSPITAL", "送检医院"
    AddField "SICK_BEDNO", "病人床号"
    AddField "SICK_BELONG_SEC", "送检科室"
    AddField "SICK_NO", "病人号"
    AddField "SICK_TYPE", "病人类型"
    AddField "SICK_UNIT", "病人单位"
    AddField "SICK_WARD", "所属病区"
    AddField "SICK_CLASS", "病人分类"
    
End Sub

Public Sub ShellWait(sCommandLine As String)
    
    '---------------------
    '等待进程的结束
    '---------------------
    
    Dim hShell As Long
    Dim hProc As Long
    Dim lExit As Long
  
    hShell = Shell(sCommandLine, vbMaximizedFocus)
    hProc = OpenProcess(&H400, False, hShell)
    Do
        GetExitCodeProcess hProc, lExit
        DoEvents
    Loop While lExit = &H103
  
End Sub

Public Sub PopItemDetail(ctl As Control, Optional ClassName As String = vbNullString)
    
    '--------------------------
    '弹出某comboBox的内容列表
    '--------------------------
    
    With frmItemDetail
        .ClassName = IIf((ClassName = vbNullString), ctl.Tag, ClassName)
        .SelString = ctl.Text
        .Show vbModal
        If .bCancel Then Exit Sub
        ctl.Text = .SelString
    End With
    
End Sub

'Public Function OpenRS(ByVal str As String, Optional strConn As String = "System") As ADODB.Recordset
'
'    On Error GoTo ErrHandle
'
'    '-----------------------
'    '返回str所指定的记录集
'    '-----------------------
'
'    Dim NewRS As New ADODB.Recordset
'
'    NewRS.CursorLocation = adUseClient
'    Select Case strConn
'        Case "System"
'            NewRS.Open str, ConnUS, adOpenKeyset, adLockOptimistic
'        Case "Data"
'            NewRS.Open str, ConnData, adOpenKeyset, adLockOptimistic
'    End Select
'
'    Set OpenRS = NewRS
'    Exit Function
'
'ErrHandle:
'
'End Function
'
'Public Function OpenRSClient(ByVal str As String, Optional strConn As String = "System") As ADODB.Recordset
'
'    On Error GoTo ErrHandle
'
'    '-----------------------
'    '返回str所指定的记录集
'    '-----------------------
'
'    Dim NewRS As New ADODB.Recordset
'
'    NewRS.CursorLocation = adUseClient
'
'    Select Case strConn
'        Case "System"
'            NewRS.Open str, ConnUS, adOpenKeyset, adLockOptimistic
'        Case "Data"
'            NewRS.Open str, ConnData, adOpenKeyset, adLockOptimistic
'    End Select
'
'    Set OpenRSClient = NewRS
'    Exit Function
'
'ErrHandle:
'
'End Function
'
'Public Function OpenRSBatch(ByVal str As String, Optional strConn As String = "System") As ADODB.Recordset
'
'    On Error GoTo ErrHandle
'
'    '-----------------------
'    '返回str所指定的记录集
'    '-----------------------
'
'    Dim NewRS As New ADODB.Recordset
'
'    NewRS.CursorLocation = adUseClient
'
'    Select Case strConn
'        Case "System"
'            NewRS.Open str, ConnUS, adOpenStatic, adLockBatchOptimistic
'        Case "Data"
'            NewRS.Open str, ConnData, adOpenStatic, adLockBatchOptimistic
'    End Select
'
'    Set OpenRSBatch = NewRS
'    Exit Function
'
'ErrHandle:
'
'End Function

Public Function ExistRecord(TableName As String, FieldName As String, Value As String, Optional OtherCondition As String = vbNullString) As Boolean
        
    '-----------------------------------------------------
    '判断指定表中是否存在FieldName字段值为Value的记录
    '-----------------------------------------------------
    
    Dim strSQL As String
    Dim rsTemp As New ADODB.Recordset
    
    strSQL = "SELECT " & FieldName & " FROM " & TableName & " WHERE " & FieldName & " = '" & Value & "' " & OtherCondition
    
    rsTemp.Open strSQL, GDB
    
    If Not rsTemp.EOF Then
        ExistRecord = True
    Else
        ExistRecord = False
    End If
    
    Set rsTemp = Nothing

End Function