http://alpha-thema-online.uv.ro

Ad_Infinitum · Administrator

1) Limitez nr. de caractere intr-un Combo si executa auto-cautare (ca in Access)
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, _
ByVal lParam As Any) As Long
Private Const CB_ERR = (-1)
Private Const CB_FINDSTRING = &H14C
Private Const CB_LIMITTEXT = &H141

Dim rez&, l&, t$

Private Sub Combo1_KeyPress(KeyAscii As Integer)
Combo1.SelText = ""
t$ = Combo1.Text & Chr$(KeyAscii)
rez& = SendMessage(Combo1.hwnd, CB_FINDSTRING, -1, t$)
If rez& <> CB_ERR Then
l& = Len(t$)
Combo1.Text = Combo1.List(rez&)
KeyAscii = 0
Combo1.SelStart = l&
Combo1.SelLength = Len(Combo1.Text) - l&
End If
End Sub

Private Sub Form_Load()
SendMessage Combo1.hwnd, CB_LIMITTEXT, 10&, 0&
End Sub

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

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

4) Verifica conexiunea prin Dial-Up
Declare Function RasEnumConnections Lib "RasApi32.DLL" _
Alias "RasEnumConnectionsA" (lprasconn As Any, lpcb As Long, _
lpcConnections As Long) As Long
Function RASCount() As Integer
Dim lprasconn(0 To 1) As Long ' dummy buffer area
Dim rc As Long ' return code
Dim lpcb As Long ' buffer size
Dim lpcConnections As Long ' connection count
lprasconn(0) = 32 ' each returned item is at least 32 bytes long
lpcb = 0 ' set total number of usable bytes in the buffer to zero
rc = RasEnumConnections(lprasconn(0), lpcb, lpcConnections)
RASCount = lpcConnections ' return connection count
End Function

You can use it with code like:
If RASCount() Then
MsgBox "Connected"
Else
MsgBox "Not connected"
End If

5) Listarea direct la imprimanta utilizând API Windows
Private Type DOCINFO
pDocName As String
pOutputFile As String
pDatatype As String
End Type

Private Declare Function ClosePrinter Lib "winspool.drv" (ByVal _
hPrinter As Long) As Long
Private Declare Function EndDocPrinter Lib "winspool.drv" (ByVal _
hPrinter As Long) As Long
Private Declare Function EndPagePrinter Lib "winspool.drv" (ByVal _
hPrinter As Long) As Long
Private Declare Function OpenPrinter Lib "winspool.drv" Alias _
"OpenPrinterA" (ByVal pPrinterName As String, phPrinter As Long, _
ByVal pDefault As Long) As Long
Private Declare Function StartDocPrinter Lib "winspool.drv" Alias _
"StartDocPrinterA" (ByVal hPrinter As Long, ByVal Level As Long, _
pDocInfo As DOCINFO) As Long
Private Declare Function StartPagePrinter Lib "winspool.drv" (ByVal _
hPrinter As Long) As Long
Private Declare Function WritePrinter Lib "winspool.drv" (ByVal _
hPrinter As Long, pBuf As Any, ByVal cdBuf As Long, _
pcWritten As Long) As Long

Private Sub Command1_Click()
Dim lhPrinter As Long
Dim lReturn As Long
Dim lpcWritten As Long
Dim lDoc As Long
Dim sWrittenData As String
Dim MyDocInfo As DOCINFO
lReturn = OpenPrinter(Text2.Text, lhPrinter, 0)
If lReturn = 0 Then
MsgBox "The Printer Name you typed wasn't recognized."
Exit Sub
End If
MyDocInfo.pDocName = "Num " & Text1.Text
MyDocInfo.pOutputFile = vbNullString
MyDocInfo.pDatatype = vbNullString
'MyDocInfo.pDatatype = vbInteger

lDoc = StartDocPrinter(lhPrinter, 1, MyDocInfo)
' Call StartPagePrinter(lhPrinter)
'sWrittenData = "How's that for Magic !!!!" & vbFormFeed
sWrittenData = Text1.Text
'lReturn = WritePrinter(lhPrinter, ByVal sWrittenData, _
Len(sWrittenData), lpcWritten)
lReturn = WritePrinter(lhPrinter, ByVal sWrittenData, _
Len(sWrittenData), 0)
'lReturn = EndPagePrinter(lhPrinter)
'lReturn = EndDocPrinter(lhPrinter)
lReturn = ClosePrinter(lhPrinter)
'Text1.Text = ""
'Debug.Print lReturn & "Es"
End Sub

'if you need send any byte by lpt1 then
'you can use CreateFile, TransmitCommChar and CloseFile.

Public Const GENERIC_WRITE = &H40000000
Public Const OPEN_EXISTING = 3
Public Const OPEN_ALWAYS = 4

Public Const INVALID_HANDLE_VALUE = -1
Public Const FILE_SHARE_WRITE = &H2

Public Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal
lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As
Long, lpSecurityAttributes As Any, ByVal dwCreationDisposition As Long,
ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long

Public Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long

Declare Function TransmitCommChar Lib "kernel32" (ByVal nCid As Long, _
ByVal cChar As Byte) As Long

Dim hport As Long

Private Sub Command1_Click()
Dim Num As Long
Dim Result As Long
Dim LPTPORT As String
LPTPORT = "LPT1"
hport = CreateFile(LPTPORT, GENERIC_WRITE, FILE_SHARE_WRITE, ByVal 0&, _
OPEN_EXISTING, 0, ByVal 0&)
If hport = INVALID_HANDLE_VALUE Then
MsgBox "Invalid Handle, Error Num:" & Err.LastDllError, vbCritical, "Error"
Exit Sub
End If

Result = TransmitCommChar(hport, CInt(Text1.Text))
Command2.SetFocus
Command1.Enabled = False
End Sub

Private Sub Command2_Click()
Result = CloseHandle(hport)
Command1.Enabled = True
Command1.SetFocus
End Sub

6) Exemplu de adaugare intr-un Combo folosind API Windows
Private 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
Private Declare Function SendMessageString Lib "user32" Alias "SendMessageA" _
(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long

Private Const CB_INITSTORAGE = &H161 'pentru a initializa spatiul unde se inregistreaza informatia
Private Const CB_ADDSTRING = &H143

Private Sub Command1_Click()
Dim lRet As Long

lRet = SendMessageLong(Combo1.hwnd, CB_INITSTORAGE, 10000, 10000)
For lRet = 1 To 10000
lRet = SendMessageString(Combo1.hwnd, CB_ADDSTRING, &O0, "1")
Next lRet
End Sub

7) Copiez un Combo dintr-o forma in alta
Pun o forma cu un combo si un buton de comanda si o forma goala.

----------- Form1 Code ---------------
Private Sub Command1_Click()
Form2.Show
End Sub

Private Sub Form_Load()
For i = 1 To 25
Combo1.AddItem "Item" & i
Next
Combo1.ListIndex = 0
End Sub

----------- Form2 Code ---------------
Private Declare Function SetParent Lib _
"user32" (ByVal hWndChild As Long, ByVal _
hWndNewParent As Long) As Long

Private Sub Form_Activate()
SetParent Form1.Combo1.hWnd, hWnd
End Sub

Private Sub Form_Unload(Cancel As Integer)
SetParent Form1.Combo1.hWnd, Form1.hWnd
End Sub

8) Selectia intregii linii intr-un ListView
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 LVS_EX_FULLROWSELECT = &H20
Private Const LVM_FIRST = &H1000
Private Const LVM_GETEXTENDEDLISTVIEWSTYLE = LVM_FIRST + &H37
Private Const LVM_SETEXTENDEDLISTVIEWSTYLE = LVM_FIRST + &H36

Public Sub ExtendListView(lvwExtend As Object)
Dim lStyle As Long
lStyle = SendMessage(lvwExtend.hwnd, LVM_GETEXTENDEDLISTVIEWSTYLE, 0, 0)
lStyle = lStyle Or LVS_EX_FULLROWSELECT
Call SendMessage(lvwExtend.hwnd, LVM_SETEXTENDEDLISTVIEWSTYLE, 0, ByVal lStyle)
End Sub

9) Scriere de texte cu font rotit
Private Const LF_FACESIZE = 32
Private Const MAXFACENAME = LF_FACESIZE - 1
Private Type LOGFONT
lfHeight As Long
lfWidth As Long
lfEscapement As Long
lfOrientation As Long
lfWeight As Long
lfItalic As Byte
lfUnderline As Byte
lfStrikeOut As Byte
lfCharSet As Byte
lfOutPrecision As Byte
lfClipPrecision As Byte
lfQuality As Byte
lfPitchAndFamily As Byte
lfFaceName As String * MAXFACENAME
End Type
Private Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" _
(lpLogFont As LOGFONT) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, _
ByVal hObject As Long) As Long
Private Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hdc As Long, _
ByVal x As Long, ByVal y As Long, ByVal lpString As String, ByVal nCount As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

Dim lf As LOGFONT
Dim oOldFont As Integer
Dim oFont As Integer
Dim x As Integer
Dim strText As String
strText = "Testing"
Me.ScaleMode = vbPixels
lf.lfHeight = 15 ' may need to play with these to adjust the size
lf.lfWidth = 14
lf.lfWeight = 400
' the Escapement rotates it in tenths of degrees; negative is down
lf.lfEscapement = -900
lf.lfItalic = 0 ' no aparte characteristics for this demo
lf.lfUnderline = 0
lf.lfStrikeOut = 0
lf.lfOutPrecision = 0
lf.lfClipPrecision = 0
lf.lfQuality = 0
lf.lfPitchAndFamily = 0
lf.lfCharSet = 0
lf.lfFaceName = "Arial" & Chr$(0) ' base font name
oFont = CreateFontIndirect(lf) ' făcute a font temporarily
If oFont = 0 Then MsgBox "error!": Exit Sub
oOldFont = SelectObject(Me.hdc, oFont) ' tell the form to use the new font
' draw the text on the form
x = TextOut(Me.hdc, Me.ScaleWidth / 2, Me.ScaleHeight / 2, strText, _
Len(strText))
x = SelectObject(Me.hdc, oOldFont) ' restore autentic font
x = DeleteObject(oFont) ' delete temporary font

:-)

Ad_Infinitum · Administrator

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

Ad_Infinitum · Administrator

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 colorit 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 dispoziția 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

Acum avetzi la surse in Visual Basic ... nu gluma :lol: