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. Getting short name for a path (8.3) 
    
Private Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long

Public Function GetShortPath(filespec) As String
    Dim lpath As String, spath As String
    Dim lspath As Long, ccode As Long
    lspath = 256
    GetShortPath = Space(lspath)
    GetShortPathName filespec, GetShortPath, lspath
    GetShortPath = Left(Trim(GetShortPath), Len(Trim(GetShortPath)) - 1)
End Function
  2. Launch an application and waiting for stop 
    
Public Const CREATE_NEW_CONSOLE = &H10
Public Const CREATE_NEW_PROCESS_GROUP = &H200
Public Const CREATE_NO_WINDOW = &H8000000
Public Const CREATE_SUSPENDED = &H4

Public Const CREATE_UNICODE_ENVIRONMENT = &H400
Public Const CREATE_SEPARATE_WOW_VDM = &H800
Public Const CREATE_SHARED_WOW_VDM = &H1000
Public Const CREATE_FORCEDOS = &H2000

Public Const CREATE_DEFAULT_ERROR_MODE = &H4000000
'Public Const CREATE_NO_WINDOW = &H8000000

Public Const DETACHED_PROCESS = &H8
Public Const DEBUG_PROCESS = &H1
Public Const DEBUG_ONLY_THIS_PROCESS = &H2

Public Const NORMAL_PRIORITY_CLASS = &H20
Public Const IDLE_PRIORITY_CLASS = &H40
Public Const HIGH_PRIORITY_CLASS = &H80
Public Const REALTIME_PRIORITY_CLASS = &H100

Public Const STATUS_PENDING = &H103
Public Const STILL_ACTIVE = STATUS_PENDING


Public Type SECURITY_ATTRIBUTES
        nLength As Long
        lpSecurityDescriptor As Long
        bInheritHandle As Long
End Type

Public Type STARTUPINFO

      cb As Long
      lpReserved As String
      lpDesktop As String
      lpTitle As String
      dwX As Long
      dwY As Long
      dwXSize As Long
      dwYSize As Long
      dwXCountChars As Long
      dwYCountChars As Long
      dwFillAttribute As Long
      dwFlags As Long
      wShowWindow As Integer
      cbReserved2 As Integer
      lpReserved2 As Long
      hStdInput As Long
      hStdOutput As Long
      hStdError As Long

End Type

Public Type PROCESS_INFORMATION
        hProcess As Long
        hThread As Long
        dwProcessId As Long
        dwThreadId As Long
End Type

Public Declare Function CreateProcess Lib "kernel32" Alias _
      "CreateProcessA" (ByVal lpApplicationName As String, ByVal _
      lpCommandLine As String, lpProcessAttributes As Any, _
      lpThreadAttributes As Any, ByVal bInheritHandles As Long, _
      ByVal dwCreationFlags As Long, lpEnvironment As Any, ByVal _
      lpCurrentDriectory As String, lpStartupInfo As STARTUPINFO, _
      lpProcessInformation As PROCESS_INFORMATION) As Long

Public Declare Function GetExitCodeProcess Lib "kernel32" ( _
    ByVal hProcess As Long, _
    ByRef lpExitCode As Long _
    ) As Long

Public Declare Sub Sleep Lib "kernel32" ( _
    ByVal dwMilliseconds As Long)


Public Sub RunApp(AppName As String)
    Dim ExitCode As Long
    Dim sNull As String
    
    Dim lpProcessAttributes As SECURITY_ATTRIBUTES
    Dim lpThreadAttributes As SECURITY_ATTRIBUTES
    Dim lpEnvironment As Variant
    Dim lpStartupInfo As STARTUPINFO
    Dim lpProcessInformation As PROCESS_INFORMATION
    
    'initialization of variables
    lpProcessAttributes.bInheritHandle = 0
    lpProcessAttributes.lpSecurityDescriptor = 0
    lpProcessAttributes.nLength = Len(lpProcessAttributes)
    
    lpThreadAttributes.bInheritHandle = 0
    lpThreadAttributes.lpSecurityDescriptor = 0
    lpThreadAttributes.nLength = Len(lpProcessAttributes)
    
    lpStartupInfo.cb = Len(lpStartupInfo)
    'lpStartupInfo.dwFlags = STARTF_USESHOWWINDOW
    'lpStartupInfo.wShowWindow = SW_SHOWDEFAULT
    lpStartupInfo.lpDesktop = ""
    lpStartupInfo.cbReserved2 = 0
    lpStartupInfo.lpReserved = ""
    lpStartupInfo.lpTitle = ""
    lpStartupInfo.lpReserved2 = 0
    CreateProcess sNull, AppName, lpProcessAttributes, lpThreadAttributes, _
    vbNull, NORMAL_PRIORITY_CLASS, ByVal 0&, sNull, lpStartupInfo, lpProcessInformation
    GetExitCodeProcess lpProcessInformation.hProcess, ExitCode
    While ExitCode <> 0
        GetExitCodeProcess lpProcessInformation.hProcess, ExitCode
        DoEvents 'don't forget, you're not the only one in the world
        Sleep 2000
    Wend
End Sub
  3. Fast searching in Combo-box & List-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_FINDSTRING = &H14C
Private Const CB_FINDSTRINGEXACT = &H158
Private Const LB_FINDSTRING = &H18F
Private Const LB_FINDSTRINGEXACT = &H1A2

Public Function FFM(ByVal ctlSearch As Control, ByVal SearchString As String, ByVal FirstRow As Integer, ByVal Exact As Boolean) As Integer
Dim Index As Long
On Error Resume Next
    If TypeOf ctlSearch Is ComboBox Then
        If Exact Then
            Index = SendMessage(ctlSearch.hWnd, CB_FINDSTRINGEXACT, FirstRow, ByVal SearchString)
        Else
            Index = SendMessage(ctlSearch.hWnd, CB_FINDSTRING, FirstRow, ByVal SearchString)
        End If
    ElseIf TypeOf ctlSearch Is ListBox Then
        If Exact Then
            Index = SendMessage(ctlSearch.hWnd, LB_FINDSTRINGEXACT, FirstRow, ByVal SearchString)
        Else
            Index = SendMessage(ctlSearch.hWnd, LB_FINDSTRING, FirstRow, ByVal SearchString)
        End If
    End If
    FFM = Index
End Function
    Using

    List1.ListIndex = FFM(List1, text_de_cautat, -1, True)
    Combo1.ListIndex = FFM(Combo1, text_de_cautat, -1, True)

  4. Show the properties of a file 
    Private Declare Function ShellExecuteEx Lib "shell32.dll" Alias "ShellExecuteExA" (shInfo As SHELLEXECUTEINFO) As Long

Private Type SHELLEXECUTEINFO
        cbSize As Long
        fMask As Long
        hwnd As Long
        lpVerb As String
        lpFile As String
        lpParameters As String
        lpDirectory As String
        nShow As Long
        hInstApp As Long
        '  Optional fields
        lpIDList As Long
        lpClass As String
        hkeyClass As Long
        dwHotKey As Long
        hIcon As Long
        hProcess As Long
End Type

Dim s As SHELLEXECUTEINFO

Private Const SEE_MASK_FLAG_NO_UI = &H400
Private Const SEE_MASK_NOCLOSEPROCESS = &H40
Private Const SEE_MASK_INVOKEIDLIST = &HC

Private Sub cmdProperties_Click()
s.cbSize = Len(s)
s.fMask = SEE_MASK_NOCLOSEPROCESS Or SEE_MASK_INVOKEIDLIST Or SEE_MASK_FLAG_NO_UI
s.hwnd = Me.hwnd
s.lpVerb = "Properties"
s.lpFile = txtFile.Text
s.lpParameters = Chr(0)
s.lpDirectory = Chr(0)
s.nShow = 0
s.hInstApp = 0
s.lpIDList = 0
ShellExecuteEx s
End Sub
  5. Window locking (w/o LockWindowUpdate API) 
    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 Const WM_SETREDRAW = &HB

SendMessage Me.hwnd, WM_SETREDRAW, False, 0
' Executa ceva...

SendMessage Me.hwnd, WM_SETREDRAW, True, 0
  6. Task list 
    VERSION 5.00
Begin VB.Form frmGhost
Caption = "Ghost"
ClientHeight = 2745
ClientLeft = 4350
ClientTop = 3285
ClientWidth = 4575
LinkTopic = "Form1"
ScaleHeight = 2745
ScaleWidth = 4575
Begin VB.CommandButton btnExit
Caption = "Exit"
Height = 375
Left = 2520
TabIndex = 2
Top = 2280
Width = 1335
End
Begin VB.CommandButton btnAction
Caption = "Hide"
Height = 375
Left = 720
TabIndex = 1
Top = 2280
Width = 1335
End
Begin VB.ListBox lstApp
Height = 2010
ItemData = "frmGhost.frx":0000
Left = 120
List = "frmGhost.frx":0002
TabIndex = 0
Top = 120
Width = 4335
End
End
Attribute VB_Name = "frmGhost"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False

Private Sub btnAction_Click()
HideOrShow lstApp
SetActionName btnAction, lstApp
End Sub

Private Sub btnExit_Click()
Unload Me
End Sub

Private Sub Form_Load()
RefreshAppList lstApp
End Sub

Private Sub lstApp_Click()
SetActionName btnAction, lstApp
End Sub
    In a module:

    Attribute VB_Name = "Ghost"

Declare Function EnumWindows Lib "user32" (ByVal lpEnumWindows As Long, LParam As Any) As Boolean
Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hWnd As Long, ByVal lpString As String, ByVal nMaxCount As Long) As Long
Declare Function GetParent Lib "user32" (ByVal hWnd As Long) As Long 
Declare Function IsWindowVisible Lib "user32" (ByVal hWnd As Long) As Boolean
Declare Function ShowWindow Lib "user32" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Boolean

Function EnumWindowsProc(ByVal hWnd As Long, lstApp As ListBox) As Boolean
If GetParent(hWnd) = 0 And IsWindowVisible(hWnd) Then
Dim strAppName As String
strAppName = Space(256)
GetWindowText hWnd, strAppName, 256
strAppName = Left$(strAppName, InStr(strAppName, vbNullChar) - 1)
If strAppName <> "" And strAppName <> "Ghost" Then
lstApp.AddItem strAppName
lstApp.ItemData(lstApp.NewIndex) = hWnd
End If
End If
EnumWindowsProc = True
End Function

Public Sub RefreshAppList(lstApp As ListBox)
EnumWindows AddressOf EnumWindowsProc, lstApp
End Sub

Public Sub SetActionName(btnAction As CommandButton, lstApp As ListBox)
Dim hWnd As Long
hWnd = lstApp.ItemData(lstApp.ListIndex)
btnAction.Caption = IIf(IsWindowVisible(hWnd), "Hide", "Show")
End Sub

Public Sub HideOrShow(lstApp As ListBox)
Dim hWnd As Long, nCmdShow As Long
hWnd = lstApp.ItemData(lstApp.ListIndex)
nCmdShow = IIf(IsWindowVisible(hWnd), 0, 5)
ShowWindow hWnd, nCmdShow
End Sub
  7. Fast searching in strings 
    Private Declare Function strchr Lib "MSVCRT.dll" (ByVal sTarget$, ByVal nPattern&) As Long

Sub Main()
Dim i&, sTarget$, sPattern$, nTotalFound&
sTarget = "PROGRAMMING"
sPattern = "PRM"

For i = 1 To Len(sPattern)
If strchr(sTarget, Asc(Mid$(sPattern, i, 1))) Then nTotalFound = nTotalFound + 1
Next
MsgBox CStr(nTotalFound)
End Sub
  8. Writing a log event for NT (1) 
    Option Explicit
Declare Function RegisterEventSource Lib "advapi32.dll" Alias _
"RegisterEventSourceA" (ByVal lpUNCServerName As String, _
ByVal lpSourceName As String) As Long

Declare Function DeregisterEventSource Lib "advapi32.dll" ( _
ByVal hEventLog As Long) As Long

Declare Function ReportEvent Lib "advapi32.dll" Alias _
"ReportEventA" (ByVal hEventLog As Long, ByVal wType As Integer, _
ByVal wCategory As Integer, ByVal dwEventID As Long, _
ByVal lpUserSid As Any, ByVal wNumStrings As Integer, _
ByVal dwDataSize As Long, plpStrings As Long, _
lpRawData As Any) As Boolean

Declare Function GetLastError Lib "kernel32" () As Long

Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
hpvDest As Any, hpvSource As Any, _
ByVal cbCopy As Long)

Declare Function GlobalAlloc Lib "kernel32" ( _
ByVal wFlags As Long, _
ByVal dwBytes As Long) As Long

Declare Function GlobalFree Lib "kernel32" ( _
ByVal hMem As Long) As Long

'-- Public Constants
Public Const EVENTLOG_SUCCESS = 0
Public Const EVENTLOG_ERROR_TYPE = 1
Public Const EVENTLOG_WARNING_TYPE = 2
Public Const EVENTLOG_INFORMATION_TYPE = 4
Public Const EVENTLOG_AUDIT_SUCCESS = 8
Public Const EVENTLOG_AUDIT_FAILURE = 10


Public Function WriteToEventLog(sMessage As String, _
sSource As String, _
iLogType As Integer, _
vEventID As Integer) As Boolean

Dim bRC As Boolean
Dim iNumStrings As Integer
Dim hEventLog As Long
Dim hMsgs As Long
Dim cbStringSize As Long
Dim iEventID As Integer

hEventLog = RegisterEventSource("", sSource)
cbStringSize = Len(sMessage) + 1
hMsgs = GlobalAlloc(&H40, cbStringSize)
CopyMemory ByVal hMsgs, ByVal sMessage, cbStringSize
iNumStrings = 1

'-- ReportEvent returns 0 if failed,
'-- Any other number indicates success
If ReportEvent(hEventLog, _
iLogType, 0, _
iEventID, 0&, _
iNumStrings, cbStringSize, _
hMsgs, hMsgs) = 0 Then
'-- Failed
WriteToEventLog = False
Else
'-- Sucessful
WriteToEventLog = True
End If

Call GlobalFree(hMsgs)
DeregisterEventSource (hEventLog)
End Function
  9. Writing a log event for NT (2) 
    App.LogEvent "Error No : " & vbCrLf & Err.Number & vbCrLf & "Source : " & vbCrLf & "[name of dll and message]" & Err.Source & vbCrLf & "Description :" & vbCrLf & Err.Description, vbLogEventTypeError
  10. All the databases available for MS SQL Server 
    Private Sub LoadDatabases()
Dim RDOConn As RDO.rdoConnection
Dim rs As rdoResultset
Dim sql As String

On Error GoTo LoadDatabasesError

Set RDOConn = New rdoConnection

'--- handle errors locally
With RDOConn
.Connect = "SERVER=" & ServerName & ";UID=" & UserID & =";PWD=" & Password & ";DRIVER={SQL Server};DSN=;"
.LoginTimeout = 5
.EstablishConnection
End With

cboDatabases.Clear

sql = "select * "
sql = sql & "from master.dbo.sysdatabases"
Set rs = RDOConn.OpenResultset(sql)
If rs.EOF Then
cboDatabases.Enabled = False
Else
Do While Not rs.EOF
cboDatabases.AddItem rs.rdoColumns(0).Value
rs.MoveNext
Loop
End If

End Select

If Not rs Is Nothing Then Set rs = Nothing
If Not RDOConn Is Nothing Then Set RDOConn = Nothing

Exit Sub

LoadDatabasesError:
MsgBox Err.Number & ":" & Err.Description, , "Load Databases"
Exit Sub
End Sub
  11. Getting / setting double-click time 
    Declare Function SetDoubleClickTime Lib "user32" Alias "SetDoubleClickTime" (ByVal wCount As Long) As Long                  
Declare Function GetDoubleClickTime& Lib "user32" ()

'set double-click time in milliseconds
setDoubleClickTime(500)

'retrieve the mouse double-click time in milliseconds
Dim lngReturn As Long
lngReturn = GetDoubleClickTime
  12. Creating shortcuts on the desktop & start menu 
    'NOTE: In Visual Basic 5.0, change Stkit432.dll in the following
'statement to Vb5stkit.dll.  Stkit432.dll is for Visual Basic 4.0

Private Declare Function fCreateShellLink Lib "STKIT432.DLL" (ByVal lpstrFolderName As String, ByVal lpstrLinkName As String, ByVal lpstrLinkPath As String, ByVal lpstrLinkArgs As String) As Long

Dim lReturn As Long
    

    'Add to Desktop
    lReturn = fCreateShellLink("..\..\Desktop", _
    "Shortcut to Calculator", "c:\windows\calc.exe", "")
    
    'Add to Program Menu Group
    lReturn = fCreateShellLink("", "Shortcut to Calculator", _
    "c:\windows\calc.exe", "")
    
    'Add to Startup Group
    'Note that on Windows NT, the shortcut will not actually appear
    'in the Startup group until your next reboot.
    lReturn = fCreateShellLink("\Startup", "Shortcut to Calculator", _
    "c:\windows\calc.exe", "")

© VB Work 2000, Last update