Option Compare Database
Option Explicit
Private Declare Function MoveWindow Lib "user32.dll" (ByVal hwnd As Long, ByVal x As Long, _
ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, _
ByVal bRepaint As Long) As Long
Private Declare Function GetWindowRect Lib "user32.dll" (ByVal hwnd As Long, lpRect As RECT) As Long
Type RECT
left As Long
top As Long
right As Long
bottom As Long
End Type
Public Sub WipeEffect(frm As Form, lngOpt As Long, lngIncrement As Long)
'-----------------------------------------------------------------------------------------------------------------------------------------------
' Fuente : https://access-global.net/diseno-efectos-wipe-y-shrink
'-----------------------------------------------------------------------------------------------------------------------------------------------
' Título : WipeEffect
' Autor : Candace Tripp | http://www.candace-tripp.net/
' Fecha : anterior al 9 de mayo de 2005
' Propósito : provocar el efecto wipe en formularios de Access
'-----------------------------------------------------------------------------------------------------------------------------------------------
' Más información : https://www.access-programmers.co.uk/forums/threads/wipe-effects.86382/
' https://docs.microsoft.com/en-us/windows/win32/api/winuser/nf-winuser-movewindow
' https://docs.microsoft.com/en-us/windows/win32/api/winuser/nf-winuser-getwindowrect
'-----------------------------------------------------------------------------------------------------------------------------------------------
' Test: : Para adaptar este código en tu aplicación puedes basarte en este procedimiento test. Copiar el bloque siguiente al
' portapapeles y pega en el editor de VBA en el evento de cierre del formulario que desees.
'
' Private Sub Form_Close()
' Dim lngIncrement As Long
'
' lngIncrement = 100
' Call WipeEffect(Me, 1, lngIncrement)
'
' End Sub
'
'-----------------------------------------------------------------------------------------------------------------------------------------------
Dim r As RECT
Dim lngRet As Long
Dim lngX As Long
Dim lngTop As Long
Dim lngLeft As Long
Dim factor As Long
Dim lngFormHeight As Long
Dim lngFormWidth As Long
Dim lngIncrementW As Long
Dim lngIncrementH As Long
lngRet = GetWindowRect(frm.hwnd, r)
lngFormWidth = r.right - r.left
lngFormHeight = r.bottom - r.top
lngIncrementW = lngFormWidth \ lngIncrement
lngIncrementH = lngFormHeight \ lngIncrement
Select Case lngOpt
Case 1 ' wipe up
For lngX = 1 To lngIncrement
lngRet = MoveWindow(frm.hwnd, r.left, r.top, _
lngFormWidth, lngFormHeight - lngX * lngIncrementH, 1)
Next lngX
Case 2 ' wipe down
For lngX = 1 To lngIncrement
lngRet = MoveWindow(frm.hwnd, r.left, r.top + lngX * lngIncrementH, _
lngFormWidth, lngFormHeight - lngX * lngIncrementH, 1)
Next lngX
Case 3 ' wipe right
For lngX = 1 To lngIncrement
lngRet = MoveWindow(frm.hwnd, r.left + lngX * lngIncrementW, r.top, _
lngFormWidth - lngX * lngIncrementW, lngFormHeight, 1)
Next lngX
Case 4 ' wipe left
For lngX = 1 To lngIncrement
lngRet = MoveWindow(frm.hwnd, r.left, r.top, _
lngFormWidth - lngX * lngIncrementW, lngFormHeight, 1)
Next lngX
Case 5 ' shrink/move
For lngX = 1 To lngIncrement
lngRet = MoveWindow(frm.hwnd, r.left - lngX * lngIncrementW, _
r.top + lngX * lngIncrementH, _
lngFormWidth - lngX * lngIncrementW, _
lngFormHeight - lngX * lngIncrementH, 1)
Next lngX
Case Else ' shiver
factor = 30
For lngX = 1 To 2500
If lngX Mod 4 = 0 Then
lngLeft = r.left - factor
lngTop = r.top - factor
ElseIf lngX Mod 3 = 0 Then
lngLeft = r.left - factor
lngTop = r.top + factor
ElseIf lngX Mod 2 = 0 Then
lngLeft = r.left + factor
lngTop = r.top - factor
Else
lngLeft = r.left + factor
lngTop = r.top + factor
End If
lngRet = MoveWindow(frm.hwnd, _
lngLeft, _
lngTop, _
lngFormWidth, _
lngFormHeight, 1)
Next lngX
MsgBox "Brrrrrrrr!! I think I hab a code.", vbCritical, "Code"
End Select
End Sub
