moduleapi.bas

FAT硬盘格式读写程序,希望能有所裨益.

  '//按绝对地址来读磁盘数据，要求绝对地址满足512字节的倍数，否则会出错
Public Function ReadDiskbyPos(db() As Byte, ByVal dStartPos As Double, ByVal lReadBytes As Long) As Boolean
  
    Dim lPosLow As Long
    Dim lPosHigh As Long
    Dim lRead As Long
    lPosHigh = Int(dStartPos / OFFSET_4)
    lPosLow = UnsignedToLong(dStartPos - lPosHigh * OFFSET_4)
'    iPos = Cylinders * Tracks * lBufferSize
'    lBufferSize = lReadBytes
    If SeekAbsolute(lPosHigh, lPosLow) Then
        ReadDiskbyPos = ReadBytes(lReadBytes, db(), lRead)
    End If
End Function
'//按绝对地址来写磁盘数据，要求绝对地址满足512字节的倍数，否则会出错
Public Function WriteDiskbyPos(ByVal dStartPos As Double, ByVal lWriteBytes As Long, db() As Byte) As Boolean

    Dim lPosLow As Long
    Dim lPosHigh As Long
    Dim lWrite As Long
    lPosHigh = Int(dStartPos / OFFSET_4)
    lPosLow = UnsignedToLong(dStartPos - lPosHigh * OFFSET_4)
    
    If SeekAbsolute(lPosHigh, lPosLow) Then
        WriteDiskbyPos = WriteBytes(lWriteBytes, db())
    End If
End Function
Public Function UnsignedToLong(Value As Double) As Long
        If Value < 0 Or Value >= OFFSET_4 Then Error 6
        If Value <= MAXINT_4 Then
          UnsignedToLong = Value
        Else
          UnsignedToLong = Value - OFFSET_4
        End If
      End Function
Public Function WriteDisk(ByVal Cylinders As Long, ByVal Tracks As Long, db() As Byte) As Boolean
    '//按柱面和磁道来写磁盘数据
    Dim iPos As Long
    Dim lRead As Long
    
    iPos = Cylinders * Tracks * lBufferSize
    
    If SeekAbsolute(0, iPos) Then
        WriteDisk = WriteBytes(lBufferSize, db())
    End If
End Function
'/////////////////////////////////////////////////////////////////////////////////////
'//file system

Private Function SeekAbsolute(ByVal HighPos As Long, ByVal LowPos As Long) As Boolean
'//seek file查找文件定读写位置
'//Notice: when you set LowPos=5, the read/write will begin with the 6th(LowPos+1) byte
LowPos = SetFilePointer(hDisk, LowPos, VarPtr(HighPos), FILE_BEGIN)
If LowPos = -1 Then
  SeekAbsolute = (Err.LastDllError = ERROR_SUCCESS)
Else
  SeekAbsolute = True
End If
End Function
Private Function ReadBytes(ByVal ByteCount As Long, ByRef DataBytes() As Byte, ByRef ActuallyReadByte As Long) As Boolean
'//read data to array
Dim RetVal As Long
RetVal = ReadFile(hDisk, DataBytes(0), ByteCount, ActuallyReadByte, 0)
'ActuallyReadByte =>> if the bytesRead=0 mean EOF
ReadBytes = Not (RetVal = 0)

End Function

Private Function WriteBytes(ByVal ByteCount As Long, ByRef DataBytes() As Byte) As Boolean
'//write data from array
Dim RetVal As Long
Dim BytesToWrite As Long
Dim BytesWritten As Long

RetVal = WriteFile(hDisk, DataBytes(0), ByteCount, BytesWritten, 0)

WriteBytes = Not (RetVal = 0)
End Function

Public Function SynBrowseForFolder(ByVal lngwHandle As Long, ByVal strTitle As String) As String
On Error Resume Next
        
    Dim BI    As BROWSEINFO
     Dim lPid  As Long
     Dim sPath As String
     Dim iPos  As Integer
    
     Dim lPidlRoot As ITEMIDLIST
     Call SHGetFolderLocation(lngwHandle, CSIDL_DESKTOP, 0&, 0&, lPidlRoot)
     
     'Fill in the required members for the browse
     With BI
        .hOwner = lngwHandle
       .pidlRoot = lPidlRoot.mkid.cb '0&
       .pszDisplayName = Space$(MAX_PATH)
       .lpszTitle = strTitle
       .ulFlags = BIF_RETURNONLYFSDIRS Or BIF_NEWDIALOGSTYLE Or BIF_STATUSTEXT Or BIF_EDITBOX Or BIF_VALIDATE     '  '这个参数就是有一个新建文件夹按钮
     End With
    
     'show the browse dialog
     lPid = SHBrowseForFolder(BI)
     Dim flName As String
     If InStr(1, Trim(BI.pszDisplayName), "?") Then
        flName = ""
    Else
        If lPid <> 0 Then
          'got a pidl .. but is it valid?
          sPath = Space$(MAX_PATH)
          If SHGetPathFromIDList(ByVal lPid, ByVal sPath) Then
            'valid, so get the share path
            iPos = InStr(sPath, Chr$(0))
            flName = Left$(sPath, iPos - 1)
            If Len(flName) = 3 Then
                flName = Left(flName, 2)
            End If
          End If
        Else
          'a server selected...add \\ because it's a unc path
          flName = "\\" & Trim(BI.pszDisplayName)
          If flName = "\\" Then
             flName = ""
          End If
        End If
    End If
    SynBrowseForFolder = flName
    Call CoTaskMemFree(lPid)
End Function


Function GetDlgRtnFileName(ByVal iAction As Integer, vOpenFile As OPENFILENAME, ByVal hWndOw As Long, ByVal sFilter As String, _
                           ByVal sTitle As String, ByVal DefExt As String, ByVal InitFileName As String) As String '用API函数获得打开对话框和保存对话框返回的文件名

         Dim lReturn As Long
         
         vOpenFile.lStructSize = Len(vOpenFile)
         vOpenFile.hwndOwner = hWndOw 'Form1.hwnd
         vOpenFile.hInstance = App.hInstance

         vOpenFile.lpstrFilter = sFilter
         vOpenFile.nFilterIndex = 1
         If iAction = 2 Then
            vOpenFile.lpstrFile = InitFileName & String((257 - Len(InitFileName)), 0)
         Else
            vOpenFile.lpstrFile = String(257, 0)
         End If
         vOpenFile.nMaxFile = Len(vOpenFile.lpstrFile) - 1
         vOpenFile.lpstrFileTitle = vOpenFile.lpstrFile
         vOpenFile.nMaxFileTitle = vOpenFile.nMaxFile
         vOpenFile.lpstrInitialDir = "C:\"
         vOpenFile.lpstrTitle = sTitle '"使用对话框API而不是控件" '"Use the Comdlg API not the OCX"
         vOpenFile.flags = 2
         vOpenFile.lpstrDefExt = DefExt
         Select Case iAction
                Case DLG_SHOWOPEN
                     lReturn = GetOpenFileName(vOpenFile)
                Case DLG_SHOWSAVE
                     lReturn = GetSaveFileName(vOpenFile)
                Case Else   'unknown action
                     Exit Function
         End Select

         If lReturn = 0 Then
            GetDlgRtnFileName = "Cancel" 'MsgBox "用户按下Cancel按钮" '"The User pressed the Cancel Button"
         Else
            GetDlgRtnFileName = Trim(Left(vOpenFile.lpstrFile, InStr(1, vOpenFile.lpstrFile, Chr$(0), vbBinaryCompare) - 1))

         End If
End Function
 Sub Create_File(FileName As String, ArrayByte() As Byte, lWriteNum As Long)

Dim i As Long ', j As Long
Dim Pointer As Long                           '返回写入文件的指针位置
Dim fHandle As Long                           '文件被打开的句柄
Dim fSuccess As Long                          '函数返回量
Dim lBytesWritten As Long                     '接收实际写入的字节数

Dim lStr As Long

 '以下一句为创建一个文件
fHandle = CreateFile(FileName, GENERIC_WRITE Or GENERIC_READ, _
                         FILE_SHARE_READ Or FILE_SHARE_WRITE, 0, OPEN_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0) '

If fHandle <> INVALID_HANDLE_VALUE Then                         '打开成功开始处理
   Pointer = SetFilePointer(fHandle, 0, 0, FILE_END)            '设置写入位置'FILE_BEGIN

'       lStr = oList.GetTextLen(i)

   fSuccess = WriteFile(fHandle, ArrayByte(0), lWriteNum, lBytesWritten, 0)
   fSuccess = FlushFileBuffers(fHandle)
   SetEndOfFile fHandle
   fSuccess = CloseHandle(fHandle)
    
End If

 End Sub
 Public Function getPrivileges(hhToken As Long, ByVal sPrivilegeName As String) As Boolean
         Dim hProcessID As Long         ' Handle to your sample
                                        ' process you are going to
                                        ' terminate.
         Dim hProcess As Long           ' Handle to your current process
                                        ' (Term02.exe).
         Dim hToken As Long             ' Handle to your process token.
         Dim lPrivilege As Long         ' Privilege to enable/disable
         Dim iPrivilegeflag As Boolean  ' Flag whether to enable/disable
                                        ' the privilege of concern.
         Dim lResult As Long            ' Result call of various APIs.

         getPrivileges = False
         'hProcessID = ApplicationPID

         ' get our current process handle
         hProcess = GetCurrentProcess


         lResult = OpenProcessToken(hProcess, TOKEN_ADJUST_PRIVILEGES Or _
                                   TOKEN_QUERY, hToken)


         If (lResult = 0) Then
                                 
            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