VBA/Excel/Access/Word/Windows API/Windows Resources
Содержание
- 1 Change the Excel icon
- 2 Check mouse button
- 3 Check Whether an Excel File Is Open on a Network
- 4 Clipping and Unclipping the Cursor
- 5 Custom About Dialog
- 6 Disable the X for Closing a Userform
- 7 Find window by class name
- 8 Freeze a window
- 9 Get color depth
- 10 Get DC and release it
- 11 Get execuatable file name from a given file name
- 12 Get screen width and height
- 13 Get the computer name
- 14 Get user name
- 15 Get window"s rectangle
- 16 Returns the Windows directory
- 17 Show Excel Window Size
- 18 The FindWindow() function finds the first top-level window in the window list that satisfies the specified arguments.
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>