Coduri sursa in vb 6.0

Declare Function  ShowCursor& Lib "user32" (ByVal lShow As Long), parametrul lShow setat pe  FALSE
Dezactivare Controale
Dezactiveaza toate controalele dintr-o forma:
For i  = 0 To Form1.Controls.Count - 1
    Form1.Controls(i).Enabled =  False

Private Sub  Text1_GotFocus()
        SendKeys "{home}+{end}"
End  Sub

Private Sub  Text1_GotFocus()
        Text1.SelStart = 0
        Text1.SelLength =  Len(Text1.Text)
End Sub

Private Sub Form_KeyPress(KeyAscii As Integer)
        If  KeyAscii = 13 Then
            SendKeys "{TAB}"
            KeyAscii = 0
        End  If
End Sub

Public Const SPIF_UPDATEINIFILE = &H1
Public Const  SPI_SETDESKWALLPAPER = 20
Public Const SPIF_SENDWININICHANGE =  &H2

Private Declare Function SystemParametersInfo Lib "User32" Alias  "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByVal  lpvParam As String, ByVal fuWinIni As Long) As Long

Public Sub  SetWallpaper(ByVal pFileName As String)
    Dim Ret as long
    Ret =  SystemParametersInfo(SPI_SETDESKWALLPAPER, 0&, pFileName,SPIF_UPDATEINIFILE  Or SPIF_SENDWININICHANGE)
End Sub

Private Declare Function SystemParametersInfo Lib "user32" Alias  "SystemParametersInfoA"(ByVal uAction As Long, ByVal uParam As Long, lpvParam As  Any, ByVal fuWinIni As Long) As Long

Private Const SPI_SCREENSAVERRUNNING  = 97

Private Sub Form_Unload(Cancel As Integer)
      ‘cand inchideti  aplicatia, "combinatia" trebuie activata
      Call Command2_Click
End  Sub

Private Sub Command1_Click()
      Dim Ret As long
      Dim pOld As  Boolean
      Ret = SystemParametersInfo(SPI_SCREENSAVERRUNNING, True, pOld,  0)
End Sub

Private Sub Command2_Click()
      Dim Ret As long
      Dim  pOld As Boolean
      Ret = SystemParametersInfo(SPI_SCREENSAVERRUNNING, False,  pOld, 0)
End Sub
Redau un fisier *.wav
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

Private Declare Function  sndPlaySoundA Lib "WINMM.DLL" (ByVal lpszSoundName as string, ByVal ValueFlags  As Long) As Long

Public Sub PlayWavFile(ByVal pFilename As  String)
        Dim Ret As Long
        Ret = sndPlaySoundA(pFilename, SND_ASYNC Or  SND_NODEFAULT)
End Sub
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

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

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
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

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
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
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
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

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
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
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

strApplication = "IEXPLORE" ' Pentru Internet Explorer
strApplication = "NETSCAPE" ' Pentru Netscape
strDDETopic = strApplication & "|WWW_GetWindowInfo"
With DDEText
.LinkTopic = strDDETopic
.LinkItem = "0xFFFFFFFF"
.LinkMode = 2
.LinkRequest
End With
sCurrentURL = Mid(DDEText.Text, 2, InStr(DDEText.Text, ",") - 3)
Cum lansez browserul Internet implicit cu o anumita adresa?
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

Const SW_MAXIMIZE = 3

Private Sub Command1_Click()
Dim lRet As Long
lRet = ShellExecute(Me.hwnd, "open","http://zed.go.ro", vbNullString, vbNullString, SW_MAXIMIZE)
End Sub
Rezolutia ecranului
Public Function GetScreenResolution() As String
Dim TWidth As Long
Dim THeight As Long
TWidth = Screen.Width \ Screen.TwipsPerPixelX
THeight = Screen.Height \ Screen.TwipsPerPixelY
GetScreenResolution = TWidth & "x" & THeight
End Function

Private Declare Function EnumDisplaySettings Lib "user32" Alias "EnumDisplaySettingsA" (ByVal lpszDeviceName As Long, ByVal iModeNum As Long, lpDevMode As Any) As Boolean
Private Declare Function ChangeDisplaySettings Lib "user32" Alias "ChangeDisplaySettingsA" (lpDevMode As Any, ByVal dwflags As Long) As Long
Const CCDEVICENAME = 32
Const CCFORMNAME = 32
Const DM_PELSWIDTH = &H80000
Const DM_PELSHEIGHT = &H100000

Private Type DEVMODE
    dmDeviceName As String * CCDEVICENAME
    dmSpecVersion As Integer
    dmDriverVersion As Integer
    dmSize As Integer
    dmDriverExtra As Integer

    dmFields As Long
    dmOrientation As Integer
    dmPaperSize As Integer
    dmPaperLength As Integer
    dmPaperWidth As Integer
    dmScale As Integer
    dmCopies As Integer
    dmDefaultSource As Integer
    dmPrintQuality As Integer
    dmColor As Integer
    dmDuplex As Integer
    dmYResolution As Integer
    dmTTOption As Integer
    dmCollate As Integer

    dmFormName As String * CCFORMNAME
    dmUnusedPadding As Integer
    dmBitsPerPel As Integer
    dmPelsWidth As Long
    dmPelsHeight As Long
    dmDisplayFlags As Long
    dmDisplayFrequency As Long
End Type

Dim DevM As DEVMODE

Private Sub Command1_Click()
    Dim a As Boolean
    Dim i&
    i = 0
    Do
        a = EnumDisplaySettings(0&, i&, DevM)
        i = i + 1
    Loop Until (a = False)
End Sub

Private Sub Command2_Click()
    Dim b&
    DevM.dmFields = DM_PELSWIDTH Or DM_PELSHEIGHT

    DevM.dmPelsWidth = 640  ‘Schimba rezolutia in 640x480
    DevM.dmPelsHeight = 480

    b = ChangeDisplaySettings(DevM, 0)
End Sub

With lbl_DDE
.LinkTopic = "Folders|AppProperties"
.LinkMode = vbLinkManual
.LinkExecute "[OpenFindFile(,)]"
End With

Declare Function WinHelp Lib "user32" Alias "WinHelpA" (ByVal hwnd As Long, ByVal lpHelpFile As String, ByVal wCommand As Long, ByVal dwData As Long) As Long

Public Const HELP_CONTEXT = &H1 ' Display topic in ulTopic
Public Const HELP_HELPONHELP = &H4 ' Display help on using help
Public Const HELP_INDEX = &H3 ' Display index
Public Const HELP_QUIT = &H2 ' Terminate help
Public Const HELP_SETINDEX = &H5 ' Set current Index for multi index help
Public Const HELP_MULTIKEY = &H201&
Public Const HELP_PARTIALKEY = &H105&

Private Sub MnuHelpContents_Click()
Dim Help_path As String
Dim RV As Long
Help_path = App.HelpFile
RV = WinHelp(Me.hwnd, Help_path, &H3, CLng(0))
End Sub

Public Sub DisableCloseButton(frm as Form)
Dim hMenu As Long
Dim menuItemCount As Long
hMenu = GetSystemMenu(frm.hWnd, 0)
If hMenu Then
menuItemCount = GetMenuItemCount(hMenu)
'este pe ultima pozitie (menuItemCount-1)
RemoveMenu hMenu, menuItemCount - 1, MF_REMOVE Or MF_BYPOSITION
'Sterg separatorul de linie
RemoveMenu hMenu, menuItemCount - 2, MF_REMOVE Or MF_BYPOSITION
DrawMenuBar frm.hWnd
End If
End Sub

Declare Sub SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long)

Public Sub TopMost(ByVal sformname As Form)
'this function keeps the form at the top
'not good when the argument ( sfomrname) is an mdichild already.
'I usually call this procedure on the form_load
'event of any form that I want to be on top
'by simply typing;
'Topmost(me)
'here is the procedure ;

If sformname.MDIChild = True Then
MsgBox ("Form cannot be MDI child")
Exit Sub
End If
SetWindowPos sformname.hwnd, -1, sformname.LEFT / Screen.TwipsPerPixelX, _
sformname.TOP / Screen.TwipsPerPixelY, sformname.Width / Screen.TwipsPerPixelX, _
sformname.Height / Screen.TwipsPerPixelY, &H10 Or &H40
End Sub

Function IsMediaValid(ByVal strPathName As String) As Boolean
Dim bMedia As Boolean
Dim nDrive As Long, nDriveType As Long
Dim nSerialNumber As Long, nCompLen As Long
Dim nFlags As Long
Dim strDrive As String, strVolName As String
Dim strFileSystem As String

' // Return TRUE if the drive doesn't support removable media.
nDriveType = GetDriveType(strPathName)
If ((nDriveType <> DRIVE_REMOVABLE) And _
(nDriveType <> DRIVE_CDROM)) Then
IsMediaValid = True
Exit Function
End If

' // Return FALSE if the drive is empty (::GetVolumeInformation fails).
strDrive = Left(strPathName, 3)
nDrive = Asc(Left(strDrive, 1)) - &H41

strVolName = String(255, Chr(0))
strFileSystem = String(255, Chr(0))
bMedia = GetVolumeInformation _
(strDrive, strVolName, 255, nSerialNumber, _
nCompLen, nFlags, strFileSystem, 255)
If (Not bMedia) Then
m_dwMediaID(nDrive) = &HFFFFFFFF
IsMediaValid = False
Exit Function
End If

' // Also return FALSE if the disk's serial number has changed.
If ((m_dwMediaID(nDrive) <> nSerialNumber) And _
(m_dwMediaID(nDrive) <> &HFFFFFFFF)) Then
m_dwMediaID(nDrive) = nSerialNumber
IsMediaValid = False
Exit Function
End If

' // Update our record of the serial number and return TRUE.
m_dwMediaID(nDrive) = nSerialNumber
IsMediaValid = True
End Function
Afisez dialogul 'Printer Setup'
Pun pe forma un CommonDialog, apoi scriu

On Error Resume Next 'Daca se apasa 'Cancel' va da o eroare
dlgPrintSetup.CancelError = True
dlgPrintSetup.Copies = 1
dlgPrintSetup.FromPage = 1
dlgPrintSetup.Max = 2
dlgPrintSetup.Min = 1
dlgPrintSetup.ToPage = 1
dlgPrintSetup.HelpFile = "C:\WINDOWS\HELP\Winhlp32.hlp"
dlgPrintSetup.HelpCommand = cdlHelpPartialKey
dlgPrintSetup.HelpContext = 0
dlgPrintSetup.flags = cdlPDPrintSetup + cdlPDHidePrintToFile + cdlPDHelpButton
dlgPrintSetup.ShowPrinter
If Err = cdlCancel Then ' A fost apasat Cancel 'Cancel'
'...
End If

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_SHOWNORMAL = 1 

Private Sub Command1_Click() 
Dim Ret        As Long 
Dim ClassName  As String 
Dim StartWindow As Long       
ClassName = Space(256) 
ClassName = "Shell_TrayWnd" 
StartWindow = FindWindow(ClassName, vbNullString)    'Hide the start menu bar 
Ret = ShowWindow(StartWindow, SW_HIDE) 
MsgBox "The Start Menu is hidden (or should be!)"
End Sub 

Private Sub Command2_Click() 
Dim Ret        As Long 
Dim ClassName  As String 
Dim StartWindow As Long       
ClassName = Space(256) 
ClassName = "Shell_TrayWnd" 
StartWindow = FindWindow(ClassName, vbNullString)    'Display the start menu bar as normal 
Ret = ShowWindow(StartWindow, SW_SHOWNORMAL) 
MsgBox "The Start Menu should now be visible"
End Sub

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

Private Const WM_SYSCOMMAND = &H112&
Private Const SC_SCREENSAVE = &HF140&

Private Sub Command1_Click()
  Dim Ret As Long
  Ret = SendMessage(Form1.hWnd, WM_SYSCOMMAND, SC_SCREENSAVE, 0&)
End Sub
Afisez un raport Access dintr-un mdb
Dim objAccess As Access.Application
Set objAccess = CreateObject("access.application")
With objAccess
  .OpenCurrentDatabase filepath:=App.Path & "\ceva.mdb"
  .DoCmd.OpenReport reportname:="Un_raport", View:=acViewPreview
End With
Open/Close pentru CD-ROM
Private Declare Function MCISendString Lib "winmm.dll" Alias "mciSendStringA" (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long

Private Sub cmdOpen_Click()
  Dim Ret    As Long
  Dim RetStr As String
  Ret = MCISendString("set CDAudio door open", RetStr, 127, 0)
End Sub

Private Sub cmdClose_Click()
  Dim Ret    As Long
  Dim RetStr As String
  Ret = MCISendString("set CDAudio door closed", RetStr, 127, 0)
End Sub

Private Declare Function ModifyMenuPic Lib "user32" Alias "ModifyMenuA" (ByVal hmenu As Long, ByVal nPosition As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpString As Long) As Long
Private Declare Function GetMenu Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetSubMenu Lib "user32" (ByVal hmenu As Long, ByVal nPos As Long) As Long
Private Declare Function GetMenuItemID Lib "user32" (ByVal hmenu As Long, ByVal nPos As Long) As Long
Const MF_BITMAP = 4
Const MF_BYCOMMAND = 0
Const MF_BYPOSITION = &H400&

Sub Form_Load()
Dim hmenu&, hSubmenu&, menuid&, result As Long ' Note the "&" characters
Me.Show ' make me visible so all is initialized properly
hmenu = GetMenu(Form1.hwnd) ' get handle to form menu
hSubmenu = GetSubMenu(hmenu, 0) ' get handle to first submenu
menuid = GetMenuItemID(hSubmenu, 0) ' get ID of first submenu item
result = ModifyMenuPic(hSubmenu, menuid, MF_BYCOMMAND Or MF_BITMAP, _
    menuid, Picture1.Picture) ' change first submenu item to bitmap
menuid = GetMenuItemID(hSubmenu, 1) ' get second item ID
result = ModifyMenuPic(hSubmenu, menuid, MF_BYCOMMAND Or MF_BITMAP, _
    menuid, Picture2.Picture) ' change to bitmap
End Sub