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

Change the Excel icon

   <source lang="vb">

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

</source>
   
  

Check mouse button

   <source lang="vb">

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

</source>
   
  

Check Whether an Excel File Is Open on a Network

   <source lang="vb">

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

</source>
   
  

Clipping and Unclipping the Cursor

   <source lang="vb">

   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
</source>
   
  

Custom About Dialog

   <source lang="vb">

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

</source>
   
  

Disable the X for Closing a Userform

   <source lang="vb">

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

</source>
   
  

Find window by class name

   <source lang="vb">

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

</source>
   
  

Freeze a window

   <source lang="vb">

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

</source>
   
  

Get color depth

   <source lang="vb">

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

</source>
   
  

Get DC and release it

   <source lang="vb">

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

</source>
   
  

Get execuatable file name from a given file name

   <source lang="vb">

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

</source>
   
  

Get screen width and height

   <source lang="vb">

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

</source>
   
  

Get the computer name

   <source lang="vb">

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

</source>
   
  

Get user name

   <source lang="vb">

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

</source>
   
  

Get window"s rectangle

   <source lang="vb">

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

</source>
   
  

Returns the Windows directory

   <source lang="vb">

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

</source>
   
  

Show Excel Window Size

   <source lang="vb">

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

</source>
   
  

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

   <source lang="vb">

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

</source>