Lista VB Ro
Carti
Surse
Articole
Programe
Legaturi
Pareri

1. Setez marginile unui text-box (in pixeli)

   Private Declare Function SendMessageBynum& Lib "user32" Alias "SendMessageA" _
       (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, _
       ByVal lparam As Long)
   Private Const EC_LEFTMARGIN& = &H1&
   Private Const EC_RIGHTMARGIN& = &H2&
   Private Const EM_SETMARGINS = &HD3&
   
   Private Sub SetTextMargin(T As TextBox, ByVal mLeft As Integer, _
      ByVal mRight As Integer)
     Dim lparam As Long
     lparam = mLeft + mRight * &H10000
     SendMessageBynum T.hwnd, EM_SETMARGINS, EC_LEFTMARGIN Or EC_RIGHTMARGIN, lparam
   End Sub
   

2. Text undo (reface text)

   Private Declare Function SendMessageBynum& Lib "user32" Alias "SendMessageA" _
       (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, _
       ByVal lparam As Long)
   Private Const EM_UNDO = &HC7&
   
   Private Sub TextUndo(T As TextBox)
     SendMessageBynum T.hwnd, EM_UNDO, 0, 0
   End Sub
   

3. Muta ferestrele fara caption

   Private Const HTCAPTION& = 2
   Private Const WM_NCLBUTTONDOWN& = &HA1
   Private Declare Function SendMessageBynum& Lib "user32" _
       Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, _
       ByVal wParam As Long, ByVal lParam As Long)
   Private Declare Function ReleaseCapture& Lib "user32" ()
   
   Public Sub StartMove(frm As Form)
     ReleaseCapture
     SendMessageBynum frm.hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0
   End Sub
   

4. Determina numarul de culori suportate de monitor

   Private Const PLANES& = 14
   Private Const BITSPIXEL& = 12
   Private Declare Function GetDeviceCaps& Lib "gdi32" _
      (ByVal hdc As Long, ByVal nIndex As Long)
   Private Declare Function GetDC& Lib "user32" (ByVal hwnd As Long)
   Private Declare Function ReleaseDC& Lib "user32" (ByVal hwnd As Long, _
      ByVal hdc As Long)
   
   Private Function ColorDepth() As Integer
     Dim nPlanes As Integer, BitsPerPixel As Integer, dc As Long
     dc = GetDC(0)
     nPlanes = GetDeviceCaps(dc, PLANES)
     BitsPerPixel = GetDeviceCaps(dc, BITSPIXEL)
     ReleaseDC 0, dc
     ColorDepth = nPlanes * BitsPerPixel
   End Function
   

5. Determina separatorul de zecimale si pentru gruparea miilor

   Private Const LOCALE_USER_DEFAULT& = &H400
   Private Const LOCALE_SDECIMAL& = &HE
   Private Const LOCALE_STHOUSAND& = &HF
   Private Declare Function GetLocaleInfo& Lib "kernel32" Alias _
       "GetLocaleInfoA" (ByVal Locale As Long, ByVal LCType As Long, _
       ByVal lpLCData As String, ByVal cchData As Long)
   
   Private Function ThousandSeparator() As String
     Dim r As Long, s As String
     s = String(10, "a")
     r = GetLocaleInfo(LOCALE_USER_DEFAULT, LOCALE_STHOUSAND, s, 10)
     ThousandSeparator = Left$(s, r)
   End Function
   
   Private Function DecimalSeparator() As String
     Dim r As Long, s As String
     s = String(10, "a")
     r = GetLocaleInfo(LOCALE_USER_DEFAULT, LOCALE_SDECIMAL, s, 10)
     DecimalSeparator = Left$(s, r)
   End Function
   

6. Inlocuirea meniului de context (click-dreapta) pentru text-box

   Private Declare Function LockWindowUpdate Lib "user32" _
     (ByVal hwndLock As Long) As Long
   
   Private Sub Text1_MouseDown(Button As Integer, Shift As Integer, _
     X As Single, Y As Single)
         If Button = vbRightButton Then
         ' Avoid the 'disabled' gray text by locking updates
         LockWindowUpdate Text1.hWnd
         ' A disabled TextBox will not display a context menu
         Text1.Enabled = False      ' Give the previous line time to complete
         DoEvents      ' Display own context menu
         PopupMenu MyPopUpMenu
         ' Enable the control again
         Text1.Enabled = True      ' Unlock updates
         LockWindowUpdate 0&
       End If
   End Sub
   

7. Genereaza mesaj de eroare pentru apeluri API

   Private Const FORMAT_MESSAGE_FROM_SYSTEM& = &H1000
   Private Const FORMAT_MESSAGE_IGNORE_INSERTS& = &H200
   Private Declare Function FormatMessage& Lib "kernel32" Alias _
       "FormatMessageA" (ByVal dwFlags As Long, lpSource As Any, _
       ByVal dwMessageId As Long, ByVal dwLanguageId As Long, _
       ByVal lpBuffer As String, ByVal nSize As Long, Arguments As Long)
   
   Public Function APIerrorDescription(ByVal code As Long) As String
     Dim msg As String, r As Long
     msg = String(256, 0)
     r = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM Or _
       FORMAT_MESSAGE_IGNORE_INSERTS, ByVal 0, code, 0, msg, 256, ByVal 0)
     If r Then APIerrorDescription = Left$(msg, r)
   End Function
   

8. Cum se poate schimba culoarea fontului pentru un command-button

   Option Explicit
   
   Private Type RECT
     Left As Long
     Top As Long
     Right As Long
     Bottom As Long
   End Type
   
   Private Const DT_SINGLELINE& = &H20
   Private Const DT_CENTER& = &H1
   Private Const DT_VCENTER& = &H4
   Private Const TRANSPARENT& = 1
   Private Declare Function SetBkMode& Lib "gdi32" (ByVal hdc As Long,  _
   ByVal nBkMode As Long)
   Private Declare Function SetTextColor& Lib "gdi32" (ByVal hdc As Long, _
   ByVal crColor As Long)
   Private Declare Function GetDC& Lib "user32" (ByVal hwnd As Long)
   Private 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)
   
   Private Sub Command1_GotFocus()
     Timer1.Enabled = True
   End Sub
   
   Private Sub Command1_LostFocus()
     Timer1.Enabled = True
   End Sub
   
   Private Sub Command1_MouseDown(Button As Integer, Shift As Integer,  _
   x As Single, y As Single)
     PaintCaption Command1, 2, 2, vbRed
   End Sub
   
   Private Sub Command1_MouseUp(Button As Integer, Shift As Integer, _
   x As Single, y As Single)
     PaintCaption Command1, 0, 0, vbRed
   End Sub
   
   Private Sub Form_Paint()
     Timer1.Enabled = True
   End Sub
   
   Private Sub Timer1_Timer()
     PaintCaption Command1, 0, 0, vbRed
     Timer1.Enabled = False
   End Sub
   
   Private Sub PaintCaption(btn As CommandButton, ByVal x As Long, _
   ByVal y As Long, clr As Long)
     Dim dc As Long, re As RECT
     dc = GetDC(btn.hwnd)
     SetTextColor dc, clr
     SetBkMode dc, TRANSPARENT
     re.Left = x
     re.Top = y
     re.Bottom = btn.Height
     re.Right = btn.Width
     DrawText dc, btn.Tag, -1, re, DT_CENTER Or DT_VCENTER Or DT_SINGLELINE
   End Sub
   

9. Inregistrez automat un control (fara regsrv32.exe)

   Private Declare Function DllRegisterServer_exemplu Lib _
     "Exemplu_dvs.ocx" Alias "DllRegisterServer" () As Long
   
     Dim retval As Long
     retval = DllRegisterServer_exemplu
   

10. Start Mode pentru Windows

    Private Declare Function GetSystemMetrics Lib "user32" _
       (ByVal nIndex As Long) As Long
    
    Private Const SM_CLEANBOOT = 67  
    
    Private Sub Command1_Click()
           Select Case GetSystemMetrics(SM_CLEANBOOT)
                  Case 1: Label1 = "Safe Mode."
                  Case 2: Label1 = "Safe Mode with Network support."
                  Case Else: Label1 = "Windows is running normally."
          End Select
    End Sub  
    

11. Sterge Recent Docs

    Private Declare Sub SHAddToRecentDocs Lib "shell32.dll" _
      (ByVal uFlags As Long, ByVal pv As String)
    
    Private Const SHARD_PIDL As Long = 1
    Private Const SHARD_PATH As Long = 2
    
    Call SHAddToRecentDocs(SHARD_PATH, vbNullString)
    

12. Testeaza starea tastelor NUMLOCK, CAPSLOCK, SCROLL

    Private Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long)
       As Integer
    Const VK_NUMLOCK = &H90
    Const VK_SCROLL = &H91
    Const VK_CAPITAL = &H14
    
    Private Sub Command1_Click()
        Dim Key As Integer
    
        Key = GetKeyState(VK_NUMLOCK)
        If Key And 1 Then
            text1.Text = "Num Lock is On"
        Else
            text1.Text = "Num Lock is Off"
        End If
    
        Key = GetKeyState(VK_SCROLL)
        If Key And 1 Then
            Text2.Text = "Scroll Lock is On"
        Else
            Text2.Text = "Scroll Lock is Off"
        End If
    
        Key = GetKeyState(VK_CAPITAL)
        If Key And 1 Then
            Text3.Text = "Caps Lock is On"
        Else
            Text3.Text = "Caps Lock is Off"
        End If
    End Sub
    

13. Completeaza un tree-view cu o structura de directoare

    Calea de start se da in Text1 si trebuie sa sa termine cu "\"

    Private Sub Command1_Click()
    FillTreeView Text1.Text
    End Sub
    
    Private Sub FillTreeView(s As String)
    tv1.Nodes.Clear
    tv1.Nodes.Add , , "root", s
    MyPath = s  ' Set the path.
    myname = Dir(MyPath, vbDirectory)   ' Retrieve the first entry.
    Do While myname <> ""   ' Start the loop.
        ' Ignore the current directory and the encompassing directory.
        If myname <> "." And myname <> ".." Then
            ' Use bitwise comparison to make sure MyName is a directory.
    
    If (GetAttr(MyPath & myname) And vbDirectory) = vbDirectory Then
                'Debug.Print MyName  ' Display entry only if it
                tv1.Nodes.Add "root", tvwChild, , myname
            End If  ' it represents a directory.
        End If
        myname = Dir    ' Get next entry.
    Loop
    End Sub