sd.txt

//按柱面和磁道来读取磁盘数据,要求 Public Function ReadDisk(ByVal Cylinders As Long, ByVal Tracks As Long, db() As

                                 
            CloseHandle (hToken)
            getPrivileges = False
            Exit Function

         End If

'         lResult = SetPrivilege(hToken, SE_DEBUG_NAME, True)
         lResult = SetPrivilege(hToken, sPrivilegeName, True)
         If (lResult = False) Then

            CloseHandle (hToken)
            getPrivileges = False
            Exit Function

         End If
         getPrivileges = True
         hhToken = hToken
      End Function
Public Function SetPrivilege(ByVal hToken As Long, ByVal Privilege As String, _
                                    ByVal bSetFlag As Boolean) As Boolean

         Dim TP As TOKEN_PRIVILEGES          ' Used in getting the current
                                             ' token privileges
         Dim TPPrevious As TOKEN_PRIVILEGES  ' Used in setting the new
                                             ' token privileges
         Dim Luid As Luid                    ' Stores the Local Unique
                                             ' Identifier - refer to MSDN
         Dim cbPrevious As Long              ' Previous size of the
                                             ' TOKEN_PRIVILEGES structure
         Dim lResult As Long                 ' Result of various API calls

         ' Grab the size of the TOKEN_PRIVILEGES structure,
         ' used in making the API calls.
         cbPrevious = Len(TP)

         ' Grab the LUID for the request privilege.
         lResult = LookupPrivilegeValue("", Privilege, Luid)

         ' If LoopupPrivilegeValue fails, the return result will be zero.
         ' Test to make sure that the call succeeded.
         If (lResult = 0) Then
            SetPrivilege = False
         End If

         ' Set up basic information for a call.
         ' You want to retrieve the current privileges
         ' of the token under concern before you can modify them.
         TP.PrivilegeCount = 1
         TP.Privileges(0).pLuid = Luid
         TP.Privileges(0).Attributes = 0
         SetPrivilege = lResult

         ' You need to acquire the current privileges first
         lResult = AdjustTokenPrivileges(hToken, False, TP, Len(TP), _
                                        TPPrevious, cbPrevious)

         ' If AdjustTokenPrivileges fails, the return result is zero,
         ' test for success.
         If (lResult = 0) Then
            SetPrivilege = False
         End If

         ' Now you can set the token privilege information
         ' to what the user is requesting.
         TPPrevious.PrivilegeCount = 1
         TPPrevious.Privileges(0).pLuid = Luid

         ' either enable or disable the privilege,
         ' depending on what the user wants.
         Select Case bSetFlag
            Case True: TPPrevious.Privileges(0).Attributes = _
                       TPPrevious.Privileges(0).Attributes Or _
                       (SE_PRIVILEGE_ENABLED)
            Case False: TPPrevious.Privileges(0).Attributes = _
                        TPPrevious.Privileges(0).Attributes Xor _
                        (SE_PRIVILEGE_ENABLED And _
                        TPPrevious.Privileges(0).Attributes)
         End Select

         ' Call adjust the token privilege information.
         lResult = AdjustTokenPrivileges(hToken, False, TPPrevious, _
                                        Len(TPPrevious), TP, cbPrevious)

         ' Determine your final result of this function.
         If (lResult = 0) Then
            ' You were not able to set the privilege on this token.
            SetPrivilege = False
         Else
            ' You managed to modify the token privilege
            SetPrivilege = True
         End If

      End Function
'----------------------------------------------
' Procedure  : GetCheckSum
' Auther     : WangWeiSheng
' Input      : FileName       输入短文件名字节数组
' Input      : Xx             输入一个偏移量
' OutPut     : Byte           返回计算出的校验值
' Purpose    : 计算短文件名的校验值
'----------------------------------------------
Public Function GetCheckSum(Filename() As Byte, Xx As Integer) As Byte
Dim i As Integer
Dim Sum As Integer
Dim CheckSum As Byte

For i = 0 To 10
   Sum = (RightRotAByte(CheckSum) + Filename(Xx + i))
    CheckSum = Sum And &HFF
Next
GetCheckSum = CheckSum
End Function
'----------------------------------------------
' Procedure  : RightRotAByte
' Auther     : WangWeiSheng
' Input      : CheckSum       输入要右移的数（一个字节）
' OutPut     : Integer        返回右移后的数
' Purpose    : 循环右移一个byte
'----------------------------------------------
Public Function RightRotAByte(ByVal CheckSum As Byte) As Integer
Dim TempByte As Byte
Dim Sng As Byte
Sng = IIf((CheckSum And &H1), &H80, &H0)
TempByte = CheckSum And &H3
CheckSum = (CheckSum And &HFC) / 2
RightRotAByte = Sng Or CheckSum Or (((TempByte And 2) = 2) And 1)
End Function







'1 ?判断光驱的盘符:
  Function GetCDROM() As String ' 返回光驱的盘符(字母)
    Dim Fso, FsoDrive, FsoDrives
    
    'Dim FsoDrive As Drive, FsoDrives As Drives '定义驱动器、驱动器集合对象
    
    Set Fso = CreateObject("Scripting.FileSystemObject") 'New FileSystemObject '创建 FSO 对象的一个实例
    Set FsoDrives = Fso.Drives
    
    
    
    For Each FsoDrive In FsoDrives '遍历所有可用的驱动器
      If FsoDrive.DriveType = diskCDROM Then 'CDRom Then '如果驱动器的类型为 CDrom
        GetCDROM = "" & FsoDrive.DriveLetter '输出其盘符
      'Else
      '  GetCDROM = ""
      End If
    Next
    
 
    Set Fso = Nothing
    Set FsoDrive = Nothing
    Set FsoDrives = Nothing
    
  End Function

'2 ?判断文件?文件夹是否存在:
  '返回布尔值:True 存在，False 不存在，filername 文件名
  Function FileExist(Filename As String)
    Dim Fso As New FileSystemObject
    If Fso.FileExists(Filename) = True Then
      FileExist = True
    Else
      FileExist = False
    End If
    
    Set Fso = Nothing
  End Function
  '返回布尔值:True 存在，False 不存在，foldername 文件夹
  Function FolderExist(foldername As String)
  Dim Fso As New FileSystemObject
  If Fso.FolderExists(foldername) = True Then
  FolderExist = True
  Else
  FolderExist = False
  End If
  Set Fso = Nothing
  End Function


 
'3 ?获取驱动器参数:
  '返回磁盘总空间大小(单位：M)，Drive = 盘符 A ,C, D ...
  Function AllSpace(Drive As String) As Double
    Dim Fso, Drv
    Set Fso = CreateObject("Scripting.FileSystemObject") 'New FileSystemObject '创建 FSO 对象的一个实例
    Set Drv = Fso.GetDrive(Drive) '得到 Drv 对象的实例
    
    
      If Drv.IsReady Then '如果该驱动器存在(软驱或光驱里有盘片，硬盘存取正常)
        AllSpace = Drv.TotalSize '将字节转换为兆
      Else
        AllSpace = 0
      End If
    
    Set Fso = Nothing
    Set Drv = Nothing
  End Function
  '返回磁盘可用空间大小(单位：M)，Drive = 盘符 A ,C, D ...
  Function FreeSpace(Drive) As Double
    Dim Fso, Drv
    Set Fso = CreateObject("Scripting.FileSystemObject") 'New FileSystemObject '创建 FSO 对象的一个实例
    Set Drv = Fso.GetDrive(Drive) '得到 Drv 对象的实例
    
    If Drv.IsReady Then
        FreeSpace = Drv.FreeSpace
    End If
    
    Set Fso = Nothing
    Set Drv = Nothing
  End Function


'获取驱动器文件系统类型，Drive = 盘符 A ,C, D ...
  Function FsType(Drive As String) As String
    Dim Fso, Drv
    Set Fso = CreateObject("Scripting.FileSystemObject") 'New FileSystemObject '创建 FSO 对象的一个实例
    Set Drv = Fso.GetDrive(Drive) '得到 Drv 对象的实例
    
    If Drv.IsReady Then
      FsType = Drv.FileSystem
    Else
      FsType = ""
    End If
    
    Set Fso = Nothing
    Set Drv = Nothing
  End Function


 
  '4，获取系统文件夹路径：
  '返回 Windows 文件夹路径
  Function GetWindir()
  Dim Fso As New FileSystemObject
  GetWindir = Fso.GetSpecialFolder(WindowsFolder)
  Set Fso = Nothing
  End Function
  '返回 Windows\System 文件夹路径
  Function GetWinSysdir()
  Dim Fso As New FileSystemObject
  GetWinSysdir = Fso.GetSpecialFolder(SystemFolder)
  Set Fso = Nothing
  End Function
 ' 5，综合运用：一个文件备份通用过程：
  'Filename = 文件名，Drive = 驱动器，Folder = 文件夹(一层)
  Sub BackupFile(Filename As String, Drive As String, Folder As String)
  Dim Fso As New FileSystemObject '创建 FSO 对象实例
  Dim Dest_path As String, Counter As Long
  Counter = 0
  Do While Counter < 6 '如果驱动器没准备好，继续检测。共检测 6 秒
  Counter = Counter + 1
  Call Waitfor(1) '间隔 1 秒
  If Fso.Drives(Drive).IsReady = True Then
  Exit Do
  End If
  Loop
  If Fso.Drives(Drive).IsReady = False Then '6 秒后目标盘仍未准备就绪，退出
  MsgBox " 目标驱动器 " & Drive & " 没有准备好！ ", vbCritical
  Exit Sub
  End If
  If Fso.GetDrive(Drive).FreeSpace < Fso.GetFile(Filename).Size Then
  MsgBox "目标驱动器空间太小！", vbCritical '目标驱动器空间不够，退出
  Exit Sub
  End If
  If Right(Drive, 1) <> ":" Then
  Drive = Drive & ":"
  End If
  If Left(Folder, 1) <> "\" Then
  Folder = "\" & Folder
  End If
  If Right(Folder, 1) <> "\" Then
  Folder = Folder & "\"
  End If
  Dest_path = Drive & Folder
  If Not Fso.FolderExists(Dest_path) Then '如果目标文件夹不存在，创建之
  Fso.CreateFolder Dest_path
  End If
  Fso.CopyFile Filename, Dest_path & Fso.GetFileName(Filename), True
  '拷贝，直接覆盖同名文件
  MsgBox " 文件备份完毕。", vbOKOnly
  Set Fso = Nothing
  End Sub
  Private Sub Waitfor(Delay As Single) '延时过程，Delay 单位约为 1 秒
  Dim StartTime As Single
  StartTime = Timer
  Do Until (Timer - StartTime) > Delay
  Loop
  End Sub