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" Case 4 Me.Print "Node type: Mixed" Case 8 Me.Print "Node type: Hybrid" Case Else Me.Print "Unknown node type" End Select Me.Print "NetBIOS Scope ID: " & FixedInfo.ScopeId 'scope ID 'routing If FixedInfo.EnableRouting Then Me.Print "IP Routing Enabled " Else Me.Print "IP Routing not enabled" End If ' proxy If FixedInfo.EnableProxy Then Me.Print "WINS Proxy Enabled " Else Me.Print "WINS Proxy not Enabled " End If ' netbios If FixedInfo.EnableDns Then Me.Print "NetBIOS Resolution Uses DNS " Else Me.Print "NetBIOS Resolution Does not use DNS " End If Else Me.Print "GetNetworkParams failed with error " & error Exit Sub End If AdapterInfoSize = 0 error = GetAdaptersInfo(ByVal 0&, AdapterInfoSize) If error <> 0 Then If error <> ERROR_BUFFER_OVERFLOW Then Me.Print "GetAdaptersInfo sizing failed with error " & error Exit Sub End If End If ReDim AdapterInfoBuffer(AdapterInfoSize - 1) error = GetAdaptersInfo(AdapterInfoBuffer(0), AdapterInfoSize) If error <> 0 Then Me.Print "GetAdaptersInfo failed with error " & error Exit Sub End If CopyMemory AdapterInfo, AdapterInfoBuffer(0), Len(AdapterInfo) pAdapt = AdapterInfo.Next Do While pAdapt <> 0 CopyMemory Buffer2, AdapterInfo, Len(Buffer2) Select Case Buffer2.Type Case MIB_IF_TYPE_ETHERNET Me.Print "Ethernet adapter " Case MIB_IF_TYPE_TOKENRING Me.Print "Token Ring adapter " Case MIB_IF_TYPE_FDDI Me.Print "FDDI adapter " Case MIB_IF_TYPE_PPP Me.Print "PPP adapter" Case MIB_IF_TYPE_LOOPBACK Me.Print "Loopback adapter " Case MIB_IF_TYPE_SLIP Me.Print "Slip adapter " Case Else Me.Print "Other adapter " End Select Me.Print " AdapterName: " & Buffer2.AdapterName Me.Print "AdapterDescription: " & Buffer2.Description 'adatpter name For i = 0 To Buffer2.AddressLength - 1 PhysicalAddress = PhysicalAddress & Hex(Buffer2.Address(i)) If i < Buffer2.AddressLength - 1 Then PhysicalAddress = PhysicalAddress & "-" End If Next Me.Print "Physical Address: " & PhysicalAddress 'mac address If Buffer2.DhcpEnabled Then Me.Print "DHCP Enabled " Else Me.Print "DHCP disabled" End If pAddrStr = Buffer2.IpAddressList.Next Do While pAddrStr <> 0 CopyMemory Buffer, Buffer2.IpAddressList, LenB(Buffer) Me.Print "IP Address: " & Buffer.IpAddress Me.Print "Subnet Mask: " & Buffer.IpMask pAddrStr = Buffer.Next If pAddrStr <> 0 Then CopyMemory Buffer2.IpAddressList, ByVal pAddrStr, Len(Buffer2.IpAddressList) End If Loop Me.Print "Default Gateway: " & Buffer2.GatewayList.IpAddress pAddrStr = Buffer2.GatewayList.Next Do While pAddrStr <> 0 CopyMemory Buffer, Buffer2.GatewayList, Len(Buffer) Me.Print "IP Address: " & Buffer.IpAddress pAddrStr = Buffer.Next If pAddrStr <> 0 Then CopyMemory Buffer2.GatewayList, ByVal pAddrStr, Len(Buffer2.GatewayList) End If Loop Me.Print "DHCP Server: " & Buffer2.DhcpServer.IpAddress Me.Print "Primary WINS Server: " & Buffer2.PrimaryWinsServer.IpAddress Me.Print "Secondary WINS Server: " & Buffer2.SecondaryWinsServer.IpAddress NewTime = CDate(Adapt.LeaseObtained) Me.Print "Lease Obtained: " & CStr(NewTime) NewTime = CDate(Adapt.LeaseExpires) Me.Print "Lease Expires : " & CStr(NewTime) pAdapt = Buffer2.Next If pAdapt <> 0 Then CopyMemory AdapterInfo, ByVal pAdapt, Len(AdapterInfo) End If Loop End Sub Private Sub Form_Load() Me.Font = "VNI-Palatin" Me.AutoRedraw = True Ten_Card_ManHinh Ten_Cac_May_In Ban_Phim Lay_CPU Lay_Ports Lay_Adepter End Sub . 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. '*********************************************************************&apos ;LIệt kê danh sách tên máy in Private Sub Ten_Cac_May_In() Dim longbuffer() As Long