-
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 13th, 2002, 06:55 PM
#3
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
#4
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
#5
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
#6
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!
-
Nov 13th, 2002, 08:34 PM
#7
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
-
Nov 13th, 2002, 10:19 PM
#8
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
#9
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
#10
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
-
Nov 13th, 2002, 10:48 PM
#11
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
#12
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
#13
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
#14
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
#15
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
#16
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
#17
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
#18
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
#19
So Unbanned
Originally posted by crptcblade
Why depend on something that can be deleted?
How's that?
-
Nov 13th, 2002, 11:20 PM
#20
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
#21
So Unbanned
Originally posted by crptcblade
You can change/delete environment variables through the control panel.
Where?
-
Nov 13th, 2002, 11:31 PM
#22
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
#23
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
#24
*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
#25
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
#26
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
#27
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
#28
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
#29
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
#30
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
#31
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
#32
-
Jul 30th, 2004, 01:46 AM
#33
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
#34
-
Aug 1st, 2004, 07:13 PM
#35
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! 
-
Aug 3rd, 2004, 07:32 PM
#36
Frenzied Member
-
Aug 4th, 2004, 08:32 AM
#37
Frenzied Member
mouseover effect on command buttons
VB Code:
Private Declare Function ReleaseCapture Lib "USER32" () As Long Private Declare Function SetCapture Lib "USER32" (ByVal hwnd As Long) As Long Private Sub Command1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) ' will change the background color for the command button With Command1 If (X < 0) Or (Y < 0) Or (X > .Width) Or (Y > .Height) Then ReleaseCapture Command1.BackColor = &HE0E0E0 Else SetCapture .hwnd Command1.BackColor = vbWhite End If End With End Sub Private Sub Command2_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) ' will change the background color for the command button With Command2 If (X < 0) Or (Y < 0) Or (X > .Width) Or (Y > .Height) Then ReleaseCapture Command2.BackColor = &HE0E0E0 Else SetCapture .hwnd Command2.BackColor = vbWhite End If End With End Sub
:::`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++
-
May 22nd, 2005, 07:27 PM
#38
Re: Visual Basic API FAQs
Here are a few more I've dug up from a few old projects 
-------------------------------------------------------------------------------------
Arrange Desktop Icons:
VB Code:
Private Const LVA_ALIGNLEFT = &H1 Private Const LVM_ARRANGE = &H1016 Private Const GW_CHILD = 5 Private Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" ( _ ByVal lpClassName As String, _ ByVal lpWindowName As String) As Long Private Declare Function GetWindow Lib "user32.dll" ( _ ByVal hWnd As Long, _ ByVal wCmd As Long) As Long Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" ( _ ByVal hWnd As Long, _ ByVal wMsg As Long, _ ByVal wParam As Long, _ lParam As Long) As Long Public Function ArrangeDesktopIcons() As Boolean Dim lngHandle As Long Dim lngRetVal As Long lngHandle = FindWindow("Progman", vbNullString) lngHandle = GetWindow(lngHandle, GW_CHILD) lngHandle = GetWindow(lngHandle, GW_CHILD) lngRetVal = SendMessage(lngHandle, LVM_ARRANGE, LVA_ALIGNLEFT, 0) ArrangeDesktopIcons = lngRetVal > 0 End Function
how to Call:
I've made it easy for you, just call the ArrangeDesktopIcons function 
-------------------------------------------------------------------------------------
Determine if a COM Port is Available:
VB Code:
Private Type DCB DCBlength As Long BaudRate As Long fBitFields As Long wReserved As Integer XonLim As Integer XoffLim As Integer ByteSize As Byte Parity As Byte StopBits As Byte XonChar As Byte XoffChar As Byte ErrorChar As Byte EofChar As Byte EvtChar As Byte wReserved1 As Integer End Type Private Type COMMCONFIG dwSize As Long wVersion As Integer wReserved As Integer dcbx As DCB dwProviderSubType As Long dwProviderOffset As Long dwProviderSize As Long wcProviderData As Byte End Type Private Declare Function GetDefaultCommConfig Lib "kernel32.dll" Alias "GetDefaultCommConfigA" ( _ ByVal lpszName As String, _ lpCC As COMMCONFIG, _ lpdwSize As Long) As Long Public Function ComPortExists(ByVal ComPort As Integer) As Boolean Dim udtComConfig As COMMCONFIG Dim lngUDTSize As Long Dim lngRet As Long lngUDTSize = LenB(udtComConfig) lngRet = GetDefaultCommConfig("COM" + Trim$(Str$(ComPort)) + Chr$(0), udtComConfig, lngUDTSize) ComPortExists = lngRet <> 0 End Function
how to Call:
I've made it easy for you, just call the ComPortExists function with the port number to check 
-------------------------------------------------------------------------------------
Now, i can't say I've written those, probably found them and modified them but I'll post them here anyway 
If anyone knows the authors names then please post them here 
Cheers,
RyanJ
-
Sep 7th, 2006, 12:34 AM
#39
Re: Visual Basic API FAQs
Here is My contribution,
1. How to Select/Deselect All the items in a Filelistbox/Listbox/Combobox.
VB Code:
Private Declare Function SendMessageLong Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long Private Const LB_SETSEL = &H185 Private Sub cmd_select_Click() Call SendMessageLong(File1.hwnd, LB_SETSEL, 1, -1) End Sub wParam --> 0 = DeSelect, 1 = Select lParam --> -1 = All, 0-## = Just that Index
Set Multiselect Property To
VB Code:
File1.MultiSelect = 1 ' Simple MultiSelect ' File1.MultiSelect = 2 ' Extended MultiSelect '
Thanks To tward_biteme1
2.How to Limit the Charcter Length of a Combo box.
VB Code:
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_LIMITTEXT = &H141 SendMessage Combo1.hwnd, CB_LIMITTEXT, 10, 0& 'where 10 is length given Here.You can Change this
Thanks to Hack and MartinLiss
Last edited by danasegarane; Sep 7th, 2006 at 12:41 AM.
-
Oct 21st, 2006, 08:55 AM
#40
New Member
Re: Visual Basic API FAQs
 Originally Posted by The Hobo
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.
The problem with this code is that it will change the size of the form to 0,0,0,0. This is what I have added:
VB Code:
Sub TopMostX(BB As Byte, FormX As Form) ', XLeft, XTop, XHeight, XWidth) If Left$(FormX.Left, 1) = "-" Then FormX.Left = 0 End If If Left$(FormX.Top, 1) = "-" Then FormX.Top = 0 End If If Left$(FormX.Height, 1) = "-" Then FormX.Height = 3000 End If If Left$(FormX.Width, 1) = "-" Then FormX.Width = 3000 End If XLeft = FormX.Left XTop = FormX.Top XHeight = FormX.Height XWidth = FormX.Width If BB = 1 Then ' Turn on the TopMost attribute. SetWindowPos FormX.hwnd, -1, 0, 0, 0, 0, &H50 ElseIf BB = 2 Then ' Turn off the TopMost attribute. SetWindowPos FormX.hwnd, -2, 0, 0, 0, 0, &H50 End If FormX.Left = XLeft FormX.Top = XTop FormX.Height = XHeight FormX.Width = XWidth End Sub
(The "-" is when the form is on the outside of the boundaries of the screen)
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
|