dlgscanphoto.frm

本系统可用于医院和专业体检中心的健康体检管理

Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False

Option Explicit
Dim m_blnAccept As Boolean
Dim m_strScanFile As String

Private Sub cmdAccept_Click()
    Call capEditCopy(lwndC)
    picChild.PICTURE = Clipboard.GetData()
    
    '显示摄像
    picParent.ZOrder 0
    Call SetScrollBar
End Sub

Private Sub cmdCancel_Click()
    m_blnAccept = False
    Unload Me
End Sub

Private Sub cmdOK_Click()
    If picChild.PICTURE = 0 Then
        MsgBox "请扫描图像！", vbInformation, "提示"
        Exit Sub
    Else
        Call SavePicture(picChild.PICTURE, m_strScanFile)
'        Dim f As New FileSystemObject
'        f.CopyFile picChild.Tag, m_strScanFile, True
'        Set f = Nothing
    End If
    
    m_blnAccept = True
    Unload Me
End Sub

Private Sub cmdPhotography_Click()
    '显示摄像窗口
    picPhotography.ZOrder 0
    fsbVertical.Visible = False
    fsbHorizontal.Visible = False
    Picture1.Visible = False
End Sub

Private Sub cmdScan_Click()
On Error GoTo ErrMsg
    Dim Status
    Dim lngRet As Long
    Dim intT As Integer
    
    lngRet = TWAIN_AcquireToClipboard(Me.hwnd, intT)
    picChild.PICTURE = Clipboard.GetData(vbCFDIB)
    
    picParent.ZOrder 0
    Call SetScrollBar
    
    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Description)
    ErrMsg Status
ExitLab:
    '
End Sub

'被调函数
Public Function ShowXMuScanPhoto(ByVal lngGUID As String, ByVal strDXID As String, _
        ByVal strXXID As String, Optional ByVal strFileName As String, _
        Optional ByVal blnEdit As Boolean = False) As String
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rstemp As ADODB.Recordset
    Dim strDXPYSX As String
    Dim strXXPYSX As String
    
    '***********************************************************************
    '体检项目的图像浏览/获取
    '***********************************************************************
    m_strScanFile = GetTempPathW & "scan_" & strXXID & ".jpg"
    If strFileName <> "" Then
        picChild.PICTURE = LoadPicture(strFileName)
    Else
        If Dir(m_strScanFile) <> "" Then Kill m_strScanFile
        
        '拼音缩写
        strSQL = "select DXPYSX,XXPYSX from SET_DX,SET_ZH_DATA,SET_XX" _
                & " where SET_DX.DXID='" & strDXID & "'" _
                & " and SET_XX.XXID='" & strXXID & "'" _
                & " and SET_DX.DXID=SET_ZH_DATA.DXID" _
                & " and SET_ZH_DATA.XXID=SET_XX.XXID"
        Set rstemp = New ADODB.Recordset
        rstemp.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
        If Not rstemp.EOF Then
            strDXPYSX = rstemp("DXPYSX")
            strXXPYSX = rstemp("XXPYSX")
            rstemp.Close
            
            '获取图像
            strSQL = "select [" & strXXPYSX & PHOTO_FIELD & "]" _
                    & " from [DATA_" & strDXPYSX & "]" _
                    & " where GUID=" & lngGUID
            Set rstemp = New ADODB.Recordset
            rstemp.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
            If Not rstemp.EOF Then
                If Not IsNull(rstemp(0)) Then
                    If ColumnToFile(rstemp.Fields(0), m_strScanFile, rstemp) Then
                        picChild.PICTURE = LoadPicture(m_strScanFile)
                    End If
                End If
            End If
        End If
    End If
    
    '检查是否已有图像
    If picChild.PICTURE <> 0 Then
        Call SetScrollBar
    Else
        'Begin photography
        cmdPhotography_Click
    End If
    
    If Not blnEdit Then
        cmdSelectCamara.Enabled = blnEdit
        cmdPhotography.Enabled = blnEdit
        cmdAccept.Enabled = blnEdit
        
        cmdSelectScan.Enabled = blnEdit
        cmdScan.Enabled = blnEdit
        cmdOK.Enabled = blnEdit
    End If
    
    Me.Show vbModal
    
    If Not m_blnAccept Then
        m_strScanFile = ""
    End If
    
    ShowXMuScanPhoto = m_strScanFile
    
    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    '
End Function

'设置滚动条
Private Sub SetScrollBar()
    With fsbHorizontal
        If picParent.ScaleWidth < picChild.Width Then
            .Max = picChild.Width - picParent.ScaleWidth + BorderSpace
            .Min = 2
            .SmallChange = IIf(Int(.Max / 20) < 1, 1, Int(.Max / 10))
            .LargeChange = IIf(5 * .SmallChange <= .Max, 5 * .SmallChange, .Max)
            .Visible = True
            
            fsbHorizontal_Change
        Else
            .Visible = False
            picChild.Left = (picParent.ScaleWidth - picChild.Width) / 2
'            fsbHorizontal_Change
        End If
    End With
    
    With fsbVertical
        If picParent.ScaleHeight < picChild.Height Then
            .Max = picChild.Height - picParent.ScaleHeight + BorderSpace
            .Min = 2
            .SmallChange = IIf(Int(.Max / 20) < 1, 1, Int(.Max / 10))
            .LargeChange = IIf(5 * .SmallChange <= .Max, 5 * .SmallChange, .Max)
    '        .Value = 0
            .Visible = True
            
            fsbVertical_Change
        Else
            .Visible = False
            picChild.Top = (picParent.ScaleHeight - picChild.Height) / 2
'            fsbVertical_Change
        End If
    End With

    Picture1.Visible = fsbHorizontal.Visible And fsbVertical.Visible
End Sub

Private Sub cmdSelectSource_Click()
    Dim lngRet As Long
    
    lngRet = TWAIN_SelectImageSource(Me.hwnd)
End Sub

Private Sub cmdSelectCamara_Click()
'   /*
'    * Display the Video Source dialog when "Source" is selected from the
'    * menu bar.
'    */
    
    capDlgVideoSource lwndC
End Sub

Private Sub cmdSelectScan_Click()
    Dim lngRet As Long
    
    lngRet = TWAIN_SelectImageSource(Me.hwnd)
End Sub

Private Sub Form_Load()
    Dim lpszName As String * 100
    Dim lpszVer As String * 100
    Dim Caps As CAPDRIVERCAPS
    
    '//Create Capture Window
'    capGetDriverDescriptionA 0, lpszName, 100, lpszVer, 100  '// Retrieves driver info
    lwndC = capCreateCaptureWindowA(lpszName, _
            WS_THICKFRAME Or WS_VISIBLE Or WS_CHILD, _
            0, 0, Me.picPhotography.ScaleWidth, Me.picPhotography.ScaleHeight, _
            Me.picPhotography.hwnd, 0)

    '// Set title of window to name of driver
'    SetWindowText lwndC, lpszName
    
'    lwndC = Me.Picture1.hWnd
'    Call SetResize(Me.Picture1.hWnd, Me.hWnd)
    
    '// Set the video stream callback function
    capSetCallbackOnStatus lwndC, AddressOf MyStatusCallback
    capSetCallbackOnError lwndC, AddressOf MyErrorCallback
    
    '// Connect the capture window to the driver
    If capDriverConnect(lwndC, 0) Then
        '/////
        '// Only do the following if the connect was successful.
        '// if it fails, the error will be reported in the call
        '// back function.
        '/////
        '// Get the capabilities of the capture driver
        capDriverGetCaps lwndC, VarPtr(Caps), Len(Caps)
        
        '// If the capture driver does not support a dialog, grey it out
        '// in the menu bar.
        If Caps.fHasDlgVideoSource = 0 Then cmdSelectCamara.Enabled = False
'        If Caps.fHasDlgVideoFormat = 0 Then mnuFormat.Enabled = False
'        If Caps.fHasDlgVideoDisplay = 0 Then mnuDisplay.Enabled = False
        
        '// Turn Scale on
        capPreviewScale lwndC, True
            
        '// Set the preview rate in milliseconds
        capPreviewRate lwndC, 66
        
        '// Start previewing the image from the camera
        capPreview lwndC, True
            
        '// Resize the capture window to show the whole image
        ResizeCaptureWindow lwndC
    End If
End Sub

Private Sub fsbHorizontal_Change()
    picChild.Left = -(fsbHorizontal.Value - BorderSpace / 2)
End Sub

Private Sub fsbHorizontal_Scroll()
    fsbHorizontal_Change
End Sub

Private Sub fsbVertical_Change()
    picChild.Top = -(fsbVertical.Value - BorderSpace / 2)
End Sub

Private Sub fsbVertical_Scroll()
    fsbVertical_Change
End Sub

Private Sub XPCommandButton1_Click()
    Dim strFileName As String
    
    strFileName = GetFileName(Me.CommonDialog1, "图像文档（*.jpg）|*.jpg", _
            "选择心电图文件", , READFILE)
    
    If strFileName <> "" Then
        '这个地方需要验证模板文件的有效性
    '  picChild.PICTURE = strFileName
     Set picChild.PICTURE = LoadPicture(strFileName)
     picChild.Tag = strFileName
 picParent.ZOrder 0
    Call SetScrollBar
    End If
End Sub