VBA/Excel/Access/Word/Windows API/Windows Resources

Change the Excel icon

 
Declare Function FindWindow Lib "user32" Alias "FindWindowA" ( ByVal ClassName As String, ByVal WindowName As String) As Long
Declare Function ExtractIcon Lib "shell32.dll" Alias "ExtractIconA" ( ByVal Instance As Long, ByVal ExeFileName As String, ByVal IconIndex As Long) As Long
Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal Message As Long, ByVal wParam As Integer, ByVal lParam As Long) As Long
Const WM_SETICON = &H80
Public Sub SetExcelIcon(ByVal IconPath As String)
  Dim A As Long
  Dim hWnd As Long
  Dim hIcon As Long
  hWnd = FindWindow("XLMAIN", Application.Caption)
  hIcon = ExtractIcon(0, IconPath, 0)
  If hIcon > 1 Then
    Call SendMessage(hWnd, WM_SETICON, True, hIcon)
    Call SendMessage(hWnd, WM_SETICON, False, hIcon)
  End If
End Sub
Public Sub TestExcelIcon()
  Call SetExcelIcon(ThisWorkbook.Path + "\myico.ico")
End Sub

Check mouse button

 
Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Sub ShowHands()
    If GetSystemMetrics(SM_SWAPBUTTON) = False Then
        MsgBox "Your mouse is right-handed!"
    Else
        MsgBox "Your mouse is left-handed!"
    End If
End Sub

Check Whether an Excel File Is Open on a Network

 
Private Declare Function lOpen Lib "kernel32" Alias "_lopen" (ByVal lpPathName As String, ByVal iReadWrite As Long) As Long
Private Declare Function lClose Lib "kernel32" Alias "_lclose" (ByVal hFile As Long) As Long
Private Const OF_SHARE_EXCLUSIVE = &H10
Private Function FileIsOpen(strFullPath_FileName As String) As Boolean
    Dim hdlFile As Long
    Dim lastErr As Long
    hdlFile = -1
    hdlFile = lOpen(strFullPath_FileName, OF_SHARE_EXCLUSIVE)
    If hdlFile = -1 Then
        lastErr = Err.LastDllError
    Else
        lClose (hdlFile)
    End If
    FileIsOpen = (hdlFile = -1) And (lastErr = 32)
End Function
Sub CheckFileOpen()
    If FileIsOpen("C:\C.xlsx") Then
        MsgBox "File is open"
    
    Else
        MsgBox "File is not open"
    End If
    
End Sub

Clipping and Unclipping the Cursor

 
    Type RECT
       Left As Long
       Top As Long
       Right As Long
       Bottom As Long
    End Type
    
    Declare Function ClipCursor Lib "user32" (lpRect As Any) As Long
    
    Sub cmdClip()
        Dim rectClipArea As RECT
        Dim lngRetVal As Long
     
        With rectClipArea
           .Top = 200
           .Left = 100
           .Bottom = 420
           .Right = 280
        End With
     
        lngRetVal = ClipCursor(rectClipArea)
     
     End Sub
     
     Private Sub cmdUnclip()
        Dim lngRetVal As Long
        lngRetVal = ClipCursor(ByVal 0&)
     End Sub

Custom About Dialog

 
Declare Function ShellAbout Lib "shell32.dll" Alias "ShellAboutA" (ByVal hwnd As Long, ByVal szApp As String, ByVal szOtherStuff As String, ByVal hIcon As Long) As Long
Declare Function GetActiveWindow Lib "user32" () As Long
Sub AboutMrExcel()
    Dim hwnd As Integer
    On Error Resume Next
    hwnd = GetActiveWindow()
    ShellAbout hwnd, nm, " Consulting" + vbCrLf, 0
    On Error GoTo 0
End Sub

Disable the X for Closing a Userform

 
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetSystemMenu Lib "user32" (ByVal hWnd As Long, ByVal bRevert As Long) As Long
Private Declare Function DeleteMenu Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long
Private Const SC_CLOSE As Long = &HF060
Private Sub Main()
    Dim hWndForm As Long
    Dim hMenu As Long
    
    hWndForm = FindWindow("ThunderDFrame", "title")  "XL2000
    hMenu = GetSystemMenu(hWndForm, 0)
    DeleteMenu hMenu, SC_CLOSE, 0&
End Sub
Playing Sounds
Public Declare Function PlayWavSound Lib "winmm.dll" Alias "sndPlaySoundA" (ByVal LpszSoundName As String, ByVal uFlags As Long) As Long
Public Sub PlaySound()
    Dim SoundName As String
    
    SoundName = "C:\s.wav"
    PlayWavSound SoundName, 0
End Sub

Find window by class name

 
Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal ClassName As String,ByVal WindowName As String) As Long
Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long,Rect As Rect) As Long
Private Type Rect
  Left As Long
  Top As Long
  Right As Long
  Bottom As Long
End Type
Public Sub ShowExcelWindowSize()
  Dim hWnd As Long, aRect As Rect
  hWnd = FindWindow("XLMAIN", Application.Caption)
  Call GetWindowRect(hWnd, aRect)
  Debug.Print " Left: " & aRect.Left 
  Debug.Print " Right: " & aRect.Right 
  Debug.Print " Top: " & aRect.Top
  Debug.Print " Bottom: " & aRect.Bottom 
  Debug.Print " Width: " & (aRect.Right - aRect.Left) 
  Debug.Print " Height: " & (aRect.Bottom - aRect.Top)
End Sub

Freeze a window

 
Option Explicit
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" ( ByVal ClassName As String, ByVal WindowName As String) As Long
Private Declare Function LockWindowUpdate Lib "user32" (ByVal hwndLock As Long) As Long
Public Sub Freeze(Form As UserForm)
  Dim hwnd As Long
    
  If Val(Application.Version) >= 9 Then
    hwnd = FindWindow("ThunderDFrame", Form.Caption)
  Else
    hwnd = FindWindow("ThunderXFrame", Form.Caption)
  End If
  If hwnd > 0 Then LockWindowUpdate hwnd
End Sub

Get color depth

 
Private Const BITSPIXEL = 12
Private Const LOGPIXELSX = 88
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDC As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetDeviceCaps Lib "Gdi32" (ByVal hDC As Long, ByVal Index As Long) As Long
Sub Main()
  Dim hDC As Long
  hDC = GetDC(0)
  ColourDepth = GetDeviceCaps(hDC, BITSPIXEL)
  Call ReleaseDC(0, hDC)
End Sub

Get DC and release it

 
Private Const BITSPIXEL = 12
Private Const LOGPIXELSX = 88
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDC As Long) As Long
Private Declare Function GetDeviceCaps Lib "Gdi32" (ByVal hDC As Long, ByVal Index As Long) As Long
Sub Main()
  Dim hDC As Long
  hDC = GetDC(0)
  PointsPerPixel = 72 / GetDeviceCaps(hDC, LOGPIXELSX)
  Call ReleaseDC(0, hDC)
End Sub

Get execuatable file name from a given file name

 
Private Declare Function FindExecutableA Lib "shell32.dll" (ByVal lpFile As String, ByVal lpDirectory As String, ByVal lpResult As String) As Long
Function GetExecutable(strFile As String) As String
    Dim strPath As String
    Dim intLen As Integer
    strPath = String(255, 0)
    intLen = FindExecutableA(strFile, "\", strPath)
    If intLen > 32 Then
        GetExecutable = Left(strPath, intLen)
     Else
        GetExecutable = ""
     End If
End Function
Sub GetFileName()
    Dim fname As String
    fname = Application.GetOpenFilename
    Debug.Print GetExecutable(fname)
End Sub

Get screen width and height

 
Private Declare Function GetSystemMetrics Lib "user32" (ByVal Index As Long) As Long
Private Const SM_CXSCREEN As Long = 0
Private Const SM_CYSCREEN As Long = 1
Public Sub ShowScreenDimensions()
   Dim X As Long
   Dim Y As Long
   X = GetSystemMetrics(SM_CXSCREEN)
   Y = GetSystemMetrics(SM_CYSCREEN)
   Call MsgBox("Screen resolution is " & X & "x" & Y)
End Sub

Get the computer name

 
Private Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal Buffer As String, Size As Long) As Long
Sub Main()
  Dim Buffer As String * 255
  Dim Result As Long
  Dim Length As Long
  Length = 255
  Result = GetComputerName(Buffer, Length)
  If Length > 0 Then ComputerName = Left(Buffer, Length)
End Sub

Get user name

 
Private Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal Buffer As String, ByRef Size As Long) As Long
Sub Main()
  Dim Buffer As String * 255
  Dim Result As Long
  Dim Length As Long
  Length = 255
    
  Result = GetUserName(Buffer, Length)
  If Length > 0 Then UserName = Left(Buffer, Length - 1)
End Sub

Get window"s rectangle

 
Private Type Rect
  Left As Long
  Top As Long
  Right As Long
  Bottom As Long
End Type
Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, ByRef lpRect As Rect) As Long
Public Sub TestRect()
  Dim R As Rect
  Call GetWindowRect(Application.hWnd, R)
  Debug.Print R.Bottom
End Sub

Returns the Windows directory

 
Declare Function GetWindowsDirectoryA Lib "kernel32" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Sub ShowWindowsDir()
    Dim WinPath As String
    Dim WinDir As String
    WinPath = Space(255)
    WinDir = Left(WinPath, GetWindowsDirectoryA _
      (WinPath, Len(WinPath)))
    MsgBox WinDir, vbInformation, "Windows Directory"
End Sub
Function WindowsDir() As String
    Dim WinPath As String
    WinPath = Space(255)
    WindowsDir = Left(WinPath, GetWindowsDirectoryA _
       (WinPath, Len(WinPath)))
End Function

Show Excel Window Size

 
Private Const FORMAT_MESSAGE_FROM_SYSTEM As Long = &H1000
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal ClassName As String, ByVal WindowName As String) As Long
Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long,Rect As Rect) As Long
Private Declare Function FormatMessage Lib "kernel32" Alias "FormatMessageA" (ByVal dwFlags As Long, ByVal Source As Long, ByVal MessageId As Long, ByVal LanguageId As Long, ByVal Buffer As String, ByVal Size As Long, ByVal Arguments As Long) As Long
Private Type Rect
  Left As Long
  Top As Long
  Right As Long
  Bottom As Long
End Type
Sub ShowExcelWindowSize()
  Dim hWnd As Long
  Dim aRect As Rect
  
  hWnd = FindWindow("XLMAIN", Application.Caption)
  If hWnd = 0 Then
    Call MsgBox(LastDLLErrText(Err.LastDllError))
  Else
    Call GetWindowRect(hWnd, aRect)
      Debug.Print " Left: " & aRect.Left 
      Debug.Print " Right: " & aRect.Right 
      Debug.Print " Top: " & aRect.Top
      Debug.Print " Bottom: " & aRect.Bottom 
      Debug.Print " Width: " & (aRect.Right - aRect.Left) 
      Debug.Print " Height: " & (aRect.Bottom - aRect.Top)
  End If
End Sub
Function LastDLLErrText(ByVal ErrorCode As Long) As String
  Dim Buffer As String * 255
  Dim Result As Long
  Result = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, 0&, ErrorCode, 0, Buffer, 255, 0)
  LastDLLErrText = Left(Buffer, Result)
End Function

The FindWindow() function finds the first top-level window in the window list that satisfies the specified arguments.

 
Public Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Public Declare Function GetClassName Lib "user32.dll" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, nMaxCount As Long) As Long
Private Sub FindHandle()
    Dim hForm As Long, rv As Long
    Dim s As String
    hForm = FindWindow(vbNullString, "UserForm1")
    Debug.Print hForm
    s = String(256, "x")   "Creates a string with 256 x"s
    rv = GetClassName(hForm, s, 255)
    Debug.Print Left(s, rv)
End Sub