Visul basic Codes

Royal · Administrator Data inscrierii: 11/Aug/2008 Mesaje: 359

# 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://www.geocities.com/siliconvalley/hills/4377", _ 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

# Cum lansez dialogul 'Find File' ?
Pun un label chiar invizibil pe ecran (lbl_DDE), apoi:

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

Dezactivarea butonului de inchidere a ferestrei ('X')

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

Declaratiile functiilor GetSystemMenu, GetMenuItemCount, RemoveMenu, DrawMenuBar si a constantelor MF_REMOVE si MF_BYPOSITION se gasesc cu API Viewer.

# Verific prezenta dischetei in unitatea a:

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

# Ascund si reafisez butonul 'Start' din Windows

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 natural
Ret = ShowWindow(StartWindow, SW_SHOWNORMAL)
MsgBox "The Start Menu should now be visible"
End Sub

# Porneste Screen-saver-ul

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

# Modific Wallpaper-ul ecranului

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

# 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

# Schimb valorile marcat/nemarcat pt. un check-box

Evident o solutie este

if Check1 = vbChecked Then
Check1 = vbUnchecked
Else
Check1 = vbChecked
End If

Dar pentru ca Check1 = Not Check1 nu merge se poate face mai simplu:

Check1 = (Not Check1) + 2
# Restrictionez un text-box doar la cifre

Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _
(ByVal hwnd As Long, ByVal nIndex As Long) As Long

Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
(ByVal hwnd As Long, ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long

Public Const GWL_STYLE = (-16)

Public Const ES_NUMBER = &H2000

SetWindowLong txtItins.hwnd, GWL_STYLE, _
GetWindowLong(txtItins.hwnd, GWL_STYLE) Or _
ES_NUMBER

# Sterge un fisier si-l pune in Recycle Bin

Utilizare:

Private Sub Command1_Click()
Dim MyBool As Boolean
MyBool = DelToRecycBin("c:\Myfile.txt")
If MyBool = True Then
MsgBox "Fisierul a fost sters! Il puteti recupera din Recycle Bin."
Else
MsgBox "Eroare la stergere!"
End If
End Sub

Iar intr-un modul se pune:

Private Type SHFILEOPSTRUCT
hwnd As Long
wFunc As Long
pFrom As String
pTo As String
fFlags As Integer
fAnyOperationsAborted As Boolean
hNameMappings As Long
lpszProgressTitle As String
End Type
Private Declare Function SHFileOperation Lib "shell32.dll" Alias "SHFileOperationA" _
(lpFileOp As SHFILEOPSTRUCT) As Long
Private Const F0_DELETE = &H3
Private Const F0F_ALLOWUNDO = &H40
Private Const FOF_CREATEPROGRESSDLG As Long = &H0

Public Function DelToRecycBin(FileName As String) As Boolean
Dim FileOperation As SHFILEOPSTRUCT
Dim lReturn As Long
On Error GoTo DelToRecycBin_Err
With FileOperation
.wFunc = F0_DELETE
.pFrom = FileName
.fFlags = F0F_ALLOWUNDO + F0F_CREATEPROGRESSDLG
End With
lReturn = SHFileOperation(FileOperation)
If lReturn <> 0 Then
DelToRecycBin = False
Else
DelToRecycBin = True
End If
Exit Function
DelToRecycBin_Err:
DelToRecycBin = False
MsgBox Err.Description
End Function

# Golesc Recycle Bin-ul

Merge doar pe Win 98 sau pe Win 95 cu IE 4.0.

Private Declare Function SHEmptyRecycleBin Lib "shell32" Alias "SHEmptyRecycleBinA" _
(ByVal hwnd As Long, ByVal pszRootPath As String, ByVal dwFlags As Long) As Long

Private Sub Form_Load()
Call EmptyBin
End Sub

Private Sub EmptyBin(Optional drvBin As String)
Dim r As Long
Dim flags As Long
If drvBin = "" Then
drvBin = vbNullString 'sterge toate Cosurile de gunoi
End If
' flags values
' 1. SHERB_NOCONFIRMATION - No confirmation dialog box
' 2. SHERB_NOPROGRESSUI - No progress indicator, i.e. flying rubbish AVI
' 3. SHERB_NOSOUND - No confirmation sound
r = SHEmptyRecycleBin(Me.hwnd, drvBin, flags)
End Sub

# Determina adresa IP si numele calculatorului cu 'winsock.dll'

Option Explicit
Private Const WS_VERSION_REQD = &H101
Private Const WS_VERSION_MAJOR = WS_VERSION_REQD \ &H100 And &HFF&
Private Const WS_VERSION_MINOR = WS_VERSION_REQD And &HFF&
Private Const MIN_SOCKETS_REQD = 1
Private Const SOCKET_ERROR = -1
Private Const WSADescription_Len = 256
Private Const WSASYS_Status_Len = 128

Private Type HOSTENT
hName As Long
hAliases As Long
hAddrType As Integer
hLength As Integer
hAddrList As Long
End Type

Private Type WSADATA
wversion As Integer
wHighVersion As Integer
szDescription(0 To WSADescription_Len) As Byte
szSystemStatus(0 To WSASYS_Status_Len) As Byte
iMaxSockets As Integer
iMaxUdpDg As Integer
lpszVendorInfo As Long
End Type

Private Declare Function WSAGetLastError Lib "WSOCK32.DLL" () As Long
Private Declare Function WSAStartup Lib "WSOCK32.DLL" _
(ByVal wVersionRequired&, lpWSAData As WSADATA) As Long
Private Declare Function WSACleanup Lib "WSOCK32.DLL" () As Long
Private Declare Function gethostname Lib "WSOCK32.DLL" (ByVal hostname$, HostLen&) As Long
Private Declare Function gethostbyname Lib "WSOCK32.DLL" (ByVal hostname$) As Long

Private Declare Sub RtlMoveMemory Lib "KERNEL32" (hpvDest As Any, ByVal hpvSource&, ByVal cbCopy&)
Function hibyte(ByVal wParam As Integer)

hibyte = wParam \ &H100 And &HFF&

End Function

Function lobyte(ByVal wParam As Integer)

lobyte = wParam And &HFF&

End Function

Sub SocketsInitialize()
Dim WSAD As WSADATA
Dim iReturn As Integer
Dim sLowByte As String, sHighByte As String, sMsg As String

iReturn = WSAStartup(WS_VERSION_REQD, WSAD)

If iReturn <> 0 Then
MsgBox "Winsock.dll is not responding."
End
End If

If lobyte(WSAD.wversion) < WS_VERSION_MAJOR Or (lobyte(WSAD.wversion) = _
WS_VERSION_MAJOR And hibyte(WSAD.wversion) < WS_VERSION_MINOR) Then
sHighByte = Trim$(Str$(hibyte(WSAD.wversion)))
sLowByte = Trim$(Str$(lobyte(WSAD.wversion)))
sMsg = "Windows Sockets version " & sLowByte & "." & sHighByte
sMsg = sMsg & " is not supported by winsock.dll "
MsgBox sMsg
End
End If

If WSAD.iMaxSockets < MIN_SOCKETS_REQD Then
sMsg = "This application requires a minimum of "
sMsg = sMsg & Trim$(Str$(MIN_SOCKETS_REQD)) & " supported sockets."
MsgBox sMsg
End
End If

End Sub

Sub SocketsCleanup()
Dim lReturn As Long

lReturn = WSACleanup()

If lReturn <> 0 Then
MsgBox "Socket error " & Trim$(Str$(lReturn)) & " occurred in Cleanup """
End
End If

End Sub

Private Sub Command1_Click()
Dim hostname As String * 256
Dim hostent_addr As Long
Dim host As HOSTENT
Dim hostip_addr As Long
Dim temp_ip_address() As Byte
Dim i As Integer
Dim ip_address As String

If gethostname(hostname, 256) = SOCKET_ERROR Then
MsgBox "Windows Sockets error " & Str(WSAGetLastError())
Else
hostname = Trim$(hostname)
End If

hostent_addr = gethostbyname(hostname)

If hostent_addr = 0 Then
MsgBox "Winsock.dll is not responding."
End If

RtlMoveMemory host, hostent_addr, LenB(host)
RtlMoveMemory hostip_addr, host.hAddrList, 4

ReDim temp_ip_address(1 To host.hLength)
RtlMoveMemory temp_ip_address(1), hostip_addr, host.hLength

For i = 1 To host.hLength
ip_address = ip_address & temp_ip_address(i) & "."
Next
ip_address = Mid$(ip_address, 1, Len(ip_address) - 1)

MsgBox hostname
MsgBox ip_address

End Sub

Private Sub Form_Load()
SocketsInitialize
End Sub

Private Sub Form_Unload(Cancel As Integer)
SocketsCleanup
End Sub

# 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

# 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 Riguros 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)

# 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

# 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

# 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

# Verificarea sistemului de operare

Public Const VER_PLATFORM_WIN32s = 0
Public Const VER_PLATFORM_WIN32_WINDOWS = 1
Public Const VER_PLATFORM_WIN32_NT = 2

'windows-defined type OSVERSIONINFO
Public Type OSVERSIONINFO
OSVSize As Long 'size, in bytes, of this data structure
dwVerMajor As Long 'ie NT 3.51, dwVerMajor = 3; NT 4.0, dwVerMajor = 4.
dwVerMinor As Long 'ie NT 3.51, dwVerMinor = 51; NT 4.0, dwVerMinor= 0.
dwBuildNumber As Long 'NT: build number of the OS
'Win9x: build number of the OS in low-order word.
' High-order word contains major & minor ver nos.
PlatformID As Long 'Identifies the operating system platform.
szCSDVersion As String * 128 'NT: string, such as "Service Pack 3"
'Win9x: 'arbitrary additional information'
End Type

Public Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" _
(lpVersionInformation As OSVERSIONINFO) As Long

Public Function IsWin95() As Boolean
'returns True if running Win95
Dim OSV As OSVERSIONINFO
OSV.OSVSize = Len(OSV)
If GetVersionEx(OSV) = 1 Then
'PlatformId contains a value representing the OS.
'If VER_PLATFORM_WIN32_WINDOWS and
'dwVerMajor = 4, and dwVerMinor = 0,
'return true
IsWin95 = (OSV.PlatformID = VER_PLATFORM_WIN32_WINDOWS) And _
(OSV.dwVerMajor = 4 And OSV.dwVerMinor = 0)
End If
End Function

Public Function IsWin98() As Boolean
'returns True if running Win98
Dim OSV As OSVERSIONINFO
OSV.OSVSize = Len(OSV)
If GetVersionEx(OSV) = 1 Then
'PlatformId contains a value representing the OS.
'If VER_PLATFORM_WIN32_WINDOWS and
'dwVerMajor => 4, or dwVerMajor = 4 and
'dwVerMinor > 0, return true
IsWin98 = (OSV.PlatformID = VER_PLATFORM_WIN32_WINDOWS) And _
(OSV.dwVerMajor > 4) Or _
(OSV.dwVerMajor = 4 And OSV.dwVerMinor > 0)
End If
End Function

Public Function IsWinNT4() As Boolean
'returns True if running WinNT4
Dim OSV As OSVERSIONINFO
OSV.OSVSize = Len(OSV)
If GetVersionEx(OSV) = 1 Then
'PlatformId contains a value representing the OS.
'If VER_PLATFORM_WIN32_NT and dwVerMajor is 4, return true
IsWinNT4 = (OSV.PlatformID = VER_PLATFORM_WIN32_NT) And _
(OSV.dwVerMajor = 4)
End If
End Function

Public Function IsWinNT5() As Boolean
'returns True if running WinNT2000 (NT5)
Dim OSV As OSVERSIONINFO
OSV.OSVSize = Len(OSV)
If GetVersionEx(OSV) = 1 Then

'PlatformId contains a value representing the OS.
'If VER_PLATFORM_WIN32_NT and dwVerMajor is 5, return true
IsWinNT5 = (OSV.PlatformID = VER_PLATFORM_WIN32_NT) And _
(OSV.dwVerMajor = 5)
End If
End Function

# Obtinerea adresei placii de retea (Ethernet)

Private Const NCBASTAT = &H33
Private Const NCBNAMSZ = 16
Private Const HEAP_ZERO_MEMORY = &H8
Private Const HEAP_GENERATE_EXCEPTIONS = &H4
Private Const NCBRESET = &H32

Private Type NCB
ncb_command As Byte 'Integer
ncb_retcode As Byte 'Integer
ncb_lsn As Byte 'Integer
ncb_num As Byte ' Integer
ncb_buffer As Long 'String
ncb_length As Integer
ncb_callname As String * NCBNAMSZ
ncb_name As String * NCBNAMSZ
ncb_rto As Byte 'Integer
ncb_sto As Byte ' Integer
ncb_post As Long
ncb_lana_num As Byte 'Integer
ncb_cmd_cplt As Byte 'Integer
ncb_reserve(9) As Byte ' Reserved, must be 0
ncb_event As Long
End Type
Private Type ADAPTER_STATUS
adapter_address(5) As Byte 'As String * 6
rev_major As Byte 'Integer
reserved0 As Byte 'Integer
adapter_type As Byte 'Integer
rev_minor As Byte 'Integer
duration As Integer
frmr_recv As Integer
frmr_xmit As Integer
iframe_recv_err As Integer
xmit_aborts As Integer
xmit_success As Long
recv_success As Long
iframe_xmit_err As Integer
recv_buff_unavail As Integer
t1_timeouts As Integer
ti_timeouts As Integer
Reserved1 As Long
free_ncbs As Integer
max_cfg_ncbs As Integer
max_ncbs As Integer
xmit_buf_unavail As Integer
max_dgram_size As Integer
pending_sess As Integer
max_cfg_sess As Integer
max_sess As Integer
max_sess_pkt_size As Integer
name_count As Integer
End Type
Private Type NAME_BUFFER
name As String * NCBNAMSZ
name_num As Integer
name_flags As Integer
End Type
Private Type ASTAT
adapt As ADAPTER_STATUS
NameBuff(30) As NAME_BUFFER
End Type

Private Declare Function Netbios Lib "netapi32.dll" _
(pncb As NCB) As Byte
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(hpvDest As Any, ByVal hpvSource As Long, ByVal cbCopy As Long)
Private Declare Function GetProcessHeap Lib "kernel32" () As Long
Private Declare Function HeapAlloc Lib "kernel32" _
(ByVal hHeap As Long, ByVal dwFlags As Long, _
ByVal dwBytes As Long) As Long
Private Declare Function HeapFree Lib "kernel32" (ByVal hHeap As Long, _
ByVal dwFlags As Long, lpMem As Any) As Long

Private Function EthAddr(LanaNumber As Long) As String
Dim udtNCB As NCB
Dim bytResponse As Byte
Dim udtASTAT As ASTAT
Dim udtTempASTAT As ASTAT
Dim lngASTAT As Long
Dim strOut As String
Dim x As Integer
udtNCB.ncb_command = NCBRESET
bytResponse = Netbios(udtNCB)
udtNCB.ncb_command = NCBASTAT
udtNCB.ncb_lana_num = LanaNumber
udtNCB.ncb_callname = "* "
udtNCB.ncb_length = Len(udtASTAT)
lngASTAT = HeapAlloc(GetProcessHeap(), HEAP_GENERATE_EXCEPTIONS _
Or HEAP_ZERO_MEMORY, udtNCB.ncb_length)
strOut = ""
If lngASTAT Then
udtNCB.ncb_buffer = lngASTAT
bytResponse = Netbios(udtNCB)
CopyMemory udtASTAT, udtNCB.ncb_buffer, Len(udtASTAT)
With udtASTAT.adapt
For x = 0 To 5
strOut = strOut & Right$("00" & Hex$(.adapter_address(x)), 2)
Next x
End With
HeapFree GetProcessHeap(), 0, lngASTAT
End If
EthAddr = strOut
End Function

# 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

# 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

# Dispoziția (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

# 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

# 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

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

# 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

# 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

# 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

# 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

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

# 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

# Oprirea programului pentru un interval de timp

Pe lângã solutia cu Timer sau utilizarea functiei API Sleep se poate face astfel:

Private Sub Pause(interval) ' New sub
Current = Timer
Do While Timer - Current < Val(interval)
DoEvents
Loop
End Sub

# PC-ul are placa de sunet?

Private Declare Function waveOutGetNumDevs Lib "MMSYSTEM" () As Integer

i% = waveOutGetNumDevs()
If i% > 0 Then
MsgBox "You Can Play Wave Data"
Else
MsgBox "Cannot Play Wave Data"
End If

# Spatiu deschis pe HDD

Private Declare Function GetDiskFreeSpace Lib "kernel32" Alias "GetDiskFreeSpaceA" ( _
ByVal lpRootPathName As String, lpSectorsPerCluster As Long, lpBytesPerSector As Long, _
lpNumberOfFreeClusters As Long, lpTotalNumberOfClusters As Long) As Long

Dim free_Space As Long
ChDrive "C:"
Dim numSectorsPerCluster As Long
Dim numBytesPerSector As Long
Dim numFreeClusters As Long
Dim numTotalClusters As Long
Dim success As Boolean
success = GetDiskFreeSpace("C:\", numSectorsPerCluster, numBytesPerSector, _
numFreeClusters, numTotalClusters)
free_Space = numSectorsPerCluster * numBytesPerSector * numFreeClusters
Label1.Caption = "The plenar free space on Drive C: = " & _
format(Str$(free_Space/1024),"###,### ") & " KB"