(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

(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

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é.

(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

Cám ơn CFVH. Mình đã lấy được CPU và HD rồi. Nhưng còn MAIN vẫn chưa được.

@ 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

Hé hé, tks cafe, đã cập nhật tất cả lên trang đầu cho mọi người dễ theo dõi!

--------->>>> Sửa lại đoạn code GETCPU của Noname chút. Lấy CPU name và Manufacturer

Đã 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!

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