Lista VB Ro
Carti
Surse
Articole
Programe
Legaturi
Pareri

1. Verific daca e instalat suportul pentru DCOM

   Public Declare Function GetProcAddress Lib "kernel32" _
       (ByVal hModule As Long, ByVal lpProcName As String) As Long
   
   Public Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" _
       (ByVal lpModuleName As String) As Long
           
   Public Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" _
       (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, _
       ByVal samDesired As Long, phkResult As Long) As Long
       
   Public Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" _
       (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, _
       lpType As Long, lpData As Any, lpcbData As Long) As Long
       
   Public Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
   
   Public Const ERROR_SUCCESS = 0
   Public Const HKEY_CURRENT_CONFIG = &H80000005
   Public Const HKEY_LOCAL_MACHINE = &H80000002
   Public Const STANDARD_RIGHTS_ALL = &H1F0000
   Public Const KEY_QUERY_VALUE = &H1
   Public Const KEY_SET_VALUE = &H2
   Public Const KEY_CREATE_SUB_KEY = &H4
   Public Const KEY_ENUMERATE_SUB_KEYS = &H8
   Public Const KEY_NOTIFY = &H10
   Public Const KEY_CREATE_LINK = &H20
   Public Const SYNCHRONIZE = &H100000
   Public Const KEY_ALL_ACCESS = ((STANDARD_RIGHTS_ALL Or _
       KEY_QUERY_VALUE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY Or _
       KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY Or KEY_CREATE_LINK) And (Not SYNCHRONIZE))
   
   Sub Main()
    If DCOMOK Then
     MsgBox "DCOM instaled!"
    Else
     MsgBox "DCOM not instaled!"
    End If
   End Sub
   
   Private Function DCOMOK() As Boolean
       'Determine if DCOM (Distributed COM) can be used. It can if it
       'is installed and is enabled on the current machine.
       'Dim bOK As Boolean
       Dim bPresent As Boolean
       Dim bEnabled As Boolean
       Dim hKey As Long
       Dim lpType As Long
       Dim lpData
       Dim lResult As Long
       Dim lpcbData As Long
       
       lResult = GetProcAddress(GetModuleHandle("OLE32"), "CoInitializeEx")
       If lResult <> 0 Then
           bPresent = True
       Else
           bPresent = False
       End If
       
       lResult = RegOpenKeyEx(HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Ole", 0, _
           KEY_ALL_ACCESS, hKey)
       lpcbData = Len("EnableDCOM")    '10
       
       If lResult = ERROR_SUCCESS Then
           lResult = RegQueryValueEx(ByVal hKey, "EnableDCOM", 0, ByVal lpType, lpData, lpcbData)
       End If
       
       If lResult = ERROR_SUCCESS Then
           bEnabled = True
           RegCloseKey (hKey)
       Else
           bEnabled = False
       End If
       
       If bEnabled And bPresent Then
           DCOMOK = True
       Else
           DCOMOK = False
       End If
   End Function
   

2. Numarul de linii dintr-un textbox multilinie

   Public 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
   
   Public Const EM_GETLINECOUNT = &HBA
   
   Sub Text1_Change()
       Dim lineCount as Long
       On Local Error Resume Next
     
      'get/show the number of lines in the edit control
       lineCount = SendMessageLong(Text1.hwnd, EM_GETLINECOUNT, 0&, 0&)
       Label1 = Format$(lineCount, "##,###")
   End Sub
   

3. Verific daca este o conexiune activa la Internet (Win 9x)

   Public Const ERROR_SUCCESS = 0&
   Public Const APINULL = 0&
   Public Const HKEY_LOCAL_MACHINE = &H80000002
   Public ReturnCode As Long
   
   Declare Function RegCloseKey Lib "advapi32.dll" (ByVal _
   hKey As Long) As Long
   
   Declare Function RegOpenKey Lib "advapi32.dll" Alias _
   "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As _
   String, phkResult As Long) As Long
   
   Declare Function RegQueryValueEx Lib "advapi32.dll" Alias _
   "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName _
   As String, ByVal lpReserved As Long, lpType As Long, _
   lpData As Any, lpcbData As Long) As Long
   
   Public Function ActiveConnection() As Boolean
   Dim hKey As Long
   Dim lpSubKey As String
   Dim phkResult As Long
   Dim lpValueName As String
   Dim lpReserved As Long
   Dim lpType As Long
   Dim lpData As Long
   Dim lpcbData As Long
   ActiveConnection = False
   lpSubKey = "System\CurrentControlSet\Services\RemoteAccess"
   ReturnCode = RegOpenKey(HKEY_LOCAL_MACHINE, lpSubKey, _
   phkResult)
   
   If ReturnCode = ERROR_SUCCESS Then
       hKey = phkResult
       lpValueName = "Remote Connection"
       lpReserved = APINULL
       lpType = APINULL
       lpData = APINULL
       lpcbData = APINULL
       ReturnCode = RegQueryValueEx(hKey, lpValueName, _
       lpReserved, lpType, ByVal lpData, lpcbData)
       lpcbData = Len(lpData)
       ReturnCode = RegQueryValueEx(hKey, lpValueName, _
       lpReserved, lpType, lpData, lpcbData)
       
       If ReturnCode = ERROR_SUCCESS Then
           If lpData = 0 Then
               ActiveConnection = False
           Else
               ActiveConnection = True
           End If
       End If
   RegCloseKey (hKey)
   End If
   End Function
   

4. Starea (felul) conexiunii la Internet

   Public Declare Function InternetGetConnectedState _
   Lib "wininet.dll" (ByRef lpSFlags As Long, _
   ByVal dwReserved As Long) As Long
   
   Public Const INTERNET_CONNECTION_LAN As Long = &H2
   Public Const INTERNET_CONNECTION_MODEM As Long = &H1
   
   Public Declare Function InternetGetConnectedState _
   Lib "wininet.dll" (ByRef lpSFlags As Long, _
   ByVal dwReserved As Long) As Long
   
   Public Function Online() As Boolean
       'If you are online it will return True, otherwise False
       Online = InternetGetConnectedState(0& ,0&)
   End Function
   
   Public Function ViaLAN() As Boolean
   Dim SFlags As Long
   'return the flags associated with the connection
   Call InternetGetConnectedState(SFlags, 0&)
   'True if the Sflags has a LAN connection
   ViaLAN = SFlags And INTERNET_CONNECTION_LAN
   End Function
   
   Public Function ViaModem() As Boolean
   Dim SFlags As Long
   'return the flags associated with the connection
   Call InternetGetConnectedState(SFlags, 0&)
   'True if the Sflags has a modem connection
   ViaModem = SFlags And INTERNET_CONNECTION_MODEM
   End Function
   
   Private Sub Command1_Click() 
   Text1 = ViaLAN() 
   Text2 = ViaModem() 
   Text3 = Online()
   End Sub
   

5. Determina felul task-barului

   Private Declare Function SHAppBarMessage Lib "shell32.dll" (ByVal dwMessage
   As Long, pData As APPBARDATA) As Long
   
   Private Const ABM_GETSTATE = &H4
   
   Private Type RECT
           Left As Long
           Top As Long
           Right As Long
           Bottom As Long
   End Type
   
   Private Type APPBARDATA
           cbSize As Long
           hwnd As Long
           uCallbackMessage As Long
           uEdge As Long
           rc As RECT
           lParam As Long '  message specific
   End Type
   
   Dim p As APPBARDATA
   Dim rez As Long
   
   Private Sub Command1_Click()
   rez = SHAppBarMessage(ABM_GETSTATE, p)
   Select Case rez
   Case 0
       Label1 = "No always-on-top, no auto hide"
   Case 1
       Label1 = "No always-on-top, auto hide"
   Case 2
       Label1 = "Always-on-top, no auto hide"
   Case 3
       Label1 = "Always-on-top, auto hide"
   End Select
   End Sub
   

6. Ascunde taskbarul

   Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal
   lpClassName As String, ByVal lpWindowName As String) As Long
   Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal
   nCmdShow As Long) As Long
   
   Private Const SW_HIDE = 0
   Private Const SW_SHOW = 5
   
   Dim taskbar As Long
   
   Private Sub Command1_Click()
   ShowWindow taskbar, SW_HIDE
   End Sub
   
   Private Sub Command2_Click()
   ShowWindow taskbar, SW_SHOW
   End Sub
   
   Private Sub Form_Load()
   taskbar = FindWindow("Shell_TrayWnd", vbNullString)
   End Sub
   

7. Deschide o baza de date Access cu parola utilizind DAO

   Dim d As DAO.Database
   Dim r As DAO.Recordset
   
   Private Sub Form_Load()
   Set d = DBEngine.Workspaces(0).OpenDatabase("c:\db1.mdb", False, True, _
     ";UID=Admin;PWD=parola;")
   Set r = d.OpenRecordset("Table1")
   End Sub
   
   

8. Deschide o baza de date Access cu parola utilizind ODBC

   Dim w As DAO.Workspace
   Dim d As DAO.Database
   Dim r As DAO.Recordset
   
   
   Private Sub Form_Load()
   Set w = DBEngine.CreateWorkspace("WorkSpaceTest", "Admin", "", dbUseODBC)
   DBEngine.Workspaces.Append w
   Set d = w.OpenDatabase("", dbDriverNoPrompt, , _
     "ODBC;DRIVER=Microsoft Access driver (*.mdb);DBQ=c:\db1.mdb;UID=Admin;PWD=parola;")
   Set r = d.OpenRecordset("Table1")
   End Sub
   

9. Redau un fisier WAV

      '--[Form1.frm]------------------------
      Option Explicit
      Const pathWavFiles = "C:\WinNT\Media\"
   
      Private Sub Command1_Click()
         PlayWav "tada.wav"
      End Sub
   
      Sub PlayWav(SoundName As String)
         Dim tmpSoundName As String
         Dim wFlags%, X%
         tmpSoundName = pathWavFiles & SoundName
         wFlags% = SND_ASYNC Or SND_NODEFAULT
         X% = sndPlaySound(tmpSoundName, wFlags%)
      End Sub
      '-------------------------------------
      '--[Module1.bas]----------------------
      ' WAV Sound values
      Global Const SND_SYNC = &H0
      Global Const SND_ASYNC = &H1
      Global Const SND_NODEFAULT = &H2
      Global Const SND_LOOP = &H8
      Global Const SND_NOSTOP = &H10
   
      Public Declare Function sndPlaySound& _
         Lib "winmm.dll" Alias "sndPlaySoundA" _
         (ByVal lpszSoundName As String, ByVal uFlags As Long)
      '-------------------------------------
   

10. Procedura pentru a astepta un numar dat de secunde

    Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
    
        Sub Pause(ByVal fSeconds As Single)
        '
        ' Pause execution for specified # of seconds [fSeconds]
        '
           Dim fTimer As Single  ' initial timer value
           fTimer = Timer
           Do While Timer - fTimer < fSeconds
             Sleep 200
             DoEvents
              '
              ' if we cross midnight, back up one day
              ' one day in seconds = 24*60*60 = 86400
              '
              If Timer < fTimer Then
                  fTimer = fTimer - 86400
              End If
           Loop
        End Sub
    

11. Functii pentru criptare / decriptare

    Se definesc constantele ENCRYPT_OFFSET si ENCRYPT_BASE, apoi:

        Function EncryptString(ByVal sSource As String) As String
        '
        ' Does XOR encryption on string
        '
         Dim sEncrypted As String
         Dim nLength As Long
         Dim nLoop As Long
         Dim nTemp As Integer
    
         nLength = Len(sSource)
         sEncrypted = Space$(nLength)
         For nLoop = 1 To nLength
          nTemp = Asc(Mid$(sSource, nLoop, 1))
          If nLoop Mod 2 Then
           nTemp = nTemp - ENCRYPT_OFFSET
          Else
           nTemp = nTemp + ENCRYPT_OFFSET
          End If
          nTemp = nTemp Xor (ENCRYPT_BASE - ENCRYPT_OFFSET)
          Mid$(sEncrypted, nLoop, 1) = Chr$(nTemp)
         Next
         EncryptString = sEncrypted
        End Function
    
        Function DecryptString(ByVal sSource As String) As String
        '
        ' Does XOR decryption on string
        '
         Dim sDecrypted As String
         Dim nLength As Long
         Dim nLoop As Long
         Dim nTemp As Integer
    
         nLength = Len(sSource)
         sDecrypted = Space$(nLength)
         For nLoop = 1 To nLength
          nTemp = Asc(Mid$(sSource, nLoop, 1)) Xor _
                        (ENCRYPT_BASE - ENCRYPT_OFFSET)
          If nLoop Mod 2 Then
           nTemp = nTemp + ENCRYPT_OFFSET
          Else
           nTemp = nTemp - ENCRYPT_OFFSET
          End If
          Mid$(sDecrypted, nLoop, 1) = Chr$(nTemp)
         Next
         DecryptString = sDecrypted
        End Function