Lista VB Ro
Carti
Surse
Articole
Programe
Legaturi
Pareri

1. Determina toate controalele dintr-un frame (1)

   Dim c As Control
   
   Private Sub Command1_Click()
   For Each c In Controls
   If c.Container Is Frame1 Then Print c.Name
   Next
   End Sub
   

2. Determina toate controalele dintr-un frame (2)

   Private Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, _
     ByVal wCmd As Long) As Long
   Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" _
     (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
   
   Private Const GW_CHILD = 5
   Private Const GW_HWNDNEXT = 2
   
   Dim l As Long
   Dim s As String * 255
   
   Private Sub Command2_Click()
   l = GetWindow(Frame1.hwnd, GW_CHILD)
   If l <> 0 Then
       GetWindowText l, s, 255
       Print Left$(s, InStr(s, Chr(0)) - 1)
       Do
       l = GetWindow(l, GW_HWNDNEXT)
       If l <> 0 Then
           GetWindowText l, s, 255
           Print Left$(s, InStr(s, Chr(0)) - 1)
       End If
       Loop While l <> 0
   End If
   End Sub
   

3. Obtin serial-number-ul pentru HDD

   Private Declare Function GetVolumeInformation Lib "kernel32" _
     Alias "GetVolumeInformationA" (ByVal lpRootPathName As String, _
     ByVal lpVolumeNameBuffer As String, ByVal nVolumeNameSize As Long, _
     lpVolumeSerialNumber As Long, lpMaximumComponentLength As Long, _
     lpFileSystemFlags As Long, ByVal lpFileSystemNameBuffer As String, _
     ByVal nFileSystemNameSize As Long) As Long
   
   Dim VolName As String * 255
   Dim VolFS As String * 255
   Dim Serial As Long
   GetVolumeInformation "c:\", VolName, 255, Serial, 0, 0, VolFS, 255
   VolName = Left$(VolName, InStr(VolName, Chr(0)) - 1)
   VolFS = Left$(VolFS, InStr(VolFS, Chr(0)) - 1)
   MsgBox VolName & vbCrLf & VolFS & vbCrLf & Serial
   

4. Ce Service Pack e instalat pe NT?

   Private Type OSVERSIONINFO
   dwOSVersionInfoSize As Long
   dwMajorVersion As Long
   dwMinorVersion As Long
   dwBuildNumber As Long
   dwPlatformId As Long
   szCSDVersion As String * 128
   End Type
   
   Private Declare Function GetVersionEx Lib "kernel32" Alias _
   "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As Long 
   
   ' Returns Version of Windows as a String
   ' NOTE: Win95 returns "4.00", WIn98 returns "4.10"
   '
   ' It also optionally returns the Windows NT Service Pack
   ' version in the argument, if one is passed 
   
   Function WindowsVersionSP(Optional NTServicePack As Integer) As String
   Dim osInfo As OSVERSIONINFO
   osInfo.dwOSVersionInfoSize = Len(osInfo)
   GetVersionEx osInfo
   WindowsVersionSP = osInfo.dwMajorVersion & "." & Right$( _
     "0" & Format$(osInfo.dwMinorVersion), 2)
   
   If osInfo.dwMajorVersion = 4 Then
    If InStr(osInfo.szCSDVersion, "3") > 0 Then
     NTServicePack = 3
    ElseIf InStr(osInfo.szCSDVersion, "4") > 0 Then
     NTServicePack = 4
    ElseIf InStr(osInfo.szCSDVersion, "5") > 0 Then
     NTServicePack = 5
    ElseIf InStr(osInfo.szCSDVersion, "6") > 0 Then
     NTServicePack = 6
    Else
     NTServicePack = 0
    End If
   End If
   End Function 
   

5. Converteste ProgId la CLSID

   Private Declare Function CLSIDFromProgID Lib "ole32.dll" (ByVal _
   lpszProgID As Long, pCLSID As Any) As Long
   Private Declare Function StringFromCLSID Lib "ole32.dll" (pCLSID As _
   Any, lpszProgID As Long) As Long
   Private Declare Sub CopyMemory Lib "kernel32" Alias _
   "RtlMoveMemory" (dest As Any, source As Any, ByVal bytes As Long)
   Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long) 
   ' Convert a ProgID (such as "Word.Application") into the
   ' string representation of its CLSID 
   Function ProgIdToCLSID(ByVal ProgID As String) As String
   Dim pResult As Long, pChar As Long
   Dim char As Integer, length As Long
   ' No need to use a special UDT
   Dim guid(15) As Byte
   
   ' get the CLSID in binary form
   CLSIDFromProgID StrPtr(ProgID), guid(0)
   ' convert to a string, get pointer to result
   StringFromCLSID guid(0), pResult
   ' find the terminating null char
   pChar = pResult - 2
   Do
   pChar = pChar + 2
   CopyMemory char, ByVal pChar, 2
   Loop While char
   ' now get the entire string in one operation
   length = pChar - pResult
   ' no need for a temporary string
   ProgIdToCLSID = Space$(length \ 2)
   CopyMemory ByVal StrPtr(ProgIdToCLSID), ByVal pResult, length
   ' release the memory allocated to the string
   CoTaskMemFree pResult
   End Function 
   

6. Converteste CLSID la ProgID

   Private Declare Function ProgIDFromCLSID Lib "ole32.dll" (pCLSID As _
   Any, lpszProgID As Long) As Long
   Private Declare Function CLSIDFromString Lib "ole32.dll" (ByVal _
   lpszProgID As Long, pCLSID As Any) As Long
   Private Declare Sub CopyMemory Lib "kernel32" Alias _
   "RtlMoveMemory" (dest As Any, source As Any, ByVal bytes As Long) 
   ' Convert a string representation of a CLSID, including the
   ' surrounding brace brackets, into the corresponding ProgID. 
   Function CLSIDToProgID(ByVal CLSID As String) As String
   Dim pResult As Long, pChar As Long
   Dim char As Integer, length As Long
   ' No need to use a special UDT
   Dim guid(15) As Byte 
   ' convert from string to a binary CLSID
   CLSIDFromString StrPtr(CLSID), guid(0)
   ' convert to a string, get pointer to result
   ProgIDFromCLSID guid(0), pResult
   ' find the terminating null char
   pChar = pResult - 2
   Do
   pChar = pChar + 2
   CopyMemory char, ByVal pChar, 2
   Loop While char
   ' now get the entire string in one operation
   length = pChar - pResult
   ' no need for a temporary string
   CLSIDToProgID = Space$(length \ 2)
   CopyMemory ByVal StrPtr(CLSIDToProgID), ByVal pResult, length
   End Function 
   

7. Obtin un obiect dintr-un pointer

   Private Declare Sub CopyMemory Lib "Kernel32" Alias _
   "RtlMoveMemory" (dest As Any, Source As Any, ByVal bytes As Long) 
   ' Returns an object given its pointer
   ' This function reverses the effect of the ObjPtr function 
   Function ObjFromPtr(ByVal pObj As Long) As Object
   Dim obj As Object
   ' force the value of the pointer into the temporary object variable
   CopyMemory obj, pObj, 4
   ' assign to the result (this increments the ref counter)
   Set ObjFromPtr = obj
   ' manually destroy the temporary object variable 
   ' (if you omit this step you'll get a GPF!)
   CopyMemory obj, 0&, 4
   End Function 
   

8. Data crearii, modificarii si ultima accesare a unui fisier

   Private Const MAX_PATH = 260
   
   Private Type SYSTEMTIME
       wYear As Integer
       wMonth As Integer
       wDayOfWeek As Integer
       wDay As Integer
       wHour As Integer
       wMinute As Integer
       wSecond As Integer
       wMilliseconds As Integer
   End Type
   
   Private Type FILETIME
       dwLowDateTime As Long
       dwHighDateTime As Long
   End Type
   
   Private Declare Function CreateFile Lib "kernel32" Alias _
       "CreateFileA" (ByVal lpFileName As String, _
       ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, _
       ByVal NoSecurity As Long, ByVal dwCreationDisposition As Long, _
       ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
   Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As _
       Long) As Long
   Private Declare Function GetFileTime Lib "kernel32" (ByVal hFile As _
       Long, lpCreationTime As FILETIME, lpLastAccessTime As FILETIME, _
       lpLastWriteTime As FILETIME) As Long
   Private Declare Function FileTimeToSystemTime Lib "kernel32" _
       (lpFileTime As FILETIME, lpSystemTime As SYSTEMTIME) As Long
   Private Declare Function FileTimeToLocalFileTime Lib "kernel32" _
       (lpFileTime As FILETIME, lpLocalFileTime As FILETIME) As Long
   
   Private Const GENERIC_READ = &H80000000
   Private Const FILE_SHARE_READ = &H1
   Private Const FILE_SHARE_WRITE = &H2
   Private Const OPEN_EXISTING = 3
   Private Const INVALID_HANDLE_VALUE = -1
   
   ' Retrieve the Create date, Modify (write) date and Last Access date of
   ' the specified file. Returns True if successful, False otherwise.
   
   Function GetFileTimeInfo(ByVal FileName As String, Optional CreateDate As Date, _
       Optional ModifyDate As Date, Optional LastAccessDate As Date) As Boolean
   
       Dim hFile As Long
       Dim ftCreate As FILETIME
       Dim ftModify As FILETIME
       Dim ftLastAccess As FILETIME
       Dim ft As FILETIME
       Dim st As SYSTEMTIME
       
       ' open the file, exit if error
       hFile = CreateFile(FileName, GENERIC_READ, _
           FILE_SHARE_READ Or FILE_SHARE_WRITE, 0&, OPEN_EXISTING, 0&, _
           0&)
       If hFile = INVALID_HANDLE_VALUE Then Exit Function
       
       ' read date information
       If GetFileTime(hFile, ftCreate, ftLastAccess, ftModify) Then
           ' non zero means successful
           GetFileTimeInfo = True
           
           ' convert result to date values
           ' first, convert UTC file time to local file time
           FileTimeToLocalFileTime ftCreate, ft
           ' then convert to system time
           FileTimeToSystemTime ft, st
           ' finally, make up the Date value
           CreateDate = DateSerial(st.wYear, st.wMonth, _
               st.wDay) + TimeSerial(st.wHour, st.wMinute, _
               st.wSecond) + (st.wMilliseconds / 86400000)
           
           ' do the same for the ModifyDate
           FileTimeToLocalFileTime ftModify, ft
           FileTimeToSystemTime ft, st
           ModifyDate = DateSerial(st.wYear, st.wMonth, _
               st.wDay) + TimeSerial(st.wHour, st.wMinute, _
               st.wSecond) + (st.wMilliseconds / 86400000)
           ' and for LastAccessDate
           FileTimeToLocalFileTime ftLastAccess, ft
           FileTimeToSystemTime ft, st
           LastAccessDate = DateSerial(st.wYear, st.wMonth, _
               st.wDay) + TimeSerial(st.wHour, st.wMinute, _
               st.wSecond) + (st.wMilliseconds / 86400000)
       End If
       
       ' close the file, in all cases
       CloseHandle hFile
   End Function
   
   Private Sub Command1_Click()
   Dim dateCreate As Date
   Dim dateModify As Date
   Dim dateLastAccess As Date
   CommonDialog1.ShowOpen
   Text1 = CommonDialog1.FileName
   GetFileTimeInfo Text1, dateCreate, dateModify, dateLastAccess
   MsgBox dateCreate & vbCrLf & dateModify & vbCrLf & dateLastAccess
   End Sub
   

9. Ultima zi din luna

   Public Function LastDay(Month As Integer, Year As Integer) As Integer
   Dim dtThisMonth As Date
   Dim dtNextMonth As Date
   Dim dtLastDay As Date
   dtThisMonth = CDate(Month & "/01/" & Year)
   dtNextMonth = DateAdd("m", 1, dtThisMonth)
   dtLastDay = DateAdd("d", -1, dtNextMonth)
   LastDay = Day(dtLastDay)
   End Function
   

10. Verific daca programul a mai fost lansat

    'Private Type SECURITY_ATTRIBUTES
    '        nLength As Long
    '        lpSecurityDescriptor As Long
    '        bInheritHandle As Long
    'End Type
    
    Private Declare Function CreateMutex Lib "kernel32" Alias "CreateMutexA" _
      (ByVal lpMutexAttributes As Long, ByVal bInitialOwner As Long, _
      ByVal lpName As String) As Long
    Private Declare Function ReleaseMutex Lib "kernel32" (ByVal hMutex As Long) As Long
    
    Private Const ERROR_ALREADY_EXISTS = 183&
    
    Dim hMutex As Long
    
    Private Sub Command1_Click()
    Me.Caption = Text1
    End Sub
    
    Private Sub Form_Load()
    On Error Resume Next
    hMutex = CreateMutex(0, True, "Test 1")
    If Err.LastDllError = ERROR_ALREADY_EXISTS Then
    MsgBox "Deja ruleaza!"
    Unload Me
    End If
    End Sub
    
    Private Sub Form_Unload(Cancel As Integer)
    ReleaseMutex hMutex
    End Sub
    

11. Afiseaza/ascunde butonul 'Start'

    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 Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, _
       ByVal wCmd As Long) As Long
    
    Private Const GW_CHILD = 5
    Private Const SW_HIDE = 0
    Private Const SW_SHOWNORMAL = 1
    
    Dim h As Long
    
    Private Sub Command1_Click()
    ShowWindow h, SW_HIDE
    End Sub
    
    
    Private Sub Command2_Click()
    ShowWindow h, SW_SHOWNORMAL
    End Sub
    
    Private Sub Form_Load()
    Command1.Caption = "Hide start"
    Command2.Caption = "Show start"
    h = FindWindow("Shell_TrayWnd", vbNullString)
    h = GetWindow(h, GW_CHILD)
    End Sub
    

12. Converteste Byte Array la String

    Public Function ByteArrayToString(bytArray() As Byte) As String
       Dim sAns As String
       Dim iPos As String
       sAns = StrConv(bytArray, vbUnicode)
       iPos = InStr(sAns, Chr(0))
       If iPos > 0 Then sAns = Left(sAns, iPos - 1)
       ByteArrayToString = sAns
    End Function