frmcustom.frm

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

    strSQL = "delete from " & strTable _
            & " where BBID='" & strBBID & "'"
    Set cmd = New ADODB.Command
    Set cmd.ActiveConnection = GCon
    cmd.CommandText = strSQL
    cmd.Execute
    
    
    For Each objControl In Me.Controls
        If (objControl.name <> "ReSize1") And (objControl.name <> "CommonDialog1") Then
            '只处理在图片框里面的控件
            If objControl.Container.name = picChild.name Then
                '索引为零的那部分不予处理；隐藏的控件不予处理
                If (objControl.Index > 0) And (objControl.Visible = True) Then
                    strSQL = ""
                    blnPhoto = False
                    If TypeOf objControl Is Line Then
                        '线条
                        strSQL = "insert into " & strTable & " values(" _
                                & "'" & strBBID & "'" _
                                & "," & objControl.Index _
                                & "," & WLine _
                                & ",null" _
                                & "," & objControl.X1 _
                                & "," & objControl.Y1 _
                                & "," & objControl.X2 _
                                & "," & objControl.Y2 _
                                & ",null,null,null" _
                                & ")"
                                
                    ElseIf (TypeOf objControl Is TextBox) And (objControl.name = "txtCaption") Then
                        '标签
                        strFormat = objControl.FontName _
                                & "," & objControl.FontSize _
                                & "," & objControl.FontBold _
                                & "," & objControl.FontItalic _
                                & "," & objControl.FontUnderline _
                                & "," & objControl.Alignment _
                                & ",0"
                        
                        strSQL = "insert into " & strTable & " values(" _
                                & "'" & strBBID & "'" _
                                & "," & objControl.Index _
                                & "," & WText _
                                & ",'" & strFormat & "'" _
                                & "," & objControl.Left _
                                & "," & objControl.Top _
                                & "," & objControl.Width _
                                & "," & objControl.Height _
                                & ",'" & objControl.Text & "'" _
                                & ",null,null" _
                                & ")"
                    ElseIf TypeOf objControl Is TextBox And (objControl.name = "txtAuto") Then
                        '动态文本
                        strFormat = objControl.FontName _
                                & "," & objControl.FontSize _
                                & "," & objControl.FontBold _
                                & "," & objControl.FontItalic _
                                & "," & objControl.FontUnderline _
                                & "," & objControl.Alignment _
                                & ",0"
                        
                        strSQL = "insert into " & strTable & " values(" _
                                & "'" & strBBID & "'" _
                                & "," & objControl.Index _
                                & "," & WAuto _
                                & ",'" & strFormat & "'" _
                                & "," & objControl.Left _
                                & "," & objControl.Top _
                                & "," & objControl.Width _
                                & "," & objControl.Height _
                                & ",'" & objControl.Text & "'" _
                                & ",'" & objControl.Tag & "'" _
                                & ",null" _
                                & ")"
                    ElseIf TypeOf objControl Is PictureBox Then
                        '图片
                        strSQL = "insert into " & strTable & " values(" _
                                & "'" & strBBID & "'" _
                                & "," & objControl.Index _
                                & "," & WPhoto _
                                & ",null" _
                                & "," & objControl.Left _
                                & "," & objControl.Top _
                                & "," & objControl.Width _
                                & "," & objControl.Height _
                                & ",null,null,null" _
                                & ")"
                        blnPhoto = True
                    End If
                    
                    '写入数据库
                    If strSQL <> "" Then
                        cmd.CommandText = strSQL
                        cmd.Execute
                        
                        '如果是图片，则添加图片字段
                        If blnPhoto = True Then
                            If objControl.PICTURE <> 0 Then
                                '说明存在图片，需要保存
                                '首先把图片保存到临时文件中
                                If Dir(mstrTempFile) <> "" Then Kill mstrTempFile
                                SavePicture objControl.PICTURE, mstrTempFile
                                
                                '把图片写入到数据库
                                strSQL = "select * from " & strTable _
                                        & " where BBID='" & strBBID & "'" _
                                        & " and ReportIndex=" & objControl.Index _
                                        & " and ReportType=" & WPhoto
                                Set rsTemp = New ADODB.Recordset
                                rsTemp.Open strSQL, GCon, adOpenDynamic, adLockOptimistic
                                WriteToDB rsTemp("ReportPhoto"), mstrTempFile
                                rsTemp.Update
                                rsTemp.Close
                            End If
                        End If
                    End If
                End If
            End If
        End If
    Next
    
    cmdSave.Enabled = False
    
    GoTo ExitLab
    
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Me.MousePointer = vbDefault
    '****************************************************************
    '                   保存过后恢复为象素单位
    '****************************************************************
    picChild.ScaleMode = vbPixels
End Sub

Private Sub Form_Click()
'    menuSel = brank
End Sub

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
    If KeyCode = vbKeyDelete Then
        Select Case menuSel
            Case Line
                '线条
                linLine(mintIndex).Visible = False
                picChild.Refresh
                cmdSave.Enabled = True
            Case Text
                '标签
                txtCaption(mintIndex).Visible = False
                cmdSave.Enabled = True
            Case Auto
                '动态文本
                txtAuto(mintIndex).Visible = False
                cmdSave.Enabled = True
            Case WPhoto
                '图片
'                picPhoto(mintIndex).Visible = False
'                cmdSave.Enabled = True
            Case Brank
                '空白
        End Select
    End If
End Sub


Private Sub Form_Load()
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rsReport As ADODB.Recordset
    Dim ctl As Control
    Dim i As Long
        
    Me.Show
'    Me.WindowState = 2
    
    picChild.Width = 210
    picChild.Height = 297
    SetScrollBar
    
    
    PI = 4 * Atn(1)
'    For Each ctl In Me
'        If TypeOf ctl Is Line Then
'            Set aLine = ctl
'            Call SetRegion
'            i = i + 1
'        End If
'    Next
    
    '获取临时图片路径
    mstrTempFile = Environ("Temp") & "\dhtj.jpg"
    
    '获取已经定义的报表名称
    strSQL = "select * from REPORT_MC" _
            & " order by BBID"
    Set rsReport = New ADODB.Recordset
    rsReport.Open strSQL, GCon, adOpenStatic, adLockOptimistic
    If rsReport.RecordCount > 0 Then
        rsReport.MoveFirst
        Do
            cmbReport.AddItem rsReport("BBMC")
            cmbReport.ItemData(cmbReport.NewIndex) = rsReport("BBID")
            
            rsReport.MoveNext
        Loop Until rsReport.EOF
        '选中最后一张
        cmbReport.ListIndex = -1
        
        rsReport.Close
    End If
    
    cmbReport_Click
    
    Exit Sub
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status

End Sub

'设置滚动条
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 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 optPhoto_Click()
    picChild.MousePointer = 10
End Sub

Private Sub picPhoto_DblClick(Index As Integer)
    Dim strFileName As String
    
    strFileName = GetFileName(Me.CommonDialog1, _
            "位图(*.bmp),JPEG(*.jpg)|*.bmp;*.jpg|GIF图像(*.gif)|*.gif|图标(*.ico)|*.ico", _
            "选择图片文件", , READFILE)
    If strFileName <> "" Then
        Set picPhoto(Index).PICTURE = LoadPicture(strFileName)
        
        picPhoto_Resize (Index)
        
        picPhoto(Index).Tag = strFileName
        
        cmdSave.Enabled = True
    End If
'
'    strProperty = picPhoto(Index).Tag
'    strRet = dlgPhoto.GetPhotoProperty(strProperty)
'    If strRet <> "" Then
'        If Dir(strProperty) <> "" Then
'            Set picPhoto(Index).Picture = LoadPicture(strRet)
'
'        End If
'
'
'    End If
End Sub

Private Sub picPhoto_KeyDown(Index As Integer, KeyCode As Integer, Shift As Integer)
    If Shift = vbCtrlMask Then
        Select Case KeyCode
            Case vbKeyLeft
                picPhoto(Index).Left = picPhoto(Index).Left - 1
                KeyCode = 0
                cmdSave.Enabled = True
            Case vbKeyRight
                picPhoto(Index).Left = picPhoto(Index).Left + 1
                KeyCode = 0
                cmdSave.Enabled = True
            Case vbKeyUp
                picPhoto(Index).Top = picPhoto(Index).Top - 1
                KeyCode = 0
                cmdSave.Enabled = True
            Case vbKeyDown
                picPhoto(Index).Top = picPhoto(Index).Top + 1
                KeyCode = 0
                cmdSave.Enabled = True
            Case Else
                '
        End Select
    End If
    
    If KeyCode = vbKeyDelete Then
        If menuSel = Photo Then
            '图片
            picPhoto(mintIndex).Visible = False
            cmdSave.Enabled = True
        End If
    End If
End Sub

Private Sub picPhoto_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
    picChild.Refresh '如果先前有画上小框框，於此将之去除
    haveSel = False
    
    menuSel = Photo
    mintIndex = Index
    
    If optNormal.Value = True Then
        DragMe picPhoto(Index).hWnd
    End If
End Sub

Private Sub picParent_Click()
    menuSel = Brank
End Sub

Private Sub picPhoto_Paint(Index As Integer)
    cmdSave.Enabled = True
End Sub

Private Sub picPhoto_Resize(Index As Integer)
On Error Resume Next
    With picPhoto(Index)
        DoEvents
        .PaintPicture .PICTURE, 0, 0, .ScaleWidth, .ScaleHeight
        If Err.Number <> 0 Then
            Err.Clear
            .PaintPicture .PICTURE, 0, 0, .ScaleWidth, .ScaleHeight, , , , , vbSrcCopy
        End If
    End With
End Sub

Private Sub txtCaption_DblClick(Index As Integer)
    Dim strLabel As String
    Dim typFont As FontType
    
    strLabel = dlgLabel.ShowLabel(txtCaption(Index).Text, txtCaption(Index))
    If strLabel <> "" Then
        txtCaption(Index).Text = strLabel
    End If
End Sub

Private Sub optAuto_Click()
    picChild.MousePointer = 10
End Sub

Private Sub optLabel_Click()
    picChild.MousePointer = 10
End Sub

Private Sub optLine_Click()
    picChild.MousePointer = 2
End Sub

Private Sub optNormal_Click()
    picChild.MousePointer = vbDefault
End Sub

Private Sub picChild_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
On Error Resume Next
    Dim i As Long, j As Long
    Dim hRegion5 As Long
    Dim ctl As Control
    
    mblnDown = True
    
    msngLeft = X
    msngTop = Y
    
    picChild.Refresh '如果先前有画上小框框，於此将之去除
    haveSel = False