ScrollToPosition 方法示例

ScrollToPosition 是一个运行模式方法，可用于已启用增强型坐标的画面。以下示例将在放大某个对象后使用 ScrollToPosition 方法。

Option Explicit

Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long

Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long

Private Declare Function GetClientRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long

Private Type RECT

    Left As Long

    Top As Long

    Right As Long

    Bottom As Long

End Type

Private Sub CFixPicture_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Double, ByVal Y As Double)

If Button > 1 Then

unzoom

Else

'这会将缩放点放置在鼠标单击位置的中心

ZoomtoObject X, Y

End If

End Sub

Private Sub ZoomtoObject(xpos As Double, ypos As Double)

 Dim lZoom As Double

    Dim scrollx, windowHeightPixel, pixelx As Long

    Dim scrolly, windowWidthPixel, pixely As Long

    Dim Top, windowWidthLogical As Double

    Dim Left, windowHeightLogical As Double

    Dim lhwndWS As Long

    Dim lhwndParent As Long

    Dim lhwndPic As Long

    Dim lRet As Long

    Dim sBuf, sName As String

    Dim buffer As String

    sBuf = vbNullString

    sName = Me.PictureName

    windowWidthPixel = 0

    windowHeightPixel = 0

    '查找工作台窗口

    lhwndWS = FindWindow("WorkSpaceClass", sBuf)

    If lhwndWS > 0 Then

        lhwndParent = FindWindowEx(lhwndWS, 0, "MDIClient", vbNullString)

        If lhwndParent <> 0 Then

            lhwndPic = FindWindowEx(lhwndParent, 0, vbNullString, sName)

             '获取画面的客户端矩形

             If lhwndPic <> 0 Then

                Dim aRect2 As RECT

                lRet = GetClientRect(lhwndPic, aRect2)

                If lRet <> 0 Then

                    Top = 0

                    Left = 0

                    windowHeightPixel = aRect2.Bottom - aRect2.Top

                    windowWidthPixel = aRect2.Right - aRect2.Left

                End If

            End If

        End If

    End If

    

    Me.PixelToLogical windowWidthPixel, windowHeightPixel, windowWidthLogical, windowHeightLogical

    lZoom = Me.Zoom

    lZoom = lZoom + lZoom / 2

   

    scrollx = (windowWidthLogical / lZoom) / 2

    scrolly = (windowHeightLogical / lZoom) / 2

      

    If lZoom > 1 Then

        scrollx = xpos - scrollx

        scrolly = ypos - scrolly

    Else

        scrollx = xpos

        scrolly = ypos

    End If

    

    Me.Zoom = lZoom

    Me.LogicalToPixel scrollx, scrolly, pixelx, pixely

    Me.ScrollToPosition pixelx * lZoom, pixely * lZoom

End Sub

Private Sub unzoom()

Me.Zoom = 1

End Sub

注意：有关增强型坐标的更多信息，请参阅“创建画面”电子书中的画面坐标系主题。