22. marts 2002 - 18:23
#10
Du kunne lave det som hardwarenøgle.
Problem:
hvis brugeren udskifter hardwar skal brugeren have en ny kode.
GetSoundCart
GetProcessor
GetHarddisk (hvis brugeren formater disk eller setter en harddisk mere i computeren, ny kode)
GetDisplay
GetMemmory (Funker ikke)
'------------------------------------------------ Form1 ------------------------------------------------
Option Explicit
Private Sub Form_Load()
Dim aKey As String
Dim cValu As Long
Dim i As Long
Text1.Text = "" 'Hardwarenøgle
Text2.Text = "" 'Bruger kode ud fra hardwarenøgle
Text1.Text = GetSoundCart + GetProcessor + GetHarddisk + GetDisplay '+ GetMemmory
aKey = "AaBbCcDdEeFfGgHhIiJjKkLlMmNnOoPpQqRrSsTtUuVvWwXxYyZz"
For i = 1 To Len(Str(Text1.Text))
cValu = Val(Mid(Text1.Text, i, 1)) '+ 1
Text2.Text = Text2.Text & Mid(aKey, cValu + i, 1)
Next i
End Sub
'------------------------------------------------ Form1 ------------------------------------------------
'------------------------------------------------ Module1 ------------------------------------------------
Option Explicit
'GetMemmory
Private Type MEMORYSTATUS
dwLength As Long
dwMemoryLoad As Long
dwTotalPhys As Long
dwAvailPhys As Long
dwTotalPageFile As Long
dwAvailPageFile As Long
dwTotalVirtual As Long
dwAvailVirtual As Long
End Type
Private Declare Sub GlobalMemoryStatus Lib "kernel32" (lpBuffer As MEMORYSTATUS)
'GetMemmory
'GetProcessor
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 Declare Sub GetSystemInfo Lib "kernel32" (lpSystemInfo As SYSTEM_INFO)
'GetProcessor
'GetDisplay
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 Function ChangeDisplaySettingsEx Lib "user32" Alias "ChangeDisplaySettingsExA" (lpszDeviceName As Any, lpDevMode As Any, ByVal hWnd As Long, ByVal dwFlags As Long, lParam 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
'GetDisplay
'GetHarddisk
Private Declare Function GetVolumeInformation Lib "kernel32" Alias "GetVolumeInformationA" (ByVal lpRootPathName As String, ByVal lpVolumeNameBuffer As String, ByVal nVolumeNameSize As Long, lpVolumeSerialNumber As Long, lpMaximumComponentLength As Long, lpFileSystemFlags As Long, ByVal lpFileSystemNameBuffer As String, ByVal nFileSystemNameSize As Long) As Long
Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
'GetHarddisk
'GetSoundCart
Private Type MIDIOUTCAPS
wMid As Integer
wPid As Integer
vDriverVersion As Long
szPname As String * 32
wTechnology As Integer
wVoices As Integer
wNotes As Integer
wChannelMask As Integer
dwSupport As Long
End Type
Private Type WAVEINCAPS
wMid As Integer
wPid As Integer
vDriverVersion As Long
szPname As String * 32
dwFormats As Long
wChannels As Integer
End Type
Private Type WAVEOUTCAPS
wMid As Integer
wPid As Integer
vDriverVersion As Long
szPname As String * 32
dwFormats As Long
wChannels As Integer
End Type
Private Type MIXERCAPS
wMid As Integer
wPid As Integer
vDriverVersion As Long
szPname As String * 32
fdwSupport As Long
cDestinations As Long
End Type
Private Declare Function midiOutGetDevCaps Lib "winmm.dll" Alias "midiOutGetDevCapsA" (ByVal uDeviceID As Long, lpCaps As MIDIOUTCAPS, ByVal uSize As Long) As Long
Private Declare Function midiOutGetNumDevs Lib "winmm" () As Integer
Private Declare Function waveInGetDevCaps Lib "winmm.dll" Alias "waveInGetDevCapsA" (ByVal uDeviceID As Long, lpCaps As WAVEINCAPS, ByVal uSize As Long) As Long
Private Declare Function waveInGetNumDevs Lib "winmm.dll" () As Long
Private Declare Function waveOutGetDevCaps Lib "winmm.dll" Alias "waveOutGetDevCapsA" (ByVal uDeviceID As Long, lpCaps As WAVEOUTCAPS, ByVal uSize As Long) As Long
Private Declare Function waveOutGetNumDevs Lib "winmm.dll" () As Long
Private Declare Function mixerGetDevCaps Lib "winmm.dll" Alias "mixerGetDevCapsA" (ByVal uMxId As Long, pmxcaps As MIXERCAPS, ByVal cbmxcaps As Long) As Long
Private Declare Function mixerGetNumDevs Lib "winmm.dll" () As Long
'GetSoundCart
Function GetMemmory() As Long 'GetMemmory
Dim MemStat As MEMORYSTATUS
Dim Phys, File, Virtual As Long
GlobalMemoryStatus MemStat
Phys = Val(MemStat.dwTotalPhys)
File = Val(MemStat.dwTotalPageFile)
Virtual = Val(MemStat.dwTotalVirtual)
GetMemmory = Val((Phys / 1024) + (File / 1024) + (Virtual / 1024))
End Function
Function GetProcessor() As Long 'GetProcessor
Dim SInfo As SYSTEM_INFO
Dim dwNumber, dwProcessor, Min, Max, dwActive, dwAllocation, dwOem, dwPage, dwReserved As Long
GetSystemInfo SInfo
dwNumber = Val(SInfo.dwNumberOrfProcessors)
dwProcessor = Val(SInfo.dwProcessorType)
Min = Val(SInfo.lpMinimumApplicationAddress)
Max = Val(SInfo.lpMaximumApplicationAddress)
dwActive = Val(SInfo.dwActiveProcessorMask)
dwAllocation = Val(SInfo.dwAllocationGranularity)
dwOem = Val(SInfo.dwOemID)
dwPage = Val(SInfo.dwPageSize)
dwReserved = Val(SInfo.dwReserved)
GetProcessor = Val((dwNumber / 1024)) + Val((dwProcessor / 1024)) + Val((Min / 1024)) + Val((Max / 1024)) + Val((dwActive / 1024)) + Val((dwAllocation / 1024)) + Val((dwOem / 1024)) + Val((dwPage / 1024)) + Val((dwReserved / 1024))
End Function
Function GetHarddisk() As Long 'GetHarddisk
Dim Serial, cDrive, i, dTemp As Long
Dim nDrive As String
For i = 65 To 90
nDrive = Chr(i) & ":\"
cDrive = GetDriveType(nDrive)
If cDrive = 3 Then
GetVolumeInformation nDrive, 0&, 0&, Serial, 0&, 0&, 0&, 0&
dTemp = dTemp + Serial
End If
Next i
GetHarddisk = Val(dTemp / 1024)
End Function
Function GetDisplay() As Long 'GetDisplay
Dim DD As DISPLAY_DEVICE
Dim Display As String
Dim i, fDisplay As Long
DD.cb = Len(DD)
If EnumDisplayDevices(ByVal 0&, 0, DD, ByVal 0&) Then
Display = Left$(DD.DeviceString, InStr(1, DD.DeviceString, Chr$(0)) - 1)
Else
Display = "Display Information"
End If
For i = 1 To Len(Display)
fDisplay = fDisplay + Asc(Mid(Display, i, 1))
Next i
GetDisplay = Val(fDisplay)
End Function
Function GetSoundCart() As Long 'GetSoundCart
Dim numDevices, TempSound2, i As Long
Dim ocaps As WAVEOUTCAPS
Dim icaps As WAVEINCAPS
Dim mcaps As MIDIOUTCAPS
Dim xcaps As MIXERCAPS
Dim TempSound As String
numDevices = waveOutGetNumDevs()
For i = 0 To (numDevices - 1)
waveOutGetDevCaps i, ocaps, Len(ocaps)
TempSound = TempSound & ocaps.szPname
Next
numDevices = waveInGetNumDevs()
For i = 0 To (numDevices - 1)
waveInGetDevCaps i, icaps, Len(icaps)
TempSound = TempSound & icaps.szPname
Next
numDevices = midiOutGetNumDevs()
For i = 0 To (numDevices - 1)
midiOutGetDevCaps i, mcaps, Len(mcaps)
TempSound = TempSound & mcaps.szPname
Next
numDevices = mixerGetNumDevs()
For i = 0 To (numDevices - 1)
mixerGetDevCaps i, xcaps, Len(xcaps)
TempSound = TempSound & xcaps.szPname
Next
For i = 1 To Len(TempSound)
TempSound2 = TempSound2 + Asc(Mid(TempSound, i, 1))
Next i
GetSoundCart = Val(TempSound2)
End Function
'------------------------------------------------ Module1 ------------------------------------------------
