Access - EFECTO AL ABRIR UN FORMULARIO

Option Compare Database

Public Declare PtrSafe Function SetWindowPos _

Lib "user32" ( _

ByVal hwnd As LongPtr, _

ByVal hwndInsertAfter As LongPtr, _

ByVal X As Long, ByVal Y As Long, _

ByVal cx As Long, ByVal cy As Long, _

ByVal wFlags As Long) _

As Long

Public Const SWP_NOSIZE = &H1

Public Const SWP_NOMOVE = &H2

Public Const HWND_TOPMOST = -1

Public Const HWND_NOTOPMOST = -2

Declare PtrSafe Function BuscarIcono Lib "shell32.dll" Alias "ExtractIconA" ( _

ByVal Instala As Long, ByVal ArchivoICO As String, ByVal Indice As Long) As Long

Declare PtrSafe Function BuscaVentana Lib "user32" Alias "FindWindowA" ( _

ByVal Clase As String, ByVal Nombre As String) As Long

Declare PtrSafe Function MandaMensaje Lib "user32" Alias "SendMessageA" ( _

ByVal Ventana As Long, ByVal mensaje As Long, ByVal ParV As Integer, ByVal ParL As Any) As Long

Declare PtrSafe Function ObtenerEstilo Lib "user32" Alias "GetWindowLongA" ( _

ByVal hwnd As Long, ByVal Indice As Long) As Long

Declare PtrSafe Function EstablecerEstilo Lib "user32" Alias "SetWindowLongA" ( _

ByVal hwnd As Long, ByVal Indice As Long, ByVal nuevoEstilo As Long) As Long

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

Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal hwnd As Long) As Long

Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long

Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long

Public Const WS_MINIMIZEBOX As Long = &H20000

Public Const WS_MAXIMIZEBOX As Long = &H10000

Public Const GWL_STYLE As Long = (-16)

Public ruta As String, icono As Long, Ventana As Long, estilo As Long

Public lngMyHandle As Long, lngCurrentStyle As Long, lngNewStyle As Long

Private Declare PtrSafe Function SetLayeredWindowAttributes Lib "user32" _

(ByVal hwnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long

Private Const GWL_EXSTYLE = (-20)

Private Const WS_EX_LAYERED = &H80000

Private Const LWA_ALPHA = &H2

Declare PtrSafe Function GetSystemMenu Lib "user32" _

(ByVal hwnd As Long, ByVal bRevert As Long) As Long

Declare PtrSafe Function GetMenuItemCount Lib "user32" _

(ByVal hMenu As Long) As Long

Declare PtrSafe Function RemoveMenu Lib "user32" _

(ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long

Const MF_BYPOSITION = &H400&

Const MF_REMOVE = &H1000&

Const SW_HIDE = 0

Const SW_NORMAL = 1

Const SW_MINIMIZED = 2

Const SW_MAXIMIZED = 3

Declare PtrSafe Function ShowWindow Lib "user32" _

  (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long

Public Declare PtrSafe Function LoadImage Lib "user32" _

Alias "LoadImageA" (ByVal hInst As Long, ByVal lpsz As String, ByVal un1 As Long, ByVal n1 As Long, _

ByVal n2 As Long, ByVal un2 As Long) As Long

Public Declare PtrSafe Function SendMessage Lib "user32" _

Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

Public Const WM_GETICON = &H7F

Public Const WM_SETICON = &H80

Public Const ICON_SMALL = 0

Public Const ICON_BIG = 1

Public Const IMAGE_BITMAP = 0

Public Const IMAGE_ICON = 1

Public Const IMAGE_CURSOR = 2

Public Const IMAGE_ENHMETAFILE = 3

Public Const LR_DEFAULTCOLOR = &H0

Public Const LR_MONOCHROME = &H1

Public Const LR_COLOR = &H2

Public Const LR_COPYRETURNORG = &H4

Public Const LR_COPYDELETEORG = &H8

Public Const LR_LOADFROMFILE = &H10

Public Const LR_LOADTRANSPARENT = &H20

Public Const LR_DEFAULTSIZE = &H40

Public Const LR_LOADMAP3DCOLORS = &H1000

Public Const LR_CREATEDIBHeader = &H2000

Public Const LR_COPYFROMRESOURCE = &H4000

Public Const LR_SHARED = &H8000

Public Function SetFormIcon(hwnd As Long, IconPath As String) As Boolean

Dim hIcon As Long

hIcon = LoadImage(0&, IconPath, IMAGE_ICON, 16, 16, LR_LOADFROMFILE)

If hIcon <> 0 Then

Call SendMessage(hwnd, WM_SETICON, 0, ByVal hIcon)

SetFormIcon = True

End If

End Function

Sub iniciar()

If Application.Version < 9 Then

    lngMyHandle = FindWindow("THUNDERXFRAME", Form_Log.Caption)

Else

    lngMyHandle = FindWindow("THUNDERDFRAME", Form_Log.Caption)

End If

lngCurrentStyle = GetWindowLong(lngMyHandle, GWL_STYLE)

lngNewStyle = lngCurrentStyle Or WS_MINIMIZEBOX

SetWindowLong lngMyHandle, GWL_STYLE, lngNewStyle

End Sub

Sub botones()

ruta = "C:\Users\ico.ico"

icono = BuscarIcono(0, ruta, 0)

Ventana = BuscaVentana(vbNullString, Form_Log.Caption)

MandaMensaje Ventana, &H80, 1, icono

estilo = ObtenerEstilo(Ventana, -16)

EstablecerEstilo Ventana, -16, estilo

estilo = ObtenerEstilo(Ventana, -20) Or &H40000

EstablecerEstilo Ventana, -20, estilo

End Sub

Function OcultarVentanaAccess(Ocultar As Boolean) As Boolean

Dim lngHwnd As Long

Dim bytNivel As Byte

    lngHwnd = Application.hWndAccessApp

    bytNivel = IIf(Ocultar, 0, 255)

    SetWindowLong lngHwnd, GWL_EXSTYLE, GetWindowLong(lngHwnd, GWL_EXSTYLE) Or WS_EX_LAYERED

    SetLayeredWindowAttributes lngHwnd, 0, bytNivel, LWA_ALPHA

    OcultarVentanaAccess = True

End Function

Call ShowWindow(hWndAccessApp, 0)

Call iniciar

Call botones

SetFormIcon hwnd, CurrentProject.Path & "\ico.ico"

with createobject("access.application")

.opencurrentdatabase("C:\Users\tu base")

end with