• Vui lòng đọc nội qui diễn đàn để tránh bị xóa bài viết
  • Tìm kiếm trước khi đặt câu hỏi

Lấy thông tin hardware

Các thủ thuật về hệ thống, thư mục, tập tin và mạng
dactung93
Thành viên tâm huyết
Thành viên tâm huyết
Posts: 496
Joined: Tue 04/11/2008 8:43 am
Has thanked: 6 times
Been thanked: 8 times

Lấy thông tin hardware

Postby dactung93 » Wed 24/02/2010 3:17 pm

Thủ thuật:
Tác giả: Sưu tầm từ nhiều nguồn + Edit
Mô tả: Cái này giúp ta có thể kiểm tra được các thiết bị phần cứng của máy như
+ Garsas
+ Video
+ Network
+ Keyboard
+ Mouse
+ Disk
+ CD-Rom
+SCSI
+ Processer
+ Memory
+ Flopyy
+ Modem
+ Infrared
+ FCMCID
+ Tape
+ Battery ( Dùng cho máy tính sách tay )


From chính gồm 1 button, 1 textbox đặt tên là txtHW ( Hoặc bạn thay đổi tùy ý cũng được )

Đầu tiên ta tạo một module khai báo như sau
  1. 'Hardware scanner
  2. '================
  3. Public isClient As Boolean
  4. Public isClienta As Boolean
  5. Public strUserName As String
  6. Public strPassword As String
  7. Public klientoID As Integer
  8. Public webUserName As String
  9. Public webPassword As String
  10. Public oDeviceType() As Variant
  11. Public oDeviceCaption() As Variant
  12. Public oDeviceParam() As Variant
  13. Public oDeviceInterf() As Variant
  14. Public eilute As Integer
  15. Public isHardware As Boolean
  16.  
  17.  


Quay trở lại From chính.
Khai báo trong from

[vb]'Hardware scanner
Dim DeviceFound() As Variant
Dim DeviceList() As Variant
Dim DeviCecount As Integer
Dim ramas As Variant
Dim ramotipas As Variant
Dim PelesInt() As Variant
Dim PelesTipas() As Variant
Dim objWshNet, DeviceListLen, strServer, objService, isconnect, objDeviceSet, Device[/vb]

Chúng ta có 3 hàm để thực hiện các công việc

[vb]
Public Sub scanhard()
On Error GoTo doctor
Dim DeviceListLen As String
eilute = 0
'MSFlexGrid1
ReDim Preserve DeviceList(40)
ReDim Preserve DeviceFound(40)
DeviceListLen = 16
DeviceList = Array("Win32_FloppyDrive", "Win32_DiskDrive", "Win32_CDROMDrive", _
"Win32_Processor", _
"Win32_PhysicalMemory", _
"Win32_SoundDevice", "Win32_SCSIController", "Win32_VideoController", _
"Win32_Keyboard", _
"Win32_PointingDevice", _
"Win32_NetworkAdapter", "Win32_POTSModem", _
"Win32_InfraredDevice", _
"Win32_PCMCIAController", _
"Win32_TapeDrive", _
"Win32_PortableBattery")


strServer = txtUname
isconnect = ConnectTO("root\cimv2", _
strUserName, _
strPassword, _
strServer, _
objService)
If Not isconnect Then
MsgBox "Please check the server name, " _
& "credentials and WBEM Core.", vbCritical,

End If
DeviCecount = 0
For i = 0 To DeviceListLen - 1
Set objDeviceSet = objService.InstancesOf(DeviceList(i))
If objDeviceSet.Count <> 0 Then
DeviceFound(DeviCecount) = DeviceList(i)
DeviCecount = DeviCecount + 1
Call GetSndDevInfo(objService, DeviceList(i))
'MsgBox MSFlexGrid1.Rows
End If
Next
Exit Sub
doctor:
MsgBox "Failed to access hardware information. Operation terminated.", vbCritical,
End Sub[/vb]

[vb]
'================
Private Sub GetSndDevInfo(objService, strWBEMClass)

On Error Resume Next

ReDim Preserve oDeviceType(100)
ReDim Preserve oDeviceCaption(100)
ReDim Preserve oDeviceParam(100)
ReDim Preserve oDeviceInterf(100)

Set objDeviceSet = objService.InstancesOf(strWBEMClass)
'MsgBox strWBEMClass
If objDeviceSet.Count <> 0 Then
For Each Device In objDeviceSet

Select Case strWBEMClass
' ----------------------------------
Case "Win32_SoundDevice"
txtHW.Text = txtHW.Text & "Sound device:" & vbCrLf & Device.Caption & vbCrLf & vbCrLf
oDeviceType(eilute) = "Sound device"
oDeviceCaption(eilute) = Device.Caption
oDeviceParam(eilute) = ""
oDeviceInterf(eilute) = ""
eilute = eilute + 1
' -----------------------------------
Case "Win32_VideoController"
txtHW.Text = txtHW.Text & "Video controller:" & vbCrLf & Device.Caption & vbCrLf & "Memory: " & Device.AdapterRAM / 1048576 & " MB" & vbCrLf & vbCrLf
oDeviceType(eilute) = "Video controller"
oDeviceCaption(eilute) = Device.Caption
oDeviceParam(eilute) = Device.AdapterRAM / 1048576
oDeviceInterf(eilute) = ""
eilute = eilute + 1
'----------------------------------
Case "Win32_NetworkAdapter"
If (Device.NetConnectionID = "Local Area Connection") And (Device.MACAddress <> "") Then
txtHW.Text = txtHW.Text & "Network adapter:" & vbCrLf & Device.Caption & vbCrLf & Device.MACAddress & vbCrLf
oDeviceType(eilute) = "Network adapter"
oDeviceCaption(eilute) = Device.Caption
oDeviceParam(eilute) = Device.MACAddress
oDeviceInterf(eilute) = ""
eilute = eilute + 1
End If
' ---------------------------------
Case "Win32_Keyboard"
txtHW.Text = txtHW.Text & "Keyboard:" & vbCrLf & Device.Description & vbCrLf & vbCrLf
oDeviceType(eilute) = "Keyboard"
oDeviceCaption(eilute) = Device.Description
oDeviceParam(eilute) = ""
oDeviceInterf(eilute) = ""
eilute = eilute + 1
' ---------------------------------
Case "Win32_PointingDevice"
txtHW.Text = txtHW.Text & "Pointing device/mouse:" & vbCrLf & Device.Caption & vbCrLf & PelesTipas(Device.PointingType) & vbCrLf & "Interface: " & PelesInt(Device.DeviceInterface) & vbCrLf & vbCrLf
oDeviceType(eilute) = "Pointing device/mouse:"
oDeviceCaption(eilute) = Device.Caption
oDeviceParam(eilute) = PelesTipas(Device.PointingType)
oDeviceInterf(eilute) = PelesInt(Device.DeviceInterface)
eilute = eilute + 1
' ----------------------------------
Case "Win32_DiskDrive"
txtHW.Text = txtHW.Text & "Harddisk:" & vbCrLf & Device.Description & vbCrLf & Device.Caption & vbCrLf & "Capacity: " & Device.Size / 1000000000 & " GB" & vbCrLf & "Interface: " & Device.InterfaceType & vbCrLf & vbCrLf
oDeviceType(eilute) = Device.Description
oDeviceCaption(eilute) = Device.Caption
oDeviceParam(eilute) = Device.Size
oDeviceInterf(eilute) = Device.InterfaceType
eilute = eilute + 1
' --------------------------------------
Case "Win32_CDROMDrive"
txtHW.Text = txtHW.Text & "CD ROM:" & vbCrLf & Device.Description & vbCrLf & "Drive letter: " & Device.Caption & vbCrLf & "Capacity: " & Device.Size / 1048576 & " MB" & vbCrLf & vbCrLf
oDeviceType(eilute) = Device.Description
oDeviceCaption(eilute) = Device.Caption
oDeviceParam(eilute) = Device.Size
oDeviceInterf(eilute) = ""
eilute = eilute + 1
'------------------------------------------
Case "Win32_SCSIController"
txtHW.Text = txtHW.Text & "SCSI controller:" & vbCrLf & Device.Caption & vbCrLf & vbCrLf
oDeviceType(eilute) = "SCSI Controller"
oDeviceCaption(eilute) = Device.Caption
oDeviceParam(eilute) = ""
oDeviceInterf(eilute) = ""
eilute = eilute + 1
' -------------------------------------
Case "Win32_Processor"
txtHW.Text = txtHW.Text & "Processor/" & Device.Role & ":" & vbCrLf & Device.Name & vbCrLf & "Clock speed: " & Device.CurrentClockSpeed & vbCrLf & vbCrLf
oDeviceType(eilute) = Device.Role
oDeviceCaption(eilute) = Device.Name
oDeviceParam(eilute) = Device.CurrentClockSpeed
oDeviceInterf(eilute) = ""
eilute = eilute + 1
' -----------------------------------------
Case "Win32_PhysicalMemory"
txtHW.Text = txtHW.Text & Device.Description & ":" & vbCrLf & "Formfactor: " & ramas(Device.FormFactor) & vbCrLf & "Capacity: " & Device.Capacity / 1048576 & " MB" & vbCrLf & "Memory type: " & ramotipas(Device.MemoryType) & vbCrLf & vbCrLf
oDeviceType(eilute) = Device.Description
oDeviceCaption(eilute) = ramas(Device.FormFactor)
oDeviceParam(eilute) = Device.Capacity / 1048576
oDeviceInterf(eilute) = ramotipas(Device.MemoryType)
eilute = eilute + 1
' --------------------------------------
Case "Win32_FloppyDrive"
txtHW.Text = txtHW.Text & Device.Description & vbCrLf & Device.Caption & vbCrLf & Device.MaxMediaSize & vbCrLf & vbCrLf
oDeviceType(eilute) = Device.Description
oDeviceCaption(eilute) = Device.Caption
oDeviceParam(eilute) = Device.MaxMediaSize
oDeviceInterf(eilute) = ""
eilute = eilute + 1
' ------------------------------------
Case "Win32_POTSModem"
txtHW.Text = txtHW.Text & "POTS modem:" & vbCrLf & Device.Caption & vbCrLf & "Max baud rate to phone: " & Device.MaxBaudRateToPhone & vbCrLf & Device.Description & vbCrLf & vbCrLf
oDeviceType(eilute) = "POTS Modem"
oDeviceCaption(eilute) = Device.Caption
oDeviceParam(eilute) = Device.MaxBaudRateToPhone
oDeviceInterf(eilute) = Device.Description
eilute = eilute + 1
' ----------------------------------
Case "Win32_InfraredDevice"
txtHW.Text = txtHW.Text & "Infrared device:" & vbCrLf & Device.Caption & vbCrLf & vbCrLf
oDeviceType(eilute) = "Infrared Device"
oDeviceCaption(eilute) = Device.Caption
oDeviceParam(eilute) = ""
oDeviceInterf(eilute) = ""
eilute = eilute + 1
' ----------------------------------
Case "Win32_PCMCIAController"
txtHW.Text = txtHW.Text & "PCMCIA controller:" & vbCrLf & Device.Caption & vbCrLf & vbCrLf
oDeviceType(eilute) = "PCMCIA Controller"
oDeviceCaption(eilute) = Device.Caption
oDeviceParam(eilute) = ""
oDeviceInterf(eilute) = ""
eilute = eilute + 1
' -------------------------------------
Case "Win32_TapeDrive"
txtHW.Text = txtHW.Text & "Tape drive:" & vbCrLf & Device.Caption & vbCrLf & "Capacity: " & Device.MaxMediaSize & vbCrLf & Device.Description & vbCrLf & vbCrLf
oDeviceType(eilute) = "Tape Drive"
oDeviceCaption(eilute) = Device.Caption
oDeviceParam(eilute) = Device.MaxMediaSize
oDeviceInterf(eilute) = Device.Description
eilute = eilute + 1
' -----------------------------------
Case "Win32_PortableBattery"
txtHW.Text = txtHW.Text & "Portable battery:" & vbCrLf & Device.Caption & vbCrLf & Device.Chemistry & vbCrLf & vbCrLf
oDeviceType(eilute) = "Portable Battery"
oDeviceCaption(eilute) = Device.Caption
oDeviceParam(eilute) = ""
oDeviceInterf(eilute) = Device.Chemistry
eilute = eilute + 1
End Select
Next
End If

txtHW.Text = txtHW.Text & "========================================" & vbCrLf & vbCrLf
End Sub[/vb]

[vb]Private Function ConnectTO(ByVal strNameSpace, _
ByVal strUserName, _
ByVal strPassword, _
ByRef strServer, _
ByRef objService)

On Error Resume Next

Dim objLocator, objWshNet

ConnectTO = True 'Ko có lỗi sảy ra

'Tạo đối tượng để kết nối tới CIM
Set objLocator = CreateObject("WbemScripting.SWbemLocator")
If Err.Number Then
MsgBox "Error 0x" & CStr(Hex(Err.Number)) & _
" occurred in creating a locator object.", vbCritical,
If Err.Description <> "" Then
MsgBox "Error description: " & Err.Description & ".", vbCritical,
End If
Err.Clear
ConnectTO = False 'Có lỗi
Exit Function
End If

'Connect to the namespace which is either local or remote
Set objService = objLocator.ConnectServer(strServer, strNameSpace, _
strUserName, strPassword)
objService.Security_.impersonationlevel = 3
If Err.Number Then
MsgBox "Error 0x" & CStr(Hex(Err.Number)) & _
" occurred in connecting to server " _
& strServer & ".", vbCritical, "Error"
If Err.Description <> "" Then
MsgBox "Error description: " & Err.Description & ".", vbCritical, "Error"
End If
Err.Clear
ConnectTO = False 'Xảy ra lỗi
End If
End Function
[/vb]

From
[vb]
Private Sub Command1_Click()
Call scanhard
End Sub

Private Sub Form_Load()
'Hardware scanner
eilute = 0
webUserName = ""
webPassword = ""
isClient = False
isClienta = False
klientoID = 0
ramas = Array("Unknown", "Other", "SIP", "DIP", "ZIP", "SOJ", "Proprietary", _
"SIMM", "DIMM", "TSOP", "PGA", "RIMM", "SODIMM")

ramotipas = Array("Unknown", "Other", "DRAM", "Synchronous DRAM", "Cache DRAM", _
"EDO", "EDRAM", "VRAM", "SRAM", "RAM", "ROM", "Flash", "EEPROM", _
"FEPROM", "EPROM", "CDRAM", "3DRAM", "SDRAM", "SGRAM")

ReDim Preserve PelesInt(165)
PelesInt(1) = "Other"
PelesInt(2) = "Unknown"
PelesInt(3) = "Serial"
PelesInt(4) = "PS / 2"
PelesInt(5) = "Infrared"
PelesInt(6) = "HP - HIL"
PelesInt(7) = "Bus mouse"
PelesInt(8) = "ADB (Apple Desktop Bus)"
PelesInt(160) = "Bus mouse DB-9"
PelesInt(161) = "Bus mouse micro-DIN"
PelesInt(162) = "USB"

ReDim Preserve PelesTipas(10)
PelesTipas(1) = "Other"
PelesTipas(2) = "Unknown"
PelesTipas(3) = "Mouse"
PelesTipas(4) = "Track Ball"
PelesTipas(5) = "Track Point"
PelesTipas(6) = "Glide Point"
PelesTipas(7) = "Touch Pad"

Set objWshNet = CreateObject("Wscript.Network")
txtUname = objWshNet.ComputerName

End Sub

[/vb]



Koha JeseMen
Thành viên chính thức
Thành viên chính thức
Posts: 24
Joined: Tue 27/07/2010 9:00 pm
Has thanked: 5 times

Re: Lấy thông tin hardware

Postby Koha JeseMen » Wed 27/04/2011 4:54 pm

Send Source luôn đi !
Lỗi ReDim Preserve DeviceList(40)

LV Phuoc
Posts: 1
Joined: Mon 25/04/2011 10:29 pm
Has thanked: 1 time

Re: Lấy thông tin hardware

Postby LV Phuoc » Wed 11/05/2011 10:18 pm

Up Source cho bạn :)

Code: Select all

http://www.mediafire.com/?0mqye8e5wj75p3k

otacon
Posts: 3
Joined: Fri 22/06/2012 5:51 pm

Re: Lấy thông tin hardware

Postby otacon » Wed 27/06/2012 2:21 am

up lại đi bro ơi

User avatar
khoaakt
Thành viên năng nổ
Thành viên năng nổ
Posts: 75
Joined: Tue 19/06/2012 6:30 pm
Location: http://việtnam.vn/Kontum/Trường/THPT Chuyên Nguyễn Tất Thành.htm
Has thanked: 8 times
Been thanked: 7 times
Contact:

Re: Lấy thông tin hardware

Postby khoaakt » Sat 18/08/2012 5:19 pm

Tét code OK... f5..OK ra thế này...
Image
cách khắc phục???

dactung93
Thành viên tâm huyết
Thành viên tâm huyết
Posts: 496
Joined: Tue 04/11/2008 8:43 am
Has thanked: 6 times
Been thanked: 8 times

Re: Lấy thông tin hardware

Postby dactung93 » Wed 22/08/2012 2:09 am

Bạn để thuộc tính textbox là multiline=true rồi scoll nữa


Return to “[VB] Hệ thống - Tập tin - Thư mục và Mạng”

Who is online

Users browsing this forum: No registered users and 3 guests