Requires EventVB.dll version F or higher
The form is a standard VB form with borderstyle set to 4 - Fixed Toolwindow.
HTH,Code:Option Explicit Dim WithEvents vbLink As EventVB.APIFunctions Dim WithEvents vbWnd As EventVB.ApiWindow Dim vbWndRect As APIRect Public Enum SnapLocation SnapToLeft = 0 SnapToRight = 1 SnapToTop = 2 SnapToBottom = 3 End Enum Private mSnappedTo As SnapLocation Private FORMWIDTH As Long '\\ Alter the tolerance if it 'snaps' to readily... Private Const SNAPTOLERANCE = 5 Private Sub CopyRect(ByVal FromRect As APIRect, ToRect As APIRect) With ToRect .Left = FromRect.Left .Top = FromRect.Top .Right = FromRect.Right .Bottom = FromRect.Bottom End With End Sub Friend Property Let SnappedTo(ByVal newSnap As SnapLocation) If newSnap <> mSnappedTo Then mnuSnap(mSnappedTo).Checked = False mSnappedTo = newSnap mnuSnap(mSnappedTo).Checked = True With SnapToRectangle(mSnappedTo) vbWnd.Move .Left, .Top, (.Right - .Left), (.Bottom - .Top), True End With End If End Property Friend Property Get SnappedTo() As SnapLocation SnappedTo = mSnappedTo End Property Private Property Get SnapToRectangle(ByVal Location As SnapLocation) As APIRect Dim rcRet As New APIRect With rcRet Select Case Location Case SnapToBottom .Bottom = Screen.Height / Screen.TwipsPerPixelY .Top = .Bottom - (FORMWIDTH / Screen.TwipsPerPixelY) .Left = 0 .Right = Screen.Width / Screen.TwipsPerPixelX Case SnapToTop .Top = 0 .Bottom = (FORMWIDTH / Screen.TwipsPerPixelY) .Left = 0 .Right = Screen.Width / Screen.TwipsPerPixelX Case SnapToLeft .Top = 0 .Bottom = Screen.Height / Screen.TwipsPerPixelY .Left = 0 .Right = (FORMWIDTH / Screen.TwipsPerPixelX) Case SnapToRight .Top = 0 .Bottom = Screen.Height / Screen.TwipsPerPixelY .Right = Screen.Width / Screen.TwipsPerPixelX .Left = .Right - (FORMWIDTH / Screen.TwipsPerPixelX) End Select End With Set SnapToRectangle = rcRet End Property Private Sub Form_Load() Set vbLink = New EventVB.APIFunctions FORMWIDTH = Me.Width Set vbWnd = New EventVB.ApiWindow vbWnd.hWnd = Me.hWnd vbLink.SubclassedWindows.Add vbWnd Me.SnappedTo = SnapToLeft End Sub Private Sub Form_Unload(Cancel As Integer) vbLink.SubclassedWindows.Remove vbWnd End Sub Private Sub mnuSnap_Click(Index As Integer) Me.SnappedTo = Index End Sub Private Sub vbWnd_Moving(ByVal MoveEdges As EventVB.WindowSizingEdges, MoveRectangle As EventVB.APIRect) Dim CurRect As APIRect Set CurRect = SnapToRectangle(Me.SnappedTo) With MoveRectangle '\\ If going left, snap to left If .Left < (CurRect.Left - SNAPTOLERANCE) Then Call CopyRect(SnapToRectangle(SnapToLeft), MoveRectangle) Me.SnappedTo = SnapToLeft '\\ If going right, snap to right ElseIf .Right > (CurRect.Right + SNAPTOLERANCE) Then Call CopyRect(SnapToRectangle(SnapToRight), MoveRectangle) Me.SnappedTo = SnapToRight '\\ If going up, snap to top ElseIf .Top < (CurRect.Top - SNAPTOLERANCE) Then Call CopyRect(SnapToRectangle(SnapToTop), MoveRectangle) Me.SnappedTo = SnapToTop ElseIf .Bottom > (CurRect.Bottom + SNAPTOLERANCE) Then '\\ If going down, snap to bottom Call CopyRect(SnapToRectangle(SnapToBottom), MoveRectangle) Me.SnappedTo = SnapToBottom End If End With End Sub
Duncan




Reply With Quote