Lista VB Ro
Carti
Surse
Articole
Programe
Legaturi
Pareri

1. Obtinerea numelui scurt (8.3) a unei caii (Lucian Gadau)

   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. Lansarea unei aplicatii externe si asteptarea terminarii ei (RunApp) (Lucian Gadau)

   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. Cautare rapida in ListBox sau ComboBox (Serban Tomita)

   
   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
   

   Exemplu de utilizare:
   List1.ListIndex = FFM(List1, text_de_cautat, -1, True)
   Combo1.ListIndex = FFM(Combo1, text_de_cautat, -1, True)

4. Afisarea proprietatilor unui fisier

   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. Blocarea unei ferestre

   Desi se poate folosi
   Declare Function LockWindowUpdate Lib "user32" Alias "LockWindowUpdate" (ByVal hwndLock As Long) As Long
   nu este recomandata de MS (in special pt. NT). Se poate folosi in schimb:

   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. Lista proceselor curente (Alexandru Andrei)

   Pentru a vedea executabilele care ruleaza la un moment dat, se poate folosi functia Windows EnumWindowsProc ca in exemplul urmator (vb5).
   Codul pt. Forma:

   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
   

   Codul pt. Modul:

   
   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. Cel mai rapid mod de lucru cu stringuri

   Merge doar intr-un fisier bas compilat (exe) nu din IDE.

   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. Scrierea in Event Log pt. Win NT

   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
   

   sau

   App.LogEvent "Error No : " & vbCrLf & Err.Number & vbCrLf & "Source : " & vbCrLf & _
     "[name of dll and message]" & Err.Source & vbCrLf & "Description :" & vbCrLf & _
     Err.Description, vbLogEventTypeError
   

9. Determinarea bazelor de date disponibile pe un MS SQL Server (cu RDO)

   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
   

10. Seteaza/obtine intervalul de timp pt. dublu-click

    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
    

11. Creaza shortcut-uri pe ecran si in 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", "")