в 16:33, 26 мая 2010

2010-05-26T16:33:00Z

Admin: 1 версия

2010-05-26T12:48:34Z

1 версия

Новая страница

==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>

← Предыдущая	Версия 16:33, 26 мая 2010
(нет различий)

VBA/Excel/Access/Word/Windows API/Windows Resources - История изменений

в 16:33, 26 мая 2010

Admin: 1 версия