modapis.bas

1、以DLL形式提供医生工作站 2、 根据【检查项目】

    End If
    
    
    On Error GoTo ErrHandler
    Dim wfd As WIN32_FIND_DATA
    Dim hFile
    Dim ftNew As FILETIME
    Dim ftNext   As FILETIME
    Dim strCurFileName As String
    Dim strPath As String
    
    strPath = strDirectoryPath
    strCurFileName = ""
    If Right(strPath, 1) <> "" Then
        strPath = strPath + "\"
    End If
    hFile = FindFirstFile(strPath + "*.*", wfd)
    If hFile = INVALID_HANDLE_VALUE Then
       GetFileBetweenTimes = ""
    Else
        Dim b As Boolean
        
        Dim n1 As Long
        Dim n2 As Long
        
        If wfd.dwFileAttributes <> FILE_ATTRIBUTE_DIRECTORY Then
            n1 = CompareFileTime(wfd.ftLastAccessTime, ftTime1)
            n2 = CompareFileTime(wfd.ftLastAccessTime, ftTime2)
            If n1 > 0 And n2 < 0 Then
                ftNew.dwHighDateTime = wfd.ftLastAccessTime.dwHighDateTime
                ftNew.dwLowDateTime = wfd.ftLastAccessTime.dwLowDateTime
                strCurFileName = wfd.cFileName
            End If
        End If
        
        b = FindNextFile(hFile, wfd)
        Do While b
            Dim str As String
            If wfd.dwFileAttributes <> FILE_ATTRIBUTE_DIRECTORY Then
                str = wfd.cFileName
                n1 = CompareFileTime(wfd.ftLastAccessTime, ftTime1)
                n2 = CompareFileTime(wfd.ftLastAccessTime, ftTime2)
                If n1 > 0 And n2 < 0 Then
                    ftNew.dwHighDateTime = wfd.ftLastAccessTime.dwHighDateTime
                    ftNew.dwLowDateTime = wfd.ftLastAccessTime.dwLowDateTime
                    strCurFileName = wfd.cFileName
                    
                    Exit Do
                End If
                
            End If
            
            b = FindNextFile(hFile, wfd)
        Loop
            
        b = FindNextFile(hFile, wfd)
        Do While b
            If wfd.dwFileAttributes <> FILE_ATTRIBUTE_DIRECTORY Then
                n1 = CompareFileTime(wfd.ftLastAccessTime, ftTime1)
                n2 = CompareFileTime(wfd.ftLastAccessTime, ftTime2)
                If n1 > 0 And n2 < 0 And CompareFileTime(ftNext, ftNew) > 0 Then
                    ftNew = ftNext
                    strCurFileName = wfd.cFileName
                End If
            End If
            b = FindNextFile(hFile, wfd)
        Loop
            

            
                
    End If
    strCurFileName = DelInvaildChr(strCurFileName)
    GetFileBetweenTimes = strCurFileName
    Exit Function
ErrHandler:
    GetFileBetweenTimes = ""
    If hFile <> INVALID_HANDLE_VALUE Then
        FindClose hFile
    End If
End Function




Public Function DelInvaildChr(str As String) As String
    On Error Resume Next
    Dim i As Long
    For i = Len(str) To 1 Step -1
        If Asc(Mid(str, i, 1)) <> 0 And Asc(Mid(str, i, 1)) <> 32 Then
            DelInvaildChr = left(str, i)
            Exit For
        End If
    Next
End Function

Public Function GetNewestFileName(ByVal strDirectoryPath As String) As String
    On Error GoTo ErrHandler
    
    Dim wfd As WIN32_FIND_DATA
    Dim hFile
    Dim ftNew As FILETIME
    Dim ftNext   As FILETIME
    Dim strCurFileName As String
    Dim strPath As String
    
    strPath = strDirectoryPath
    strCurFileName = ""
    If Right(strPath, 1) <> "" Then
        strPath = strPath + "\"
    End If
    hFile = FindFirstFile(strPath + "*.*", wfd)
    If hFile = INVALID_HANDLE_VALUE Then
       GetNewestFileName = ""
    Else
        ftNew.dwHighDateTime = wfd.ftLastWriteTime.dwHighDateTime
        ftNew.dwLowDateTime = wfd.ftLastWriteTime.dwLowDateTime
        strCurFileName = wfd.cFileName
        While hFile <> INVALID_HANDLE_VALUE
            hFile = FindNextFile(hFile, wfd)
            ftNext.dwHighDateTime = wfd.ftLastWriteTime.dwHighDateTime
            ftNext.dwLowDateTime = wfd.ftLastWriteTime.dwLowDateTime
            
            If CompareFileTime(ftNext, ftNew) = 1 Then
                ftNew = ftNext
                strCurFileName = wfd.cFileName
            End If
        Wend
    End If
    
    GetNewestFileName = strCurFileName
    Exit Function
ErrHandler:
    GetNewestFileName = ""
    If hFile <> INVALID_HANDLE_VALUE Then
        FindClose hFile
    End If
End Function



' 返回光驱的盘符(字母)
Public Function GetCDROM() As String
On Error GoTo ErrHandler
     
     Dim strDrives As String
     Dim Fso As New FileSystemObject           '创建 FSO 对象的一个实例
     Dim FsoDrive As Drive, FsoDrives As Drives '定义驱动器、驱动器集合对象
     Set FsoDrives = Fso.Drives
     For Each FsoDrive In FsoDrives '遍历所有可用的驱动器
     If FsoDrive.DriveType = CDRom Then '如果驱动器的类型为 CDrom
     strDrives = strDrives + CStr(FsoDrive.DriveLetter) + ":"  '输出其盘符
     Else
     'GetCDROM = ""
     End If
     Next
     Set Fso = Nothing
     Set FsoDrive = Nothing
     Set FsoDrives = Nothing
     
     GetCDROM = strDrives
     Exit Function
ErrHandler:
    GetCDROM = ""
End Function

'将DCM图片进行初始化
Public Function InitDcm(ByRef dcmPara As DICOMX) As Boolean
On Error GoTo ErrHandler
    Dim dcm As New DcmInit
    dcmPara.LicenseCode = dcm.MyDcmInit()
    InitDcm = dcmPara.LicenseIsOK
    
    Exit Function
ErrHandler:
    InitDcm = False
End Function



'枚举本系统进程，查询strProcessName对应的进程名称
'声明为MyEnumProcess()，以与系统自身的EnumProcess()进行区别
'如果包含相同进程名称的进程数大于1，则nProcessId为最后一个枚举的进程的ID
'strProcessPath为最后一个枚举的进程的全路径
'返回值：返回符合strProcessName的进程个数
Public Function MyEnumProcess(ByVal strProcessName As String, ByRef nProcessId As Long, _
    ByRef strProcessFullPath As String) As Integer
    On Error GoTo ErrHandler
    
    Dim nProcessCount As Long
    nProcessCount = 0
    
    
    Dim process As PROCESSENTRY32
    Dim hSnapShot As Long
    Dim l1 As Long
    
    hSnapShot = CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0)


    If hSnapShot < 0 Then
        nProcessId = 0
        strProcessFullPath = ""
        MyEnumProcess = 0
        Exit Function
    End If

    process.dwSize = PROCESS_FILE_MAX_PATH

    If (Process32First(hSnapShot, process)) = False Then
        nProcessId = 0
        strProcessFullPath = ""
        MyEnumProcess = 0
        Exit Function
    End If
    
    Do
        strProcessFullPath = Space(PROCESS_FILE_MAX_PATH)
        'InStr可能会带来问题，暂时这样处理，应改为=比较  2008-08-20  17:11
        If InStr(LCase(process.szExeFile), LCase(strProcessName)) <> 0 Then
            nProcessCount = nProcessCount + 1
            nProcessId = process.th32ProcessID
            
            Dim hProcess As Long
            Dim cbNeed     As Long
            Dim hModule(1) As Long
            Dim lRet As Long
            hProcess = OpenProcess(PROCESS_QUERY_INFORMATION Or PROCESS_TERMINATE Or PROCESS_VM_READ, _
                False, process.th32ProcessID)
     
            lRet = EnumProcessModules(hProcess, hModule(1), 1, cbNeed)
            Call GetModuleFileNameEx(hProcess, hModule(0), strProcessFullPath, PROCESS_FILE_MAX_PATH)
            process.szExeFile = Space(PROCESS_FILE_MAX_PATH)
        End If
    
    Loop Until (Process32Next(hSnapShot, process) < 1)


    l1 = CloseHandle(hSnapShot)
    
    MyEnumProcess = nProcessCount
    Exit Function
ErrHandler:
    nProcessId = 0
    strProcessFullPath = ""
    MyEnumProcess = 0
End Function

  '模   块   名：EnumModule
  '功         能：读出一个进程中所有的模块名和模块路径（第一个就是程序本身的路径）
  '返   回   值：暂无（大家也可以写入错误处理）
  '参         数：EnumModule(进程的标识符，读出的模块数组)
  '调用方法：（Form1、Command1、Text1、List1）各一个
          'Private   Sub   Command1_Click()
                  'Dim   Arr()   As   String
                  'EnumModule   CLng(Text1.Text),   Arr
                  'Dim   i
                  'For   Each   i   In   Arr
                          'List1.AddItem   i
                  'Next
                  'MsgBox   List1.ListCount
          'End   Sub
Public Function EnumModule(ByVal hProc As Long, ByRef sModule() As String) As Long
          Dim lRet     As Long     '返回值
          Dim i     As Long     '循环计数器
          Dim hProcess     As Long     '进程标识
          Dim hModule()     As Long     '进程中的所有模块
          Dim ModName     As String     '模块名
          Dim ModFilePath     As String     '模块路径
          Dim cbNeed     As Long     '偶也不知是做什么的，好像是计录进程中的模块数量cbNeed   /   4
           
          hProcess = OpenProcess(PROCESS_QUERY_INFORMATION Or PROCESS_VM_READ, 0&, hProc)
          ReDim hModule(1) As Long
          lRet = EnumProcessModules(hProcess, hModule(1), 1, cbNeed)
          ReDim hModule(1 To cbNeed / 4) As Long
          lRet = EnumProcessModules(hProcess, hModule(1), cbNeed, cbNeed)
           
          For i = 1 To cbNeed / 4
                  If hModule(i) Then
                          ModName = String(MAX_PATH, 0)
                          GetModuleBaseName hProcess, hModule(i), ModName, Len(ModName)
                          ModName = left(ModName, InStr(1, ModName, Chr(0)) - 1)
                           
                          ModFilePath = String(MAX_PATH, 0)
                          GetModuleFileNameEx hProcess, hModule(i), ModFilePath, Len(ModFilePath)
                          ModFilePath = left(ModFilePath, InStr(1, ModFilePath, Chr(0)) - 1)
                          ReDim Preserve sModule(i - 1) As String
                          sModule(i - 1) = ModName & "=" & ModFilePath
                  End If
          Next
          CloseHandle hProcess
End Function

'定时检测SCP进程
Public Sub MonitorProcess()
    Dim process As PROCESSENTRY32
    Dim l As Long
    Dim l1 As Long
    Dim mName As String

    Dim i As Integer
    l = CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0)

    If l Then
        process.dwSize = 1060

        If (Process32First(l, process)) Then

            Dim strProcessFullPath As String
            Dim nProcessId As Long
            Dim nProcessCount As Long
            Dim nRtn As Integer
            Dim strScpExePath As String
            Dim strKillExePath As String
            strScpExePath = "htscp.exe"
            
            nProcessId = MyEnumProcess("htscp.exe", nProcessId, strProcessFullPath)
            If nProcessId > 1 Then
                nRtn = ShellExecute(0, "open", "Kill.exe", strScpExePath, App.Path, vbHide)
                If nRtn > 32 Then
                Else
                    'MsgBox "接收服务关闭失败!", vbExclamation, "提示"
                End If
            ElseIf nProcessId = 1 Then
                If process.szExeFile <> App.Path & "\htscp.exe" Then
                    nRtn = ShellExecute(0, "open", strKillExePath, strScpExePath, App.Path, vbHide)
                    If nRtn > 32 Then
                    Else
                       'MsgBox "接收服务关闭失败!", vbExclamation, "提示"
                    End If
                End If
            End If
    
    
'begin====启动接收服务===modProgramEntry=========================================================
            Const SECTION_WORKSTATION = "WORKSTATION"
            Const KEY_TEMPDCM_LOCAL_ROOT = "TEMPDCM_LOCAL_ROOT"
            Const CONFIG_FILE = "htpacs.ini"
    
            Dim strTempDcmRoot As String
            
            Dim nRet As Integer
            Dim strScpDirectory As String
            Dim strConfigFilePath As String
            strConfigFilePath = App.Path + "\" + CONFIG_FILE
            strTempDcmRoot = Space(256)
            nRet = GetPrivateProfileString(SECTION_WORKSTATION, KEY_TEMPDCM_LOCAL_ROOT, "", strTempDcmRoot, _
                256, strConfigFilePath)
            strTempDcmRoot = left(strTempDcmRoot, nRet)
            If Trim(strTempDcmRoot) <> "" Then
    '        strScpDirectory = App.Path & "\" & SCP_DIRECTORY
                strScpDirectory = Trim(strTempDcmRoot)
            End If

            strScpExePath = App.Path & "\htscp.exe"
            nRtn = ShellExecute(0, "open", strScpExePath, "  -od " & strScpDirectory & " 104 -xcr move_dcm_ct.exe", _
                App.Path, vbHide)
            If nRtn > 32 Then
            Else
                'MsgBox "接收服务启动失败!", vbExclamation, "提示"
            End If
'end====启动接收服务============================================================
   
        End If

    End If

    l1 = CloseHandle(l)
    
End Sub