VB Workshop

H o w     t o ... ,

      All the subjects will be grouped (about 10-15 per page) for an easy download and update.

How to ...

  1. Retrieving the current URL in MSIE and NN
    I'm putting a text-box (DDEText) on a form and then: 
    
strApplication = "IEXPLORE" ' Pentru Internet Explorer 
strApplication = "NETSCAPE" ' Pentru Netscape
strDDETopic = strApplication & "|WWW_GetWindowInfo"
With DDEText
.LinkTopic = strDDETopic
.LinkItem = "0xFFFFFFFF"
.LinkMode = 2
.LinkRequest
End With
sCurrentURL = Mid(DDEText.Text, 2, InStr(DDEText.Text, ",") - 3)
  2. Launch the Internet browser with an address 
    
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 

    
Const SW_MAXIMIZE = 3 

    
Private Sub Command1_Click() 
Dim lRet As Long 

lRet = ShellExecute(Me.hwnd, "open","http://www.geocities.com/siliconvalley/hills/4377", vbNullString, vbNullString, SW_MAXIMIZE) 
End Sub
  3. Get screen resolution 
    
Public Function GetScreenResolution() As String
Dim TWidth As Long
Dim THeight As Long

TWidth = Screen.Width \ Screen.TwipsPerPixelX
THeight = Screen.Height \ Screen.TwipsPerPixelY
GetScreenResolution = TWidth & "x" & THeight
End Function
  4. Invoke a help file 
    
Declare Function WinHelp Lib "user32" Alias "WinHelpA" (ByVal hwnd As Long,
ByVal lpHelpFile As String, ByVal wCommand As Long, ByVal dwData As Long) As
Long

Public Const HELP_CONTEXT = &H1 ' Display topic in ulTopic 
Public Const HELP_HELPONHELP = &H4 ' Display help on using help 
Public Const HELP_INDEX = &H3 ' Display index
Public Const HELP_QUIT = &H2 ' Terminate help
Public Const HELP_SETINDEX = &H5 ' Set current Index for multi
index help
Public Const HELP_MULTIKEY = &H201&
Public Const HELP_PARTIALKEY = &H105&

Private Sub MnuHelpContents_Click()
Dim Help_path As String
Dim RV As Long
Help_path = App.HelpFile
RV = WinHelp(Me.hwnd, Help_path, &H3, CLng(0))
End Sub
  5. Disable the close button for a window 
    
Public Sub DisableCloseButton(frm as Form)
Dim hMenu As Long
Dim menuItemCount As Long
hMenu = GetSystemMenu(frm.hWnd, 0)
If hMenu Then 
menuItemCount = GetMenuItemCount(hMenu)
'este pe ultima pozitie (menuItemCount-1) 
RemoveMenu hMenu, menuItemCount - 1, MF_REMOVE Or MF_BYPOSITION 
'Sterg separatorul de linie
RemoveMenu hMenu, menuItemCount - 2, MF_REMOVE Or MF_BYPOSITION
DrawMenuBar frm.hWnd
End If
End Sub
    Declarations for GetSystemMenu, GetMenuItemCount, RemoveMenu, DrawMenuBar si a constantelor MF_REMOVE and MF_BYPOSITION can be found with API Viewer add-in.
  6. Create a flat toolbar (IE or MS Office style) 
    
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As 
Long, ByVal wMsg As Long, ByVal wParam As Integer, ByVal lParam As Any) As Long
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As 
Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long

Private Const WM_USER = &H400
Private Const TB_SETSTYLE = WM_USER + 56
Private Const TB_GETSTYLE = WM_USER + 57
Private Const TBSTYLE_FLAT = &H800
Private Const TBSTYLE_LIST = &H1000

Public Sub CoolBar(tlb As Toolbar, tlbToolbarStyle As Long)
    Dim lngStyle As Long, lngResult As Long, lngHWND As Long 

    ' Find child window and get style bits
    lngHWND = FindWindowEx(tlb.hwnd, 0&, "ToolbarWindow32", vbNullString)
    lngStyle = SendMessage(lngHWND, TB_GETSTYLE, 0&, 0&)
    Select Case tlbToolbarStyle
        Case 1
            'Creates an Office97 Toolbar
            lngStyle = lngStyle Or TBSTYLE_FLAT
        Case 2
            'Creates an IE4 stsyle toolbar with text to the right of the picture. You must supply text in order to get the effect 
            lngStyle = lngStyle Or TBSTYLE_FLAT Or TBSTYLE_LIST
        Case Else
            lngStyle = lngStyle Or TBSTYLE_FLAT
    End Select
    'Use the API call to change the Toolbar effect
    lngResult = SendMessage(lngHWND, TB_SETSTYLE, 0, lngStyle)
    tlb.Refresh
End Sub
  7. Show a combo-box in a MSFlexGrid cell 
    
Private Sub Combo1_Click()
    MSFlexGrid1.Text = Combo1.Text
End Sub

Private Sub Form_Load()
    'hide combo until we need it
    Combo1.Visible = False


    'aici creez lista de selectie
    Combo1.AddItem "Linie 1"
    Combo1.AddItem "Linie 2"
    Combo1.AddItem "Linie 3"
    Combo1.AddItem "Linie 4"
    Combo1.AddItem "Linie 5"

    'make lots and lots of rows and columns
    MSFlexGrid1.Rows = 500
    MSFlexGrid1.Cols = 500
    MSFlexGrid1.FixedRows = 2
    MSFlexGrid1.FixedCols = 1
End Sub

Private Sub Form_Resize()
    'make grid the size of the form
    MSFlexGrid1.Move Me.ScaleLeft, Me.ScaleTop, Me.ScaleWidth, Me.ScaleHeight
End Sub

Private Sub MSFlexGrid1_Click()
    'make sure user didn't click on a fixed row or column
    If MSFlexGrid1.Col >= MSFlexGrid1.FixedCols And MSFlexGrid1.Row >=
MSFlexGrid1.FixedRows Then
        Call PositionCombo
    End If
End Sub

Private Sub MSFlexGrid1_EnterCell()
    Call PositionCombo
End Sub


Sub PositionCombo()
'Positions the combobox on the current cell and make it visible
    Combo1.Move MSFlexGrid1.CellLeft + MSFlexGrid1.Left, MSFlexGrid1.CellTop +
MSFlexGrid1.Top, MSFlexGrid1.CellWidth
    Combo1.Visible = True
End Sub

Sub HideCombo()
'set combo1 visible property to false
    Combo1.Visible = False
End Sub

Private Sub MSFlexGrid1_LeaveCell()
    Call HideCombo
End Sub

Private Sub MSFlexGrid1_RowColChange()
    Call HideCombo
End Sub

Private Sub MSFlexGrid1_Scroll()
    Call HideCombo
End Sub
  8. Window always-on-top 
    
Public Sub TopMost(ByVal sformname As Form)
'in order this to work, you need to declare the SetWinDowPos in a module gen declaration area as follows;
'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)

If sformname.MDIChild = True Then
MsgBox ("Form cannot be MDI child")
Exit Sub
End If

SetWindowPos sformname.hwnd, -1, sformname.LEFT / Screen.TwipsPerPixelX, _
sformname.TOP / Screen.TwipsPerPixelY, sformname.Width / Screen.TwipsPerPixelX, _
sformname.Height / Screen.TwipsPerPixelY, &H10 Or &H40
End Sub
  9. Show the Find File dialog With a label on the form (lbl_DDE): 
    
With lbl_DDE
.LinkTopic = "Folders|AppProperties"
.LinkMode = vbLinkManual
.LinkExecute "[OpenFindFile(,)]"
End With
  10. Check for Diskette in a drive 
    
Function IsMediaValid(ByVal strPathName As String) As Boolean
Dim bMedia As Boolean
Dim nDrive As Long, nDriveType As Long
Dim nSerialNumber As Long, nCompLen As Long
Dim nFlags As Long
Dim strDrive As String, strVolName As String
Dim strFileSystem As String

' // Return TRUE if the drive doesn't support removable media.
nDriveType = GetDriveType(strPathName)
If ((nDriveType <> DRIVE_REMOVABLE) And _
(nDriveType <> DRIVE_CDROM)) Then
IsMediaValid = True
Exit Function
End If

' // Return FALSE if the drive is empty (::GetVolumeInformation fails).
strDrive = Left(strPathName, 3)
nDrive = Asc(Left(strDrive, 1)) - &H41

strVolName = String(255, Chr(0))
strFileSystem = String(255, Chr(0))
bMedia = GetVolumeInformation _
(strDrive, strVolName, 255, nSerialNumber, _
nCompLen, nFlags, strFileSystem, 255)
If (Not bMedia) Then
m_dwMediaID(nDrive) = &HFFFFFFFF
IsMediaValid = False
Exit Function
End If

' // Also return FALSE if the disk's serial number has changed.
If ((m_dwMediaID(nDrive) <> nSerialNumber) And _
(m_dwMediaID(nDrive) <> &HFFFFFFFF)) Then
m_dwMediaID(nDrive) = nSerialNumber
IsMediaValid = False
Exit Function
End If

' // Update our record of the serial number and return TRUE.
m_dwMediaID(nDrive) = nSerialNumber
IsMediaValid = True

End Function

© VB Work 2000, Last update