frmcustom.frm

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

    
    If optLabel.Value = True Then '标签
        mintText = mintText + 1
        Load txtCaption(mintText)
        Set txtCaption(mintText).Container = picChild
        
        With txtCaption(mintText)
            .Move X, Y
'            .Text = "新建标签"
            
            '设置拉伸风格
            SetResize .hWnd, Me.hWnd
            
            .Visible = True
        End With
        
        cmdSave.Enabled = True
    ElseIf optAuto.Value = True Then '动态文本
        mintAuto = mintAuto + 1
        Load txtAuto(mintAuto)
        Set txtAuto(mintAuto).Container = picChild
        
        With txtAuto(mintAuto)
            .Move X, Y
'            .Text = "新建文本"
            
            '设置拉伸风格
            SetResize .hWnd, Me.hWnd
            
            .Visible = True
        End With
        
        cmdSave.Enabled = True
    ElseIf optLine.Value = True Then '线条
    
    ElseIf optPhoto.Value = True Then '图片
        mintPhoto = mintPhoto + 1
        Load picPhoto(mintPhoto)
        Set picPhoto(mintPhoto).Container = picChild
        With picPhoto(mintPhoto)
            .Move X, Y
            
            '设置拉伸风格
            SetResize .hWnd, Me.hWnd
            
            .Visible = True
        End With
        
        cmdSave.Enabled = True
    ElseIf optNormal.Value = True Then '正常情况
        If Button = vbLeftButton Then '单击了鼠标左键
            NotRefresh = True
            haveSel = False
            For Each ctl In Me
                If TypeOf ctl Is Line Then
                    If (ctl.Index >= 1) And (ctl.Visible = True) Then
                        hRegion5 = CLng(ctl.Tag)
                        i = PtInRegion(hRegion5, X, Y)
                        If i <> 0 Then
                            Set aLine = ctl
                            Exit For
                        End If
                    End If
                End If
            Next
            If i <> 0 Then
                oldPoint.X = X
                oldPoint.Y = Y
                Call SetSelect
                haveSel = True
                
                menuSel = Line
                mintIndex = aLine.Index
            Else
                haveSel = False
                menuSel = Brank
            End If
        End If
        '虽上面已Check Mouse是否处於某个 line的Region内，但是Line处於Select状态时，
        '有画上两个小方框，这两个小方框未必在Region之内，所以User在方框处按Mouse也算有选取
        i = PtInRegion(hreg1, X, Y)
        j = PtInRegion(hreg2, X, Y)
        inReg1 = False: inReg2 = False
        If i <> 0 Or j <> 0 Then
            haveSel = True
            'Mouse down时mouse是否处於hreg1/ hreg2, 若是则影响Mouse move时Line的移动
            If i <> 0 Then inReg1 = True
            If j <> 0 Then inReg2 = True
        End If
    End If
End Sub

Private Sub picChild_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
On Error GoTo ErrMsg
    Dim Status
    Dim intIndex As Integer
    Dim i As Long, j As Long
    
    If optNormal.Value = True Then
        If haveSel Then
            i = PtInRegion(hreg1, X, Y)
            j = PtInRegion(hreg2, X, Y)
        End If
        If Button = 0 Then
            If i <> 0 Or j <> 0 Then 'Mouse在选取的两个方框内时改变Mouse的形状
                Screen.MousePointer = 2
            Else
                Screen.MousePointer = vbDefault
            End If
        Else
            If Button = 1 Then
                If haveSel Then
                    Call MoveLine(X, Y)
                    cmdSave.Enabled = True
                    Exit Sub
                End If
            End If
        End If
    End If
    
    If mblnDown = True Then
        If optLine.Value = True Then
            If (msngLeft <> X) Or (msngTop <> Y) Then
                '获取当前最大的索引
                intIndex = mintLine + 1

On Error Resume Next
                With linLine(intIndex)
                    Load linLine(intIndex)
                    Set linLine(intIndex).Container = picChild

                    .X1 = msngLeft
                    .Y1 = msngTop
                    .X2 = X
                    .Y2 = Y
                    .Visible = True
                    cmdSave.Enabled = True
                    
                    Set aLine = linLine(intIndex)
                    Call SetRegion
                End With
            End If
        End If
    End If
    
     Exit Sub
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
End Sub

Private Sub picChild_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
On Error GoTo ErrMsg
    Dim Status
    
    If Button = vbLeftButton Then
        If haveSel Then '重新设定Line物件的hRegion范围
            Call SetSelect
            Call SetRegion
        Else
            If optLine.Value = True Then
                If (msngLeft <> X) Or (msngTop <> Y) Then
                    '获取当前最大的索引
                    mintLine = mintLine + 1
                    
On Error Resume Next
                    With linLine(mintLine)
                        Load linLine(mintLine)
                        Set linLine(mintLine).Container = picChild
                        
                        .X1 = msngLeft
                        .Y1 = msngTop
                        .X2 = X
                        .Y2 = Y
                        .Visible = True
                        
                        cmdSave.Enabled = True
                    End With
                End If
            End If
        End If
    End If

    mblnDown = False
    Exit Sub
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
End Sub

Private Sub txtAuto_DblClick(Index As Integer)
    Dim blnRet As Boolean
    
    blnRet = dlgAuto.ShowAutoText(txtAuto(Index).Text, txtAuto(Index))
    '是否启用保存按钮
    If blnRet = True Then
        cmdSave.Enabled = True
    End If
End Sub

Private Sub txtAuto_KeyDown(Index As Integer, KeyCode As Integer, Shift As Integer)
    If Shift = vbCtrlMask Then
        Select Case KeyCode
            Case vbKeyLeft
                txtAuto(Index).Left = txtAuto(Index).Left - 1
                KeyCode = 0
                cmdSave.Enabled = True
            Case vbKeyRight
                txtAuto(Index).Left = txtAuto(Index).Left + 1
                KeyCode = 0
                cmdSave.Enabled = True
            Case vbKeyUp
                txtAuto(Index).Top = txtAuto(Index).Top - 1
                KeyCode = 0
                cmdSave.Enabled = True
            Case vbKeyDown
                txtAuto(Index).Top = txtAuto(Index).Top + 1
                KeyCode = 0
                cmdSave.Enabled = True
            Case Else
                '
        End Select
    End If
End Sub

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

Private Sub txtCaption_KeyDown(Index As Integer, KeyCode As Integer, Shift As Integer)
    If Shift = vbCtrlMask Then
        Select Case KeyCode
            Case vbKeyLeft
                txtCaption(Index).Left = txtCaption(Index).Left - 1
                KeyCode = 0
                cmdSave.Enabled = True
            Case vbKeyRight
                txtCaption(Index).Left = txtCaption(Index).Left + 1
                KeyCode = 0
                cmdSave.Enabled = True
            Case vbKeyUp
                txtCaption(Index).Top = txtCaption(Index).Top - 1
                KeyCode = 0
                cmdSave.Enabled = True
            Case vbKeyDown
                txtCaption(Index).Top = txtCaption(Index).Top + 1
                KeyCode = 0
                cmdSave.Enabled = True
            Case Else
                '
        End Select
    End If
End Sub

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

Private Sub Form_Unload(Cancel As Integer)
On Error Resume Next
    Dim ctl As Control
    Dim hRegion5 As Long
    For Each ctl In Me
        If TypeOf ctl Is Line Then
            hRegion5 = Val(ctl.Tag)
            DeleteObject hRegion5
        End If
    Next
    DeleteObject hreg1
    DeleteObject hreg2
    
    Set frmCustom = Nothing
End Sub

Private Sub Form_Resize()
If Me.WindowState = vbNormal Or Me.WindowState = vbMaximized Then
   If haveSel Then
      DoEvents '等Form show出来
      Call SetSelect '重画小方框
   End If
End If
End Sub

'设定Line物件的hRegion
Private Sub SetRegion()
    Dim hregion As Long
    Dim pt(3) As POINTAPI
    Dim n As Long, dx As Long, dy As Long
    Dim sida As Double
    
    '初始化绘图参数
    With picChild
        .ScaleMode = 3
        .DrawStyle = 0
        .DrawMode = 13
        .FillColor = &H808000
        .FillStyle = 0
        .ForeColor = &H8000000E
    End With
    
    hregion = Val(aLine.Tag)
    DeleteObject hregion
    n = 8
    With aLine
        dx = .X2 - .X1
        dy = .Y2 - .Y1
    End With
    If dx <> 0 Then
        sida = Atn(dy / dx)
    Else
        sida = PI / 2
    End If
    
    With aLine
        pt(0).X = CLng(.X2 + n * Sin(sida))
        pt(0).Y = CLng(.Y2 + n * Cos(sida))
        pt(1).X = CLng(.X2 - n * Sin(sida))
        pt(1).Y = CLng(.Y2 - n * Cos(sida))
        pt(2).X = CLng(.X1 - n * Sin(sida))
        pt(2).Y = CLng(.Y1 - n * Cos(sida))
        pt(3).X = CLng(.X1 + n * Sin(sida))
        pt(3).Y = CLng(.Y1 + n * Cos(sida))
    End With
    hregion = CreatePolygonRgn(pt(0), 4, 1)
    aLine.Tag = Str(hregion) '将hRegion记录在line.Tag
End Sub
'设定被选取的 line物件两个端点的hRegion与画上两个方框
Private Sub SetSelect()
On Error Resume Next
    '初始化绘图参数
    With picChild
        .ScaleMode = 3
        .DrawStyle = 0
        .DrawMode = 13
        .FillColor = &H808000
        .FillStyle = 0
        .ForeColor = &H8000000E
    End With
    
    
    With aLine
        Call Rectangle(picChild.hdc, .X1 - 3, .Y1 - 3, .X1 + 3, .Y1 + 3)
        Call Rectangle(picChild.hdc, .X2 - 3, .Y2 - 3, .X2 + 3, .Y2 + 3)
        DeleteObject hreg1
        DeleteObject hreg2
        
        hreg1 = CreateRectRgn(.X1 - 3, .Y1 - 3, .X1 + 3, .Y1 + 3)
        hreg2 = CreateRectRgn(.X2 - 3, .Y2 - 3, .X2 + 3, .Y2 + 3)
        lp1.X = .X1
        lp1.Y = .Y1
        lp2.X = .X2
        lp2.Y = .Y2
    End With
End Sub
Private Sub MoveLine(ByVal X As Single, ByVal Y As Single)
    Dim dx As Long, dy As Long
    
    '初始化绘图参数
    With picChild
        .ScaleMode = 3
        .DrawStyle = 0
        .DrawMode = 13
        .FillColor = &H808000
        .FillStyle = 0
        .ForeColor = &H8000000E
    End With
    
    
    If NotRefresh Then
        picChild.Refresh '去除画上的两个小方框
        NotRefresh = False
    End If
    dx = X - oldPoint.X
    dy = Y - oldPoint.Y
    If inReg1 Then 'in hreg1 则(x2, y2)不动，只改(x1, y1)
        With aLine
            .X1 = X
            .Y1 = Y
        End With
    Else
        If inReg2 Then 'in hreg2 则(x1, y1)不动，只改(x2, y2)
            With aLine
                .X2 = X
                .Y2 = Y
            End With
         Else   '不在hreg1, hreg2中，所以是整条线移动
            With aLine
                .X1 = lp1.X + dx
                .Y1 = lp1.Y + dy
                .X2 = lp2.X + dx
                .Y2 = lp2.Y + dy
            End With
         End If
    End If
End Sub