Follow along with the video below to see how to install our site as a web app on your home screen.
Note: This feature may not be available in some browsers.
Public Const WS_SYSMENU = &H80000
Public Const GWL_STYLE = (-16)
Public Type RECT
tLng_Left As Long
tLng_Top As Long
tLng_Right As Long
tLng_Bottom As Long
End Type
Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Declare Function SetWindowText Lib "user32" Alias "SetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String) As Long
Public Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Public Declare Function MoveWindow Lib "user32" (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
Option Explicit
Dim fLng_OrigWindWord As Long
'==============================================================
Private Sub Form_Load()
Dim lLng_HideAccessWord As Long
fLng_OrigWindWord = GetWindowLong(hWndAccessApp, GWL_STYLE)
lLng_HideAccessWord = fLng_OrigWindWord And (Not WS_SYSMENU)
SetWindowLong hWndAccessApp, GWL_STYLE, lLng_HideAccessWord
[COLOR=green] ' If you don't want to change the Title Bar text,
' then send "" as the parameter, exactly as the call
' appears in the Form_Unload event.[/color]
RedrawTitleBar "Place your Customized Access Title Bar Text Here"
End Sub
'==============================================================
Private Sub Form_Unload(Cancel As Integer)
SetWindowLong hWndAccessApp, GWL_STYLE, fLng_OrigWindWord
RedrawTitleBar ""
End Sub
'==============================================================
Private Sub RedrawTitleBar(rStr_TitleBarText As String)
Dim lRct_WinPos As RECT
Dim lLng_WinWidth As Long
Dim lLng_WinHeight As Long
SetWindowText hWndAccessApp, IIf((Len(rStr_TitleBarText) < 1), "Microsoft Access", rStr_TitleBarText)
GetWindowRect hWndAccessApp, lRct_WinPos
With lRct_WinPos
lLng_WinWidth = .tLng_Right - .tLng_Left + 1
lLng_WinHeight = .tLng_Bottom - .tLng_Top + 1
[COLOR=green] ' Not really moving the window, just repainting it[/color]
MoveWindow hWndAccessApp, .tLng_Left, .tLng_Top, lLng_WinWidth, lLng_WinHeight, True
End With
End Sub
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Integer, ByVal lparam As Long) As Long
Public Declare Function ExtractIcon Lib "shell32.dll" Alias "ExtractIconA" (ByVal hInst As Long, ByVal lpszExeFileName As String, ByVal nIconIndex As Long) As Long
Public Const WM_GETICON = &H7F
Public Const WM_SETICON = &H80
Public Const ICON_BIG = 1
Function WindowSetIcon(rLng_WindowHandle As Long, rStr_IconPath As String) As Boolean
On Error GoTo ErrorHandler
Dim lLng_RetVal As Long
Dim lLng_IconHandle As Long
Dim lBol_ProcOK As Boolean
lBol_ProcOK = False
lLng_IconHandle = ExtractIcon(0, rStr_IconPath, 0)
If (lLng_IconHandle > 0) Then
lLng_RetVal = SendMessage(rLng_WindowHandle, WM_SETICON, False, lLng_IconHandle)
lBol_ProcOK = True
Else
MsgBox "Unable to Extract Icon from Filename: " & rStr_IconPath
End If
Exit_WindowSetIcon:
WindowSetIcon = lBol_ProcOK
Exit Function
ErrorHandler:
MsgBox "Error Encountered: " & Err.Number & " -- " & Err.Description
lBol_ProcOK = False
Resume Exit_WindowSetIcon
End Function
Dim lBol_SetIcon As Boolean
lBol_SetIcon = WindowSetIcon(Me.hWnd, "C:\...\...\<IconFileName>.ICO")