Visual Basic API FAQs

[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.

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:

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:

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.

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.

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.

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)

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

[crptcblade]

Extracting a file's icon

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)

[Sastraxi]

A whole slew of functions I've been working on, mostly for the GDI

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

[Sastraxi]

And, the declarations:

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

[crptcblade]

Creating odd shaped forms/controls

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.

[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.

'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!

[crptcblade]

How to limit a form's size (min and max)

'/////////////
'* 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 .

[crptcblade]

Get Windows version

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

[crptcblade]

Simulate MouseEnter and MouseLeave events

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.

[crptcblade]

Get the name of the current user, and the computer

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

[crptcblade]

Get the Windows, System, and Temp directories

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

[crptcblade]

Detect whether a program/AX control/AX DLL is running in the VB6 IDE

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

[The Hobo]

Display Date in User's Date Format

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

[crptcblade]

Find an list item in a listbox by its string value without looping

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

[crptcblade]

Same thing, but with a Combobox

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

[DiGiTaIErRoR]

Not sure about this, but won't the environ function return the windows version?

If so, why use API?

[crptcblade]

A few simple textbox functions

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

[crptcblade]

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?

[DiGiTaIErRoR]

Originally posted by crptcblade
Why depend on something that can be deleted?

How's that?

[crptcblade]

You can change/delete environment variables through the control panel.

[DiGiTaIErRoR]

Originally posted by crptcblade
You can change/delete environment variables through the control panel.

Where?

[crptcblade]

Depends on the OS I think, on 2k its Control Panel->System->Advanced Tab->Environment Variables button.

[DiGiTaIErRoR]

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?

[crptcblade]

*shrug*

Try looking in Windows help. It should lead you right to it.

[aafuss]

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?

[crptcblade]

The API, constant, and Type declarations must go at the very top of your code.

[Frans C]

Originally posted by The Hobo
Display Date in User's Date Format

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:

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.

[The Hobo]

Originally posted by Frans C
Neat function, but I believe this does the same:

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.

[Frans C]

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.

[CoderNewbie]

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.

[Insane_Magician]

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!

[manavo11]

I made this a sticky

[ice_531]

Thanks Philip

Ill add some of my own stuff to this thread later

[manavo11]

Originally posted by ice_531
Thanks Philip

Ill add some of my own stuff to this thread later

Go ahead Just make sure you don't post something that's already here

[EJ12N]

Add Horizontal Scroll bar to Listboxes

'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

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

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

:-)

[ice_531]

Okay here we go: hi manavo

Well i wrote up a project to show how to find windows by partial window caption.....seeing as how some windows have the same classname and the hwnd changes...you need to search by title of window but sometimes the title might change as well

here is the project... i did the example to grab the text of an msn instant message window ( the chat text ) ... i think it is simple to understand and if you have any questions or want me to comment every line ( haha ) please ask.

ice

[ice_531]

mouseover effect on command buttons

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

[sciguyryan]

Here are a few more I've dug up from a few old projects

-------------------------------------------------------------------------------------
Arrange Desktop Icons:

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:

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

[danasegarane]

Here is My contribution,

1. How to Select/Deselect All the items in a Filelistbox/Listbox/Combobox.

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

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.

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

[VBDie]

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:

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)