获取各种电脑硬件物理地址（序列号）的程序源码征集

要求：
    1.硬件包括CUP、硬盘、主板、网卡、声卡、光区等
    2.程序代码应是完整的、准确的、适用各种操作系统
    3.需要说明适用范围、注意事项
    ……请各位高手把自己的优秀成果给大家共享一下！

解决方案 »

  1.   

    1.声卡信息:
    Private Declare Function waveOutGetNumDevs 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 LongPrivate Const Mb_OK = &H0
    Private Const Maxpnamelen = 32
    Private Const Wave_Format_1m08 = &H1
    Private Const Wave_Format_1m16 = &H4
    Private Const Wave_Format_1s08 = &H2
    Private Const Wave_Format_1s16 = &H8
    Private Const Wave_Format_2m08 = &H10
    Private Const Wave_Format_2m16 = &H40
    Private Const Wave_Format_2s08 = &H20
    Private Const Wave_Format_2s16 = &H80
    Private Const Wave_Format_4m08 = &H100
    Private Const Wave_Format_4m16 = &H400
    Private Const Wave_Format_4s08 = &H200
    Private Const Wave_Format_4s16 = &H800
    Private Const Wavecaps_Lrvolume = &H8
    Private Const Wavecaps_Pitch = &H1
    Private Const Wavecaps_Playbackrate = &H2
    Private Const Wavecaps_Sync = &H10
    Private Const Wavecaps_Volume = &H4Private Type Waveoutcaps
        Wmid As Integer
        Wpid As Integer
        Vdriverversion As Long
        Szpname As String * Maxpnamelen
        Dwformats As Long
        Wchannels As Integer
        Dwsupport As Long
    End Type'  测试是否存在声卡
    Private Function TestCard() As Boolean
        Dim Y As Long
        Dim Find As String
        
        Find = "Find Sound Blaster Card"
        Y = waveOutGetNumDevs()
        If Y > 0 Then
            TestCard = True
            MsgBox "Test OK!,I can found Sound Blaster Card!", Mb_OK, Find
        Else
            TestCard = False
            MsgBox "No found device", Mb_OK, Find
        End If
    End Function'  判断声卡支持的声音格式
    Private Function Listwaveformat(Aboutwave As Long) As String
        Dim Waveformat As String
        
        Select Case Aboutwave
            Case Wave_Format_1m08
                Waveformat = "11.025Khz,Mono,8bit,11Kb/Ps"
            Case Wave_Format_1m16
                Waveformat = "11.025Khz,Mono,16bit,22Kb/Ps"
            Case Wave_Format_1s08
                Waveformat = "11.025Khz,Stereo,8bit,22Kb/Ps"
            Case Wave_Format_1s16
                Waveformat = "11.025Khz,Stereo,16bit,43Kb/Ps"
            Case Wave_Format_2m08
                Waveformat = "22.05Khz,Mono,8bit,22Kb/Ps"
            Case Wave_Format_2m16
                Waveformat = "22.05Khz,Mono,16bit,43Kb/Ps"
            Case Wave_Format_2s08
                Waveformat = "22.05Khz,Stereo,8bit,43Kb/Ps"
            Case Wave_Format_2s16
                Waveformat = "22.05Khz,Stereo,16bit,86Kb/Ps"
            Case Wave_Format_4m08
                Waveformat = "44.1Khz,Mono,8bit,43Kb/Ps"
            Case Wave_Format_4m16
                Waveformat = "44.1Khz,Mono,16bit,86Kb/Ps"
            Case Wave_Format_4s08
                Waveformat = "44.1Khz,Stereo,8bit,86Kb/Ps"
            Case Wave_Format_4s16
                Waveformat = "44.1Khz,Stereo,16bit,172Kb/Ps"
        End Select
        Listwaveformat = Waveformat
    End Function'  获得声卡的支持的输出功能列表
    Private Function Listwavesupport(Aboutwave As Long) As String
        Dim Wavefun As String
        
        Select Case Aboutwave
            Case Wavecaps_Pitch
                Wavefun = "Support Pitch"
            Case Wavecaps_Playbackrate
                Wavefun = "Support Playback"
            Case Wavecaps_Volume
                Wavefun = "Support Volume Control"
            Case Wavecaps_Lrvolume
                Wavefun = "Support Left-Right Channals"
            Case Wavecaps_Sync
                Wavefun = "Support Synchronization"
        End Select
        Listwavesupport = Wavefun
    End Function'  单击按钮测试声卡
    Private Sub CmdTest_Click()
        Dim Existent As Boolean
        Dim Consequencd As Long
        Dim Returncaps As Waveoutcaps
        Dim Mainver As Long
        Dim Lesserver As Long
        Dim Pname As String * 32
        Dim Aboutwave As Long
        Dim Channel As String * 2
        Dim I As Integer
        
        Text1.Text = ""
        Existent = TestCard
        '  显示声卡的各项信息
        If Existent Then
            Consequence = waveOutGetDevCaps(0, Returncaps, Len(Returncaps))
            If Consequencd = 0 Then
                Mainver = Returncaps.Vdriverversion \ 256
                Lesserver = Returncaps.Vdriverversion Mod 256
                Pname = Left$(Returncaps.Szpname, InStr(Returncaps.Szpname, Chr$(0)) - 1)
                Channel = Str$(Returncaps.Wchannels)
                Text1.Text = "产品名称：" & Pname & vbCrLf
                Text1.Text = Text1.Text & "产品 Id：" & Returncaps.Wpid & vbCrLf
                Text1.Text = Text1.Text & "驱动程序 Id：" & Returncaps.Wmid & vbCrLf
                Text1.Text = Text1.Text & "驱动程序版本：" & Mainver & "." & Lesserver & vbCrLf
                Text1.Text = Text1.Text & "输出声道：" & Channel & vbCrLf
                Text1.Text = Text1.Text & "支持格式列表：" & vbCrLf
                For I = 0 To 11
                    If Returncaps.Dwformats And (2 ^ I) Then
                        Text1.Text = Text1.Text & Listwaveformat(2 ^ I) & vbCrLf
                    End If
                Next I
                Text1.Text = Text1.Text & "扩展输出功能列表："
                For I = 0 To 4
                    If Returncaps.Dwsupport And (2 ^ I) Then
                        Text1.Text = Text1.Text & Listwavesupport(2 ^ I) & vbCrLf
                    End If
                Next I
             End If
        Else
            End
        End If
    End SubPrivate Sub Form_Load()
        Text1.Text = ""
    End Sub
      

  2.   

    硬盘序列号
    '下载DiskID32.DLL
    'http://www.iskydown.com/SoftDown.asp?ID=13275&lbID=0'演示代码：
    Private Declare Function DiskID32 Lib "DiskID32.DLL" (ByRef DiskModel As Byte, ByRef DiskID As Byte) As LongPrivate Sub Form_Load()
        Dim DiskModel(31) As Byte, DiskID(31) As Byte, i As Long
        If DiskID32(DiskModel(0), DiskID(0)) Then
            Dim dModel As String, dID As String
            For i = 0 To 31
                dModel = IIf(DiskModel(i), dModel & Chr(DiskModel(i)), dModel)
                dID = IIf(DiskID(i), dID & Chr(DiskID(i)), dID)
            Next i
        End If
        MsgBox dModel & Chr(32) & dID: End
    End Sub
      

  3.   

    [转帖]直接从RING3获取硬盘序列号
    '****************************************************************
    '原作: Bardo
    '出处: 《东方热讯》网站
    '网址: www.easthot.net
    '****************************************************************
    '（如需转载，请不在删除以上信息，否则视为侵权！）
    '****************************************************************    要这个有什么用？可以生成与硬件相关的注册码。控制软件不重复使用！那么，很多多人认为VB实现不了。自然没有找到方法，一定是实现不了。然而，感谢WWW，我们能在上面找到VC的源码，DELPHI的源码。但是VB的就是见不到。为此，我决定将VC的源码改成VB的，以下即是：'VC原作说明部分（再发行时，请注意采用注解的方式，请不要删除的方式侵权，谢谢！）
    '*************************************************************************
    '通常情况下,我们通过=&HEC命令对IDE端口进行监测.获取硬盘信息.
    '一般情况下,我们就写个VXD或者DRIVER来完成.但是现在,通过MS的S.M.A.R.T.接口,
    '我们可以直接从RING3调用API DeviceIoControl()来获取硬盘信息.下面乃是我的例程:
    '另外,也有编译好的版本供大家平时使用.欢迎下载.
    '/*+++
    'HDID.CPP
    'Written by Lu Lin
    'http://lu0.126.com
    '2000.11.3
    '---*/
    '*************************************************************************
    'VB程序编制: BARDO
    '本来我想写一个只取盘动物理序列号的。但是考虑到大家学习的方便。还是将原来的代码
    '全部翻译了出来。如果你需要单一的只查一个主硬盘的序列号的程序，欢迎到本站下载。
    '
    '网站：东方热讯：http://www.easthot.net
    '邮件：[email protected]
    '2003.01.23
    '*************************************************************************
    Option Explicit
    '以下这一行是必须的，困为要做结构复制。而结构中有数组。所以，没有它则会错位
    Option Base 0Private Const DFP_GET_VERSION = &H74080
    Private Const DFP_SEND_DRIVE_COMMAND = &H7C084
    Private Const DFP_RECEIVE_DRIVE_DATA = &H7C088'#pragma pack(1)
    Private Type TGETVERSIONOUTPARAMS   '{
        bVersion As Byte  'Binary driver version.
        bRevision As Byte 'Binary driver revision.
        bReserved As Byte  'Not used.
        bIDEDeviceMap As Byte 'Bit map of IDE devices.
        fCapabilities As Long 'Bit mask of driver capabilities.
        dwReserved(4) As Long 'For future use.
    End TypePrivate Type TIDEREGS
        bFeaturesReg As Byte   'Used for specifying SMART "commands".
        bSectorCountReg As Byte  'IDE sector count register
        bSectorNumberReg As Byte  'IDE sector number register
        bCylLowReg As Byte    'IDE low order cylinder value
        bCylHighReg As Byte   'IDE high order cylinder value
        bDriveHeadReg As Byte   'IDE drive/head register
        bCommandReg As Byte   'Actual IDE command.
        bReserved As Byte    'reserved for future use.  Must be zero.
    End TypePrivate Type TSENDCMDINPARAMS
        cBufferSize As Long   'Buffer size in bytes
        irDriveRegs As TIDEREGS   'Structure with drive register values.
        bDriveNumber As Byte   'Physical drive number to send  'command to (0,1,2,3).
        bReserved(2) As Byte   'Reserved for future expansion.
        dwReserved(3) As Long   'For future use.
        ''BYTE  bBuffer(1)   'Input buffer.
    End TypePrivate Type TDRIVERSTATUS
        bDriverError As Byte  'Error code from driver, 'or 0 if no error.
        bIDEStatus  As Byte  'Contents of IDE Error register.
               'Only valid when bDriverError 'is SMART_IDE_ERROR.
        bReserved(1) As Byte   'Reserved for future expansion.
        dwReserved(1) As Long   'Reserved for future expansion.
    End TypePrivate Type TSENDCMDOUTPARAMS
        cBufferSize As Long      'Size of bBuffer in bytes
        DRIVERSTATUS As TDRIVERSTATUS   'Driver status structure.
        bBuffer(511) As Byte   'Buffer of arbitrary length
                 'in which to store the data read from the drive.
    End Type'下面的结构是要从另一结构复制数据过来的，所以，必须是字节数与VC的完全一致
    '而不能用兼容变量，但这里的我们还是用了兼容变量，Integer,因为此结构中这一
    '类型的的变量程序中没有用到，如果要用到，建议改为Byte类型。因为VB没有USHORTPrivate Type TIDSECTOR
        wGenConfig As Integer
        wNumCyls As Integer
        wReserved As Integer
        wNumHeads As Integer
        wBytesPerTrack As Integer
        wBytesPerSector As Integer
        wSectorsPerTrack As Integer
        wVendorUnique(2) As Integer
        sSerialNumber(19) As Byte
        wBufferType As Integer
        wBufferSize As Integer
        wECCSize As Integer
        sFirmwareRev(7) As Byte
        sModelNumber(39) As Byte
        wMoreVendorUnique As Integer
        wDoubleWordIO As Integer
        wCapabilities As Integer
        wReserved1 As Integer
        wPIOTiming As Integer
        wDMATiming As Integer
        wBS As Integer
        wNumCurrentCyls As Integer
        wNumCurrentHeads As Integer
        wNumCurrentSectorsPerTrack As Integer
        ulCurrentSectorCapacity(3) As Byte   '这里只能用byte，因为VB没有无符号的LONG型变量
        wMultSectorStuff As Integer
        ulTotalAddressableSectors(3) As Byte '这里只能用byte，因为VB没有无符号的LONG型变量
        wSingleWordDMA As Integer
        wMultiWordDMA As Integer
        bReserved(127) As Byte
    End Type'/*+++
    'Global vars
    '---*/
    Private vers As TGETVERSIONOUTPARAMS
    Private in_data As TSENDCMDINPARAMS
    Private out_data As TSENDCMDOUTPARAMS
    Private h As Long
    Private i As Long
    Private j As BytePrivate Type OSVERSIONINFO
        dwOSVersionInfoSize As Long
        dwMajorVersion As Long
        dwMinorVersion As Long
        dwBuildNumber As Long
        dwPlatformId As Long
        szCSDVersion As String * 128
    End TypePrivate Declare function GetVersionEx Lib "kernel32" Alias "GetVersionExA" _
              (LpVersionInformation As OSVERSIONINFO) As LongPrivate Const VER_PLATFORM_WIN32S = 0
    Private Const VER_PLATFORM_WIN32_WINDOWS = 1
    Private Const VER_PLATFORM_WIN32_NT = 2Private 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 LongPrivate Const CREATE_NEW = 1
    Private Const GENERIC_READ = &H80000000
    Private Const GENERIC_WRITE = &H40000000
    Private Const OPEN_EXISTING = 3
    Private Const FILE_SHARE_READ = &H1
    Private Const FILE_SHARE_WRITE = &H2Private Type OVERLAPPED
        Internal As Long
        InternalHigh As Long
        offset As Long
        OffsetHigh As Long
        hEvent As Long
    End TypePrivate 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, lpOverlapped As OVERLAPPED) As LongPrivate Declare function CloseHandle Lib "kernel32" (ByVal hObject As Long) As LongPrivate Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
             hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)
      

  4.   

    Private Sub CopyRight()
    'VC原版权代码（再发行时，请注意采用注解的方式，请不要删除的方式侵权，谢谢！）
    '****************************************************************************
    ' cerr<<endl<<"HDD identifier v1.0 for WIN95/98/Me/NT/2000. written by Lu Lin"<<endl
    ' cerr<<"For more information, please visit Inside Programming: http:'lu0.126.com"<<endl
    ' cerr<<"2000.11.3"<<endl<<endl
    '****************************************************************************
    Dim StrMsg As String
    StrMsg = StrMsg & "直接从RING3调用API DeviceIoControl()来获取硬盘信息的VB程序 "
    StrMsg = StrMsg & vbCrLf & "VC源作板权信息如下："
    StrMsg = StrMsg & vbCrLf & "***********************************************************"
    StrMsg = StrMsg & vbCrLf & "HDD identifier v1.0 for WIN95/98/Me/NT/2000. written by Lu Lin"
    StrMsg = StrMsg & vbCrLf & "For more information, please visit Inside Programming: http://lu0.126.com"
    StrMsg = StrMsg & vbCrLf & "2000.11.3"
    StrMsg = StrMsg & vbCrLf & "***********************************************************"
    StrMsg = StrMsg & vbCrLf & "VB程序编制：BARDO"
    StrMsg = StrMsg & vbCrLf & "网站：东方热讯：http://www.easthot.net"
    StrMsg = StrMsg & vbCrLf & "邮件：[email protected]"
    StrMsg = StrMsg & vbCrLf & "2003.01.23"
    MsgBox StrMsg
    End SubSub ChangeByteOrder(szString() As Byte, uscStrSize As Long)
        Dim i As Long
        Dim temp As String
         For i = 0 To uscStrSize - 1 Step 2
            temp = szString(i)
            szString(i) = szString(i + 1)
            szString(i + 1) = temp
         Next i
    End SubPrivate function hdid9x() As String'We start in 95/98/Me
    h = CreateFile("\\.\Smartvsd", 0, 0, 0, CREATE_NEW, 0, 0)
    If h = 0 Then
        hdid9x = "open smartvsd.vxd failed"
        Exit function
    End IfDim olp As OVERLAPPED
    Dim lRet As Long
    lRet = DeviceIoControl(h, DFP_GET_VERSION, ByVal 0&, 0, vers, Len(vers), ByVal i, olp)
    If lRet = 0 Then
            hdid9x = "DeviceIoControl failed:DFP_GET_VERSION"
            CloseHandle (h)
            Exit function
    End If'If IDE identify command not supported, fails
    If (vers.fCapabilities And 1) <> 1 Then
        hdid9x = "Error: IDE identify command not supported."
        CloseHandle (h)
        Exit function
    End If'Display IDE drive number detected
    Dim sPreOutStr As String
    sPreOutStr = DetectIDE(vers.bIDEDeviceMap)
    hdid9x = sPreOutStr'Identify the IDE drives
    For j = 0 To 3
        Dim phdinfo As TIDSECTOR
        Dim s(40) As Byte
        
        If (j And 1) = 1 Then
            in_data.irDriveRegs.bDriveHeadReg = &HB0
        Else
            in_data.irDriveRegs.bDriveHeadReg = &HA0
        End If
        If (vers.fCapabilities And (16 \ (2 ^ j))) = (16 \ (2 ^ j)) Then
            'We don't detect a ATAPI device.
            hdid9x = "Drive " & CStr(j + 1) & " is a ATAPI device, we don't detect it"
        Else
              in_data.irDriveRegs.bCommandReg = &HEC
              in_data.bDriveNumber = j
              in_data.irDriveRegs.bSectorCountReg = 1
              in_data.irDriveRegs.bSectorNumberReg = 1
              in_data.cBufferSize = 512
              
              lRet = DeviceIoControl(h, DFP_RECEIVE_DRIVE_DATA, in_data, Len(in_data), out_data, Len(out_data), ByVal i, olp)
              
              If lRet = 0 Then
                  hdid9x = "DeviceIoControl failed:DFP_RECEIVE_DRIVE_DATA"
                  CloseHandle (h)
                  Exit function
              End If
              
              Dim StrOut As String
              
              CopyMemory phdinfo, out_data.bBuffer(0), Len(phdinfo)
              
              CopyMemory s(0), phdinfo.sModelNumber(0), 40
              s(40) = 0
              ChangeByteOrder s, 40
              
              StrOut = ByteArrToString(s, 40)
              
              hdid9x = hdid9x & vbCrLf & "Module Number:" & StrOut
              CopyMemory s(0), phdinfo.sFirmwareRev(0), 8
              s(8) = 0
              ChangeByteOrder s, 8
              
              StrOut = ByteArrToString(s, 8)
              
              hdid9x = hdid9x & vbCrLf & "Firmware rev:" & StrOut
              CopyMemory s(0), phdinfo.sSerialNumber(0), 20
              s(20) = 0
              ChangeByteOrder s, 20
              
              StrOut = ByteArrToString(s, 20)
              
              hdid9x = hdid9x & vbCrLf & "Serial Number:" & StrOut
              
              CopyMemory s(0), phdinfo.ulTotalAddressableSectors(0), 4
              
              s(5) = 0
              Dim dblStrOut As Double
              dblStrOut = ByteArrToLong(s)
              hdid9x = hdid9x & vbCrLf & "Capacity:" & dblStrOut / 2 / 1024 & "M"
          End If
    Next j'Close handle before quit
    CloseHandle (h)
    CopyRightEnd function
      

  5.   


    Private function hdidnt() As String
    Dim hd As String * 80
    Dim phdinfo As TIDSECTOR
    Dim s(40) As Byte
    Dim StrOut As Stringhdidnt = ""
    'We start in NT/Win2000For j = 0 To 3  '这里取四个硬盘的信息，因为正常PC不超过四个硬盘
         hd = "\\.\PhysicalDrive" & CStr(j)
         hdidnt = hdidnt & vbCrLf & hd
         h = CreateFile(hd, GENERIC_READ Or GENERIC_WRITE, _
              FILE_SHARE_READ Or FILE_SHARE_WRITE, 0, OPEN_EXISTING, 0, 0)
         
         Dim olpv As OVERLAPPED
         
         Dim lRet As Long
         lRet = DeviceIoControl(h, DFP_GET_VERSION, ByVal 0&, 0, vers, Len(vers), ByVal i, olpv)
         
         If lRet = 0 Then
             CloseHandle (h)
         Else
                'If IDE identify command not supported, fails
                If (vers.fCapabilities And 1) <> 1 Then
                      hdidnt = "Error: IDE identify command not supported."
                      CloseHandle (h)
                      Exit function
                End If
                'Identify the IDE drives
                If (j And 1) = 1 Then
                    in_data.irDriveRegs.bDriveHeadReg = &HB0
                Else
                    in_data.irDriveRegs.bDriveHeadReg = &HA0
                End If
                If (vers.fCapabilities And (16 \ (2 ^ j))) <> 0 Then
                    'We don't detect a ATAPI device.
                    hdidnt = hdidnt & vbCrLf & "Drive " & CStr(j + 1) & " is a ATAPI device, we don't detect it"
                Else
                      
                      in_data.irDriveRegs.bCommandReg = &HEC
                      in_data.bDriveNumber = j
                      in_data.irDriveRegs.bSectorCountReg = 1
                      in_data.irDriveRegs.bSectorNumberReg = 1
                      in_data.cBufferSize = 512
                      
                      Dim olpr As OVERLAPPED
                      
                      lRet = DeviceIoControl(h, DFP_RECEIVE_DRIVE_DATA, in_data, Len(in_data), out_data, Len(out_data), ByVal i, olpr)
                      If lRet <= 0 Then
                           hdidnt = hdidnt & vbCrLf & "DeviceIoControl failed:DFP_RECEIVE_DRIVE_DATA"
                           CloseHandle (h)
                           
                      Else
                   
                         CopyMemory phdinfo, out_data.bBuffer(0), Len(phdinfo)
                         
                         CopyMemory s(0), phdinfo.sModelNumber(0), 40
                         s(40) = 0
                         ChangeByteOrder s, 40
                         
                         StrOut = ByteArrToString(s, 40)
                         
                         hdidnt = hdidnt & vbCrLf & "Module Number:" & StrOut
                         CopyMemory s(0), phdinfo.sFirmwareRev(0), 8
                         s(8) = 0
                         ChangeByteOrder s, 8
                         
                         StrOut = ByteArrToString(s, 8)
                         
                         hdidnt = hdidnt & vbCrLf & "Firmware rev:" & StrOut
                         CopyMemory s(0), phdinfo.sSerialNumber(0), 20
                         s(20) = 0
                         ChangeByteOrder s, 20
                         
                         StrOut = ByteArrToString(s, 20)
                         
                         hdidnt = hdidnt & vbCrLf & "Serial Number:" & StrOut
                         
                         CopyMemory s(0), phdinfo.ulTotalAddressableSectors(0), 4
                         s(5) = 0
                         Dim dblStrOut As Double
                         dblStrOut = ByteArrToLong(s)
                         
                         hdidnt = hdidnt & vbCrLf & "Capacity:" & dblStrOut / 2 / 1024 & "M"
                         CloseHandle (h)
                      End If
                End If
           End If
    Next j
    CopyRightEnd functionSub Main()Dim verinfo As OSVERSIONINFO
    Dim Ret As Long
    verinfo.dwOSVersionInfoSize = Len(verinfo)
    Ret = GetVersionEx(verinfo)
    Dim OutStr As String
    Select Case verinfo.dwPlatformId
    Case VER_PLATFORM_WIN32S
        MsgBox "Win32s is not supported by this programm."
        End
    Case VER_PLATFORM_WIN32_WINDOWS
        OutStr = hdid9x
        MsgBox OutStr
        End
    Case VER_PLATFORM_WIN32_NT
        OutStr = hdidnt
        MsgBox OutStr
        End
    End SelectEnd Sub
    Private function DetectIDE(bIDEDeviceMap As Byte) As String
        If (bIDEDeviceMap And 1) Then
            If (bIDEDeviceMap And 16) Then
                 DetectIDE = DetectIDE & "ATAPI device is attached to primary controller, drive 0."
            Else
                 DetectIDE = DetectIDE & "IDE device is attached to primary controller, drive 0."
            End If
        End If
        If (bIDEDeviceMap And 2) Then
            If (bIDEDeviceMap And 32) Then
                 DetectIDE = DetectIDE & "ATAPI device is attached to primary controller, drive 1."
            Else
                 DetectIDE = DetectIDE & "IDE device is attached to primary controller, drive 1."
            End If
        End If
        If (bIDEDeviceMap And 4) Then
            If (bIDEDeviceMap And 64) Then
                 DetectIDE = DetectIDE & "ATAPI device is attached to secondary controller, drive 0."
            Else
                 DetectIDE = DetectIDE & "IDE device is attached to secondary controller, drive 0."
            End If
        End If
        If (bIDEDeviceMap And 8) Then
            If (bIDEDeviceMap And 128) Then
                 DetectIDE = DetectIDE & "ATAPI device is attached to secondary controller, drive 1."
            Else
                 DetectIDE = DetectIDE & "IDE device is attached to secondary controller, drive 1."
            End If
        End If
    End function
    Private function ByteArrToString(inByte() As Byte, ByVal strlen As Integer) As String
        Dim i As Integer
        For i = 0 To strlen
            If inByte(i) = 0 Then
               Exit For
            End If
            ByteArrToString = ByteArrToString & Chr(inByte(i))
        Next i
    End functionPrivate function ByteArrToLong(inByte() As Byte) As Double
        Dim i As Integer
        For i = 0 To 3
            ByteArrToLong = ByteArrToLong + CDbl(inByte(i)) * (256 ^ i)
        Next i
       
    End function
    'VC源代码请见：http://www.driverdevelop.com/lu0/App/2k1103.html
      

  6.   

    取得磁盘序列号、卷标和文件系统类型
    磁盘序列号在每次软盘或硬盘格式化后都重新生成，并且不回重复。许多程序员用此加密。其实也可以修改该函数，可以得到磁盘卷标和文件系统类型信息。　　声明： Private Declare Function GetVolumeInformation Lib "kernel32.dll" Alias "GetVolumeInformationA"     (ByVal lpRootPathName As String, ByVal lpVolumeNameBuffer As String, ByVal nVolumeNameSize  As Integer, lpVolumeSerialNumber As Long, lpMaximumComponentLength As Long, lpFileSystemFlags  As Long, ByVal lpFileSystemNameBuffer As String,  ByVal nFileSystemNameSize As Long) As Long 
    　　代码： Function GetSerialNumber(sRoot As String) As Long
        Dim lSerialNum As Long
        Dim R As Long
        Dim sTemp1 As String, sTemp2 As String
        strLabel = String$(255, Chr$(0))
      注释：  磁盘卷标
        strType = String$(255, Chr$(0))
      注释： 文件系统类型 一般为 FAT 
        R = GetVolumeInformation(sRoot, strLabel, Len(strLabel), lSerialNum, 0, 0, strType, Len(strType))
        GetSerialNumber = lSerialNum
      注释：在 strLabel 中为 磁盘卷标
      注释：在 strType  中为 文件系统类型
    End Function　　用法：　　当驱动器不存在时，函数返回 0。如果是个非根目录，也将返回 0： lSerial = GetSerialNumber("c:\")  
      

  7.   

    用VB获得CPU IDhttp://community.csdn.net/Expert/topic/2664/2664732.xml
      

  8.   

    我们在开发过程中可能会需要调访问一些硬件信息以实现一些特殊的功能比如身份验证、系统序列号、数据加密等等。为了方便大家的使用我把一些可能用到的封装成了一个类，希望大家能用的到。       大家只需将以下代码拈贴到VB的工程中，并以类的模式保存即可使用。所有的代码我都已经测试过，并曾在多次开发项目中使用过。
           使用方法：
           dim oHard as new CGetHardInfo '您可将CGetHardInfo 替换成您保存的类       读取硬盘的序列号：
                  HDDSR=CGetHardInfo.HardDiskID  '读取C盘的串号 （默认值）
                 如果获取其他盘符的序列号则需要指明盘符如下：
                 CGetHardInfo.HardDrive="D"
                 HDDSR=CGetHardInfo.HardDiskID  '读取D盘的串号       获得网卡的串号：
                 NICID=CGetHardInfo.NicID
         获取本机的IP地址：
                 IPAddress=CGethardInfo.IPAddress     获取主机名称：
                HostName=CGetHardInfo.HostName     如果产生错误（比如没有网卡等）可利用LASTERROR返回产生的最后一个错误 ERRORs为产生的错误集合
          以下为获取硬件信息的完整代码
           '=================================================================
    '获取相关的硬件信息 (硬盘ID/网卡ID/主机名称/IP地址)
    '文件名称: GetHardInfo.cls
    '开发时间: 2001.10.30
    '=================================================================Option ExplicitPrivate Const NCBASTAT = &H33
    Private Const NCBNAMSZ = 16
    Private Const HEAP_ZERO_MEMORY = &H8
    Private Const HEAP_GENERATE_EXCEPTIONS = &H4
    Private Const NCBRESET = &H32
       
    Private Type NCB
         ncb_command As Byte
         ncb_retcode As Byte
         ncb_lsn As Byte
         ncb_num As Byte
         ncb_buffer As Long
         ncb_length As Integer
         ncb_callname As String * NCBNAMSZ
         ncb_name As String * NCBNAMSZ
         ncb_rto As Byte
         ncb_sto As Byte
         ncb_post As Long
         ncb_lana_num As Byte
         ncb_cmd_cplt As Byte
         ncb_reserve(9) As Byte ' Reserved, must be 0
         ncb_event As Long
    End Type
    Private Type ADAPTER_STATUS
         adapter_address(5) As Byte 'As String * 6
         rev_major As Byte
         reserved0 As Byte
         adapter_type As Byte
         rev_minor As Byte
         duration As Integer
         frmr_recv As Integer
         frmr_xmit As Integer
         iframe_recv_err As Integer
         xmit_aborts As Integer
         xmit_success As Long
         recv_success As Long
         iframe_xmit_err As Integer
         recv_buff_unavail As Integer
         t1_timeouts As Integer
         ti_timeouts As Integer
         Reserved1 As Long
         free_ncbs As Integer
         max_cfg_ncbs As Integer
         max_ncbs As Integer
         xmit_buf_unavail As Integer
         max_dgram_size As Integer
         pending_sess As Integer
         max_cfg_sess As Integer
         max_sess As Integer
         max_sess_pkt_size As Integer
         name_count As Integer
    End Type
    Private Type NAME_BUFFER
         Name  As String * NCBNAMSZ
         name_num As Integer
         name_flags As Integer
    End Type
    Private Type ASTAT
         adapt As ADAPTER_STATUS
         NameBuff(30) As NAME_BUFFER
    End Type
     
    Private Declare Function Netbios Lib "netapi32.dll" (pncb As NCB) As Byte
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, ByVal hpvSource As Long, ByVal cbCopy As Long)
    Private Declare Function GetProcessHeap Lib "kernel32" () 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 HeapFree Lib "kernel32" (ByVal hHeap As Long, ByVal dwFlags As Long, lpMem As Any) As Long
      

  9.   

    '/*获得本机IP地址格式化数据设定
    Private Const WS_VERSION_REQD = &H101
    Private Const WS_VERSION_MAJOR = WS_VERSION_REQD \ &H100 And &HFF&
    Private Const WS_VERSION_MINOR = WS_VERSION_REQD And &HFF&
    Private Const MIN_SOCKETS_REQD = 1
    Private Const SOCKET_ERROR = -1
    Private Const WSADescription_Len = 256
    Private Const WSASYS_Status_Len = 128Private Type HOSTENT
        hName As Long
        hAliases As Long
        hAddrType As Integer
        hLength As Integer
        hAddrList As Long
    End TypePrivate Type WSADATA
        wversion As Integer
        wHighVersion As Integer
        szDescription(0 To WSADescription_Len) As Byte
        szSystemStatus(0 To WSASYS_Status_Len) As Byte
        iMaxSockets As Integer
        iMaxUdpDg As Integer
        lpszVendorInfo As Long
    End Type
    Private Declare Function WSAGetLastError Lib "WSOCK32.DLL" () As Long
    Private Declare Function WSAStartup Lib "WSOCK32.DLL" (ByVal wVersionRequired As Integer, lpWSAData As WSADATA) As Long
    Private Declare Function WSACleanup Lib "WSOCK32.DLL" () As Long
       
    Private Declare Function gethostname Lib "WSOCK32.DLL" (ByVal HostName$, ByVal HostLen As Long) As Long
    Private Declare Function gethostbyname Lib "WSOCK32.DLL" (ByVal HostName$) As Long
    Private Declare Sub RtlMoveMemory Lib "kernel32" (hpvDest As Any, ByVal hpvSource&, ByVal cbCopy&)
    '*/获取磁盘信息ID API函数设定
    Private Declare Function GetVolumeInformation Lib "kernel32.dll" Alias "GetVolumeInformationA" (ByVal lpRootPathName As String, ByVal lpVolumeNameBuffer As String, ByVal nVolumeNameSize As Integer, lpVolumeSerialNumber As Long, lpMaximumComponentLength As Long, lpFileSystemFlags As Long, ByVal lpFileSystemNameBuffer As String, ByVal nFileSystemNameSize As Long) As Long
    Private Const MAX_FILENAME_LEN = 256
       
    Private mvarIPaddr As String
    Private mvarhardid As String
    Private mvarnicid As StringPrivate mvarErrors As Collection
    Private mvarHostName As String
    Private m_HardDrvie As String'/* 设置要获取硬盘的盘符
    Public Property Let HardDrive(ByVal strDrv As String)
        m_HardDrvie = strDrv
    End Property'读取获取硬盘串号的盘符 默认为C
    Public Property Get HardDrive() As String
        If m_HardDrvie = vbNullString Then
            HardDrive = "C"
        End If
    End Property'/* 返回网卡的串号
    Public Property Get NicID() As String
        NicID = GetNicID()
    End Property'返回主机名称
    Public Property Get HostName() As String
        If mvarHostName = vbNullString Then
            GetIPAddress
            HostName = mvarHostName
        End If
    End Property'返回产生的错误集合
    Public Property Get Errors() As Collection
        Set Errors = mvarErrors
    End Property'返回硬盘的串号
    Public Property Get HardDiskID() As String
        HardDiskID = GetHardID(HardDrive)
    End Property'/* 获得最后产生的错误
    Public Property Get LastError() As String
        With mvarErrors
            If .Count <= 0 Then
                LastError = vbNullString
            Else
                LastError = .Item(.Count)
            End If
        End With
    End PropertyPublic Property Get IPAddress() As String
        IPAddress = GetIPAddress()
    End Property
    Private Function GetIPAddress() As String
      
       '/*获得本机主机名称和IP地址   SocketsInitialize
       Dim HostName As String * 15
       Dim hostent_addr As Long
       Dim Host As HOSTENT
       Dim hostip_addr As Long
       Dim temp_ip_address() As Byte
       Dim i As Integer
       Dim ip_address As String   If gethostname(HostName, 256) = SOCKET_ERROR Then
             Me.Errors.Add "Windows Sockets error " & str(WSAGetLastError())
             Exit Function
       Else
             HostName = Trim$(HostName)
       End If   hostent_addr = gethostbyname(HostName)   If hostent_addr = 0 Then
          mvarErrors.Add "Winsock.dll is not responding."
          Exit Function
       End If   RtlMoveMemory Host, hostent_addr, LenB(Host)
       RtlMoveMemory hostip_addr, Host.hAddrList, 4
       mvarHostName = HostName   'get all of the IP address if machine is  multi-homed   Do
          ReDim temp_ip_address(1 To Host.hLength)
          RtlMoveMemory temp_ip_address(1), hostip_addr, Host.hLength
          
          For i = 1 To Host.hLength
                ip_address = ip_address & temp_ip_address(i) & "."
          Next
          
          ip_address = Mid$(ip_address, 1, Len(ip_address) - 1)
          mvarIPaddr = ip_address
          ip_address = ""
          
          Host.hAddrList = Host.hAddrList + LenB(Host.hAddrList)
          RtlMoveMemory hostip_addr, Host.hAddrList, 4
       Loop While (hostip_addr <> 0)
       
       SocketsCleanup   GetIPAddress = mvarIPaddr
       
    End FunctionPrivate Function GetHardID(ByVal sDRV As String) As String
         Dim retVal As Long
         Dim str As String * MAX_FILENAME_LEN
         Dim str2 As String * MAX_FILENAME_LEN
         Dim a As Long
         Dim b As Long
         GetVolumeInformation sDRV & ":\", str, MAX_FILENAME_LEN, retVal, _
         a, b, str2, MAX_FILENAME_LEN
         
         GetHardID = CStr(retVal)
    End Function
      

  10.   

    个人以为，还是用C实现比较合理，C的计算效率确实比VB的高很多。
      

  11.   

    磁盘序列号在每次软盘或硬盘格式化后都重新生成，并且不回重复。许多程序员用此加密。其实也可以修改该函数，可以得到磁盘卷标和文件系统类型信息。声明：
    Private Declare Function GetVolumeInformation Lib "kernel32.dll" Alias _
    　 "GetVolumeInformationA" (ByVal lpRootPathName As String, ByVal _
    　 lpVolumeNameBuffer As String, ByVal nVolumeNameSize　As Integer, _
    　 lpVolumeSerialNumber As Long, lpMaximumComponentLength As Long, _
    　 lpFileSystemFlags　As Long, ByVal lpFileSystemNameBuffer As String, _
    　 ByVal nFileSystemNameSize As Long) As Long代码：Function GetSerialNumber(sRoot As String) As Long
    　　Dim lSerialNum As Long
    　　Dim R As Long
    　　Dim strLabel As String, strType As String
    　　strLabel = String$(255, Chr$(0))
    　　'磁盘卷标
    　　strType = String$(255, Chr$(0))
    　　'文件系统类型 一般为 FAT 
    　　R = GetVolumeInformation(sRoot, strLabel, Len(strLabel), _
    　　　　lSerialNum, 0, 0, strType, Len(strType))
    　　GetSerialNumber = lSerialNum
    　　'在 strLabel 中为 磁盘卷标
    　　'在 strType　中为 文件系统类型
    End Function用法：当驱动器不存在时，函数返回 0。如果是个非根目录，也将返回 0：lSerial = GetSerialNumber("c:\")
      

  12.   

    震撼ING
    一直用别人的DLL读硬盘物理序列号
      

  13.   

    getserialNumber取得不是物理序列号
     taosin()的后面几种方法不能使用!
      

  14.   

    获取机器的光驱信息：
    以下代码出自　枕善居 http://www.mndsoft.comSub ListCDRomInfo(strComputer)
        Dim objWMIService, colItems
            Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
            Set colItems = objWMIService.ExecQuery("Select * from Win32_CDROMDrive", , 48)
            For Each objItem In colItems
            WScript.Echo "Availability: " & objItem.Availability
            WScript.Echo "Capabilities: " & objItem.Capabilities
            WScript.Echo "CapabilityDescriptions: " & objItem.CapabilityDescriptions
            WScript.Echo "Caption: " & objItem.Caption
            WScript.Echo "CompressionMethod: " & objItem.CompressionMethod
            WScript.Echo "ConfigManagerErrorCode: " & objItem.ConfigManagerErrorCode
            WScript.Echo "ConfigManagerUserConfig: " & objItem.ConfigManagerUserConfig
            WScript.Echo "CreationClassName: " & objItem.CreationClassName
            WScript.Echo "DefaultBlockSize: " & objItem.DefaultBlockSize
            WScript.Echo "Description: " & objItem.Description
            WScript.Echo "DeviceID: " & objItem.DeviceID
            WScript.Echo "Drive: " & objItem.Drive
            WScript.Echo "DriveIntegrity: " & objItem.DriveIntegrity
            WScript.Echo "ErrorCleared: " & objItem.ErrorCleared
            WScript.Echo "ErrorDescription: " & objItem.ErrorDescription
            WScript.Echo "ErrorMethodology: " & objItem.ErrorMethodology
            WScript.Echo "FileSystemFlags: " & objItem.FileSystemFlags
            WScript.Echo "FileSystemFlagsEx: " & objItem.FileSystemFlagsEx
            WScript.Echo "Id: " & objItem.Id
            WScript.Echo "InstallDate: " & objItem.InstallDate
            WScript.Echo "LastErrorCode: " & objItem.LastErrorCode
            WScript.Echo "Manufacturer: " & objItem.Manufacturer
            WScript.Echo "MaxBlockSize: " & objItem.MaxBlockSize
            WScript.Echo "MaximumComponentLength: " & objItem.MaximumComponentLength
            WScript.Echo "MaxMediaSize: " & objItem.MaxMediaSize
            WScript.Echo "MediaLoaded: " & objItem.MediaLoaded
            WScript.Echo "MediaType: " & objItem.MediaType
            WScript.Echo "MinBlockSize: " & objItem.MinBlockSize
            WScript.Echo "Name: " & objItem.Name
            WScript.Echo "NeedsCleaning: " & objItem.NeedsCleaning
            WScript.Echo "NumberOfMediaSupported: " & objItem.NumberOfMediaSupported
            WScript.Echo "PNPDeviceID: " & objItem.PNPDeviceID
            WScript.Echo "PowerManagementCapabilities: " & objItem.PowerManagementCapabilities
            WScript.Echo "PowerManagementSupported: " & objItem.PowerManagementSupported
            WScript.Echo "RevisionLevel: " & objItem.RevisionLevel
            WScript.Echo "SCSIBus: " & objItem.SCSIBus
            WScript.Echo "SCSILogicalUnit: " & objItem.SCSILogicalUnit
            WScript.Echo "SCSIPort: " & objItem.SCSIPort
            WScript.Echo "SCSITargetId: " & objItem.SCSITargetId
            WScript.Echo "Size: " & objItem.Size
            WScript.Echo "Status: " & objItem.Status
            WScript.Echo "StatusInfo: " & objItem.StatusInfo
            WScript.Echo "SystemCreationClassName: " & objItem.SystemCreationClassName
            WScript.Echo "SystemName: " & objItem.SystemName
            WScript.Echo "TransferRate: " & objItem.TransferRate
            WScript.Echo "VolumeName: " & objItem.VolumeName
            WScript.Echo "VolumeSerialNumber: " & objItem.VolumeSerialNumber
            Next
    End Sub
    以上代码出自　枕善居 http://www.mndsoft.com
      

  15.   

    用wmi，什么硬件信息都有了！