Page 1 of 3 123 LastLast
Results 1 to 40 of 85

Thread: Visual Basic API FAQs

  1. #1

    Thread Starter
    Stuck in the 80s The Hobo's Avatar
    Join Date
    Jul 2001
    Location
    Michigan
    Posts
    7,256

    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:
    1. Option Explicit
    2.  
    3. 'declare API:
    4. Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
    5.   (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
    6.  
    7. Private Sub Form_Load()
    8. Dim strCaption As String, lhWnd As Long
    9.  
    10.   'Exact caption of the window:
    11.   strCaption = "Untitled - Notepad"
    12.   lhWnd = FindWindow(vbNullString, strCaption)
    13.  
    14.   'if the result is 0, window was not found:
    15.   If lhWnd = 0 Then
    16.     MsgBox "Could not find Notepad..."
    17.   Else
    18.     MsgBox "Notepad found: " & lhWnd
    19.   End If
    20. End Sub

    Get HWND from class name
    The other method would be to use the window's class name:

    VB Code:
    1. Option Explicit
    2.  
    3. 'declare API:
    4. Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
    5.   (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
    6.  
    7. Private Sub Form_Load()
    8. Dim strClassName As String, lhWnd As Long
    9.  
    10.   'Class Name of the window:
    11.   strClassName = "Notepad"
    12.   lhWnd = FindWindow(strClassName, vbNullString)
    13.  
    14.   'if the result is 0, window was not found:
    15.   If lhWnd = 0 Then
    16.     MsgBox "Could not find Notepad..."
    17.   Else
    18.     MsgBox "Notepad found: " & lhWnd
    19.   End If
    20. 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:
    1. Option Explicit
    2.  
    3. 'declare api function:
    4. Private Declare Function BringWindowToTop Lib "user32" _
    5.   (ByVal hwnd As Long) As Long
    6.  
    7. 'this code brings our window to the top every half a second:  
    8. Private Sub Form_Load()
    9.   'setup our timer's interval:
    10.   Timer1.Interval = 500
    11. End Sub
    12.  
    13. Private Sub Timer1_Timer()
    14.   'bring our project to the top:
    15.   BringWindowToTop Me.hwnd
    16. 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:
    1. Option Explicit
    2.  
    3. 'declare constants:
    4. Private Const HWND_TOPMOST = -1
    5. Private Const HWND_NOTOPMOST = -2
    6.  
    7. Private Const SWP_NOSIZE = &H1
    8. Private Const SWP_NOMOVE = &H2
    9. Private Const SWP_NOACTIVATE = &H10
    10. Private Const SWP_SHOWWINDOW = &H40
    11.  
    12. 'declare API:
    13. Private Declare Sub SetWindowPos Lib "User32" (ByVal hWnd As Long, _
    14.   ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, _
    15.   ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long)
    16.  
    17. Private Sub Command1_Click()
    18.   'set topmost:
    19.   SetWindowPos Me.hWnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOACTIVATE Or _
    20.     SWP_SHOWWINDOW Or SWP_NOMOVE Or SWP_NOSIZE
    21. End Sub
    22.  
    23. Private Sub Command2_Click()
    24.   'set not topmost:
    25.   SetWindowPos Me.hWnd, HWND_NOTOPMOST, 0, 0, 0, 0, SWP_NOACTIVATE Or _
    26.     SWP_SHOWWINDOW Or SWP_NOMOVE Or SWP_NOSIZE
    27. End Sub
    28.  
    29. Private Sub Form_Load()
    30.   'project requires 2 commandbuttons:
    31.   Command1.Caption = "Top Most"
    32.   Command2.Caption = "Not Top Most"
    33. 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:
    1. Option Explicit
    2.  
    3. 'Declare API:
    4. Private Declare Function GetForegroundWindow Lib "user32" () As Long
    5. Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" _
    6.   (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
    7. Private Declare Function SetWindowText Lib "user32" Alias "SetWindowTextA" _
    8.   (ByVal hwnd As Long, ByVal lpString As String) As Long
    9.  
    10. Private Sub Command1_Click()
    11. Dim lhWnd As Long, strCaption As String
    12.  
    13.   'create our buffer for the caption:
    14.   strCaption = String(100, Chr$(0))
    15.   'get the topmost window:
    16.   lhWnd = GetForegroundWindow()
    17.    
    18.   'get the caption
    19.   GetWindowText lhWnd, strCaption, 100
    20.  
    21.   'clear the buffer:
    22.   strCaption = Left(strCaption, InStr(strCaption, Chr(0)) - 1)
    23.  
    24.   'reverse the string and set the new caption:
    25.   strCaption = StrReverse(strCaption)
    26.   SetWindowText lhWnd, strCaption
    27. 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:
    1. Option Explicit
    2.  
    3. 'declare API:
    4. Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
    5.   (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
    6.  
    7. Private Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, _
    8.   ByVal hWndNewParent As Long) As Long
    9.  
    10. Private Sub Form_Load()
    11. Dim lhWnd As Long
    12.  
    13.   'Get Notepads HWND:
    14.   lhWnd = FindWindow("Notepad", vbNullString)
    15.  
    16.   'if the result is 0, window was not found:
    17.   If lhWnd = 0 Then
    18.     MsgBox "Could not find Notepad..."
    19.   Else
    20.     'set the parent:
    21.     SetParent lhWnd, Me.hwnd
    22.   End If
    23. 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:
    1. Option Explicit
    2.  
    3. 'declare constants:
    4. Private Const SW_SHOWNORMAL = 1
    5.  
    6. 'declare API:
    7. Private Declare Function ShellExecute Lib "shell32.dll" Alias _
    8.   "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, _
    9.   ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As _
    10.   String, ByVal nShowCmd As Long) As Long
    11.  
    12. Private Sub Form_Load()
    13. Dim lError As Long
    14.  
    15.   'launch C:\movies.txt, given that it exists:
    16.   lError = ShellExecute(Me.hwnd, vbNullString, "C:\movies.txt", vbNullString, _
    17.     "C:", SW_SHOWNORMAL)
    18.  
    19.   'if returns 2:
    20.   If lError = 2 Then
    21.     MsgBox "File does not exist!"
    22.   End If
    23. End Sub

  2. #2
    The Devil crptcblade's Avatar
    Join Date
    Aug 2000
    Location
    Quetzalshacatenango
    Posts
    9,091
    Extracting a file's icon
    VB Code:
    1. Option Explicit
    2.  
    3. Private Declare Function ExtractFileIcon Lib "shell32.dll" Alias "ExtractAssociatedIconA" (ByVal hInst As Long, _
    4.                                                                                            ByVal lpIconPath As String, _
    5.                                                                                            lpiIcon As Long) _
    6.                                                                                            As Long
    7. Private Declare Function DrawIcon Lib "user32" (ByVal hdc As Long, _
    8.                                                 ByVal x As Long, _
    9.                                                 ByVal y As Long, _
    10.                                                 ByVal hIcon As Long) _
    11.                                                 As Long
    12.  
    13. Private Sub Command1_Click()
    14. Dim hIcon As Long
    15.  
    16.     hIcon = ExtractFileIcon(App.hInstance, "c:\test.txt", 1)
    17.     Call DrawIcon(Picture1.hdc, 0, 0, hIcon)
    18.  
    19. 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

  3. #3
    Good Ol' Platypus Sastraxi's Avatar
    Join Date
    Jan 2000
    Location
    Ontario, Canada
    Posts
    5,134
    A whole slew of functions I've been working on, mostly for the GDI
    VB Code:
    1. 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)
    2. Dim tRect As RECT
    3. Dim Q As SIZE
    4.  
    5.     GetTextExtentPoint32 hDestDC, Text, Len(Text), Q
    6.    
    7.     With tRect
    8.         If dwFlags And TDP_RIGHT Then
    9.             .Left = x - (Q.cx + 5)
    10.             .Right = x
    11.         ElseIf dwFlags And TDP_HCENTRE Then
    12.             .Left = x - (Q.cx / 2)
    13.             .Right = x + (Q.cx / 2)
    14.         Else
    15.             .Left = x
    16.             .Right = x + (Q.cx - 1)
    17.         End If
    18.         If dwFlags And TDP_BOTTOM Then
    19.             .Top = y - (Q.cy + 5)
    20.             .Bottom = y
    21.         ElseIf dwFlags And TDP_VCENTRE Then
    22.             .Top = y - (Q.cy / 2)
    23.             .Bottom = y + (Q.cy / 2)
    24.         Else
    25.             .Top = y
    26.             .Bottom = y + (Q.cy - 1)
    27.         End If
    28.     End With
    29.  
    30.     SelectObject hDestDC, CreateMyFont(TextPoint, TextFace)
    31.     SetTextColor hDestDC, TextColour
    32.     DrawText hDestDC, Text, Len(Text), tRect, 0
    33.    
    34. End Function
    35. Public Function CreateMyFont(nSize As Integer, sFace As String) As Long  'FROM ALL-API.NET, MODIFIED
    36.     'Create a specified font
    37.     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)
    38. End Function
    39. 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)
    40. Dim CropText As String
    41. Dim Q As SIZE
    42.  
    43.     SelectObject hDestDC, CreateMyFont(TextPoint, TextFace)
    44.     GetTextExtentPoint32 hDestDC, Text, Len(Text), Q
    45.    
    46.     CropText = Text
    47.    
    48.     Do While Q.cx > Width
    49.         Q.cx = 0: Q.cy = 0
    50.         CropText = Left$(CropText, Len(CropText) - 1)
    51.         GetTextExtentPoint32 hDestDC, CropText, Len(CropText), Q
    52.     Loop
    53.    
    54.     If CropText <> Text Then
    55.         If Len(CropText) > 3 Then
    56.             CropText = Left$(CropText, Len(CropText) - 3) & "..."
    57.         Else
    58.             If Len(CropText) = 3 Then CropText = "..."
    59.             If Len(CropText) = 2 Then CropText = ".."
    60.             If Len(CropText) = 1 Then CropText = "."
    61.         End If
    62.     End If
    63.    
    64.     TextBlt hDestDC, x, y, CropText, TextColour, TextPoint, TextFace, dwFlags
    65.    
    66. End Function
    67. 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)
    68. Dim I As Long
    69. Dim J As Long
    70.  
    71. Dim dColour As mLong
    72. Dim dRGB As mRGB
    73. Dim sColour As mLong
    74. Dim sRGB As mRGB
    75. Dim aColour As mLong
    76. Dim aRGB As mRGB
    77.  
    78. Dim TempR As Long
    79. Dim TempG As Long
    80. Dim TempB As Long
    81.  
    82.     For J = y To y + (nHeight - 1)
    83.         For I = x To x + (nWidth - 1)
    84.            
    85.             dColour.L = GetPixel(hDestDC, I, J)
    86.             sColour.L = GetPixel(hSrcDC, I - x + xSrc, J - y + ySrc)
    87.             aColour.L = GetPixel(hAlphaDC, I - x + xSrc, J - y + ySrc)
    88.            
    89.             LSet dRGB = dColour
    90.             LSet sRGB = sColour
    91.             LSet aRGB = aColour
    92.            
    93.             aRGB.R = 255 - aRGB.R
    94.             aRGB.G = 255 - aRGB.G
    95.             aRGB.B = 255 - aRGB.B
    96.            
    97.             TempR = (aRGB.R * CLng(sRGB.R + 256 - dRGB.R)) / 256 + dRGB.R - aRGB.R
    98.             TempG = (aRGB.G * CLng(sRGB.G + 256 - dRGB.G)) / 256 + dRGB.G - aRGB.G
    99.             TempB = (aRGB.B * CLng(sRGB.B + 256 - dRGB.B)) / 256 + dRGB.B - aRGB.B
    100.            
    101.             SetPixelV hDestDC, I, J, RGB(TempR, TempG, TempB)
    102.            
    103.         Next I
    104.     Next J
    105.    
    106. End Function
    107.  
    108. 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)
    109. Dim I As Long
    110. Dim J As Long
    111. Dim ICut As Long
    112. Dim JCut As Long
    113.  
    114.     For J = y To y + (nHeight - 1) Step srcHeight
    115.         If J + srcHeight > y + (nHeight - 1) Then
    116.             JCut = (y + nHeight) - J
    117.         Else
    118.             JCut = srcHeight
    119.         End If
    120.         For I = x To x + (nWidth - 1) Step srcWidth
    121.             If I + srcWidth > x + (nWidth - 1) Then
    122.                 ICut = (x + nWidth) - I
    123.             Else
    124.                 ICut = srcWidth
    125.             End If
    126.             BitBlt hDestDC, I, J, ICut, JCut, hSrcDC, xSrc, ySrc, dwRop
    127.         Next I
    128.     Next J
    129.    
    130. End Function
    131.  
    132. 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
    133. Dim hSmIco As Long
    134. Dim hLgIco As Long
    135.  
    136.     Call ExtractIconEx(hExeSrc, hIndex, hLgIco, hSmIco, 1)
    137.     If hSmallIcon Then
    138.         IconBlt = DrawIconEx(hDestDC, x, y, hSmIco, 16, 16, 0, 0, DI_NORMAL)
    139.     Else
    140.         IconBlt = DrawIconEx(hDestDC, x, y, hLgIco, 32, 32, 0, 0, DI_NORMAL)
    141.     End If
    142.     DestroyIcon hSmIco: DestroyIcon hLgIco
    143.    
    144. End Function
    145.  
    146. 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
    147. Dim hSmIco As Long
    148. Dim hLgIco As Long
    149. Dim hResult As Long
    150.  
    151.     Call ExtractIconEx(hExeSrc, hIndex, hLgIco, hSmIco, 1)
    152.     If hSmallIcon Then
    153.         hResult = DrawIconEx(hMaskDC, 0, 0, hSmIco, 16, 16, 0, 0, DI_MASK)
    154.         hResult = DrawIconEx(hImgDC, 0, 0, hSmIco, 16, 16, 0, 0, DI_IMAGE)
    155.         SmoothMask hTempDC, hMaskDC, 0, 0, 16, 16, smoothval
    156.         AlphaBlt hDestDC, x, y, 16, 16, hImgDC, frmMain.Src(8).hdc, 0, 0
    157.     Else
    158.         hResult = DrawIconEx(hMaskDC, 0, 0, hLgIco, 32, 32, 0, 0, DI_MASK)
    159.         hResult = DrawIconEx(hImgDC, 0, 0, hLgIco, 32, 32, 0, 0, DI_IMAGE)
    160.         SmoothMask hTempDC, hMaskDC, 0, 0, 32, 32, smoothval * 2
    161.         AlphaBlt hDestDC, x, y, 32, 32, hImgDC, hMaskDC, 0, 0
    162.     End If
    163.     DestroyIcon hSmIco: DestroyIcon hLgIco
    164.    
    165. End Function
    166.  
    167. 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)
    168. Dim hInverse As Long
    169. Dim I As Long, J As Long
    170. Dim Base As Long
    171. Dim Plus As Long
    172. Dim Dot As Long
    173. Dim Q As Long
    174. Dim nDot As Long
    175. Dim nPlus As Long
    176.  
    177.     hInverse = 100 - (6 * hSmoothWeight)
    178.     '.+.   This requires explaining. # will recieve hInverse rating, + will
    179.     '+#+   recieve hSmoothWeight rating, and . will recieve half of hSmoothWieght
    180.     '.+.   as its rating. Thus 4 * hSmoothWeight + (4 * 0.5) * hSmoothWeight, or 6 * hSmoothweight
    181.    
    182.     For J = y To y + (hHeight - 1)
    183.         For I = x To x + (hWidth - 1)
    184.            
    185.             Dot = 0
    186.             Q = 0
    187.             Base = 0
    188.             Plus = 0
    189.             nPlus = 0
    190.             nDot = 0
    191.            
    192.             Q = GetPixel(hdc, I, J)
    193.             Base = Mono(Q)
    194.            
    195.             If Base = 0 Then
    196.            
    197.                 Q = GetPixel(hdc, I - 1, J)
    198.                 If Q <> -1 Then
    199.                     Plus = Plus + Mono(Q)
    200.                     nPlus = nPlus + 1
    201.                 End If
    202.                 Q = GetPixel(hdc, I + 1, J)
    203.                 If Q <> -1 Then
    204.                     Plus = Plus + Mono(Q)
    205.                     nPlus = nPlus + 1
    206.                 End If
    207.                 Q = GetPixel(hdc, I, J - 1)
    208.                 If Q <> -1 Then
    209.                     Plus = Plus + Mono(Q)
    210.                     nPlus = nPlus + 1
    211.                 End If
    212.                 Q = GetPixel(hdc, I, J + 1)
    213.                 If Q <> -1 Then
    214.                     Plus = Plus + Mono(Q)
    215.                     nPlus = nPlus + 1
    216.                 End If
    217.                 Plus = Plus / nPlus
    218.            
    219.                 Q = GetPixel(hdc, I - 1, J - 1)
    220.                 If Q <> -1 Then
    221.                     Dot = Dot + Mono(Q)
    222.                     nDot = nDot + 1
    223.                 End If
    224.                 Q = GetPixel(hdc, I + 1, J - 1)
    225.                 If Q <> -1 Then
    226.                     Dot = Dot + Mono(Q)
    227.                     nDot = nDot + 1
    228.                 End If
    229.                 Q = GetPixel(hdc, I - 1, J + 1)
    230.                 If Q <> -1 Then
    231.                     Dot = Dot + Mono(Q)
    232.                     nDot = nDot + 1
    233.                 End If
    234.                 Q = GetPixel(hdc, I + 1, J + 1)
    235.                 If Q <> -1 Then
    236.                     Dot = Dot + Mono(Q)
    237.                     nDot = nDot + 1
    238.                 End If
    239.                 Dot = Dot / nDot
    240.            
    241.                 Base = ((hInverse / 100) * Base) + ((hSmoothWeight * 4 / 100) * Plus) + ((hSmoothWeight * 2 / 100) * Dot)
    242.                 SetPixelV hDestDC, I, J, RGB(Base, Base, Base)
    243.            
    244.             End If
    245.            
    246.         Next I
    247.     Next J
    248.    
    249. End Function
    250. Public Function Mono(Valu As Long) As Long
    251.     If Valu = 0 Then Mono = 0 Else Mono = 255
    252. 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)

  4. #4
    Good Ol' Platypus Sastraxi's Avatar
    Join Date
    Jan 2000
    Location
    Ontario, Canada
    Posts
    5,134
    And, the declarations:
    VB Code:
    1. Option Explicit
    2.  
    3. Public Type mLong
    4.     L As Long
    5. End Type
    6.  
    7. Public Type mRGB
    8.     R As Byte
    9.     G As Byte
    10.     B As Byte
    11.     A As Byte
    12. End Type
    13.  
    14. Public Enum TEXTDRAWPARAM
    15.     TDP_LEFT = 0
    16.     TDP_RIGHT = 1
    17.     TDP_HCENTRE = 2
    18.     TDP_TOP = 4
    19.     TDP_BOTTOM = 8
    20.     TDP_VCENTRE = 16
    21. End Enum
    22.  
    23. Public Const FW_DONTCARE = 0
    24. Public Const FW_THIN = 100
    25. Public Const FW_EXTRALIGHT = 200
    26. Public Const FW_LIGHT = 300
    27. Public Const FW_NORMAL = 400
    28. Public Const FW_MEDIUM = 500
    29. Public Const FW_SEMIBOLD = 600
    30. Public Const FW_BOLD = 700
    31. Public Const FW_EXTRABOLD = 800
    32. Public Const FW_HEAVY = 900
    33. Public Const FW_BLACK = FW_HEAVY
    34. Public Const FW_DEMIBOLD = FW_SEMIBOLD
    35. Public Const FW_REGULAR = FW_NORMAL
    36. Public Const FW_ULTRABOLD = FW_EXTRABOLD
    37. Public Const FW_ULTRALIGHT = FW_EXTRALIGHT
    38. Public Const ANSI_CHARSET = 0
    39. Public Const DEFAULT_CHARSET = 1
    40. Public Const SYMBOL_CHARSET = 2
    41. Public Const SHIFTJIS_CHARSET = 128
    42. Public Const HANGEUL_CHARSET = 129
    43. Public Const CHINESEBIG5_CHARSET = 136
    44. Public Const OEM_CHARSET = 255
    45. Public Const OUT_CHARACTER_PRECIS = 2
    46. Public Const OUT_DEFAULT_PRECIS = 0
    47. Public Const OUT_DEVICE_PRECIS = 5
    48. Public Const CLIP_DEFAULT_PRECIS = 0
    49. Public Const CLIP_CHARACTER_PRECIS = 1
    50. Public Const CLIP_STROKE_PRECIS = 2
    51. Public Const DEFAULT_QUALITY = 0
    52. Public Const DRAFT_QUALITY = 1
    53. Public Const PROOF_QUALITY = 2
    54. Public Const DEFAULT_PITCH = 0
    55. Public Const FIXED_PITCH = 1
    56. Public Const VARIABLE_PITCH = 2
    57. Public Const OPAQUE = 2
    58. Public Const TRANSPARENT = 1
    59. Public Const LOGPIXELSY = 90
    60. Public Const OBJ_BITMAP = 7
    61. Public Const DT_RIGHT = &H2
    62.  
    63. Public Declare Function GetCurrentObject Lib "gdi32" (ByVal hdc As Long, ByVal uObjectType As Long) As Long
    64. Public Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
    65. 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
    66. Public Declare Function SetPixelV Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal crColor As Long) As Long
    67. Public Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
    68. 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
    69. 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
    70. Public Declare Function DestroyIcon Lib "user32" (ByVal hIcon As Long) As Long
    71. 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
    72. Public Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
    73. 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
    74. 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
    75. Public Declare Function MulDiv Lib "kernel32" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long) As Long
    76. Public Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
    77. Public Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
    78. 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
    79. Public Declare Function VarPtrArray Lib "msvbvm60.dll" Alias "VarPtr" (Ptr() As Any) As Long
    80. Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDst As Any, pSrc As Any, ByVal ByteLen As Long)
    81. Public Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
    82. Public Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
    83.  
    84. Public Const DI_MASK = &H1
    85. Public Const DI_IMAGE = &H2
    86. Public Const DI_NORMAL = DI_MASK Or DI_IMAGE
    87.  
    88. Public Type RECT
    89.         Left As Long
    90.         Top As Long
    91.         Right As Long
    92.         Bottom As Long
    93. End Type
    94. Public Type SIZE
    95.         cx As Long
    96.         cy As Long
    97. 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)

  5. #5
    The Devil crptcblade's Avatar
    Join Date
    Aug 2000
    Location
    Quetzalshacatenango
    Posts
    9,091
    Creating odd shaped forms/controls
    VB Code:
    1. Option Explicit
    2.  
    3. Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, _
    4.                                                     ByVal Y1 As Long, _
    5.                                                     ByVal X2 As Long, _
    6.                                                     ByVal Y2 As Long) _
    7.                                                     As Long
    8. Private Declare Function CreateEllipticRgn Lib "gdi32" (ByVal X1 As Long, _
    9.                                                         ByVal Y1 As Long, _
    10.                                                         ByVal X2 As Long, _
    11.                                                         ByVal Y2 As Long) _
    12.                                                         As Long
    13. Private Declare Function CreateRoundRectRgn Lib "gdi32" (ByVal X1 As Long, _
    14.                                                          ByVal Y1 As Long, _
    15.                                                          ByVal X2 As Long, _
    16.                                                          ByVal Y2 As Long, _
    17.                                                          ByVal X3 As Long, _
    18.                                                          ByVal Y3 As Long) _
    19.                                                          As Long
    20. Private Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, _
    21.                                                     ByVal hRgn As Long, _
    22.                                                     ByVal bRedraw As Boolean) _
    23.                                                     As Long
    24. Private Declare Function CreatePolygonRgn Lib "gdi32" (lpPoint As POINT, _
    25.                                                        ByVal nCount As Long, _
    26.                                                        ByVal nPolyFillMode As Long) _
    27.                                                        As Long
    28. Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
    29.  
    30. Private Type POINT
    31.     x As Long
    32.     y As Long
    33. End Type
    34.  
    35. Private Const ALTERNATE = 1
    36. Private Const WINDING = 2
    37.  
    38. Private Sub Form_Resize()
    39. Dim hRgn As Long, w As Long, h As Long
    40.  
    41. Dim p(0 To 3) As POINT
    42.  
    43.     w = ScaleX(Me.Width, Me.ScaleMode, vbPixels) - 1
    44.     h = ScaleY(Me.Height, Me.ScaleMode, vbPixels) - 1
    45.  
    46.     'Square Window
    47.     'hRgn = CreateRectRgn(0, 0, w \ 2, h \ 2)
    48.    
    49.     'Elliptical Window
    50.     'hRgn = CreateEllipticRgn(0, 0, w, h)
    51.    
    52.     'Square Window with round corners
    53.     'hRgn = CreateRoundRectRgn(0, 0, w, h, 50, 50)
    54.    
    55.     'Polygon shaped window
    56.     'p(0).x = w / 2
    57.     'p(0).y = 0
    58.     'p(1).x = w
    59.     'p(1).y = h / 2
    60.     'p(2).x = w / 2
    61.     'p(2).y = h
    62.     'p(3).x = 0
    63.     'p(3).y = h / 2
    64.     '
    65.     'hRgn = CreatePolygonRgn(p(0), 4, 1)
    66.    
    67.     Call SetWindowRgn(Me.hWnd, hRgn, True)
    68.     Call DeleteObject(hRgn)
    69.  
    70. End Sub

    Uncomment as needed.

    Laugh, and the world laughs with you. Cry, and you just water down your vodka.


    Take credit, not responsibility

  6. #6

    Thread Starter
    Stuck in the 80s The Hobo's Avatar
    Join Date
    Jul 2001
    Location
    Michigan
    Posts
    7,256

    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:
    1. 'form code:
    2. Option Explicit
    3.  
    4. Private Sub Form_Load()
    5.   Init
    6. End Sub
    7.  
    8. Private Sub Form_Unload(Cancel As Integer)
    9.   RemoveIcon
    10.   Terminate
    11. End Sub
    12.  
    13. Private Sub Form_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
    14. Dim msg As Long
    15.  
    16.   msg = x / Screen.TwipsPerPixelX
    17.   Select Case msg
    18.     'Case WM_LBUTTONDOWN
    19.  
    20.     'Case WM_LBUTTONUP
    21.  
    22.     Case WM_LBUTTONDBLCLK
    23.       Me.Visible = True
    24.       Me.WindowState = 0
    25.     'Case WM_RBUTTONDOWN
    26.            
    27.     'Case WM_RBUTTONUP
    28.  
    29.     'Case WM_RBUTTONDBLCLK
    30.  
    31.   End Select
    32.  
    33. End Sub
    34.  
    35. Public Sub ButtonPressed()
    36.   AddIcon Me, "test"
    37. End Sub
    38.  
    39. 'module code:
    40. Option Explicit
    41.  
    42. Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
    43.   (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
    44. Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, _
    45.   lpRect As Rect) As Long
    46. Private Declare Function GetParent Lib "user32" (ByVal hwnd As Long) As Long
    47. Private Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, _
    48.   ByVal hWndNewParent As Long) As Long
    49. Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, _
    50.   ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx _
    51.   As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
    52. Private Declare Function SetWindowsHookEx Lib "user32" Alias _
    53.   "SetWindowsHookExA" (ByVal idHook&, ByVal lpfn&, ByVal hmod&, ByVal _
    54.   dwThreadId&) As Long
    55. Private Declare Function UnhookWindowsHookEx Lib "user32" _
    56.   (ByVal hHook&) As Long
    57. Private Declare Function CreateWindowEx Lib "user32" Alias _
    58.   "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, _
    59.   ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal x As Long, _
    60.   ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal _
    61.   hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, _
    62.   lpParam As Any) As Long
    63. Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, _
    64.   ByVal nCmdShow As Long) As Long
    65.  
    66. Private Declare Function Shell_NotifyIcon Lib "shell32" Alias _
    67.   "Shell_NotifyIconA" (ByVal dwMessage As Long, pnid As NOTIFYICONDATA) _
    68.   As Boolean
    69.  
    70.  
    71. Private Type Rect
    72.     Left As Long
    73.     Top As Long
    74.     Right As Long
    75.     Bottom As Long
    76. End Type
    77.  
    78. Private Type CWPSTRUCT
    79.     lParam As Long
    80.     wParam As Long
    81.     Message As Long
    82.     hwnd As Long
    83. End Type
    84.  
    85. Public Type NOTIFYICONDATA
    86.    cbSize As Long
    87.    hwnd As Long
    88.    uid As Long
    89.    uFlags As Long
    90.    uCallBackMessage As Long
    91.    hIcon As Long
    92.    szTip As String * 64
    93. End Type
    94.  
    95. Private Const NIM_ADD = &H0
    96. Private Const NIM_MODIFY = &H1
    97. Private Const NIM_DELETE = &H2
    98. Private Const WM_MOUSEMOVE = &H200
    99. Private Const NIF_MESSAGE = &H1
    100. Private Const NIF_ICON = &H2
    101. Private Const NIF_TIP = &H4
    102.  
    103. Public Const WM_LBUTTONDBLCLK = &H203
    104. Public Const WM_LBUTTONDOWN = &H201
    105. Public Const WM_LBUTTONUP = &H202
    106. Public Const WM_RBUTTONDBLCLK = &H206
    107. Public Const WM_RBUTTONDOWN = &H204
    108. Public Const WM_RBUTTONUP = &H205
    109.  
    110. Private NID As NOTIFYICONDATA
    111.  
    112. Const WM_MOVE = &H3
    113. Const WM_SETCURSOR = &H20
    114. Const WM_NCPAINT = &H85
    115. Const WM_COMMAND = &H111
    116.  
    117. Const SWP_FRAMECHANGED = &H20
    118. Const GWL_EXSTYLE = -20
    119.  
    120. Private WHook&
    121. Private ButtonHwnd As Long
    122.  
    123. Public Sub Init()
    124.     'Create the button that is going to be placed in the Titlebar
    125.     ButtonHwnd& = CreateWindowEx(0&, "Button", "-", &H40000000, 50, 50, 14, 14, frmMain.hwnd, 0&, App.hInstance, 0&)
    126.     'Show the button cause it´s invisible
    127.     Call ShowWindow(ButtonHwnd&, 1)
    128.     'Initialize the window hooking for the button
    129.     WHook = SetWindowsHookEx(4, AddressOf HookProc, 0, App.ThreadID)
    130.     Call SetWindowLong(ButtonHwnd&, GWL_EXSTYLE, &H80)
    131.     Call SetParent(ButtonHwnd&, GetParent(frmMain.hwnd))
    132. End Sub
    133.  
    134. Public Sub Terminate()
    135.     'Terminate the window hooking
    136.     Call UnhookWindowsHookEx(WHook)
    137.     Call SetParent(ButtonHwnd&, frmMain.hwnd)
    138. End Sub
    139.  
    140. Public Function HookProc&(ByVal nCode&, ByVal wParam&, Inf As CWPSTRUCT)
    141.     Dim FormRect As Rect
    142.     Static LastParam&
    143.     If Inf.hwnd = GetParent(ButtonHwnd&) Then
    144.         If Inf.Message = WM_COMMAND Then
    145.             Select Case LastParam
    146.                 'If the LastParam is cmdInTitlebar call the Click-Procedure
    147.                 'of the button
    148.                 Case ButtonHwnd&: frmMain.ButtonPressed
    149.             End Select
    150.         ElseIf Inf.Message = WM_SETCURSOR Then
    151.             LastParam = Inf.wParam
    152.         End If
    153.         ElseIf Inf.hwnd = frmMain.hwnd Then
    154.         If Inf.Message = WM_NCPAINT Or Inf.Message = WM_MOVE Then
    155.             'Get the size of the Form
    156.             Call GetWindowRect(frmMain.hwnd, FormRect)
    157.             'Place the button int the Titlebar
    158.             Call SetWindowPos(ButtonHwnd&, 0, FormRect.Right - 75, FormRect.Top + 6, 17, 14, SWP_FRAMECHANGED)
    159.         End If
    160.     End If
    161. End Function
    162.  
    163. Public Sub AddIcon(TheForm As Form, strT As String)
    164.     NID.cbSize = Len(NID)
    165.     NID.hwnd = TheForm.hwnd
    166.     NID.uid = vbNull
    167.     NID.uFlags = NIF_ICON Or NIF_TIP Or NIF_MESSAGE
    168.     NID.uCallBackMessage = WM_MOUSEMOVE
    169.     NID.hIcon = TheForm.Icon
    170.     NID.szTip = strT & vbNullChar
    171.     Shell_NotifyIcon NIM_ADD, NID
    172.    
    173.     TheForm.WindowState = vbMinimized
    174.     TheForm.Hide
    175. End Sub
    176.  
    177. Public Sub RemoveIcon()
    178.   Shell_NotifyIcon NIM_DELETE, NID
    179. End Sub

    Enjoy!
    My evil laugh has a squeak in it.

    kristopherwilson.com

  7. #7
    The Devil crptcblade's Avatar
    Join Date
    Aug 2000
    Location
    Quetzalshacatenango
    Posts
    9,091

    Another biggie...

    How to limit a form's size (min and max)
    VB Code:
    1. '/////////////
    2. '* In a form *
    3. '/////////////
    4.  
    5. Option Explicit
    6.  
    7. Private Sub Form_Load()
    8.     Call Hook(Me.hWnd)
    9. End Sub
    10.  
    11. Private Sub Form_Unload(Cancel As Integer)
    12.     Call Unhook(Me.hWnd)
    13. End Sub
    14.  
    15. '////////////////////////
    16. '* In a standard module *
    17. '////////////////////////
    18.  
    19. Option Explicit
    20.  
    21. Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, _
    22.                                                                             ByVal nIndex As Long, _
    23.                                                                             ByVal dwNewLong As Long) _
    24.                                                                             As Long
    25. Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, _
    26.                                                                               ByVal hWnd As Long, _
    27.                                                                               ByVal Msg As Long, _
    28.                                                                               ByVal wParam As Long, _
    29.                                                                               ByVal lParam As Long) _
    30.                                                                               As Long
    31. Private Declare Function DefWindowProc Lib "user32" Alias "DefWindowProcA" (ByVal hWnd As Long, _
    32.                                                                             ByVal wMsg As Long, _
    33.                                                                             ByVal wParam As Long, _
    34.                                                                             ByVal lParam As Long) _
    35.                                                                             As Long
    36. Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, _
    37.                                                                      Source As Any, _
    38.                                                                      ByVal Length As Long)
    39. Private Const GWL_WNDPROC = (-4)
    40.  
    41. Private Const WM_SIZING = &H214
    42.  
    43. Private Const WMSZ_LEFT = 1
    44. Private Const WMSZ_RIGHT = 2
    45. Private Const WMSZ_TOP = 3
    46. Private Const WMSZ_TOPLEFT = 4
    47. Private Const WMSZ_TOPRIGHT = 5
    48. Private Const WMSZ_BOTTOM = 6
    49. Private Const WMSZ_BOTTOMLEFT = 7
    50. Private Const WMSZ_BOTTOMRIGHT = 8
    51.  
    52. Private Const MIN_WIDTH = 200  'The minimum width in pixels
    53. Private Const MIN_HEIGHT = 200 'The minimum height in pixels
    54. Private Const MAX_WIDTH = 500  'The maximum width in pixels
    55. Private Const MAX_HEIGHT = 500 'The maximum height in pixels
    56.  
    57. Private Type RECT
    58.     Left   As Long
    59.     Top    As Long
    60.     RIGHT  As Long
    61.     Bottom As Long
    62. End Type
    63.  
    64. Private mPrevProc As Long
    65.  
    66. Public Sub Hook(hWnd As Long)
    67.     mPrevProc = SetWindowLong(hWnd, GWL_WNDPROC, AddressOf NewWndProc)
    68. End Sub
    69.  
    70. Public Sub Unhook(hWnd As Long)
    71.    
    72.     Call SetWindowLong(hWnd, GWL_WNDPROC, mPrevProc)
    73.     mPrevProc = 0&
    74.    
    75. End Sub
    76.  
    77. Public Function NewWndProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    78. On Error Resume Next
    79.  
    80. Dim r As RECT
    81.  
    82.     If uMsg = WM_SIZING Then
    83.         Call CopyMemory(r, ByVal lParam, Len(r))
    84.    
    85.         'Keep the form only at least as wide as MIN_WIDTH
    86.         If (r.RIGHT - r.Left < MIN_WIDTH) Then
    87.             Select Case wParam
    88.                 Case WMSZ_LEFT, WMSZ_BOTTOMLEFT, WMSZ_TOPLEFT
    89.                     r.Left = r.RIGHT - MIN_WIDTH
    90.                 Case WMSZ_RIGHT, WMSZ_BOTTOMRIGHT, WMSZ_TOPRIGHT
    91.                     r.RIGHT = r.Left + MIN_WIDTH
    92.             End Select
    93.         End If
    94.        
    95.         'Keep the form only at least as tall as MIN_HEIGHT
    96.         If (r.Bottom - r.Top < MIN_HEIGHT) Then
    97.             Select Case wParam
    98.                 Case WMSZ_TOP, WMSZ_TOPLEFT, WMSZ_TOPRIGHT
    99.                     r.Top = r.Bottom - MIN_HEIGHT
    100.                 Case WMSZ_BOTTOM, WMSZ_BOTTOMLEFT, WMSZ_BOTTOMRIGHT
    101.                     r.Bottom = r.Top + MIN_HEIGHT
    102.             End Select
    103.         End If
    104.        
    105.         'Keep the form only as wide as MAX_WIDTH
    106.         If (r.RIGHT - r.Left > MAX_WIDTH) Then
    107.             Select Case wParam
    108.                 Case WMSZ_LEFT, WMSZ_BOTTOMLEFT, WMSZ_TOPLEFT
    109.                     r.Left = r.RIGHT - MAX_WIDTH
    110.                 Case WMSZ_RIGHT, WMSZ_BOTTOMRIGHT, WMSZ_TOPRIGHT
    111.                     r.RIGHT = r.Left + MAX_WIDTH
    112.             End Select
    113.         End If
    114.        
    115.         'Keep the form only as tall as MAX_HEIGHT
    116.         If (r.Bottom - r.Top > MAX_HEIGHT) Then
    117.             Select Case wParam
    118.                 Case WMSZ_TOP, WMSZ_TOPLEFT, WMSZ_TOPRIGHT
    119.                     r.Top = r.Bottom - MAX_HEIGHT
    120.                 Case WMSZ_BOTTOM, WMSZ_BOTTOMLEFT, WMSZ_BOTTOMRIGHT
    121.                     r.Bottom = r.Top + MAX_HEIGHT
    122.             End Select
    123.         End If
    124.    
    125.         Call CopyMemory(ByVal lParam, r, Len(r))
    126.        
    127.         NewWndProc = 0&
    128.         Exit Function
    129.     End If
    130.    
    131.  
    132.     If mPrevProc > 0& Then
    133.         NewWndProc = CallWindowProc(mPrevProc, hWnd, uMsg, wParam, lParam)
    134.     Else
    135.         NewWndProc = DefWindowProc(hWnd, uMsg, wParam, lParam)
    136.     End If
    137.  
    138. 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

  8. #8
    The Devil crptcblade's Avatar
    Join Date
    Aug 2000
    Location
    Quetzalshacatenango
    Posts
    9,091
    Get Windows version
    VB Code:
    1. Option Explicit
    2.  
    3. Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As Long
    4.  
    5. Private Type OSVERSIONINFO
    6.     dwOSVersionInfoSize As Long
    7.     dwMajorVersion      As Long
    8.     dwMinorVersion      As Long
    9.     dwBuildNumber       As Long
    10.     dwPlatformId        As Long
    11.     szCSDVersion        As String * 128
    12. End Type
    13.  
    14. 'Platform IDs
    15. Private Const WIN_ID_31 = 0
    16. Private Const WIN_ID_95_98_ME = 1
    17. Private Const WIN_ID_NT_2K_XP = 2
    18.  
    19. Public Sub TellWindowsVersion()
    20. Dim lVer As OSVERSIONINFO
    21.    
    22.     lVer.dwOSVersionInfoSize = Len(lVer)
    23.    
    24.     Call GetVersionEx(lVer)
    25.    
    26.     With lVer
    27.         Select Case .dwPlatformId
    28.             Case WIN_ID_31
    29.                 MsgBox "Windows 3.x"
    30.                
    31.             Case WIN_ID_95_98_ME
    32.                 Select Case .dwMinorVersion
    33.                     Case 0:  MsgBox "Windows 95"
    34.                     Case 10: MsgBox "Windows 98"
    35.                     Case 90: MsgBox "Windows Me"
    36.                 End Select
    37.                
    38.             Case WIN_ID_NT_2K_XP
    39.                 Select Case True
    40.                     Case (.dwMajorVersion < 5)
    41.                         MsgBox "Windows NT"
    42.                     Case (.dwMajorVersion = 5)
    43.                         Select Case .dwMinorVersion
    44.                             Case 0: MsgBox "Windows 2000"
    45.                             Case 1: MsgBox "Windows XP"
    46.                         End Select
    47.                 End Select
    48.  
    49.         End Select
    50.     End With
    51.  
    52. End Sub
    53.  
    54. Private Sub Form_Load()
    55.     Call TellWindowsVersion
    56. End Sub
    Laugh, and the world laughs with you. Cry, and you just water down your vodka.


    Take credit, not responsibility

  9. #9
    The Devil crptcblade's Avatar
    Join Date
    Aug 2000
    Location
    Quetzalshacatenango
    Posts
    9,091
    Simulate MouseEnter and MouseLeave events
    VB Code:
    1. Option Explicit
    2.  
    3. Private Declare Function SetCapture Lib "user32" (ByVal hwnd As Long) As Long
    4. Private Declare Function ReleaseCapture Lib "user32" () As Long
    5. Private Declare Function GetCapture Lib "user32" () As Long
    6.  
    7. Private Sub Command1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    8.    
    9.     With Command1
    10.         If (X < 0) Or (Y < 0) Or (X > .Width) Or (Y > .Height) Then 'MouseLeave
    11.             Call ReleaseCapture
    12.         ElseIf GetCapture() <> .hwnd Then 'MouseEnter
    13.             Call SetCapture(.hwnd)
    14.         Else
    15.             'Normal MouseMove
    16.         End If
    17.     End With
    18.  
    19. 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

  10. #10
    The Devil crptcblade's Avatar
    Join Date
    Aug 2000
    Location
    Quetzalshacatenango
    Posts
    9,091
    Get the name of the current user, and the computer
    VB Code:
    1. Option Explicit
    2.  
    3. Private Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, _
    4.                                                                               nSize As Long) _
    5.                                                                               As Long
    6. Private Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, _
    7.                                                                                   nSize As Long) _
    8.                                                                                   As Long
    9.  
    10.  
    11. Private Function ReturnUserName() As String
    12.  
    13.     ReturnUserName = Space$(255)
    14.     Call GetUserName(ReturnUserName, Len(ReturnUserName))
    15.  
    16. End Function
    17.  
    18. Private Function ReturnComputerName() As String
    19.  
    20.     ReturnComputerName = Space$(255)
    21.     Call GetComputerName(ReturnComputerName, Len(ReturnComputerName))
    22.  
    23. End Function
    24.  
    25. Private Sub Command1_Click()
    26.  
    27.     MsgBox ReturnUserName
    28.     MsgBox ReturnComputerName
    29.    
    30. 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

  11. #11
    The Devil crptcblade's Avatar
    Join Date
    Aug 2000
    Location
    Quetzalshacatenango
    Posts
    9,091
    Get the Windows, System, and Temp directories
    VB Code:
    1. Option Explicit
    2.  
    3. Private Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, _
    4.                                                                                         ByVal nSize As Long) _
    5.                                                                                         As Long
    6. Private Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, _
    7.                                                                                           ByVal nSize As Long) _
    8.                                                                                           As Long
    9. Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, _
    10.                                                                           ByVal lpBuffer As String) _
    11.                                                                           As Long
    12.  
    13. Private Const DIR_SYS  As Byte = 0
    14. Private Const DIR_WIN  As Byte = 1
    15. Private Const DIR_TEMP As Byte = 2
    16.  
    17. Private Function GetPath(ByVal PathType As Byte) As String
    18.  
    19.     GetPath = Space$(255)
    20.  
    21.     Select Case PathType
    22.         Case DIR_SYS:  Call GetSystemDirectory(GetPath, Len(GetPath))
    23.         Case DIR_WIN:  Call GetWindowsDirectory(GetPath, Len(GetPath))
    24.         Case DIR_TEMP: Call GetTempPath(Len(GetPath), GetPath)
    25.     End Select
    26.  
    27. End Function
    28.  
    29. Private Sub Command1_Click()
    30.    
    31.     MsgBox GetPath(DIR_WIN)
    32.     MsgBox GetPath(DIR_SYS)
    33.     MsgBox GetPath(DIR_TEMP)
    34.    
    35. End Sub
    Laugh, and the world laughs with you. Cry, and you just water down your vodka.


    Take credit, not responsibility

  12. #12
    The Devil crptcblade's Avatar
    Join Date
    Aug 2000
    Location
    Quetzalshacatenango
    Posts
    9,091
    Detect whether a program/AX control/AX DLL is running in the VB6 IDE
    VB Code:
    1. Option Explicit
    2.  
    3. Private Declare Function GetModuleFileName Lib "kernel32" Alias "GetModuleFileNameA" (ByVal hModule As Long, _
    4.                                                                                       ByVal lpFileName As String, _
    5.                                                                                       ByVal nSize As Long) _
    6.                                                                                       As Long
    7. Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
    8.  
    9. Private Function InIDE() As Boolean
    10. Dim s As String
    11.  
    12.     s = Space$(255)
    13.    
    14.     Call GetModuleFileName(GetModuleHandle(vbNullString), s, Len(s))
    15.    
    16.     InIDE = (UCase$(Trim$(s)) Like "*VB6.EXE*")
    17.    
    18. End Function
    19.  
    20. Private Sub Command1_Click()
    21.     MsgBox InIDE
    22. End Sub
    Laugh, and the world laughs with you. Cry, and you just water down your vodka.


    Take credit, not responsibility

  13. #13

    Thread Starter
    Stuck in the 80s The Hobo's Avatar
    Join Date
    Jul 2001
    Location
    Michigan
    Posts
    7,256
    Display Date in User's Date Format

    VB Code:
    1. Option Explicit
    2.  
    3. 'declare API:
    4. Private Declare Function GetDateFormat Lib "kernel32" Alias _
    5.   "GetDateFormatA" (ByVal Locale As Long, ByVal dwFlags As Long, _
    6.   lpDate As SYSTEMTIME, ByVal lpFormat As String, ByVal lpDateStr As String, _
    7.   ByVal cchDate As Long) As Long
    8.  
    9. 'declare type:
    10. Private Type SYSTEMTIME
    11.   wYear As Integer
    12.   wMonth As Integer
    13.   wDayOfWeek As Integer
    14.   wDay As Integer
    15.   wHour As Integer
    16.   wMinute As Integer
    17.   wSecond As Integer
    18.   wMilliseconds As Integer
    19. End Type
    20.  
    21. Private Sub Form_Load()
    22. Dim strBuff As String, TheTime As SYSTEMTIME
    23.  
    24.   'setup systemtime with today's date:
    25.   With TheTime
    26.     .wDay = Day(Now)
    27.     .wMonth = Month(Now)
    28.     .wYear = Year(Now)
    29.   End With
    30.  
    31.   'create the buffer:
    32.   strBuff = String(255, 0)
    33.   'get the format:
    34.   GetDateFormat ByVal 0&, 0, TheTime, vbNullString, strBuff, Len(strBuff)
    35.   'trim the buffer:
    36.   strBuff = Left(strBuff, InStr(1, strBuff, Chr(0)) - 1)
    37.  
    38.   MsgBox strBuff
    39. End Sub
    My evil laugh has a squeak in it.

    kristopherwilson.com

  14. #14
    The Devil crptcblade's Avatar
    Join Date
    Aug 2000
    Location
    Quetzalshacatenango
    Posts
    9,091
    Find an list item in a listbox by its string value without looping
    VB Code:
    1. Option Explicit
    2.  
    3. Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, _
    4.                                                                         ByVal wMsg As Long, _
    5.                                                                         ByVal wParam As Long, _
    6.                                                                         lParam As Any) _
    7.                                                                         As Long
    8. Private Const LB_ERR = (-1)
    9. Private Const LB_FINDSTRING = &H18F
    10. Private Const LB_FINDSTRINGEXACT = &H1A2
    11.  
    12. Private Function FindItemByString(lst As ListBox, ByVal SearchFor As String, Optional FindExact As Boolean = False) As Integer
    13.     FindItemByString = CInt(SendMessage(lst.hwnd, IIf(FindExact, LB_FINDSTRINGEXACT, LB_FINDSTRING), _
    14.                             LB_ERR, ByVal SearchFor))
    15. End Function
    Laugh, and the world laughs with you. Cry, and you just water down your vodka.


    Take credit, not responsibility

  15. #15
    The Devil crptcblade's Avatar
    Join Date
    Aug 2000
    Location
    Quetzalshacatenango
    Posts
    9,091
    Same thing, but with a Combobox
    VB Code:
    1. Option Explicit
    2.  
    3. Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, _
    4.                                                                         ByVal wMsg As Long, _
    5.                                                                         ByVal wParam As Long, _
    6.                                                                         lParam As Any) _
    7.                                                                         As Long
    8.  
    9. Private Const CB_ERR = (-1)
    10. Private Const CB_FINDSTRING = &H14C
    11. Private Const CB_FINDSTRINGEXACT = &H158
    12.  
    13. Private Function FindItemByString(cmb As ComboBox, ByVal SearchFor As String, Optional FindExact As Boolean = False) As Integer
    14.     FindItemByString = CInt(SendMessage(cmb.hwnd, IIf(FindExact, CB_FINDSTRINGEXACT, CB_FINDSTRING), _
    15.                             CB_ERR, ByVal SearchFor))
    16. End Function

    Laugh, and the world laughs with you. Cry, and you just water down your vodka.


    Take credit, not responsibility

  16. #16
    So Unbanned DiGiTaIErRoR's Avatar
    Join Date
    Apr 1999
    Location
    /dev/null
    Posts
    4,111
    Not sure about this, but won't the environ function return the windows version?

    If so, why use API?

  17. #17
    The Devil crptcblade's Avatar
    Join Date
    Aug 2000
    Location
    Quetzalshacatenango
    Posts
    9,091
    A few simple textbox functions
    VB Code:
    1. Option Explicit
    2.  
    3. Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, _
    4.                                                                         ByVal wMsg As Long, _
    5.                                                                         ByVal wParam As Long, _
    6.                                                                         lParam As Any) _
    7.                                                                         As Long
    8.  
    9. Private Const EM_GETLINECOUNT = &HBA
    10. Private Const EM_LINEFROMCHAR = &HC9
    11. Private Const EM_LINELENGTH = &HC1
    12.  
    13. Private Function GetLineCount(txt As TextBox) As Long
    14.     GetLineCount = SendMessage(txt.hwnd, EM_GETLINECOUNT, ByVal 0&, ByVal 0&)
    15. End Function
    16.  
    17. Private Function GetCurrentLine(txt As TextBox) As Long
    18.     GetCurrentLine = SendMessage(txt.hwnd, EM_LINEFROMCHAR, ByVal txt.SelStart, ByVal 0&) + 1
    19. End Function
    20.  
    21. Private Function GetLineLength(txt As TextBox, line As Long) As Long
    22.     GetLineLength = SendMessage(txt.hwnd, EM_LINELENGTH, ByVal line, ByVal 0&)
    23. End Function
    24.  
    25. Private Sub Command1_Click()
    26.  
    27.     MsgBox GetLineCount(Text1)
    28.     MsgBox GetCurrentLine(Text1)
    29.     MsgBox GetLineLength(Text1, GetCurrentLine(Text1))
    30.  
    31. End Sub
    Laugh, and the world laughs with you. Cry, and you just water down your vodka.


    Take credit, not responsibility

  18. #18
    The Devil crptcblade's Avatar
    Join Date
    Aug 2000
    Location
    Quetzalshacatenango
    Posts
    9,091
    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

  19. #19
    So Unbanned DiGiTaIErRoR's Avatar
    Join Date
    Apr 1999
    Location
    /dev/null
    Posts
    4,111
    Originally posted by crptcblade
    Why depend on something that can be deleted?
    How's that?

  20. #20
    The Devil crptcblade's Avatar
    Join Date
    Aug 2000
    Location
    Quetzalshacatenango
    Posts
    9,091
    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

  21. #21
    So Unbanned DiGiTaIErRoR's Avatar
    Join Date
    Apr 1999
    Location
    /dev/null
    Posts
    4,111
    Originally posted by crptcblade
    You can change/delete environment variables through the control panel.
    Where?

  22. #22
    The Devil crptcblade's Avatar
    Join Date
    Aug 2000
    Location
    Quetzalshacatenango
    Posts
    9,091
    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

  23. #23
    So Unbanned DiGiTaIErRoR's Avatar
    Join Date
    Apr 1999
    Location
    /dev/null
    Posts
    4,111
    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?

  24. #24
    The Devil crptcblade's Avatar
    Join Date
    Aug 2000
    Location
    Quetzalshacatenango
    Posts
    9,091
    *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

  25. #25
    Fanatic Member
    Join Date
    Jul 2002
    Location
    Australia
    Posts
    635
    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

  26. #26
    The Devil crptcblade's Avatar
    Join Date
    Aug 2000
    Location
    Quetzalshacatenango
    Posts
    9,091
    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

  27. #27
    old fart Frans C's Avatar
    Join Date
    Oct 1999
    Location
    the Netherlands
    Posts
    2,926
    Originally posted by The Hobo
    Display Date in User's Date Format

    VB Code:
    1. Option Explicit
    2.  
    3. 'declare API:
    4. Private Declare Function GetDateFormat Lib "kernel32" Alias _
    5.   "GetDateFormatA" (ByVal Locale As Long, ByVal dwFlags As Long, _
    6.   lpDate As SYSTEMTIME, ByVal lpFormat As String, ByVal lpDateStr As String, _
    7.   ByVal cchDate As Long) As Long
    8.  
    9. 'declare type:
    10. Private Type SYSTEMTIME
    11.   wYear As Integer
    12.   wMonth As Integer
    13.   wDayOfWeek As Integer
    14.   wDay As Integer
    15.   wHour As Integer
    16.   wMinute As Integer
    17.   wSecond As Integer
    18.   wMilliseconds As Integer
    19. End Type
    20.  
    21. Private Sub Form_Load()
    22. Dim strBuff As String, TheTime As SYSTEMTIME
    23.  
    24.   'setup systemtime with today's date:
    25.   With TheTime
    26.     .wDay = Day(Now)
    27.     .wMonth = Month(Now)
    28.     .wYear = Year(Now)
    29.   End With
    30.  
    31.   'create the buffer:
    32.   strBuff = String(255, 0)
    33.   'get the format:
    34.   GetDateFormat ByVal 0&, 0, TheTime, vbNullString, strBuff, Len(strBuff)
    35.   'trim the buffer:
    36.   strBuff = Left(strBuff, InStr(1, strBuff, Chr(0)) - 1)
    37.  
    38.   MsgBox strBuff
    39. End Sub
    Neat function, but I believe this does the same:
    VB Code:
    1. Private Sub Form_Load()
    2.     MsgBox CStr(Date)
    3. 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.

  28. #28

    Thread Starter
    Stuck in the 80s The Hobo's Avatar
    Join Date
    Jul 2001
    Location
    Michigan
    Posts
    7,256
    Originally posted by Frans C
    Neat function, but I believe this does the same:
    VB Code:
    1. Private Sub Form_Load()
    2.     MsgBox CStr(Date)
    3. 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.
    My evil laugh has a squeak in it.

    kristopherwilson.com

  29. #29
    old fart Frans C's Avatar
    Join Date
    Oct 1999
    Location
    the Netherlands
    Posts
    2,926
    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.

  30. #30
    Addicted Member
    Join Date
    Apr 2002
    Location
    Anywhere but here
    Posts
    161
    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!

  31. #31
    Member
    Join Date
    Mar 2004
    Location
    Texas
    Posts
    53
    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

  32. #32
    Super Moderator manavo11's Avatar
    Join Date
    Nov 2002
    Location
    Around the corner from si_the_geek
    Posts
    7,171
    I made this a sticky
    Last edited by manavo11; Jul 30th, 2004 at 01:31 AM.


    Has someone helped you? Then you can Rate their helpful post.

  33. #33
    Frenzied Member ice_531's Avatar
    Join Date
    Aug 2002
    Location
    Sitting w/ Bob Status: -Next -To- Null- Friend: Philip
    Posts
    1,152
    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++

  34. #34
    Super Moderator manavo11's Avatar
    Join Date
    Nov 2002
    Location
    Around the corner from si_the_geek
    Posts
    7,171
    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


    Has someone helped you? Then you can Rate their helpful post.

  35. #35
    Hyperactive Member
    Join Date
    Nov 2003
    Location
    In Front of my computer...
    Posts
    367
    Add Horizontal Scroll bar to Listboxes

    VB Code:
    1. 'PUT IN MODULE...
    2. Public Const LB_SETHORIZONTALEXTENT = &H194
    3. 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
    4.  
    5. Public Sub HorizontalSbar(List1 As ListBox)
    6.  
    7. Dim lngReturn As Long
    8. Dim lngExtent As Long
    9.  
    10. lngExtent = 2 * (List1.Width / Screen.TwipsPerPixelX)   'Set the Horizontal Bar to 2 times its Width
    11.  
    12. lngReturn = SendMessage(List1.hwnd, LB_SETHORIZONTALEXTENT, lngExtent, 0&)
    13. End Sub
    14.  
    15. 'USAGE:
    16. 'Call HorizontalSbar(LISTBOX_NAME_HERE)

    Move Form With No Border
    VB Code:
    1. Private Declare Function ReleaseCapture Lib "user32" () As Long
    2. 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
    3.  
    4. Public Sub DragForm(frm As Form)
    5.     ReleaseCapture
    6.     Call SendMessage(frm.hwnd, &HA1, 2, 0&)
    7. End Sub
    8.  
    9. 'USAGE:
    10. 'Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X 'As Single, Y As Single)
    11. 'DragForm Me
    12. 'End Sub

    Transparent Form
    VB Code:
    1. Option Explicit
    2. Private Declare Function CreateRectRgn Lib _
    3.     "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, _
    4.     ByVal X2 As Long, ByVal Y2 As Long) As Long
    5. Private Declare Function CombineRgn Lib _
    6.     "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, _
    7.     ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
    8. Private Declare Function SetWindowRgn Lib _
    9.     "user32" (ByVal hWnd As Long, ByVal hRgn As Long, _
    10.     ByVal bRedraw As Boolean) As Long
    11. Private Declare Function DeleteObject Lib _
    12.     "gdi32" (ByVal hObject As Long) As Long
    13.  
    14. ' Constants used by the CombineRgn function
    15. Private Const RGN_AND = 1
    16. Private Const RGN_OR = 2
    17. Private Const RGN_XOR = 3
    18. Private Const RGN_DIFF = 4
    19. Private Const RGN_COPY = 5
    20.  
    21. Private Sub Form_Activate()
    22.     Dim rgnForm As Long, rgnCombined As Long
    23.     Dim rgnControl As Long, x As Long
    24.     Dim formWidth As Single, formHeight As Single
    25.     Dim borderWidth As Single, titleHeight As Single
    26.     Dim ctlLeft As Single, ctlTop As Single
    27.     Dim ctlWidth As Single, ctlHeight As Single
    28.     Dim ctl As Control
    29.  
    30.     ' Calculate the form area
    31.     borderWidth = (Me.Width - Me.ScaleWidth) / 2
    32.     titleHeight = Me.Height - Me.ScaleHeight - borderWidth
    33.     ' Convert to Pixels
    34.     borderWidth = ScaleX(borderWidth, vbTwips, vbPixels)
    35.     titleHeight = ScaleY(titleHeight, vbTwips, vbPixels)
    36.     formWidth = ScaleX(Me.Width, vbTwips, vbPixels)
    37.     formHeight = ScaleY(Me.Height, vbTwips, vbPixels)
    38.    
    39.     ' Create a region for the whole form
    40.     rgnForm = CreateRectRgn(0, 0, formWidth, formHeight)
    41.    
    42.     rgnCombined = CreateRectRgn(0, 0, 0, 0)
    43.     ' Make the graphical area transparent by combining the two regions
    44.     x = CombineRgn(rgnCombined, rgnForm, rgnForm, RGN_DIFF)
    45.  
    46.     ' Make the controls visible
    47.     For Each ctl In Controls
    48.         ' Make the regions of controls whose container is the form visible
    49.         If TypeOf ctl.Container Is Form Then
    50.             ctlLeft = ScaleX(ctl.Left, vbTwips, vbPixels) + borderWidth
    51.             ctlTop = ScaleX(ctl.Top, vbTwips, vbPixels) + titleHeight
    52.             ctlWidth = ScaleX(ctl.Width, vbTwips, vbPixels) + ctlLeft
    53.             ctlHeight = ScaleX(ctl.Height, vbTwips, vbPixels) + ctlTop
    54.             rgnControl = CreateRectRgn(ctlLeft, ctlTop, ctlWidth, ctlHeight)
    55.             x = CombineRgn(rgnCombined, rgnCombined, rgnControl, RGN_OR)
    56.         End If
    57.     Next ctl
    58.    
    59.  
    60.     ' Set the clipping area of the window using the resulting region
    61.     SetWindowRgn hWnd, rgnCombined, True
    62.     ' Tidy up
    63.     x = DeleteObject(rgnCombined)
    64.     x = DeleteObject(rgnControl)
    65.     x = DeleteObject(rgnForm)
    66. End Sub

    :-)
    Born to help others
    (If I've been helpful then please rate my post. Thanks)

    call me EJ or be slapped!

  36. #36
    Frenzied Member ice_531's Avatar
    Join Date
    Aug 2002
    Location
    Sitting w/ Bob Status: -Next -To- Null- Friend: Philip
    Posts
    1,152
    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
    Attached Files Attached Files
    :::`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++

  37. #37
    Frenzied Member ice_531's Avatar
    Join Date
    Aug 2002
    Location
    Sitting w/ Bob Status: -Next -To- Null- Friend: Philip
    Posts
    1,152
    mouseover effect on command buttons
    VB Code:
    1. Private Declare Function ReleaseCapture Lib "USER32" () As Long
    2. Private Declare Function SetCapture Lib "USER32" (ByVal hwnd As Long) As Long
    3.  
    4. Private Sub Command1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    5. ' will change the background color for the command button
    6. With Command1
    7. If (X < 0) Or (Y < 0) Or (X > .Width) Or (Y > .Height) Then
    8. ReleaseCapture
    9. Command1.BackColor = &HE0E0E0
    10.  Else
    11. SetCapture .hwnd
    12. Command1.BackColor = vbWhite
    13. End If
    14. End With
    15. End Sub
    16.  
    17. Private Sub Command2_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    18. ' will change the background color for the command button
    19. With Command2
    20. If (X < 0) Or (Y < 0) Or (X > .Width) Or (Y > .Height) Then
    21. ReleaseCapture
    22. Command2.BackColor = &HE0E0E0
    23.  Else
    24. SetCapture .hwnd
    25. Command2.BackColor = vbWhite
    26. End If
    27. End With
    28. 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++

  38. #38
    Frenzied Member sciguyryan's Avatar
    Join Date
    Sep 2003
    Location
    Wales
    Posts
    1,763

    Re: Visual Basic API FAQs

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

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

    VB Code:
    1. Private Const LVA_ALIGNLEFT = &H1
    2. Private Const LVM_ARRANGE = &H1016
    3. Private Const GW_CHILD = 5
    4.  
    5. Private Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" ( _
    6.     ByVal lpClassName As String, _
    7.     ByVal lpWindowName As String) As Long
    8. Private Declare Function GetWindow Lib "user32.dll" ( _
    9.     ByVal hWnd As Long, _
    10.     ByVal wCmd As Long) As Long
    11.    
    12. Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" ( _
    13.     ByVal hWnd As Long, _
    14.     ByVal wMsg As Long, _
    15.     ByVal wParam As Long, _
    16.     lParam As Long) As Long
    17.  
    18. Public Function ArrangeDesktopIcons() As Boolean
    19.    Dim lngHandle As Long
    20.    Dim lngRetVal As Long
    21.    lngHandle = FindWindow("Progman", vbNullString)
    22.    lngHandle = GetWindow(lngHandle, GW_CHILD)
    23.    lngHandle = GetWindow(lngHandle, GW_CHILD)
    24.    lngRetVal = SendMessage(lngHandle, LVM_ARRANGE, LVA_ALIGNLEFT, 0)
    25.    ArrangeDesktopIcons = lngRetVal > 0
    26. 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:
    1. Private Type DCB
    2.     DCBlength As Long
    3.     BaudRate As Long
    4.     fBitFields As Long
    5.     wReserved As Integer
    6.     XonLim As Integer
    7.     XoffLim As Integer
    8.     ByteSize As Byte
    9.     Parity As Byte
    10.     StopBits As Byte
    11.     XonChar As Byte
    12.     XoffChar As Byte
    13.     ErrorChar As Byte
    14.     EofChar As Byte
    15.     EvtChar As Byte
    16.     wReserved1 As Integer
    17. End Type
    18.  
    19. Private Type COMMCONFIG
    20.     dwSize As Long
    21.     wVersion As Integer
    22.     wReserved As Integer
    23.     dcbx As DCB
    24.     dwProviderSubType As Long
    25.     dwProviderOffset As Long
    26.     dwProviderSize As Long
    27.     wcProviderData As Byte
    28. End Type
    29.  
    30. Private Declare Function GetDefaultCommConfig Lib "kernel32.dll" Alias "GetDefaultCommConfigA" ( _
    31.     ByVal lpszName As String, _
    32.     lpCC As COMMCONFIG, _
    33.     lpdwSize As Long) As Long
    34.  
    35. Public Function ComPortExists(ByVal ComPort As Integer) As Boolean
    36.     Dim udtComConfig As COMMCONFIG
    37.     Dim lngUDTSize As Long
    38.     Dim lngRet As Long
    39.     lngUDTSize = LenB(udtComConfig)
    40.     lngRet = GetDefaultCommConfig("COM" + Trim$(Str$(ComPort)) + Chr$(0), udtComConfig, lngUDTSize)
    41.     ComPortExists = lngRet <> 0
    42. 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
    My Blog.

    Ryan Jones.

  39. #39
    Learning .Net danasegarane's Avatar
    Join Date
    Aug 2004
    Location
    VBForums
    Posts
    5,853

    Re: Visual Basic API FAQs

    Here is My contribution,

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

    VB Code:
    1. 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
    2.  
    3. Private Const LB_SETSEL = &H185
    4.  
    5. Private Sub cmd_select_Click()
    6. Call SendMessageLong(File1.hwnd, LB_SETSEL, 1, -1)
    7. End Sub
    8.  
    9. wParam -->   0 = DeSelect, 1 = Select
    10. lParam -->  -1 = All, 0-## = Just that Index

    Set Multiselect Property To
    VB Code:
    1. File1.MultiSelect = 1 ' Simple MultiSelect '
    2. File1.MultiSelect = 2 ' Extended MultiSelect '

    Thanks To tward_biteme1

    2.How to Limit the Charcter Length of a Combo box.
    VB Code:
    1. 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
    2.  
    3. Private Const CB_LIMITTEXT = &H141
    4.  
    5. 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.

  40. #40
    New Member
    Join Date
    Oct 2006
    Location
    South Africa
    Posts
    8

    Re: Visual Basic API FAQs

    Quote 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:
    1. Sub TopMostX(BB As Byte, FormX As Form)   ', XLeft, XTop, XHeight, XWidth)
    2.  
    3.    If Left$(FormX.Left, 1) = "-" Then
    4.       FormX.Left = 0
    5.    End If
    6.    If Left$(FormX.Top, 1) = "-" Then
    7.       FormX.Top = 0
    8.    End If
    9.    If Left$(FormX.Height, 1) = "-" Then
    10.       FormX.Height = 3000
    11.    End If
    12.    If Left$(FormX.Width, 1) = "-" Then
    13.       FormX.Width = 3000
    14.    End If
    15.    
    16.    XLeft = FormX.Left
    17.    XTop = FormX.Top
    18.    XHeight = FormX.Height
    19.    XWidth = FormX.Width
    20.    
    21.    If BB = 1 Then
    22.       ' Turn on the TopMost attribute.
    23.       SetWindowPos FormX.hwnd, -1, 0, 0, 0, 0, &H50
    24.    ElseIf BB = 2 Then
    25.       ' Turn off the TopMost attribute.
    26.       SetWindowPos FormX.hwnd, -2, 0, 0, 0, 0, &H50
    27.    End If
    28.      
    29.    FormX.Left = XLeft
    30.    FormX.Top = XTop
    31.    FormX.Height = XHeight
    32.    FormX.Width = XWidth
    33.  
    34. End Sub

    (The "-" is when the form is on the outside of the boundaries of the screen)

Page 1 of 3 123 LastLast

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  



Click Here to Expand Forum to Full Width