|
-
Nov 13th, 2002, 06:36 PM
#1
Thread Starter
Stuck in the 80s
Visual Basic API FAQs
I figured since this forum didn't have a FAQ part to it, we should make one, since a lot of questions asked are constantly asked. So here are a few things I came up with. Please feel free to add your own API code that you think would benifit someone else.
How to get a windows HWND
Since many tasks through API can be used on other windows, such as changing a caption or getting a caption, it'd
be important to first now how to obtain the HWND (which is used in most API) of another window. There are two methods
explored below:
Get HWND from caption
This example requires that you know the exact caption of the window, such as 'Untitled' with Notepad.
VB Code:
Option Explicit
'declare API:
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Sub Form_Load()
Dim strCaption As String, lhWnd As Long
'Exact caption of the window:
strCaption = "Untitled - Notepad"
lhWnd = FindWindow(vbNullString, strCaption)
'if the result is 0, window was not found:
If lhWnd = 0 Then
MsgBox "Could not find Notepad..."
Else
MsgBox "Notepad found: " & lhWnd
End If
End Sub
Get HWND from class name
The other method would be to use the window's class name:
VB Code:
Option Explicit
'declare API:
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Sub Form_Load()
Dim strClassName As String, lhWnd As Long
'Class Name of the window:
strClassName = "Notepad"
lhWnd = FindWindow(strClassName, vbNullString)
'if the result is 0, window was not found:
If lhWnd = 0 Then
MsgBox "Could not find Notepad..."
Else
MsgBox "Notepad found: " & lhWnd
End If
End Sub
Bring a window to the top
The following example brings our project form to the top of the Z-order chain. This does NOT make it stay on top. For
Always On Top, see the next example:
VB Code:
Option Explicit
'declare api function:
Private Declare Function BringWindowToTop Lib "user32" _
(ByVal hwnd As Long) As Long
'this code brings our window to the top every half a second:
Private Sub Form_Load()
'setup our timer's interval:
Timer1.Interval = 500
End Sub
Private Sub Timer1_Timer()
'bring our project to the top:
BringWindowToTop Me.hwnd
End Sub
Set window to be top most (always on top)
This code will allow you to toggle your window as being always on top or not always on top, as seen in things like AIM
and HTML Help.
VB Code:
Option Explicit
'declare constants:
Private Const HWND_TOPMOST = -1
Private Const HWND_NOTOPMOST = -2
Private Const SWP_NOSIZE = &H1
Private Const SWP_NOMOVE = &H2
Private Const SWP_NOACTIVATE = &H10
Private Const SWP_SHOWWINDOW = &H40
'declare API:
Private Declare Sub SetWindowPos Lib "User32" (ByVal hWnd As Long, _
ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, _
ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long)
Private Sub Command1_Click()
'set topmost:
SetWindowPos Me.hWnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOACTIVATE Or _
SWP_SHOWWINDOW Or SWP_NOMOVE Or SWP_NOSIZE
End Sub
Private Sub Command2_Click()
'set not topmost:
SetWindowPos Me.hWnd, HWND_NOTOPMOST, 0, 0, 0, 0, SWP_NOACTIVATE Or _
SWP_SHOWWINDOW Or SWP_NOMOVE Or SWP_NOSIZE
End Sub
Private Sub Form_Load()
'project requires 2 commandbuttons:
Command1.Caption = "Top Most"
Command2.Caption = "Not Top Most"
End Sub
Get/Set Window Caption AND Get Topmost Window
This code will first allow you to get the HWND of the foreground window, or the window with focus. Then it will capture
the title of the window and reverse it.
VB Code:
Option Explicit
'Declare API:
Private Declare Function GetForegroundWindow Lib "user32" () As Long
Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" _
(ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function SetWindowText Lib "user32" Alias "SetWindowTextA" _
(ByVal hwnd As Long, ByVal lpString As String) As Long
Private Sub Command1_Click()
Dim lhWnd As Long, strCaption As String
'create our buffer for the caption:
strCaption = String(100, Chr$(0))
'get the topmost window:
lhWnd = GetForegroundWindow()
'get the caption
GetWindowText lhWnd, strCaption, 100
'clear the buffer:
strCaption = Left(strCaption, InStr(strCaption, Chr(0)) - 1)
'reverse the string and set the new caption:
strCaption = StrReverse(strCaption)
SetWindowText lhWnd, strCaption
End Sub
Set Window Parent
This code, although not pretty, makes the VB form the parent of an instance of notepad, thus making notepad "trapped"
into that window.
VB Code:
Option Explicit
'declare API:
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, _
ByVal hWndNewParent As Long) As Long
Private Sub Form_Load()
Dim lhWnd As Long
'Get Notepads HWND:
lhWnd = FindWindow("Notepad", vbNullString)
'if the result is 0, window was not found:
If lhWnd = 0 Then
MsgBox "Could not find Notepad..."
Else
'set the parent:
SetParent lhWnd, Me.hwnd
End If
End Sub
Execute a file in it's default program
This example opens a text file in notepad (if that's the default program)
VB Code:
Option Explicit
'declare constants:
Private Const SW_SHOWNORMAL = 1
'declare API:
Private Declare Function ShellExecute Lib "shell32.dll" Alias _
"ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, _
ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As _
String, ByVal nShowCmd As Long) As Long
Private Sub Form_Load()
Dim lError As Long
'launch C:\movies.txt, given that it exists:
lError = ShellExecute(Me.hwnd, vbNullString, "C:\movies.txt", vbNullString, _
"C:", SW_SHOWNORMAL)
'if returns 2:
If lError = 2 Then
MsgBox "File does not exist!"
End If
End Sub
-
Nov 13th, 2002, 06:49 PM
#2
Extracting a file's icon
VB Code:
Option Explicit
Private Declare Function ExtractFileIcon Lib "shell32.dll" Alias "ExtractAssociatedIconA" (ByVal hInst As Long, _
ByVal lpIconPath As String, _
lpiIcon As Long) _
As Long
Private Declare Function DrawIcon Lib "user32" (ByVal hdc As Long, _
ByVal x As Long, _
ByVal y As Long, _
ByVal hIcon As Long) _
As Long
Private Sub Command1_Click()
Dim hIcon As Long
hIcon = ExtractFileIcon(App.hInstance, "c:\test.txt", 1)
Call DrawIcon(Picture1.hdc, 0, 0, hIcon)
End Sub
Tip : You can declare an API with any name you want, as long as you alias it with the correct name found in the DLL (As seen above)
Laugh, and the world laughs with you. Cry, and you just water down your vodka.
Take credit, not responsibility
-
Nov 24th, 2009, 01:25 AM
#3
Frenzied Member
Re: Visual Basic API FAQs
 Originally Posted by The Hobo
I figured since this forum didn't have a FAQ part to it, we should make one, since a lot of questions asked are constantly asked. So here are a few things I came up with. Please feel free to add your own API code that you think would benifit someone else.
How to get a windows HWND
Since many tasks through API can be used on other windows, such as changing a caption or getting a caption, it'd
be important to first now how to obtain the HWND (which is used in most API) of another window. There are two methods
explored below:
Get HWND from caption
This example requires that you know the exact caption of the window, such as 'Untitled' with Notepad.
< snip >
Cool, but how can I list all open windows with API calls? Task Manager can do that, and it can even show all running EXE files for programs without windows. It also can close any window/EXE by just selecting it and pushing end task or end process. How can I make a program like that in VB6 using API calls?
Last edited by si_the_geek; Nov 24th, 2009 at 03:57 AM.
Reason: removed large amount of unnecessary quoted text
-
Nov 13th, 2002, 06:55 PM
#4
Good Ol' Platypus
A whole slew of functions I've been working on, mostly for the GDI 
VB Code:
Public Function TextBlt(ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal Text As String, ByVal TextColour As Long, ByVal TextPoint As Integer, ByVal TextFace As String, ByVal dwFlags As TEXTDRAWPARAM)
Dim tRect As RECT
Dim Q As SIZE
GetTextExtentPoint32 hDestDC, Text, Len(Text), Q
With tRect
If dwFlags And TDP_RIGHT Then
.Left = x - (Q.cx + 5)
.Right = x
ElseIf dwFlags And TDP_HCENTRE Then
.Left = x - (Q.cx / 2)
.Right = x + (Q.cx / 2)
Else
.Left = x
.Right = x + (Q.cx - 1)
End If
If dwFlags And TDP_BOTTOM Then
.Top = y - (Q.cy + 5)
.Bottom = y
ElseIf dwFlags And TDP_VCENTRE Then
.Top = y - (Q.cy / 2)
.Bottom = y + (Q.cy / 2)
Else
.Top = y
.Bottom = y + (Q.cy - 1)
End If
End With
SelectObject hDestDC, CreateMyFont(TextPoint, TextFace)
SetTextColor hDestDC, TextColour
DrawText hDestDC, Text, Len(Text), tRect, 0
End Function
Public Function CreateMyFont(nSize As Integer, sFace As String) As Long 'FROM ALL-API.NET, MODIFIED
'Create a specified font
CreateMyFont = CreateFont(-MulDiv(nSize, GetDeviceCaps(GetDC(0), LOGPIXELSY), 72), 0, 0, 0, FW_NORMAL, False, False, False, DEFAULT_CHARSET, OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS, PROOF_QUALITY, DEFAULT_PITCH, sFace)
End Function
Public Function CropTextBlt(ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal Width As Long, ByVal Text As String, ByVal TextColour As Long, ByVal TextPoint As Integer, ByVal TextFace As String, ByVal dwFlags As TEXTDRAWPARAM)
Dim CropText As String
Dim Q As SIZE
SelectObject hDestDC, CreateMyFont(TextPoint, TextFace)
GetTextExtentPoint32 hDestDC, Text, Len(Text), Q
CropText = Text
Do While Q.cx > Width
Q.cx = 0: Q.cy = 0
CropText = Left$(CropText, Len(CropText) - 1)
GetTextExtentPoint32 hDestDC, CropText, Len(CropText), Q
Loop
If CropText <> Text Then
If Len(CropText) > 3 Then
CropText = Left$(CropText, Len(CropText) - 3) & "..."
Else
If Len(CropText) = 3 Then CropText = "..."
If Len(CropText) = 2 Then CropText = ".."
If Len(CropText) = 1 Then CropText = "."
End If
End If
TextBlt hDestDC, x, y, CropText, TextColour, TextPoint, TextFace, dwFlags
End Function
Public Function AlphaBlt(ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal hAlphaDC As Long, ByVal xSrc As Long, ByVal ySrc As Long)
Dim I As Long
Dim J As Long
Dim dColour As mLong
Dim dRGB As mRGB
Dim sColour As mLong
Dim sRGB As mRGB
Dim aColour As mLong
Dim aRGB As mRGB
Dim TempR As Long
Dim TempG As Long
Dim TempB As Long
For J = y To y + (nHeight - 1)
For I = x To x + (nWidth - 1)
dColour.L = GetPixel(hDestDC, I, J)
sColour.L = GetPixel(hSrcDC, I - x + xSrc, J - y + ySrc)
aColour.L = GetPixel(hAlphaDC, I - x + xSrc, J - y + ySrc)
LSet dRGB = dColour
LSet sRGB = sColour
LSet aRGB = aColour
aRGB.R = 255 - aRGB.R
aRGB.G = 255 - aRGB.G
aRGB.B = 255 - aRGB.B
TempR = (aRGB.R * CLng(sRGB.R + 256 - dRGB.R)) / 256 + dRGB.R - aRGB.R
TempG = (aRGB.G * CLng(sRGB.G + 256 - dRGB.G)) / 256 + dRGB.G - aRGB.G
TempB = (aRGB.B * CLng(sRGB.B + 256 - dRGB.B)) / 256 + dRGB.B - aRGB.B
SetPixelV hDestDC, I, J, RGB(TempR, TempG, TempB)
Next I
Next J
End Function
Public Function TileBlt(ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal srcWidth As Long, ByVal srcHeight As Long, ByVal dwRop As Long)
Dim I As Long
Dim J As Long
Dim ICut As Long
Dim JCut As Long
For J = y To y + (nHeight - 1) Step srcHeight
If J + srcHeight > y + (nHeight - 1) Then
JCut = (y + nHeight) - J
Else
JCut = srcHeight
End If
For I = x To x + (nWidth - 1) Step srcWidth
If I + srcWidth > x + (nWidth - 1) Then
ICut = (x + nWidth) - I
Else
ICut = srcWidth
End If
BitBlt hDestDC, I, J, ICut, JCut, hSrcDC, xSrc, ySrc, dwRop
Next I
Next J
End Function
Public Function IconBlt(ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal hExeSrc As String, ByVal hIndex As Long, ByVal hSmallIcon As Boolean) As Long
Dim hSmIco As Long
Dim hLgIco As Long
Call ExtractIconEx(hExeSrc, hIndex, hLgIco, hSmIco, 1)
If hSmallIcon Then
IconBlt = DrawIconEx(hDestDC, x, y, hSmIco, 16, 16, 0, 0, DI_NORMAL)
Else
IconBlt = DrawIconEx(hDestDC, x, y, hLgIco, 32, 32, 0, 0, DI_NORMAL)
End If
DestroyIcon hSmIco: DestroyIcon hLgIco
End Function
Public Function SmoothIconBlt(ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal hImgDC As Long, ByVal hMaskDC As Long, ByVal hTempDC As Long, ByVal hExeSrc As String, ByVal hIndex As Long, ByVal hSmallIcon As Boolean) As Long
Dim hSmIco As Long
Dim hLgIco As Long
Dim hResult As Long
Call ExtractIconEx(hExeSrc, hIndex, hLgIco, hSmIco, 1)
If hSmallIcon Then
hResult = DrawIconEx(hMaskDC, 0, 0, hSmIco, 16, 16, 0, 0, DI_MASK)
hResult = DrawIconEx(hImgDC, 0, 0, hSmIco, 16, 16, 0, 0, DI_IMAGE)
SmoothMask hTempDC, hMaskDC, 0, 0, 16, 16, smoothval
AlphaBlt hDestDC, x, y, 16, 16, hImgDC, frmMain.Src(8).hdc, 0, 0
Else
hResult = DrawIconEx(hMaskDC, 0, 0, hLgIco, 32, 32, 0, 0, DI_MASK)
hResult = DrawIconEx(hImgDC, 0, 0, hLgIco, 32, 32, 0, 0, DI_IMAGE)
SmoothMask hTempDC, hMaskDC, 0, 0, 32, 32, smoothval * 2
AlphaBlt hDestDC, x, y, 32, 32, hImgDC, hMaskDC, 0, 0
End If
DestroyIcon hSmIco: DestroyIcon hLgIco
End Function
Public Function SmoothMask(ByVal hDestDC As Long, ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal hWidth As Long, ByVal hHeight As Long, ByVal hSmoothWeight As Long)
Dim hInverse As Long
Dim I As Long, J As Long
Dim Base As Long
Dim Plus As Long
Dim Dot As Long
Dim Q As Long
Dim nDot As Long
Dim nPlus As Long
hInverse = 100 - (6 * hSmoothWeight)
'.+. This requires explaining. # will recieve hInverse rating, + will
'+#+ recieve hSmoothWeight rating, and . will recieve half of hSmoothWieght
'.+. as its rating. Thus 4 * hSmoothWeight + (4 * 0.5) * hSmoothWeight, or 6 * hSmoothweight
For J = y To y + (hHeight - 1)
For I = x To x + (hWidth - 1)
Dot = 0
Q = 0
Base = 0
Plus = 0
nPlus = 0
nDot = 0
Q = GetPixel(hdc, I, J)
Base = Mono(Q)
If Base = 0 Then
Q = GetPixel(hdc, I - 1, J)
If Q <> -1 Then
Plus = Plus + Mono(Q)
nPlus = nPlus + 1
End If
Q = GetPixel(hdc, I + 1, J)
If Q <> -1 Then
Plus = Plus + Mono(Q)
nPlus = nPlus + 1
End If
Q = GetPixel(hdc, I, J - 1)
If Q <> -1 Then
Plus = Plus + Mono(Q)
nPlus = nPlus + 1
End If
Q = GetPixel(hdc, I, J + 1)
If Q <> -1 Then
Plus = Plus + Mono(Q)
nPlus = nPlus + 1
End If
Plus = Plus / nPlus
Q = GetPixel(hdc, I - 1, J - 1)
If Q <> -1 Then
Dot = Dot + Mono(Q)
nDot = nDot + 1
End If
Q = GetPixel(hdc, I + 1, J - 1)
If Q <> -1 Then
Dot = Dot + Mono(Q)
nDot = nDot + 1
End If
Q = GetPixel(hdc, I - 1, J + 1)
If Q <> -1 Then
Dot = Dot + Mono(Q)
nDot = nDot + 1
End If
Q = GetPixel(hdc, I + 1, J + 1)
If Q <> -1 Then
Dot = Dot + Mono(Q)
nDot = nDot + 1
End If
Dot = Dot / nDot
Base = ((hInverse / 100) * Base) + ((hSmoothWeight * 4 / 100) * Plus) + ((hSmoothWeight * 2 / 100) * Dot)
SetPixelV hDestDC, I, J, RGB(Base, Base, Base)
End If
Next I
Next J
End Function
Public Function Mono(Valu As Long) As Long
If Valu = 0 Then Mono = 0 Else Mono = 255
End Function
All contents of the above post that aren't somebody elses are mine, not the property of some media corporation. 
(Just a heads-up)
-
Nov 13th, 2002, 06:56 PM
#5
Good Ol' Platypus
And, the declarations:
VB Code:
Option Explicit
Public Type mLong
L As Long
End Type
Public Type mRGB
R As Byte
G As Byte
B As Byte
A As Byte
End Type
Public Enum TEXTDRAWPARAM
TDP_LEFT = 0
TDP_RIGHT = 1
TDP_HCENTRE = 2
TDP_TOP = 4
TDP_BOTTOM = 8
TDP_VCENTRE = 16
End Enum
Public Const FW_DONTCARE = 0
Public Const FW_THIN = 100
Public Const FW_EXTRALIGHT = 200
Public Const FW_LIGHT = 300
Public Const FW_NORMAL = 400
Public Const FW_MEDIUM = 500
Public Const FW_SEMIBOLD = 600
Public Const FW_BOLD = 700
Public Const FW_EXTRABOLD = 800
Public Const FW_HEAVY = 900
Public Const FW_BLACK = FW_HEAVY
Public Const FW_DEMIBOLD = FW_SEMIBOLD
Public Const FW_REGULAR = FW_NORMAL
Public Const FW_ULTRABOLD = FW_EXTRABOLD
Public Const FW_ULTRALIGHT = FW_EXTRALIGHT
Public Const ANSI_CHARSET = 0
Public Const DEFAULT_CHARSET = 1
Public Const SYMBOL_CHARSET = 2
Public Const SHIFTJIS_CHARSET = 128
Public Const HANGEUL_CHARSET = 129
Public Const CHINESEBIG5_CHARSET = 136
Public Const OEM_CHARSET = 255
Public Const OUT_CHARACTER_PRECIS = 2
Public Const OUT_DEFAULT_PRECIS = 0
Public Const OUT_DEVICE_PRECIS = 5
Public Const CLIP_DEFAULT_PRECIS = 0
Public Const CLIP_CHARACTER_PRECIS = 1
Public Const CLIP_STROKE_PRECIS = 2
Public Const DEFAULT_QUALITY = 0
Public Const DRAFT_QUALITY = 1
Public Const PROOF_QUALITY = 2
Public Const DEFAULT_PITCH = 0
Public Const FIXED_PITCH = 1
Public Const VARIABLE_PITCH = 2
Public Const OPAQUE = 2
Public Const TRANSPARENT = 1
Public Const LOGPIXELSY = 90
Public Const OBJ_BITMAP = 7
Public Const DT_RIGHT = &H2
Public Declare Function GetCurrentObject Lib "gdi32" (ByVal hdc As Long, ByVal uObjectType As Long) As Long
Public Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Public Declare Function SetPixelV Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal crColor As Long) As Long
Public Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
Public Declare Function DrawIconEx Lib "user32" (ByVal hdc As Long, ByVal xLeft As Long, ByVal yTop As Long, ByVal hIcon As Long, ByVal cxWidth As Long, ByVal cyWidth As Long, ByVal istepIfAniCur As Long, ByVal hbrFlickerFreeDraw As Long, ByVal diFlags As Long) As Long
Public Declare Function ExtractIconEx Lib "shell32.dll" Alias "ExtractIconExA" (ByVal lpszFile As String, ByVal nIconIndex As Long, phiconLarge As Long, phiconSmall As Long, ByVal nIcons As Long) As Long
Public Declare Function DestroyIcon Lib "user32" (ByVal hIcon As Long) As Long
Public Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal lpString As String, ByVal nCount As Long) As Long
Public Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Public Declare Function GetTextExtentPoint32 Lib "gdi32" Alias "GetTextExtentPoint32A" (ByVal hdc As Long, ByVal lpsz As String, ByVal cbString As Long, lpSize As SIZE) As Long
Public Declare Function CreateFont Lib "gdi32" Alias "CreateFontA" (ByVal H As Long, ByVal W As Long, ByVal E As Long, ByVal O As Long, ByVal W As Long, ByVal I As Long, ByVal u As Long, ByVal S As Long, ByVal C As Long, ByVal OP As Long, ByVal CP As Long, ByVal Q As Long, ByVal PAF As Long, ByVal F As String) As Long
Public Declare Function MulDiv Lib "kernel32" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long) As Long
Public Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Public Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Public Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
Public Declare Function VarPtrArray Lib "msvbvm60.dll" Alias "VarPtr" (Ptr() As Any) As Long
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDst As Any, pSrc As Any, ByVal ByteLen As Long)
Public Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Public Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Public Const DI_MASK = &H1
Public Const DI_IMAGE = &H2
Public Const DI_NORMAL = DI_MASK Or DI_IMAGE
Public Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Public Type SIZE
cx As Long
cy As Long
End Type
All contents of the above post that aren't somebody elses are mine, not the property of some media corporation.
(Just a heads-up)
-
Nov 13th, 2002, 07:39 PM
#6
Creating odd shaped forms/controls
VB Code:
Option Explicit
Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, _
ByVal Y1 As Long, _
ByVal X2 As Long, _
ByVal Y2 As Long) _
As Long
Private Declare Function CreateEllipticRgn Lib "gdi32" (ByVal X1 As Long, _
ByVal Y1 As Long, _
ByVal X2 As Long, _
ByVal Y2 As Long) _
As Long
Private Declare Function CreateRoundRectRgn Lib "gdi32" (ByVal X1 As Long, _
ByVal Y1 As Long, _
ByVal X2 As Long, _
ByVal Y2 As Long, _
ByVal X3 As Long, _
ByVal Y3 As Long) _
As Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, _
ByVal hRgn As Long, _
ByVal bRedraw As Boolean) _
As Long
Private Declare Function CreatePolygonRgn Lib "gdi32" (lpPoint As POINT, _
ByVal nCount As Long, _
ByVal nPolyFillMode As Long) _
As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Type POINT
x As Long
y As Long
End Type
Private Const ALTERNATE = 1
Private Const WINDING = 2
Private Sub Form_Resize()
Dim hRgn As Long, w As Long, h As Long
Dim p(0 To 3) As POINT
w = ScaleX(Me.Width, Me.ScaleMode, vbPixels) - 1
h = ScaleY(Me.Height, Me.ScaleMode, vbPixels) - 1
'Square Window
'hRgn = CreateRectRgn(0, 0, w \ 2, h \ 2)
'Elliptical Window
'hRgn = CreateEllipticRgn(0, 0, w, h)
'Square Window with round corners
'hRgn = CreateRoundRectRgn(0, 0, w, h, 50, 50)
'Polygon shaped window
'p(0).x = w / 2
'p(0).y = 0
'p(1).x = w
'p(1).y = h / 2
'p(2).x = w / 2
'p(2).y = h
'p(3).x = 0
'p(3).y = h / 2
'
'hRgn = CreatePolygonRgn(p(0), 4, 1)
Call SetWindowRgn(Me.hWnd, hRgn, True)
Call DeleteObject(hRgn)
End Sub
Uncomment as needed.
Laugh, and the world laughs with you. Cry, and you just water down your vodka.
Take credit, not responsibility
-
Nov 13th, 2002, 08:08 PM
#7
Thread Starter
Stuck in the 80s
this is a big one
System Tray and Title Bar Button
This (really long) code is something I wrote awhile ago to demonstrate how to 1) add a button to the title bar, and 2) minimize the form to the system tray.
VB Code:
'form code:
Option Explicit
Private Sub Form_Load()
Init
End Sub
Private Sub Form_Unload(Cancel As Integer)
RemoveIcon
Terminate
End Sub
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
Dim msg As Long
msg = x / Screen.TwipsPerPixelX
Select Case msg
'Case WM_LBUTTONDOWN
'Case WM_LBUTTONUP
Case WM_LBUTTONDBLCLK
Me.Visible = True
Me.WindowState = 0
'Case WM_RBUTTONDOWN
'Case WM_RBUTTONUP
'Case WM_RBUTTONDBLCLK
End Select
End Sub
Public Sub ButtonPressed()
AddIcon Me, "test"
End Sub
'module code:
Option Explicit
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
(ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, _
lpRect As Rect) As Long
Private Declare Function GetParent Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, _
ByVal hWndNewParent As Long) As Long
Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, _
ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx _
As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Declare Function SetWindowsHookEx Lib "user32" Alias _
"SetWindowsHookExA" (ByVal idHook&, ByVal lpfn&, ByVal hmod&, ByVal _
dwThreadId&) As Long
Private Declare Function UnhookWindowsHookEx Lib "user32" _
(ByVal hHook&) As Long
Private Declare Function CreateWindowEx Lib "user32" Alias _
"CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, _
ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal x As Long, _
ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal _
hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, _
lpParam As Any) As Long
Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, _
ByVal nCmdShow As Long) As Long
Private Declare Function Shell_NotifyIcon Lib "shell32" Alias _
"Shell_NotifyIconA" (ByVal dwMessage As Long, pnid As NOTIFYICONDATA) _
As Boolean
Private Type Rect
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type CWPSTRUCT
lParam As Long
wParam As Long
Message As Long
hwnd As Long
End Type
Public Type NOTIFYICONDATA
cbSize As Long
hwnd As Long
uid As Long
uFlags As Long
uCallBackMessage As Long
hIcon As Long
szTip As String * 64
End Type
Private Const NIM_ADD = &H0
Private Const NIM_MODIFY = &H1
Private Const NIM_DELETE = &H2
Private Const WM_MOUSEMOVE = &H200
Private Const NIF_MESSAGE = &H1
Private Const NIF_ICON = &H2
Private Const NIF_TIP = &H4
Public Const WM_LBUTTONDBLCLK = &H203
Public Const WM_LBUTTONDOWN = &H201
Public Const WM_LBUTTONUP = &H202
Public Const WM_RBUTTONDBLCLK = &H206
Public Const WM_RBUTTONDOWN = &H204
Public Const WM_RBUTTONUP = &H205
Private NID As NOTIFYICONDATA
Const WM_MOVE = &H3
Const WM_SETCURSOR = &H20
Const WM_NCPAINT = &H85
Const WM_COMMAND = &H111
Const SWP_FRAMECHANGED = &H20
Const GWL_EXSTYLE = -20
Private WHook&
Private ButtonHwnd As Long
Public Sub Init()
'Create the button that is going to be placed in the Titlebar
ButtonHwnd& = CreateWindowEx(0&, "Button", "-", &H40000000, 50, 50, 14, 14, frmMain.hwnd, 0&, App.hInstance, 0&)
'Show the button cause it´s invisible
Call ShowWindow(ButtonHwnd&, 1)
'Initialize the window hooking for the button
WHook = SetWindowsHookEx(4, AddressOf HookProc, 0, App.ThreadID)
Call SetWindowLong(ButtonHwnd&, GWL_EXSTYLE, &H80)
Call SetParent(ButtonHwnd&, GetParent(frmMain.hwnd))
End Sub
Public Sub Terminate()
'Terminate the window hooking
Call UnhookWindowsHookEx(WHook)
Call SetParent(ButtonHwnd&, frmMain.hwnd)
End Sub
Public Function HookProc&(ByVal nCode&, ByVal wParam&, Inf As CWPSTRUCT)
Dim FormRect As Rect
Static LastParam&
If Inf.hwnd = GetParent(ButtonHwnd&) Then
If Inf.Message = WM_COMMAND Then
Select Case LastParam
'If the LastParam is cmdInTitlebar call the Click-Procedure
'of the button
Case ButtonHwnd&: frmMain.ButtonPressed
End Select
ElseIf Inf.Message = WM_SETCURSOR Then
LastParam = Inf.wParam
End If
ElseIf Inf.hwnd = frmMain.hwnd Then
If Inf.Message = WM_NCPAINT Or Inf.Message = WM_MOVE Then
'Get the size of the Form
Call GetWindowRect(frmMain.hwnd, FormRect)
'Place the button int the Titlebar
Call SetWindowPos(ButtonHwnd&, 0, FormRect.Right - 75, FormRect.Top + 6, 17, 14, SWP_FRAMECHANGED)
End If
End If
End Function
Public Sub AddIcon(TheForm As Form, strT As String)
NID.cbSize = Len(NID)
NID.hwnd = TheForm.hwnd
NID.uid = vbNull
NID.uFlags = NIF_ICON Or NIF_TIP Or NIF_MESSAGE
NID.uCallBackMessage = WM_MOUSEMOVE
NID.hIcon = TheForm.Icon
NID.szTip = strT & vbNullChar
Shell_NotifyIcon NIM_ADD, NID
TheForm.WindowState = vbMinimized
TheForm.Hide
End Sub
Public Sub RemoveIcon()
Shell_NotifyIcon NIM_DELETE, NID
End Sub
Enjoy!
-
May 7th, 2009, 03:53 AM
#8
Member
Re: this is a big one
Originally Posted by The Hobo
System Tray and Title Bar Button
This (really long) code is something I wrote awhile ago to demonstrate how to 1) add a button to the title bar, and 2) minimize the form to the system tray.
VB Code:
'form code:
Option Explicit
Private Sub Form_Load()
Init
End Sub
Private Sub Form_Unload(Cancel As Integer)
RemoveIcon
Terminate
End Sub
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
Dim msg As Long
msg = x / Screen.TwipsPerPixelX
Select Case msg
'Case WM_LBUTTONDOWN
'Case WM_LBUTTONUP
Case WM_LBUTTONDBLCLK
Me.Visible = True
Me.WindowState = 0
'Case WM_RBUTTONDOWN
'Case WM_RBUTTONUP
'Case WM_RBUTTONDBLCLK
End Select
End Sub
Public Sub ButtonPressed()
AddIcon Me, "test"
End Sub
'module code:
Option Explicit
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
(ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, _
lpRect As Rect) As Long
Private Declare Function GetParent Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, _
ByVal hWndNewParent As Long) As Long
Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, _
ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx _
As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Declare Function SetWindowsHookEx Lib "user32" Alias _
"SetWindowsHookExA" (ByVal idHook&, ByVal lpfn&, ByVal hmod&, ByVal _
dwThreadId&) As Long
Private Declare Function UnhookWindowsHookEx Lib "user32" _
(ByVal hHook&) As Long
Private Declare Function CreateWindowEx Lib "user32" Alias _
"CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, _
ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal x As Long, _
ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal _
hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, _
lpParam As Any) As Long
Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, _
ByVal nCmdShow As Long) As Long
Private Declare Function Shell_NotifyIcon Lib "shell32" Alias _
"Shell_NotifyIconA" (ByVal dwMessage As Long, pnid As NOTIFYICONDATA) _
As Boolean
Private Type Rect
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type CWPSTRUCT
lParam As Long
wParam As Long
Message As Long
hwnd As Long
End Type
Public Type NOTIFYICONDATA
cbSize As Long
hwnd As Long
uid As Long
uFlags As Long
uCallBackMessage As Long
hIcon As Long
szTip As String * 64
End Type
Private Const NIM_ADD = &H0
Private Const NIM_MODIFY = &H1
Private Const NIM_DELETE = &H2
Private Const WM_MOUSEMOVE = &H200
Private Const NIF_MESSAGE = &H1
Private Const NIF_ICON = &H2
Private Const NIF_TIP = &H4
Public Const WM_LBUTTONDBLCLK = &H203
Public Const WM_LBUTTONDOWN = &H201
Public Const WM_LBUTTONUP = &H202
Public Const WM_RBUTTONDBLCLK = &H206
Public Const WM_RBUTTONDOWN = &H204
Public Const WM_RBUTTONUP = &H205
Private NID As NOTIFYICONDATA
Const WM_MOVE = &H3
Const WM_SETCURSOR = &H20
Const WM_NCPAINT = &H85
Const WM_COMMAND = &H111
Const SWP_FRAMECHANGED = &H20
Const GWL_EXSTYLE = -20
Private WHook&
Private ButtonHwnd As Long
Public Sub Init()
'Create the button that is going to be placed in the Titlebar
ButtonHwnd& = CreateWindowEx(0&, "Button", "-", &H40000000, 50, 50, 14, 14, frmMain.hwnd, 0&, App.hInstance, 0&)
'Show the button cause it´s invisible
Call ShowWindow(ButtonHwnd&, 1)
'Initialize the window hooking for the button
WHook = SetWindowsHookEx(4, AddressOf HookProc, 0, App.ThreadID)
Call SetWindowLong(ButtonHwnd&, GWL_EXSTYLE, &H80)
Call SetParent(ButtonHwnd&, GetParent(frmMain.hwnd))
End Sub
Public Sub Terminate()
'Terminate the window hooking
Call UnhookWindowsHookEx(WHook)
Call SetParent(ButtonHwnd&, frmMain.hwnd)
End Sub
Public Function HookProc&(ByVal nCode&, ByVal wParam&, Inf As CWPSTRUCT)
Dim FormRect As Rect
Static LastParam&
If Inf.hwnd = GetParent(ButtonHwnd&) Then
If Inf.Message = WM_COMMAND Then
Select Case LastParam
'If the LastParam is cmdInTitlebar call the Click-Procedure
'of the button
Case ButtonHwnd&: frmMain.ButtonPressed
End Select
ElseIf Inf.Message = WM_SETCURSOR Then
LastParam = Inf.wParam
End If
ElseIf Inf.hwnd = frmMain.hwnd Then
If Inf.Message = WM_NCPAINT Or Inf.Message = WM_MOVE Then
'Get the size of the Form
Call GetWindowRect(frmMain.hwnd, FormRect)
'Place the button int the Titlebar
Call SetWindowPos(ButtonHwnd&, 0, FormRect.Right - 75, FormRect.Top + 6, 17, 14, SWP_FRAMECHANGED)
End If
End If
End Function
Public Sub AddIcon(TheForm As Form, strT As String)
NID.cbSize = Len(NID)
NID.hwnd = TheForm.hwnd
NID.uid = vbNull
NID.uFlags = NIF_ICON Or NIF_TIP Or NIF_MESSAGE
NID.uCallBackMessage = WM_MOUSEMOVE
NID.hIcon = TheForm.Icon
NID.szTip = strT & vbNullChar
Shell_NotifyIcon NIM_ADD, NID
TheForm.WindowState = vbMinimized
TheForm.Hide
End Sub
Public Sub RemoveIcon()
Shell_NotifyIcon NIM_DELETE, NID
End Sub
Enjoy!
It's nice, The button appears on the title bar but without any action when I click it.
-
Nov 13th, 2002, 08:34 PM
#9
Another biggie...
How to limit a form's size (min and max)
VB Code:
'/////////////
'* In a form *
'/////////////
Option Explicit
Private Sub Form_Load()
Call Hook(Me.hWnd)
End Sub
Private Sub Form_Unload(Cancel As Integer)
Call Unhook(Me.hWnd)
End Sub
'////////////////////////
'* In a standard module *
'////////////////////////
Option Explicit
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, _
ByVal nIndex As Long, _
ByVal dwNewLong As Long) _
As Long
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, _
ByVal hWnd As Long, _
ByVal Msg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) _
As Long
Private Declare Function DefWindowProc Lib "user32" Alias "DefWindowProcA" (ByVal hWnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) _
As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, _
Source As Any, _
ByVal Length As Long)
Private Const GWL_WNDPROC = (-4)
Private Const WM_SIZING = &H214
Private Const WMSZ_LEFT = 1
Private Const WMSZ_RIGHT = 2
Private Const WMSZ_TOP = 3
Private Const WMSZ_TOPLEFT = 4
Private Const WMSZ_TOPRIGHT = 5
Private Const WMSZ_BOTTOM = 6
Private Const WMSZ_BOTTOMLEFT = 7
Private Const WMSZ_BOTTOMRIGHT = 8
Private Const MIN_WIDTH = 200 'The minimum width in pixels
Private Const MIN_HEIGHT = 200 'The minimum height in pixels
Private Const MAX_WIDTH = 500 'The maximum width in pixels
Private Const MAX_HEIGHT = 500 'The maximum height in pixels
Private Type RECT
Left As Long
Top As Long
RIGHT As Long
Bottom As Long
End Type
Private mPrevProc As Long
Public Sub Hook(hWnd As Long)
mPrevProc = SetWindowLong(hWnd, GWL_WNDPROC, AddressOf NewWndProc)
End Sub
Public Sub Unhook(hWnd As Long)
Call SetWindowLong(hWnd, GWL_WNDPROC, mPrevProc)
mPrevProc = 0&
End Sub
Public Function NewWndProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
On Error Resume Next
Dim r As RECT
If uMsg = WM_SIZING Then
Call CopyMemory(r, ByVal lParam, Len(r))
'Keep the form only at least as wide as MIN_WIDTH
If (r.RIGHT - r.Left < MIN_WIDTH) Then
Select Case wParam
Case WMSZ_LEFT, WMSZ_BOTTOMLEFT, WMSZ_TOPLEFT
r.Left = r.RIGHT - MIN_WIDTH
Case WMSZ_RIGHT, WMSZ_BOTTOMRIGHT, WMSZ_TOPRIGHT
r.RIGHT = r.Left + MIN_WIDTH
End Select
End If
'Keep the form only at least as tall as MIN_HEIGHT
If (r.Bottom - r.Top < MIN_HEIGHT) Then
Select Case wParam
Case WMSZ_TOP, WMSZ_TOPLEFT, WMSZ_TOPRIGHT
r.Top = r.Bottom - MIN_HEIGHT
Case WMSZ_BOTTOM, WMSZ_BOTTOMLEFT, WMSZ_BOTTOMRIGHT
r.Bottom = r.Top + MIN_HEIGHT
End Select
End If
'Keep the form only as wide as MAX_WIDTH
If (r.RIGHT - r.Left > MAX_WIDTH) Then
Select Case wParam
Case WMSZ_LEFT, WMSZ_BOTTOMLEFT, WMSZ_TOPLEFT
r.Left = r.RIGHT - MAX_WIDTH
Case WMSZ_RIGHT, WMSZ_BOTTOMRIGHT, WMSZ_TOPRIGHT
r.RIGHT = r.Left + MAX_WIDTH
End Select
End If
'Keep the form only as tall as MAX_HEIGHT
If (r.Bottom - r.Top > MAX_HEIGHT) Then
Select Case wParam
Case WMSZ_TOP, WMSZ_TOPLEFT, WMSZ_TOPRIGHT
r.Top = r.Bottom - MAX_HEIGHT
Case WMSZ_BOTTOM, WMSZ_BOTTOMLEFT, WMSZ_BOTTOMRIGHT
r.Bottom = r.Top + MAX_HEIGHT
End Select
End If
Call CopyMemory(ByVal lParam, r, Len(r))
NewWndProc = 0&
Exit Function
End If
If mPrevProc > 0& Then
NewWndProc = CallWindowProc(mPrevProc, hWnd, uMsg, wParam, lParam)
Else
NewWndProc = DefWindowProc(hWnd, uMsg, wParam, lParam)
End If
End Function
This is much more effective than changing the size of the form back in its Resize event, and there should be none of that flickering, either.
And you should be able to hit the Stop button and not worry about VB crashing with that code. But be sure to save it first, just in case .
Last edited by crptcblade; Nov 14th, 2002 at 07:09 AM.
Laugh, and the world laughs with you. Cry, and you just water down your vodka.
Take credit, not responsibility
-
Jan 5th, 2024, 07:38 AM
#10
New Member
Re: Another biggie...
I tried this and it works great! I know it's a very old post but that's irrelevant to a question I have.
While the routine works great, it does seem very sensitive to crashing and burning with news at 11. I've found that while the hook is set the form will respond nicely when the edges are sized via dragging. However, any attempt to resize the window with standard vb code results in a crash. No problem, I just stay away from doing that.
However, when I change font size of some text on the form, I need to change the minimum window size and resize the window if it's below the new minimum. But pray tell, how? Calling Form_Resize does not trigger the NewWndProc function which enforces the minimum. The only way I've found is to drag the edge of the window. Surely there must be a way to do it through code and I'm hoping an expert or two here might have an answer.
BTW, one thing I tried upon changing font size was to Call Unhook, then attempt to resize with standard vb, then Call Hook again, but no good - crash and burn!
Any help would be appreciated!
-
Jan 5th, 2024, 07:43 AM
#11
New Member
-
Nov 13th, 2002, 10:19 PM
#12
Get Windows version
VB Code:
Option Explicit
Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As Long
Private Type OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
szCSDVersion As String * 128
End Type
'Platform IDs
Private Const WIN_ID_31 = 0
Private Const WIN_ID_95_98_ME = 1
Private Const WIN_ID_NT_2K_XP = 2
Public Sub TellWindowsVersion()
Dim lVer As OSVERSIONINFO
lVer.dwOSVersionInfoSize = Len(lVer)
Call GetVersionEx(lVer)
With lVer
Select Case .dwPlatformId
Case WIN_ID_31
MsgBox "Windows 3.x"
Case WIN_ID_95_98_ME
Select Case .dwMinorVersion
Case 0: MsgBox "Windows 95"
Case 10: MsgBox "Windows 98"
Case 90: MsgBox "Windows Me"
End Select
Case WIN_ID_NT_2K_XP
Select Case True
Case (.dwMajorVersion < 5)
MsgBox "Windows NT"
Case (.dwMajorVersion = 5)
Select Case .dwMinorVersion
Case 0: MsgBox "Windows 2000"
Case 1: MsgBox "Windows XP"
End Select
End Select
End Select
End With
End Sub
Private Sub Form_Load()
Call TellWindowsVersion
End Sub
Laugh, and the world laughs with you. Cry, and you just water down your vodka.
Take credit, not responsibility
-
Nov 13th, 2002, 10:26 PM
#13
Simulate MouseEnter and MouseLeave events
VB Code:
Option Explicit
Private Declare Function SetCapture Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseCapture Lib "user32" () As Long
Private Declare Function GetCapture Lib "user32" () As Long
Private Sub Command1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
With Command1
If (X < 0) Or (Y < 0) Or (X > .Width) Or (Y > .Height) Then 'MouseLeave
Call ReleaseCapture
ElseIf GetCapture() <> .hwnd Then 'MouseEnter
Call SetCapture(.hwnd)
Else
'Normal MouseMove
End If
End With
End Sub
Just Replace Command1 with any control that supports a MouseMove event.
Laugh, and the world laughs with you. Cry, and you just water down your vodka.
Take credit, not responsibility
-
Nov 13th, 2002, 10:37 PM
#14
Get the name of the current user, and the computer
VB Code:
Option Explicit
Private Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, _
nSize As Long) _
As Long
Private Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, _
nSize As Long) _
As Long
Private Function ReturnUserName() As String
ReturnUserName = Space$(255)
Call GetUserName(ReturnUserName, Len(ReturnUserName))
End Function
Private Function ReturnComputerName() As String
ReturnComputerName = Space$(255)
Call GetComputerName(ReturnComputerName, Len(ReturnComputerName))
End Function
Private Sub Command1_Click()
MsgBox ReturnUserName
MsgBox ReturnComputerName
End Sub
Last edited by crptcblade; Nov 13th, 2002 at 10:45 PM.
Laugh, and the world laughs with you. Cry, and you just water down your vodka.
Take credit, not responsibility
-
Apr 11th, 2012, 11:02 AM
#15
Lively Member
Re: Visual Basic API FAQs
Originally Posted by crptcblade
Get the name of the current user, and the computer
VB Code:
Option Explicit
Private Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, _
nSize As Long) _
As Long
Private Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, _
nSize As Long) _
As Long
Private Function ReturnUserName() As String
ReturnUserName = Space$(255)
Call GetUserName(ReturnUserName, Len(ReturnUserName))
End Function
Private Function ReturnComputerName() As String
ReturnComputerName = Space$(255)
Call GetComputerName(ReturnComputerName, Len(ReturnComputerName))
End Function
Private Sub Command1_Click()
MsgBox ReturnUserName
MsgBox ReturnComputerName
End Sub
environ("computername")
and
environ("username")
Was that so hard xD
No need of api's and stuff :P
NiTrOwow
-
Nov 13th, 2002, 10:48 PM
#16
Get the Windows, System, and Temp directories
VB Code:
Option Explicit
Private Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, _
ByVal nSize As Long) _
As Long
Private Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, _
ByVal nSize As Long) _
As Long
Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, _
ByVal lpBuffer As String) _
As Long
Private Const DIR_SYS As Byte = 0
Private Const DIR_WIN As Byte = 1
Private Const DIR_TEMP As Byte = 2
Private Function GetPath(ByVal PathType As Byte) As String
GetPath = Space$(255)
Select Case PathType
Case DIR_SYS: Call GetSystemDirectory(GetPath, Len(GetPath))
Case DIR_WIN: Call GetWindowsDirectory(GetPath, Len(GetPath))
Case DIR_TEMP: Call GetTempPath(Len(GetPath), GetPath)
End Select
End Function
Private Sub Command1_Click()
MsgBox GetPath(DIR_WIN)
MsgBox GetPath(DIR_SYS)
MsgBox GetPath(DIR_TEMP)
End Sub
Laugh, and the world laughs with you. Cry, and you just water down your vodka.
Take credit, not responsibility
-
Nov 13th, 2002, 10:55 PM
#17
Detect whether a program/AX control/AX DLL is running in the VB6 IDE
VB Code:
Option Explicit
Private Declare Function GetModuleFileName Lib "kernel32" Alias "GetModuleFileNameA" (ByVal hModule As Long, _
ByVal lpFileName As String, _
ByVal nSize As Long) _
As Long
Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
Private Function InIDE() As Boolean
Dim s As String
s = Space$(255)
Call GetModuleFileName(GetModuleHandle(vbNullString), s, Len(s))
InIDE = (UCase$(Trim$(s)) Like "*VB6.EXE*")
End Function
Private Sub Command1_Click()
MsgBox InIDE
End Sub
Laugh, and the world laughs with you. Cry, and you just water down your vodka.
Take credit, not responsibility
-
Nov 13th, 2002, 11:00 PM
#18
Thread Starter
Stuck in the 80s
Display Date in User's Date Format
VB Code:
Option Explicit
'declare API:
Private Declare Function GetDateFormat Lib "kernel32" Alias _
"GetDateFormatA" (ByVal Locale As Long, ByVal dwFlags As Long, _
lpDate As SYSTEMTIME, ByVal lpFormat As String, ByVal lpDateStr As String, _
ByVal cchDate As Long) As Long
'declare type:
Private Type SYSTEMTIME
wYear As Integer
wMonth As Integer
wDayOfWeek As Integer
wDay As Integer
wHour As Integer
wMinute As Integer
wSecond As Integer
wMilliseconds As Integer
End Type
Private Sub Form_Load()
Dim strBuff As String, TheTime As SYSTEMTIME
'setup systemtime with today's date:
With TheTime
.wDay = Day(Now)
.wMonth = Month(Now)
.wYear = Year(Now)
End With
'create the buffer:
strBuff = String(255, 0)
'get the format:
GetDateFormat ByVal 0&, 0, TheTime, vbNullString, strBuff, Len(strBuff)
'trim the buffer:
strBuff = Left(strBuff, InStr(1, strBuff, Chr(0)) - 1)
MsgBox strBuff
End Sub
-
Nov 13th, 2002, 11:03 PM
#19
Find an list item in a listbox by its string value without looping
VB Code:
Option Explicit
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
lParam As Any) _
As Long
Private Const LB_ERR = (-1)
Private Const LB_FINDSTRING = &H18F
Private Const LB_FINDSTRINGEXACT = &H1A2
Private Function FindItemByString(lst As ListBox, ByVal SearchFor As String, Optional FindExact As Boolean = False) As Integer
FindItemByString = CInt(SendMessage(lst.hwnd, IIf(FindExact, LB_FINDSTRINGEXACT, LB_FINDSTRING), _
LB_ERR, ByVal SearchFor))
End Function
Laugh, and the world laughs with you. Cry, and you just water down your vodka.
Take credit, not responsibility
-
Nov 13th, 2002, 11:05 PM
#20
Same thing, but with a Combobox
VB Code:
Option Explicit
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
lParam As Any) _
As Long
Private Const CB_ERR = (-1)
Private Const CB_FINDSTRING = &H14C
Private Const CB_FINDSTRINGEXACT = &H158
Private Function FindItemByString(cmb As ComboBox, ByVal SearchFor As String, Optional FindExact As Boolean = False) As Integer
FindItemByString = CInt(SendMessage(cmb.hwnd, IIf(FindExact, CB_FINDSTRINGEXACT, CB_FINDSTRING), _
CB_ERR, ByVal SearchFor))
End Function
Laugh, and the world laughs with you. Cry, and you just water down your vodka.
Take credit, not responsibility
-
Nov 13th, 2002, 11:13 PM
#21
So Unbanned
Not sure about this, but won't the environ function return the windows version?
If so, why use API?
-
Nov 13th, 2002, 11:13 PM
#22
A few simple textbox functions
VB Code:
Option Explicit
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
lParam As Any) _
As Long
Private Const EM_GETLINECOUNT = &HBA
Private Const EM_LINEFROMCHAR = &HC9
Private Const EM_LINELENGTH = &HC1
Private Function GetLineCount(txt As TextBox) As Long
GetLineCount = SendMessage(txt.hwnd, EM_GETLINECOUNT, ByVal 0&, ByVal 0&)
End Function
Private Function GetCurrentLine(txt As TextBox) As Long
GetCurrentLine = SendMessage(txt.hwnd, EM_LINEFROMCHAR, ByVal txt.SelStart, ByVal 0&) + 1
End Function
Private Function GetLineLength(txt As TextBox, line As Long) As Long
GetLineLength = SendMessage(txt.hwnd, EM_LINELENGTH, ByVal line, ByVal 0&)
End Function
Private Sub Command1_Click()
MsgBox GetLineCount(Text1)
MsgBox GetCurrentLine(Text1)
MsgBox GetLineLength(Text1, GetCurrentLine(Text1))
End Sub
Laugh, and the world laughs with you. Cry, and you just water down your vodka.
Take credit, not responsibility
-
Nov 13th, 2002, 11:14 PM
#23
Originally posted by DiGiTaIErRoR
Not sure about this, but won't the environ function return the windows version?
If so, why use API?
Why depend on something that can be deleted?
Laugh, and the world laughs with you. Cry, and you just water down your vodka.
Take credit, not responsibility
-
Nov 13th, 2002, 11:17 PM
#24
So Unbanned
Originally posted by crptcblade
Why depend on something that can be deleted?
How's that?
-
Nov 13th, 2002, 11:20 PM
#25
You can change/delete environment variables through the control panel.
Laugh, and the world laughs with you. Cry, and you just water down your vodka.
Take credit, not responsibility
-
Nov 13th, 2002, 11:28 PM
#26
So Unbanned
Originally posted by crptcblade
You can change/delete environment variables through the control panel.
Where?
-
Nov 13th, 2002, 11:31 PM
#27
Depends on the OS I think, on 2k its Control Panel->System->Advanced Tab->Environment Variables button.
Laugh, and the world laughs with you. Cry, and you just water down your vodka.
Take credit, not responsibility
-
Nov 13th, 2002, 11:32 PM
#28
So Unbanned
Originally posted by crptcblade
Depends on the OS I think, on 2k its Control Panel->System->Advanced Tab->Environment Variables button.
What about 9x/ME?
-
Nov 13th, 2002, 11:34 PM
#29
*shrug*
Try looking in Windows help. It should lead you right to it.
Laugh, and the world laughs with you. Cry, and you just water down your vodka.
Take credit, not responsibility
-
Nov 15th, 2002, 01:12 AM
#30
Fanatic Member
The windows version code dosn't work for me-I get a error message:
Compile error: only commemts may appear after End Sub, End Function, or End Property. How do I fix that code:[code]
Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As Long
Private Type OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
szCSDVersion As String * 128
End Type
'Platform IDs
Private Const WIN_ID_31 = 0
Private Const WIN_ID_95_98_ME = 1
Private Const WIN_ID_NT_2K_XP = 2
Public Sub TellWindowsVersion()
Dim lVer As OSVERSIONINFO
lVer.dwOSVersionInfoSize = Len(lVer)
Call GetVersionEx(lVer)
With lVer
Select Case .dwPlatformId
Case WIN_ID_31
MsgBox "Windows 3.x"
Case WIN_ID_95_98_ME
Select Case .dwMinorVersion
Case 0: MsgBox "Windows 95"
Case 10: MsgBox "Windows 98"
Case 90: MsgBox "Windows Me"
End Select
Case WIN_ID_NT_2K_XP
Select Case True
Case (.dwMajorVersion < 5)
MsgBox "Windows NT"
Case (.dwMajorVersion = 5)
Select Case .dwMinorVersion
Case 0: MsgBox "Windows 2000"
Case 1: MsgBox "Windows XP"
End Select
End Select
End Select
End With
End Sub
Private Sub Form_Load()
Call TellWindowsVersion
End Sub{/code]
to make it work?
A.A. Fussy
Babya Software Group
-
Nov 15th, 2002, 07:11 AM
#31
The API, constant, and Type declarations must go at the very top of your code.
Laugh, and the world laughs with you. Cry, and you just water down your vodka.
Take credit, not responsibility
-
Nov 15th, 2002, 08:18 AM
#32
Originally posted by The Hobo
Display Date in User's Date Format
VB Code:
Option Explicit
'declare API:
Private Declare Function GetDateFormat Lib "kernel32" Alias _
"GetDateFormatA" (ByVal Locale As Long, ByVal dwFlags As Long, _
lpDate As SYSTEMTIME, ByVal lpFormat As String, ByVal lpDateStr As String, _
ByVal cchDate As Long) As Long
'declare type:
Private Type SYSTEMTIME
wYear As Integer
wMonth As Integer
wDayOfWeek As Integer
wDay As Integer
wHour As Integer
wMinute As Integer
wSecond As Integer
wMilliseconds As Integer
End Type
Private Sub Form_Load()
Dim strBuff As String, TheTime As SYSTEMTIME
'setup systemtime with today's date:
With TheTime
.wDay = Day(Now)
.wMonth = Month(Now)
.wYear = Year(Now)
End With
'create the buffer:
strBuff = String(255, 0)
'get the format:
GetDateFormat ByVal 0&, 0, TheTime, vbNullString, strBuff, Len(strBuff)
'trim the buffer:
strBuff = Left(strBuff, InStr(1, strBuff, Chr(0)) - 1)
MsgBox strBuff
End Sub
Neat function, but I believe this does the same:
VB Code:
Private Sub Form_Load()
MsgBox CStr(Date)
End Sub
The CStr conversion function uses the system's short date format, so I don't see a reason to use API's for this.
-
Nov 15th, 2002, 01:47 PM
#33
Thread Starter
Stuck in the 80s
Originally posted by Frans C
Neat function, but I believe this does the same:
VB Code:
Private Sub Form_Load()
MsgBox CStr(Date)
End Sub
The CStr conversion function uses the system's short date format, so I don't see a reason to use API's for this.
So it does. But it could also be noted that the CStr() is not required and Date will do.
Thanks for sharing that, Frans. I didn't know it worked that way.
-
Nov 15th, 2002, 09:13 PM
#34
Originally posted by The Hobo
So it does. But it could also be noted that the CStr() is not required and Date will do.
Using an implicit conversion does the job just as well, but I prefer explicit conversions.
FYI,
In VB.NET there is a new "Option": Option Strict
If you set this on, implicit conversions aren't allowed.
Now why would you want that?
The .NET IDE shows you the benefits, because many conversion errors can be displayed while you type your code.
Many bugs can be avoided this way.
-
Jul 7th, 2003, 09:45 AM
#35
Addicted Member
I know this is a slightly older post to be asking a question... but its some good stuff.
Under the post:
System Tray and Title Bar Button
I can't seem to get the button added to the title bar to do anything... If I manually call the ButtonPressed sub it works great. It would be nice to be able to get the title bar button to work tho.
Thanks for looking.
-------------------------
My name says it all!
-
Mar 29th, 2004, 06:12 PM
#36
Member
I would like to jsut say thanks to all who have contributed to this topic. It's very useful and nice of you all. Keep up the great work!
Good programming site:
*http://www.planet-source-code.com
Our CS Clan Page:
*http://h2p.inter-gamer.com/index.html
-
Mar 30th, 2004, 04:48 PM
#37
-
Jul 30th, 2004, 01:46 AM
#38
Frenzied Member
Thanks Philip
Ill add some of my own stuff to this thread later 
:::`DISCLAIMER`:::
Do NOT take anything i have posted to be truthful in any way, shape or form.
Thank You!
--------------------------------
"Never heard about "hiking" poles. I usualy just grab a stick from the nature, and use that as a pole." - NoteMe
"Finaly I can look as gay as I want..." - NoteMe
Languages: VB6, BASIC, Java, C#. C++
-
Jul 30th, 2004, 02:12 AM
#39
-
Aug 1st, 2004, 07:13 PM
#40
Hyperactive Member
Add Horizontal Scroll bar to Listboxes
VB Code:
'PUT IN MODULE...
Public Const LB_SETHORIZONTALEXTENT = &H194
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Public Sub HorizontalSbar(List1 As ListBox)
Dim lngReturn As Long
Dim lngExtent As Long
lngExtent = 2 * (List1.Width / Screen.TwipsPerPixelX) 'Set the Horizontal Bar to 2 times its Width
lngReturn = SendMessage(List1.hwnd, LB_SETHORIZONTALEXTENT, lngExtent, 0&)
End Sub
'USAGE:
'Call HorizontalSbar(LISTBOX_NAME_HERE)
Move Form With No Border
VB Code:
Private Declare Function ReleaseCapture Lib "user32" () As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Public Sub DragForm(frm As Form)
ReleaseCapture
Call SendMessage(frm.hwnd, &HA1, 2, 0&)
End Sub
'USAGE:
'Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X 'As Single, Y As Single)
'DragForm Me
'End Sub
Transparent Form
VB Code:
Option Explicit
Private Declare Function CreateRectRgn Lib _
"gdi32" (ByVal X1 As Long, ByVal Y1 As Long, _
ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function CombineRgn Lib _
"gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, _
ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
Private Declare Function SetWindowRgn Lib _
"user32" (ByVal hWnd As Long, ByVal hRgn As Long, _
ByVal bRedraw As Boolean) As Long
Private Declare Function DeleteObject Lib _
"gdi32" (ByVal hObject As Long) As Long
' Constants used by the CombineRgn function
Private Const RGN_AND = 1
Private Const RGN_OR = 2
Private Const RGN_XOR = 3
Private Const RGN_DIFF = 4
Private Const RGN_COPY = 5
Private Sub Form_Activate()
Dim rgnForm As Long, rgnCombined As Long
Dim rgnControl As Long, x As Long
Dim formWidth As Single, formHeight As Single
Dim borderWidth As Single, titleHeight As Single
Dim ctlLeft As Single, ctlTop As Single
Dim ctlWidth As Single, ctlHeight As Single
Dim ctl As Control
' Calculate the form area
borderWidth = (Me.Width - Me.ScaleWidth) / 2
titleHeight = Me.Height - Me.ScaleHeight - borderWidth
' Convert to Pixels
borderWidth = ScaleX(borderWidth, vbTwips, vbPixels)
titleHeight = ScaleY(titleHeight, vbTwips, vbPixels)
formWidth = ScaleX(Me.Width, vbTwips, vbPixels)
formHeight = ScaleY(Me.Height, vbTwips, vbPixels)
' Create a region for the whole form
rgnForm = CreateRectRgn(0, 0, formWidth, formHeight)
rgnCombined = CreateRectRgn(0, 0, 0, 0)
' Make the graphical area transparent by combining the two regions
x = CombineRgn(rgnCombined, rgnForm, rgnForm, RGN_DIFF)
' Make the controls visible
For Each ctl In Controls
' Make the regions of controls whose container is the form visible
If TypeOf ctl.Container Is Form Then
ctlLeft = ScaleX(ctl.Left, vbTwips, vbPixels) + borderWidth
ctlTop = ScaleX(ctl.Top, vbTwips, vbPixels) + titleHeight
ctlWidth = ScaleX(ctl.Width, vbTwips, vbPixels) + ctlLeft
ctlHeight = ScaleX(ctl.Height, vbTwips, vbPixels) + ctlTop
rgnControl = CreateRectRgn(ctlLeft, ctlTop, ctlWidth, ctlHeight)
x = CombineRgn(rgnCombined, rgnCombined, rgnControl, RGN_OR)
End If
Next ctl
' Set the clipping area of the window using the resulting region
SetWindowRgn hWnd, rgnCombined, True
' Tidy up
x = DeleteObject(rgnCombined)
x = DeleteObject(rgnControl)
x = DeleteObject(rgnForm)
End Sub
:-)
Born to help others 
(If I've been helpful then please rate my post. Thanks)
call me EJ or be slapped!
Posting Permissions
- You may not post new threads
- You may not post replies
- You may not post attachments
- You may not edit your posts
-
Forum Rules
|
Click Here to Expand Forum to Full Width
|
Reply With Quote
