Các chiêu thức trong lập trình Liệt kê danh sách các thành phần phần cứng trong máyhome

Liệt kê danh sách các thành phần phần cứng trong máy home
Xuất xứ : www.ttvnol.com
Binh khí sử dụng : Không
Đoạn mã :
Dim Ports(0 To 100) As PORT_INFO_2
Const KT_TYPE = 0
Const PRINTER_ENUM_LOCAL = &H2
Private Type PRINTER_INFO_1
flags As Long
pDescription As String
pName As String
pComment As String
End Type
Private Type DISPLAY_DEVICE
cb As Long
DeviceName As String * 32
DeviceString As String * 128
StateFlags As Long
DeviceID As String * 128
DeviceKey As String * 128
End Type
Private Declare Sub GetSystemInfo Lib "kernel32" (lpSystemInfo As
SYSTEM_INFO)
Private Type SYSTEM_INFO
dwOemID As Long
dwPageSize As Long
lpMinimumApplicationAddress As Long
lpMaximumApplicationAddress As Long
dwActiveProcessorMask As Long
dwNumberOrfProcessors As Long
dwProcessorType As Long

dwAllocationGranularity As Long
dwReserved As Long
End Type
Private Type PORT_INFO_2
pPortName As String
pMonitorName As String
pDescription As String
fPortType As Long
Reserved As Long
End Type
Private Type API_PORT_INFO_2
pPortName As Long
pMonitorName As Long
pDescription As Long
fPortType As Long
Reserved As Long
End Type
Const MAX_HOSTNAME_LEN = 132
Const MAX_DOMAIN_NAME_LEN = 132
Const MAX_SCOPE_ID_LEN = 260
Const MAX_ADAPTER_NAME_LENGTH = 260
Const MAX_ADAPTER_ADDRESS_LENGTH = 8
Const MAX_ADAPTER_DESCRIPTION_LENGTH = 132
Const ERROR_BUFFER_OVERFLOW = 111
Const MIB_IF_TYPE_ETHERNET = 1
Const MIB_IF_TYPE_TOKENRING = 2
Const MIB_IF_TYPE_FDDI = 3
Const MIB_IF_TYPE_PPP = 4
Const MIB_IF_TYPE_LOOPBACK = 5
Const MIB_IF_TYPE_SLIP = 6

Private Type IP_ADDR_STRING
Next As Long
IpAddress As String * 16
IpMask As String * 16
Context As Long
End Type
Private Type IP_ADAPTER_INFO
Next As Long
ComboIndex As Long
AdapterName As String * MAX_ADAPTER_NAME_LENGTH
Description As String * MAX_ADAPTER_DESCRIPTION_LENGTH
AddressLength As Long
Address(MAX_ADAPTER_ADDRESS_LENGTH - 1) As Byte
Index As Long
Type As Long
DhcpEnabled As Long
CurrentIpAddress As Long
IpAddressList As IP_ADDR_STRING
GatewayList As IP_ADDR_STRING
DhcpServer As IP_ADDR_STRING
HaveWins As Boolean
PrimaryWinsServer As IP_ADDR_STRING
SecondaryWinsServer As IP_ADDR_STRING
LeaseObtained As Long
LeaseExpires As Long
End Type
Private Type FIXED_INFO
HostName As String * MAX_HOSTNAME_LEN
DomainName As String * MAX_DOMAIN_NAME_LEN
CurrentDnsServer As Long

DnsServerList As IP_ADDR_STRING
NodeType As Long
ScopeId As String * MAX_SCOPE_ID_LEN
EnableRouting As Long
EnableProxy As Long
EnableDns As Long
End Type
Private Declare Function GetNetworkParams Lib "IPHlpApi" (FixedInfo As Any,
pOutBufLen As Long) As Long
Private Declare Function GetAdaptersInfo Lib "IPHlpApi" (IpAdapterInfo As
Any, pOutBufLen As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory"
(Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function EnumPorts Lib "winspool.drv" Alias "EnumPortsA"
(ByVal pName As String, ByVal Level As Long, ByVal lpbPorts As Long, ByVal
cbBuf As Long, pcbNeeded As Long, pcReturned As Long) As Long
Private Declare Function lstrlenW Lib "kernel32" (ByVal lpString As Long)
As Long
Private Declare Sub CopyMem Lib "kernel32" Alias "RtlMoveMemory" (pTo As
Any, uFrom As Any, ByVal lSize 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 GetProcessHeap Lib "kernel32" () As Long
Private Declare Function HeapFree Lib "kernel32" (ByVal hHeap As Long,
ByVal dwFlags As Long, lpMem As Any) As Long
Private Declare Function EnumDisplayDevices Lib "user32" Alias
"EnumDisplayDevicesA" (Unused As Any, ByVal iDevNum As Long,
lpDisplayDevice As DISPLAY_DEVICE, ByVal dwFlags As Long) As Boolean
Private Declare Function EnumPrinters Lib "winspool.drv" Alias
"EnumPrintersA" (ByVal flags As Long, ByVal name As String, ByVal Level As

Long, pPrinterEnum As Long, ByVal cdBuf As Long, pcbNeeded As Long,
pcReturned As Long) As Long
Private Declare Function lstrcpy Lib "kernel32.dll" Alias "lstrcpyA" (ByVal
lpString1 As String, ByVal lpString2 As Long) As Long
Private Declare Function lstrlen Lib "kernel32.dll" Alias "lstrlenA" (ByVal
lpString As Long) As Long
Private Declare Function GetKeyboardType Lib "user32" (ByVal nTypeFlag As
Long) As Long
'*********************************************************************'Liệt
kê tên của Card Màn hình
Private Sub Ten_Card_ManHinh()
Dim DD As DISPLAY_DEVICE
DD.cb = Len(DD)
If EnumDisplayDevices(ByVal 0&, 0, DD, ByVal 0&) Then
Me.Print "Tên của card màn hình : " + Left$(DD.DeviceString, InStr(1,
DD.DeviceString, Chr$(0)) - 1)
Else
Me.Print "Không thấy card màn hình"
End If
End Sub
'*********************************************************************'LIệt
kê danh sách tên máy in
Private Sub Ten_Cac_May_In()
Dim longbuffer() As Long
Dim printinfo() As PRINTER_INFO_1
Dim numbytes As Long
Dim numneeded As Long
Dim numprinters As Long
Dim c As Integer, retval As Long
numbytes = 3076

ReDim longbuffer(0 To numbytes / 4) As Long
retval = EnumPrinters(PRINTER_ENUM_LOCAL, "", 1, longbuffer(0), numbytes,
numneeded, numprinters)
If retval = 0 Then
numbytes = numneeded
ReDim longbuffer(0 To numbytes / 4) As Long
retval = EnumPrinters(PRINTER_ENUM_LOCAL, "", 1, longbuffer(0), numbytes,
numneeded, numprinters)
If retval = 0 Then
Debug.Print "Could not successfully enumerate the printes."
End
End If
End If
If numprinters <> 0 Then ReDim printinfo(0 To numprinters - 1) As
PRINTER_INFO_1
For c = 0 To numprinters - 1
printinfo(c).flags = longbuffer(4 * c)
printinfo(c).pDescription = Space(lstrlen(longbuffer(4 * c + 1)))
retval = lstrcpy(printinfo(c).pDescription, longbuffer(4 * c + 1))
printinfo(c).pName = Space(lstrlen(longbuffer(4 * c + 2)))
retval = lstrcpy(printinfo(c).pName, longbuffer(4 * c + 2))
printinfo(c).pComment = Space(lstrlen(longbuffer(4 * c + 3)))
retval = lstrcpy(printinfo(c).pComment, longbuffer(4 * c + 3))
Next c
For c = 0 To numprinters - 1
Me.Print "Tên của máy in thứ "; c + 1; " là : "; printinfo(c).pName
Next c
End Sub
'*********************************************************************'Hàm
dùng để kiểu bàn phím

Private Sub Ban_Phim()
Select Case GetKeyboardType(KT_TYPE)
Case 1
Me.Print "Keyboard type: IBM PC/XT or compatible (83-key) keyboard"
Case 2
Me.Print "Keyboard type: Olivetti “ICO” (102-key) keyboard"
Case 3
Me.Print "Keyboard type: IBM PC/AT (84-key) or similar keyboard"
Case 4
Me.Print "Keyboard type: IBM enhanced (101- or 102-key) keyboard"
Case 5
Me.Print "Keyboard type: Nokia 1050 and similar keyboards"
Case 6
Me.Print "Keyboard type: Nokia 9140 and similar keyboards"
Case 7
Me.Print "Keyboard type: Japanese keyboard"
Case Else
Me.Print "Keyboard type: Unknown"
End Select
End Sub
'*********************************************************************
'Hàm lấy số serial và hiệu của CPU
Private Sub Lay_CPU()
Dim SInfo As SYSTEM_INFO
GetSystemInfo SInfo
Me.Print "số lượng CPU : " + Str$(SInfo.dwNumberOrfProcessors)
Me.Print "Đời CPU : " + Str$(SInfo.dwProcessorType)
Me.Print "Đòa chỉ bộ nhớ dưới : " + Str$
(SInfo.lpMinimumApplicationAddress)
Me.Print "Đòa chỉ bộ nhớ trên : " + Str$

(SInfo.lpMaximumApplicationAddress)
End Sub
'*********************************************************************'Danh
sách các Ports trong máy
Public Function TrimStr(strName As String) As String
Dim x As Integer
x = InStr(strName, vbNullChar)
If x > 0 Then TrimStr = Left(strName, x - 1) Else TrimStr = strName
End Function
Public Function LPSTRtoSTRING(ByVal lngPointer As Long) As String
Dim lngLength As Long
lngLength = lstrlenW(lngPointer) * 2
LPSTRtoSTRING = String(lngLength, 0)
CopyMem ByVal StrPtr(LPSTRtoSTRING), ByVal lngPointer, lngLength
LPSTRtoSTRING = TrimStr(StrConv(LPSTRtoSTRING, vbUnicode))
End Function
Public Function GetAvailablePorts(ServerName As String) As Long
Dim ret As Long
Dim PortsStruct(0 To 100) As API_PORT_INFO_2
Dim pcbNeeded As Long
Dim pcReturned As Long
Dim TempBuff As Long
Dim i As Integer
ret = EnumPorts(ServerName, 2, TempBuff, 0, pcbNeeded, pcReturned)
TempBuff = HeapAlloc(GetProcessHeap(), 0, pcbNeeded)
ret = EnumPorts(ServerName, 2, TempBuff, pcbNeeded, pcbNeeded, pcReturned)
If ret Then
CopyMem PortsStruct(0), ByVal TempBuff, pcbNeeded
For i = 0 To pcReturned - 1
Ports(i).pDescription = LPSTRtoSTRING(PortsStruct(i).pDescription)

Ports(i).pPortName = LPSTRtoSTRING(PortsStruct(i).pPortName)
Ports(i).pMonitorName = LPSTRtoSTRING(PortsStruct(i).pMonitorName)
Ports(i).fPortType = PortsStruct(i).fPortType
Next
End If
GetAvailablePorts = pcReturned
If TempBuff Then HeapFree GetProcessHeap(), 0, TempBuff
End Function
Private Sub Lay_Ports()
Dim NumPorts As Long
Dim i As Integer
NumPorts = GetAvailablePorts("")
Me.Print "Daùnh saùch caùc Port hieän taïi"
For i = 0 To NumPorts - 1
Me.Print Ports(i).pPortName
Next
End Sub
'*********************************************************************'Thôn
gt tin về tình trạng mạng và thông số card mạng
Private Sub Lay_Adepter()
Dim error As Long
Dim FixedInfoSize As Long
Dim AdapterInfoSize As Long
Dim i As Integer
Dim PhysicalAddress As String
Dim NewTime As Date
Dim AdapterInfo As IP_ADAPTER_INFO
Dim Adapt As IP_ADAPTER_INFO
Dim AddrStr As IP_ADDR_STRING
Dim FixedInfo As FIXED_INFO

Dim Buffer As IP_ADDR_STRING
Dim pAddrStr As Long
Dim pAdapt As Long
Dim Buffer2 As IP_ADAPTER_INFO
Dim FixedInfoBuffer() As Byte
Dim AdapterInfoBuffer() As Byte
FixedInfoSize = 0
error = GetNetworkParams(ByVal 0&, FixedInfoSize)
If error <> 0 Then
If error <> ERROR_BUFFER_OVERFLOW Then
Me.Print "GetNetworkParams sizing failed with error " & error
Exit Sub
End If
End If
ReDim FixedInfoBuffer(FixedInfoSize - 1)
error = GetNetworkParams(FixedInfoBuffer(0), FixedInfoSize)
If error = 0 Then
CopyMemory FixedInfo, FixedInfoBuffer(0), Len(FixedInfo)
Me.Print "Host Name: " & FixedInfo.HostName 'host name
Me.Print "DNS Servers: " & FixedInfo.DnsServerList.IpAddress 'dns server IP
pAddrStr = FixedInfo.DnsServerList.Next
Do While pAddrStr <> 0
CopyMemory Buffer, ByVal pAddrStr, Len(Buffer)
Me.Print "DNS Servers: " & Buffer.IpAddress 'dns server IP
pAddrStr = Buffer.Next
Loop
Select Case FixedInfo.NodeType 'node type
Case 1
Me.Print "Node type: Broadcast"
Case 2

Me.Print "Node type: Peer to peer"