Đánh giá chủ đề:
  • 7 Votes - 3.86 Average
  • 1
  • 2
  • 3
  • 4
  • 5
Lấy về số seri CPU, ổ cứng MainBoard trong Access
#11
(04-10-10, 07:42 PM)DoquangLam Đã viết: Nhờ các bạn trợ giúp :

- Mình có forms có tên là DangKy
- Bây giờ mình muốn các bạn viết dùm mình Code qui định cho nó khi khởi động đến lần thứ 3 hay 5,6... (do mình quy định trong code) thì hiện lên dòng thông báo "Đã hết hạn sử dụng", bấm OK thì nó thoát fomrs.
Cám ơn !

xem bài http://thuthuataccess.co.cc/forum/thread-285.html
Chữ ký của dinhvank19 Xin chào Guest! Mình là dinhvank19, thành viên của Thủ Thuật Access tham gia ngày Nov 2010.
Reply
Những người đã cảm ơn
#12
(23-08-10, 01:25 PM)Noname Đã viết: Đôi khi có 1 số nhu cầu lấy thông tin phần cứng trong chương trình (chẳng hạn để cấp bản quyền). Dưới đây là Đoạn Code cho phép bạn lấy thông tin CPU máy tính:
Mã:
Sub GetCPUID()
     'ta.o ðo^'i týo+.ng di.ch vu. WMI
     Set objWMIService = GetObject("winmgmts:\\.\root\cimv2")
     'ti`m các CPU ðang cha.y cu?a máy
     Set colItems = objWMIService.ExecQuery("Select * from Win32_Processor")
     'la(.p hie^?n thi. ID cu?a tu+`ng CPU
     For Each objItem In colItems
     MsgBox "Processor Id: " & objItem.ProcessorId
     Next
     End Sub


Lưu ý rằng trên các máy PC bình thường, chỉ có 1 CPU nên vòng lặp hiển thị thông tin sẽ chỉ chạy 1 lần và hiển thị ID của CPU duy nhất của máy.


nguồn PC word

2. Lấy CPU ổ cứng:

Mã:
Sub readserienumber()
    Dim fso As Object, Drv As Object
            'Create a FileSystemObject object
              Set fso = CreateObject("Scripting.FileSystemObject")
              'Assign the current drive letter if not specified
              Set Drv = fso.GetDrive()
              With Drv
                  If .IsReady Then
                      DriveSerial = Abs(.SerialNumber)
                  Else    '"Drive Not Ready!"
                      DriveSerial = -1
                  End If
              End With
              'Clean up
              Set Drv = Nothing
              Set fso = Nothing
              Msgbox "Serial là: " & DriveSerial
     End Sub

3. Lấy Serial Main Board

Mã:
Sub readseriemainboard()
Dim objs As Object
Dim obj As Object
Dim WMI As Object
Dim sAns As String
Set WMI = GetObject("WinMgmts:")
Set objs = WMI.InstancesOf("Win32_BaseBoard")
For Each obj In objs
sAns = sAns & obj.SerialNumber
If sAns < objs.Count Then sAns = sAns & ","
Next
Msgbox "Serial main: " & sAns
End Sub

Hình như đoạn code lấy serial đĩa cứng chạy không được trên mọi hệ điều hành!
các bạn xem đoạn code dài dòng này ra sao?

Option Explicit

'àõnh nghôa caác hùçng cêìn duâng cho haâm CreateFile
Private Const FILE_SHARE_READ = &H1
Private Const FILE_SHARE_WRITE = &H2
Private Const GENERIC_READ = &H80000000
Private Const GENERIC_WRITE = &H40000000
Private Const OPEN_EXISTING = 3
Private Const CREATE_NEW = 1
'àõnh nghôa caác hùçng, caác kiïíu cêìn duâng cho haâm DeviceIOControl
'caác thöng tin naây àûúåc lêëy tûâ böå DDK
Private Const DFP_RECEIVE_DRIVE_DATA = &H7C088
Private Enum HDINFO
HD_MODEL_NUMBER
HD_SERIAL_NUMBER
HD_FIRMWARE_REVISION
End Enum

Private Type IDEREGS
bFeaturesReg As Byte
bSectorCountReg As Byte
bSectorNumberReg As Byte
bCylLowReg As Byte
bCylHighReg As Byte
bDriveHeadReg As Byte
bCommandReg As Byte
bReserved As Byte
End Type

Private Type SENDCMDINPARAMS
cBufferSize As Long
irDriveRegs As IDEREGS
bDriveNumber As Byte
bReserved(1 To 3) As Byte
dwReserved(1 To 4) As Long
End Type

Private Type DRIVERSTATUS
bDriveError As Byte
bIDEStatus As Byte
bReserved(1 To 2) As Byte
dwReserved(1 To 2) As Long
End Type

Private Type SENDCMDOUTPARAMS
cBufferSize As Long
DStatus As DRIVERSTATUS ' ovvero DriverStatus
bBuffer(1 To 512) As Byte
End Type

'Àõnh nghôa caác haâm API cêìn duâng
Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, ByVal lpSecurityAttributes As Long, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function DeviceIoControl Lib "kernel32" (ByVal hDevice As Long, ByVal dwIoControlCode As Long, lpInBuffer As Any, ByVal nInBufferSize As Long, lpOutBuffer As Any, ByVal nOutBufferSize As Long, lpBytesReturned As Long, ByVal lpOverlapped As Long) As Long

'Àõnh nghôa haâm GetHDInfo àïí àoåc thöng tin vêåt lyá disk
Private Function GetHDInfo(Drive As Integer, hdi As HDINFO) As String
Dim bin As SENDCMDINPARAMS
Dim bout As SENDCMDOUTPARAMS
Dim hdh As Long
Dim br As Long
Dim ix As Long
Dim hddfr As Long
Dim hddln As Long
Dim s As String
Select Case hdi ' Selezione tipo caratteristica richiesta
Case HD_MODEL_NUMBER
hddfr = 55 ' Posizione nel buffer del ModelNumber
hddln = 40 ' Lunghezza nel buffer del ModelNumber
Case HD_SERIAL_NUMBER
hddfr = 21 ' Posizione nel buffer del SerialNumber
hddln = 20 ' Lunghezza nel buffer del SerialNumber
Case HD_FIRMWARE_REVISION
hddfr = 47 ' Posizione nel buffer del FirmwareRevision
hddln = 8 ' Lunghezza nel buffer del FirmwareRevision
Case Else
Err.Raise 10001, "Illegal HD Data type" ' Altre informazioni non disponibili (Evoluzione futura)
End Select
'taåo file nhêån daång öí cûáng cêìn àoåc thöng tin
hdh = CreateFile("\\.\PhysicalDrive" & Drive, GENERIC_READ + GENERIC_WRITE, FILE_SHARE_READ + FILE_SHARE_WRITE, 0, OPEN_EXISTING, 0, 0)
'kiïím tra viïåc taåo file
If hdh = 0 Then
Err.Raise 10003, , "Error on CreateFile"
End If

'thiïët lêåp caác thöng söë input
With bin
.bDriveNumber = Drive
.cBufferSize = 512
With .irDriveRegs
If (Drive And 1) Then
.bDriveHeadReg = &HB0
Else
.bDriveHeadReg = &HA0
End If
.bCommandReg = &HEC
.bSectorCountReg = 1
.bSectorNumberReg = 1
End With
End With
'goåi haâm DeviceIoControl àïí àoåc thöng tin
DeviceIoControl hdh, DFP_RECEIVE_DRIVE_DATA, bin, Len(bin), bout, Len(bout), br, 0
'copy thöng tin cêìn truy xuêët
s = ""
For ix = hddfr To hddfr + hddln - 1 Step 2
If bout.bBuffer(ix + 1) = 0 Then Exit For
s = s & Chr(bout.bBuffer(ix + 1))
If bout.bBuffer(ix) = 0 Then Exit For
s = s & Chr(bout.bBuffer(ix))
Next ix
GetHDInfo = Trim(s)
'Àoáng handle disk
CloseHandle hdh
End Function
/----------------------------------------------------------------------------
Public Function Lay_Serial() As String
On Error GoTo M01_MODAU_Err
If Not IsNull(GetHDInfo(0, HD_SERIAL_NUMBER)) Then
Lay_Serial = GetHDInfo(0, HD_SERIAL_NUMBER)
'MsgBox GetHDInfo(0, HD_SERIAL_NUMBER)
Else
MsgBox "Khong doc duoc serial number!! ", vbCritical
DoCmd.Quit
End If

M01_MODAU_Exit:
Exit Function

M01_MODAU_Err:
MsgBox Error$
Resume M01_MODAU_Exit
End Function
//sưu tầm
Chữ ký của dinhvank19 Xin chào Guest! Mình là dinhvank19, thành viên của Thủ Thuật Access tham gia ngày Nov 2010.
Reply
Những người đã cảm ơn Noname
#13
Tôi chạy sao không được nhỉ.

- Lấy CPU: OK.
- Lấy Main: chỉ có mỗi dấu , thôi.
- Lấy HD báo lỗi Set Drv = fso.GetDrive(). error 450
Noname xem giúp nhé.
Chữ ký của haquocquan Guest, you are welcome!
ღღღღღTài sản của haquocquan (View All Items) ღღღღღ
Reply
Những người đã cảm ơn
#14
(10-11-10, 08:04 PM)haquocquan Đã viết: Tôi chạy sao không được nhỉ.

- Lấy CPU: OK.
- Lấy Main: chỉ có mỗi dấu , thôi.
- Lấy HD báo lỗi Set Drv = fso.GetDrive(). error 450
Noname xem giúp nhé.

Bạn Quân. Mình có fix lỗi error 450 rồi.
Sửa lại đoạn code thế này

Mã:
Set Drv = fso.GetDrive(Environ("SystemDrive"))
Chữ ký của Cafe Via He Ở nhờ nhà mẹ mình big green
ღღღღღTài sản của Cafe Via He (View All Items) ღღღღღ
Reply
Những người đã cảm ơn haquocquan
#15
Cám ơn CFVH. Mình đã lấy được CPU và HD rồi. Nhưng còn MAIN vẫn chưa được.
Chữ ký của haquocquan Guest, you are welcome!
ღღღღღTài sản của haquocquan (View All Items) ღღღღღ
Reply
Những người đã cảm ơn
#16
@ Bạn Quân: Thử lại đoạn code này, Cafe thêm mắm muối chút nè. Lấy Model và Bios của Main luôn

Mã:
Sub readseriemainboard()
Dim objs As Object
Dim obj As Object
Dim WMI As Object
Dim sAns As String
Set WMI = GetObject("WinMgmts:")
Set objs = WMI.InstancesOf("Win32_BaseBoard")
For Each obj In objs

    sAns = sAns & "Serial Number: " & obj.SerialNumber & vbCrLf
    sAns = sAns & "Model: " & obj.product & vbCrLf

    If sAns < objs.Count Then sAns = sAns & ","

Next
'Set objs = Nothing
Set objs = WMI.InstancesOf("Win32_BIOS")
  
For Each obj In objs
    sAns = sAns & "BIOS: " & obj.Manufacturer & vbCrLf
Next
MsgBox sAns
End Sub

Chữ ký của Cafe Via He Ở nhờ nhà mẹ mình big green
ღღღღღTài sản của Cafe Via He (View All Items) ღღღღღ
Reply
Những người đã cảm ơn Noname , haquocquan
#17
Hé hé, tks cafe, đã cập nhật tất cả lên trang đầu cho mọi người dễ theo dõi!
Chữ ký của Noname 020
ღღღღღTài sản của Noname (View All Items) ღღღღღ
Reply
Những người đã cảm ơn
#18
--------->>>> Sửa lại đoạn code GETCPU của Noname chút. Lấy CPU name và Manufacturer
Mã:
Sub GetCPUID()
     'ta.o ðo^'i týo+.ng di.ch vu. WMI
     Set objWMIService = GetObject("winmgmts:\\.\root\cimv2")
     'ti`m các CPU ðang cha.y cu?a máy
     Set colItems = objWMIService.ExecQuery("Select * from Win32_Processor")
     'la(.p hie^?n thi. ID cu?a tu+`ng CPU
     For Each objItem In colItems
     MsgBox "Processor Id: " & objItem.ProcessorId & vbCrLf & _
            "Proccess Name: " & objItem.Name & vbCrLf & _
            "Manufacturer: " & objItem.Manufacturer
     Next
End Sub
Chữ ký của Cafe Via He Ở nhờ nhà mẹ mình big green
ღღღღღTài sản của Cafe Via He (View All Items) ღღღღღ
Reply
Những người đã cảm ơn haquocquan
#19
Đã Chuyển từ sub thành function lấy về thông tin CPU, main, HDD. Có demo, xem ở trang 1.
Chú ý: Một số main không cho lấy thông tin serial (các đời máy VAIO, Apple) nên hàm Lấy thông tin Main chỉ mang tính tham khảo!
Chữ ký của Noname 020
ღღღღღTài sản của Noname (View All Items) ღღღღღ
Reply
Những người đã cảm ơn haquocquan , Cafe Via He , dannynguyen1980
#20
Cảm ơn Noname về access demo
Từ nay mình có thể tạo bản quyền file.mdb giống như những phần mềm Thuế của Fash
Chữ ký của vanrongvn Hãy chia sẻ kinh nghiệm cùng mình trên ThuThuatAccess nhé! Chúc vui vẻ rose
Reply
Những người đã cảm ơn


Có thể liên quan đến chủ đề
Chủ đề: Tác giả Trả lời: Xem: Bài mới nhất
  [Thủ Thuật] Ẩn record trong table theo ngày tháng tvn_hut 6 491 24-04-16, 01:00 AM
Bài mới nhất: tvn_hut
  Thuộc tính Startup MS Access toàn tập với VBA Noname 2 2,737 18-04-16, 04:50 PM
Bài mới nhất: ongke0711
  Hàm đọc số dùng mã Unicode trong Access Noname 28 11,701 23-03-16, 11:45 PM
Bài mới nhất: thiennamlong
  [Thủ Thuật] Hỏi_Xác định phiên bản Access đang dùng maidinhdan 1 379 18-12-15, 08:43 AM
Bài mới nhất: ongke0711
Star Code tạo Serial, License Key cho Access nguoilinh229 3 502 06-11-15, 02:07 PM
Bài mới nhất: kieu manh

Chuyển nhanh:


User(s) browsing this thread: 1 Guest(s)
Diễn Đàn Thơ Văn Thi Ẩm Lâu|Nhà Hàng Sông Thơ