picselect.frm

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

VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "Comdlg32.ocx"
Begin VB.Form picquery 
   Caption         =   "图像查询/提取"
   ClientHeight    =   8385
   ClientLeft      =   60
   ClientTop       =   750
   ClientWidth     =   10875
   DrawMode        =   3  'Not Merge Pen
   Icon            =   "picselect.frx":0000
   LinkTopic       =   "Form9"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   8385
   ScaleWidth      =   10875
   StartUpPosition =   2  '屏幕中心
   WindowState     =   2  'Maximized
   Begin MSComDlg.CommonDialog SaveDialog 
      Left            =   6960
      Top             =   840
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
   End
   Begin VB.CommandButton CMDsel 
      Caption         =   "查询"
      Default         =   -1  'True
      Height          =   375
      Left            =   7560
      TabIndex        =   1
      Top             =   7680
      Visible         =   0   'False
      Width           =   1215
   End
   Begin VB.TextBox Text1 
      Height          =   375
      Left            =   5760
      TabIndex        =   0
      Top             =   7680
      Visible         =   0   'False
      Width           =   1335
   End
   Begin VB.PictureBox DcmTxtBox 
      AutoRedraw      =   -1  'True
      AutoSize        =   -1  'True
      FillStyle       =   2  'Horizontal Line
      Height          =   3615
      Left            =   0
      ScaleHeight     =   3555
      ScaleWidth      =   5595
      TabIndex        =   3
      Top             =   0
      Width           =   5655
      Begin VB.Image Image1 
         Height          =   2000
         Index           =   0
         Left            =   840
         Stretch         =   -1  'True
         Top             =   720
         Width           =   2000
      End
   End
   Begin VB.Label Label1 
      Caption         =   "请输入检查编号："
      Height          =   255
      Left            =   3960
      TabIndex        =   2
      Top             =   7800
      Visible         =   0   'False
      Width           =   1575
   End
   Begin VB.Menu rightmouse 
      Caption         =   "aa"
      Visible         =   0   'False
      Begin VB.Menu picmagnify 
         Caption         =   "放大"
      End
      Begin VB.Menu lineme 
         Caption         =   "-"
      End
      Begin VB.Menu SaveAs 
         Caption         =   "另存为…"
      End
      Begin VB.Menu line2 
         Caption         =   "-"
      End
      Begin VB.Menu unloadmeform 
         Caption         =   "退出"
      End
   End
   Begin VB.Menu MenuSel 
      Caption         =   "查询(&S)"
   End
   Begin VB.Menu BeforPic 
      Caption         =   "上一张(&B)"
      Visible         =   0   'False
   End
   Begin VB.Menu NextPic 
      Caption         =   "下一张(&N)"
      Visible         =   0   'False
   End
   Begin VB.Menu AboutDCM 
      Caption         =   "相关DCM文件(&D)"
   End
   Begin VB.Menu EXIT 
      Caption         =   "退出(&E)"
   End
End
Attribute VB_Name = "picquery"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim Chunk() As Byte
Dim lngLengh As Long
Dim intChunks As Integer
Dim intFragment As Integer
Const ChunkSize = 1000
Const lngDataFile = 1
Dim Twidth, Theight As Integer '保存被放大图片放大前的宽、高度
Public ImgIndexTop, ImgIndexLeft As Integer  '保存被放大图片放大前的坐标
Public f As Integer     '/////////////////////
Public ImageInt As Integer   '//////////

Private Sub AboutDCM_Click()
Dim DCMRS As New ADODB.Recordset
DCMRS.Open "select InspectId from DicomIMG where InspectId='" & Text1.Text & "'", conn, adOpenDynamic, adLockOptimistic
If DCMRS.EOF Then
  MsgBox "该编号记录中没有DCM文件", vbExclamation, "提示"
Else
  SearchDCM.show vbModal
End If
DCMRS.Close
End Sub

Private Sub BeforPic_Click()   '显示放大的上一张图片
   Image1(f).Width = Twidth
   Image1(f).Height = Theight
   Image1(f).Visible = False
   Image1(f).left = ImgIndexLeft
   Image1(f).top = ImgIndexTop
   Image1(f).Visible = False
   f = f - 1
   ImgIndexLeft = Image1(f).left
   ImgIndexTop = Image1(f).top
   Twidth = Image1(f).Width
   Theight = Image1(f).Height
   If Image1(f).Picture.Height > Image1(f).Picture.Width Then
      Image1(f).Height = DcmTxtBox.Height * 0.9
      Image1(f).Width = Image1(f).Height * Twidth / Theight
   Else
      Image1(f).Width = DcmTxtBox.Height * 0.9
      Image1(f).Height = Image1(f).Width / Twidth * Theight
   End If
   Image1(f).left = DcmTxtBox.Width - DcmTxtBox.Height * 0.95
   Image1(f).top = (DcmTxtBox.Height - Image1(f).Height - 300) / 2
   Image1(f).Visible = True '显示放大的图片
   BeforPic.Enabled = True
   NextPic.Enabled = True
   If f = 0 Then BeforPic.Enabled = False
   DcmTxtBox.Cls
   Call PrintDcmHead(f)
End Sub

Private Sub CMDSel_Click()
Dim DcmBmpRS As New ADODB.Recordset
Dim DcmN As Integer
Call UnloadImg
DcmTxtBox.Cls
Call Form_Resize '初始化控件的位置
picmagnify.Caption = "放大"
DcmN = 0
BeforPic.Visible = False
NextPic.Visible = False
If conntoserver.conntrue = False Then conntoserver.conntoserver
Call UserPowerMD.AddSub(loginpower)
If PowPurview2 = 1 Then
    DcmBmpRS.Open "select * from MethedPic where InsPectID='" & Text1.Text & "' order by InspectPicNo", conn, adOpenDynamic, adLockOptimistic
    If DcmBmpRS.EOF Then
       Me.Caption = "图像查询/提取"
       MsgBox "对不起,没有要查询的图片", vbExclamation + vbOKOnly, "提示"
    Else
       Me.Caption = "图像查询/提取——检查编号 " & Text1.Text
       Do While DcmBmpRS.EOF = False
         Open App.path + "\temp\" & "pictempDcm.bmp" For Binary Access Write As lngDataFile
            lngLengh = DcmBmpRS!PicImage.ActualSize
            intChunks = lngLengh \ ChunkSize
            intFragment = lngLengh Mod ChunkSize
            ReDim Chunk(intFragment)
            Chunk() = DcmBmpRS!PicImage.GetChunk(intFragment)
            Put lngDataFile, , Chunk()
            For i = 1 To intChunks
               ReDim Buffer(ChunkSize)
               Chunk() = DcmBmpRS!PicImage.GetChunk(ChunkSize)
               '建立图片临时文件
               Put lngDataFile, , Chunk()
            Next i
          Close lngDataFile
          Filename = App.path + "\temp\" & "pictempDcm.bmp"
          Image1(DcmN).Picture = LoadPicture(Filename)
          Image1(DcmN).Width = Image1(DcmN).Height * Image1(DcmN).Picture.Width / Image1(DcmN).Picture.Height
          If DcmN > 0 Then
            Image1(DcmN).left = Image1(DcmN - 1).left + Image1(DcmN - 1).Width + 100
            If (Image1(DcmN).left + Image1(DcmN).Width) <= DcmTxtBox.Width Then
              Image1(DcmN).top = Image1(DcmN - 1).top
            Else
              Image1(DcmN).left = 200
              Image1(DcmN).top = Image1(DcmN - 1).top + Image1(DcmN - 1).Height + 100
            End If
          End If
          Image1(DcmN).Visible = True
          DcmN = DcmN + 1
          Load Image1(DcmN)
          DcmBmpRS.MoveNext