searchdcm.frm

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

VERSION 5.00
Object = "{806F1F89-D431-4F37-A387-2868CC03DCA8}#48.0#0"; "GetData.ocx"
Begin VB.Form SearchDCM 
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "相关DCM文件"
   ClientHeight    =   3195
   ClientLeft      =   2760
   ClientTop       =   3750
   ClientWidth     =   5685
   Icon            =   "SearchDCM.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   3195
   ScaleWidth      =   5685
   ShowInTaskbar   =   0   'False
   StartUpPosition =   2  '屏幕中心
   Begin VB.ListBox List1 
      Height          =   2580
      Left            =   120
      TabIndex        =   1
      Top             =   480
      Width           =   3615
   End
   Begin GetData.XPB ExitCMD 
      Height          =   495
      Left            =   4200
      TabIndex        =   2
      Top             =   1440
      Width           =   1095
      _ExtentX        =   1931
      _ExtentY        =   873
      Caption         =   "退出"
      FontColor       =   -2147483630
      BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
         Name            =   "宋体"
         Size            =   9
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
   End
   Begin GetData.XPB SaveCMD 
      Height          =   495
      Left            =   4200
      TabIndex        =   3
      Top             =   600
      Width           =   1095
      _ExtentX        =   1931
      _ExtentY        =   873
      Caption         =   "保存"
      FontColor       =   -2147483630
      BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
         Name            =   "宋体"
         Size            =   9
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
   End
   Begin VB.Label Label1 
      Height          =   255
      Left            =   240
      TabIndex        =   0
      Top             =   120
      Width           =   2655
   End
End
Attribute VB_Name = "SearchDCM"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
    
  Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
    
  Private Type BROWSEINFO
          hOwner   As Long
          pidlRoot   As Long
          pszDisplayName   As String
          lpszTitle   As String
          ulFlags   As Long
          lpfn   As Long
          lParam   As Long
          iImage   As Long
  End Type
  
Const ChunkSize = 1000
Const lngDataFile = 1
Dim DCMRS As New ADODB.Recordset
Dim DcmNum As Integer
Dim Index As Integer
Dim Chunk() As Byte
Dim lngLengh As Long
Dim intChunks As Integer
Dim intFragment As Integer
Dim InspectNo As String
Dim DCMFileName As String
Dim i As Integer

Private Sub ExitCMD_Click(Shifit As Integer)
Unload Me
End Sub

Private Sub Form_Load()

'数据库图片 到 控件
InspectNo = picquery.Text1.Text
Me.Caption = "相关DCM文件" & "（检查编号：" & InspectNo & "）"
DCMRS.Open "SELECT * FROM DicomIMG where InspectId='" & InspectNo & "'", conn, adOpenDynamic, adLockOptimistic
DcmNum = DCMRS.RecordCount
Index = 1
Label1.Caption = "该编号记录中共包含 " & DcmNum & " 个DCM文件"
  Do While DCMRS.EOF = False
         DCMFileName = InspectNo & "-" & Index & ".dcm"
         Open App.path + "\temp\" & DCMFileName For Binary Access Write As lngDataFile
            lngLengh = DCMRS!DicomPic.ActualSize
            intChunks = lngLengh \ ChunkSize
            intFragment = lngLengh Mod ChunkSize
            ReDim Chunk(intFragment)
            Chunk() = DCMRS!DicomPic.GetChunk(intFragment)
            Put lngDataFile, , Chunk()
            For i = 1 To intChunks
               ReDim Buffer(ChunkSize)
               Chunk() = DCMRS!DicomPic.GetChunk(ChunkSize)
               '建立图片临时文件
               Put lngDataFile, , Chunk()
            Next i
          Close lngDataFile
          List1.AddItem (DCMFileName)
          DCMRS.MoveNext
          Index = Index + 1
        Loop
DCMRS.Close
End Sub



Private Sub Form_Unload(Cancel As Integer)
If DcmNum <> 0 Then
 For i = 0 To DcmNum - 1
   Kill App.path & "\temp\" & List1.List(i)
 Next i
End If
End Sub

Private Sub SaveCMD_Click(Shifit As Integer)
 Dim BI As BROWSEINFO
 Dim lngIDList As Long
 Dim strPath As String * 255
 Dim FilePath As String
 BI.lpszTitle = "请选择保存文件夹"
 lngIDList = SHBrowseForFolder(BI)
 If lngIDList = 0 Then
    Exit Sub
 End If
 Call SHGetPathFromIDList(ByVal lngIDList, ByVal strPath)
 FilePath = left(strPath, InStr(strPath, Chr(0)) - 1)
 If FilePath = "" Then
   MsgBox "您未正确选择保存文件夹！", vbExclamation, "错误提示"
 Else
   For i = 0 To DcmNum - 1
     FileCopy App.path & "\temp\" & List1.List(i), FilePath & "\" & List1.List(i)
   Next i
 End If
End Sub