H
huwei1118
Unregistered / Unconfirmed
GUEST, unregistred user!
这是一个有关控制磁带机读写及备份的单元,没有重要注释,无奈小弟水平有限,寻作者或高手,希望能给解释一下,给出用法及用例,及重要函数的说明。
unit U_TapeManage;
interface
uses
Types, Windows, Classes, SysUtils, ComCtrls, IdGlobal, Forms,
messages;
const
ToltalMsgA = WM_User + 2001;
StepMsgA = WM_User + 2002;
ShowMsgA = WM_User + 2003;
FILE_begin
= 0;
FILE_CURRENT = 1;
FILE_END = 2;
TIME_ZONE_ID_INVALID = $FFFFFFFF;
WAIT_FAILED = $FFFFFFFF;
TAPE_ABSOLUTE_POSITION = $0 ;
TAPE_LOGICAL_POSITION = $1 ;
TAPE_PSEUDO_LOGICAL_POSITION = $2 ;
FILE_FLAG_WRITE_THROUGH = $80000000;
FILE_FLAG_OVERLAPPED = $40000000;
FILE_FLAG_NO_BUFFERING = $20000000;
FILE_FLAG_RANDOM_ACCESS = $10000000;
FILE_FLAG_SEQUENTIAL_SCAN = $08000000;
FILE_FLAG_DELETE_ON_CLOSE = $04000000;
FILE_FLAG_BACKUP_SEMANTICS = $02000000;
FILE_FLAG_POSIX_SEMANTICS = $01000000;
FILE_FLAG_OPEN_REPARSE_POINT = $00200000;
FILE_FLAG_OPEN_NO_RECALL = $00100000;
CREATE_NEW = 1;
CREATE_ALWAYS = 2;
OPEN_EXISTING = 3;
OPEN_ALWAYS = 4;
TRUNCATE_EXISTING = 5;
PROGRESS_CONTINUE = 0;
PROGRESS_CANCEL = 1;
PROGRESS_STOP = 2;
PROGRESS_QUIET = 3;
CALLBACK_CHUNK_FINISHED = $00000000;
CALLBACK_STREAM_SWITCH = $00000001;
//
// Define CopyFileEx option flags
//
COPY_FILE_FAIL_IF_EXISTS = $00000001;
COPY_FILE_RESTARTABLE = $00000002;
COPY_FILE_OPEN_SOURCE_FOR_WRITE = $00000004;
PIPE_ACCESS_INBOUND = $00000001;
PIPE_ACCESS_OUTBOUND = $00000002;
PIPE_ACCESS_DUPLEX = $00000003;
PIPE_CLIENT_END = $00000000;
PIPE_SERVER_END = $00000001;
PIPE_WAIT = $00000000;
PIPE_NOWAIT = $00000001;
PIPE_READMODE_BYTE = $00000000;
PIPE_READMODE_MESSAGE = $00000002;
PIPE_TYPE_BYTE = $00000000;
PIPE_TYPE_MESSAGE = $00000004;
PIPE_UNLIMITED_INSTANCES = 255;
TAPE_INITIATOR_PARTITIONS = $2 ;
TAPE_ERASE_SHORT = $0 ;
TAPE_ERASE_LONG = $1 ;
TAPE_LOAD = $0 ;
TAPE_UNLOAD = $1 ;
TAPE_TENSION = $2 ;
TAPE_LOCK = $3 ;
TAPE_UNLOCK = $4 ;
TAPE_FORMAT = $5 ;
SECURITY_CONTEXT_TRACKING = $00040000;
SECURITY_EFFECTIVE_ONLY = $00080000;
SECURITY_SQOS_PRESENT = $00100000;
SECURITY_VALID_SQOS_FLAGS = $001F0000;
TAPE_REWIND = $0 ;
TAPE_ABSOLUTE_BLOCK = $1 ;
TAPE_LOGICAL_BLOCK = $2 ;
TAPE_PSEUDO_LOGICAL_BLOCK = $3 ;
TAPE_SPACE_END_OF_DATA = $4 ;
TAPE_SPACE_RELATIVE_BLOCKS = $5 ;
TAPE_SPACE_FILEMARKS = $6 ;
TAPE_SPACE_SEQUENTIAL_FMKS = $7 ;
TAPE_SPACE_SETMARKS = $8 ;
TAPE_SPACE_SEQUENTIAL_SMKS = $9 ;
Tape_No_Device = $100;
Tape_Ready = $200;
Tape_Working = $400;
Tape_Read = $800;
Tape_Write = $1000;
type
OVERLAPPED = packed record
Internal: DWORD;
InternalHigh: DWORD;
Offset: DWORD;
OffsetHigh: DWORD;
hEvent: THANDLE;
end;
LPOVERLAPPED = ^OVERLAPPED;
SECURITY_ATTRIBUTES = packed record
nLength: DWORD;
lpSecurityDescriptor: integer;
bInheritHandle: BOOL;
end;
PSECURITY_ATTRIBUTES = ^SECURITY_ATTRIBUTES;
LPSECURITY_ATTRIBUTES = ^SECURITY_ATTRIBUTES;
PROCESS_INFORMATION = packed record
hProcess: THANDLE;
hThread: THANDLE;
dwProcessId: DWORD;
dwThreadId: DWORD;
end;
PPROCESS_INFORMATION = ^PROCESS_INFORMATION;
LPPROCESS_INFORMATION = ^PROCESS_INFORMATION;
FILETIME = packed record
dwLowDateTime: DWORD;
dwHighDateTime: DWORD;
end;
PFILETIME = ^FILETIME;
LPFILETIME = ^FILETIME;
TAPE_SET_POSITION = packed record
Method: DWORD;
Partition: DWORD;
Offset: LARGE_INTEGER;
Immediate: BOOLEAN;
end;
pTAPE_SET_POSITION = ^PTAPE_SET_POSITION;
//
// System time is represented with the following structure:
//
SYSTEMTIME = packed record
wYear: WORD;
wMonth: WORD;
wDayOfWeek: WORD;
wDay: WORD;
wHour: WORD;
wMinute: WORD;
wSecond: WORD;
wMilliseconds: WORD;
end;
PSYSTEMTIME = ^SYSTEMTIME;
LPSYSTEMTIME = ^SYSTEMTIME;
pGET_MEDIA_PARAMETERS = ^GET_MEDIA_PARAMETERS;
GET_MEDIA_PARAMETERS = packed record
Capacity: LARGE_INTEGER;
Remaining: LARGE_INTEGER;
BlockSize: DWORD;
PartitionCount: DWORD;
WriteProtected: BOOLEAN;
end;
GET_DRIVE_PARAMETERS = packed record
ECC: BOOLEAN;
Compression: BOOLEAN;
DataPadding: BOOLEAN;
ReportSetmarks: BOOLEAN;
DefaultBlockSize: DWORD;
MaximumBlockSize: DWORD;
MinimumBlockSize: DWORD;
MaximumPartitionCount: DWORD;
FeaturesLow: DWORD;
FeaturesHigh: DWORD;
EOTWarningZoneSize: DWORD;
end;
pGET_DRIVE_PARAMETERS = ^GET_DRIVE_PARAMETERS;
APEFILEINFO = packed record
FileName: string[116];
//116字节
FileLength: DWORD;
//4字节
StartPosition: int64;
//8字节
WriteTime: TDateTime;
end;
type
TOnChangeFileName = procedure(sFile: string) of object;
TWorkType = (wtNormal, wtWrite, wtRead, wtDoWrite, wtInit);
TManageTheard = class(TThread)
//private
public
FCurFile: string;
FCurIndex: integer;
procedure WriteFile2Tape;
procedure RestoreFile2Disk;
constructor create;
procedure Execute;
override;
end;
TTapeManage = class
//private
public
FTapeTotalContent: Int64;
FileInfo: array[0..999] of APEFILEINFO;
TapeHWND: HWND;
fTapeOpen: boolean;
fTapeLoad: boolean;
fWorking: boolean;
fGetState: boolean;
FIndex: integer;
thMng: TManageTheard;
FWorkType: TWorkType;
FWorkList: array of string;
FWorkCount: integer;
FWorkFile: TStringList;
Mparameters: GET_MEDIA_PARAMETERS;
FMsgHandle: HWND;
FMsgHdle: HWND;
FToltalMsg: UINT;
FStepMsg: UINT;
FShowMsg: UINT;
procedure First;
procedure SetDevicePos(nPos: Int64);
procedure WriteFileA(sFile: string);
procedure GetMadiaparameters;
function initialize: boolean;
procedure WriteTail;
function GetCutrrentUseContent: int64;
procedure GetStateText;
proceduredo
AddFile(fList: TStrings);
procedure InitD;
procedure ShowNoDevice;
constructor create;
destructor destroy;
override;
procedure init;
procedure InitDevice;
function CheckDeviceFreeSize(fList: TStrings): boolean;
procedure AddFile(fList: TStrings);
procedure AppendFile(sFile: string);
procedure GetFileList(bAbsRead: boolean = false);
procedure RestoreFile(sFile: string;
Index: integer);
procedure GetFileList2LV(var fLV: TListView);
procedure RestoreFiles(sPath: string;
IDS: TStrings);
procedure SetProgressMsg(hnd: HWND;
ToltalMsg, StepMsg, ShowMsg: UINT);
property Working: boolean read fWorking write fWorking;
end;
var
TapeMng: TTapeManage;
implementation
//uses U_DefaultValue;
{ TTapeManage }
procedure TTapeManage.AddFile(fList: TStrings);
var
i: integer;
iSize, sCount: int64;
begin
if not fTapeOpen or not fTapeLoad then
ShowNoDevice;
//if fWorking then
exit;
FWorking := true;
FWorkFile.Text := fList.Text;
{GetStateText;
if not CheckDeviceFreeSize(fList) then
begin
Application.MessageBox('磁带机空间不够!'#13'或写保护没有打开!'#13'减少要备份的文件或打开写保护后再试。 ', '系统提示');
FWorking := false;
exit;
end;
FWorkList := nil;
sCount := 0;
FWorkCount := 0;
FIndex := -1;
for i := 0 to 999do
begin
if (FileInfo.FileName = 'END') or (FileInfo.FileLength = 0) then
begin
FIndex := i;
break;
end;
end;
if Findex > -1 then
SetDevicePos(FileInfo[FIndex].StartPosition)
else
begin
First;
Findex := 0;
end;
for i := 0 to fList.Count - 1do
begin
iSize := FileSizeByName(fList.Strings);
if iSize < 1024 then
continue;
//小于1K就不写
inc(sCount, iSize);
inc(FWorkCount);
SetLength(FWorkList, FWorkCount);
FWorkList[FWorkCount - 1] := fList.Strings;
end;
if FToltalMsg <> 0 then
begin
SendMessage(FMsgHdle, FToltalMsg, sCount div 1024, 0);
end;
}
FWorkType := wtDoWrite;
end;
procedure TTapeManage.AppendFile(sFile: string);
var
Index: integer;
iPos: int64;
n: DWORD;
begin
Index := FIndex;
if Index = -1 then
exit;
iPos := FileInfo[Index].StartPosition;
FileInfo[Index].FileName := sFile;
FileInfo[Index].FileLength := FileSizeByName(sFile);
FileInfo[Index].WriteTime := now;
//FileInfo[Index].StartPosition := 500 + iPos + FileInfo[Index].FileLength;
FileInfo[Index + 1].StartPosition := 500 + iPos + FileInfo[Index].FileLength;
FileInfo[Index + 1].FileLength := 0;
FileInfo[Index + 1].FileName := 'END';
n := (FileInfo[Index + 1].StartPosition div 500);
if n * 500 < FileInfo[Index + 1].StartPosition then
Inc;
FileInfo[Index + 1].StartPosition := n * 500;
//SetDevicePos(iPos);
n := 0;
if FileInfo[Index].StartPosition = 0 then
n := 10;
WriteFile(TapeHWND, FileInfo[Index], Sizeof(APEFILEINFO), n, nil);
WriteFileA(sFile);
Inc(FIndex);
GetStateText;
//iPos := FileInfo[Index + 1].StartPosition;
//SetDevicePos(iPos);
//n := 0;
//WriteFile(TapeHWND, FileInfo[Index + 1], Sizeof(APEFILEINFO), n, nil);
end;
function TTapeManage.CheckDeviceFreeSize(fList: TStrings): boolean;
var
i: integer;
iLen, iSize: int64;
begin
Result := false;
iLen := 0;
for i := 0 to fList.Count - 1do
begin
iSize := FileSizeByName(fList.Strings);
//if iSize &lt;
1024 then
Continue;
inc(iLen, iSize);
end;
for i := 0 to 999do
begin
if FileInfo.FileLength > 0 then
Inc(iLen, FileInfo.FileLength)
else
break;
end;
i := 0;
while i < 10do
begin
if FTapeTotalContent = 0 then
GetMadiaparameters
else
break;
inc(i);
end;
if FTapeTotalContent < iLen then
exit;
if Mparameters.WriteProtected then
exit;
Result := true;
end;
constructor TTapeManage.create;
begin
FWorkFile := TStringList.Create;
fGetState := false;
fTapeOpen := false;
fTapeLoad := false;
FMsgHandle := 0;
FMsgHdle := 0;
FToltalMsg := 0;
FStepMsg := 0;
FShowMsg := 0;
FTapeTotalContent := 0;
fWorking := false;
FillChar(FileInfo, Sizeof(FileInfo), 0);
TapeHWND := CreateFile('//./TAPE0', GENERIC_READ + GENERIC_WRITE, FILE_SHARE_READ +
FILE_SHARE_WRITE, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
fTapeOpen := TapeHWND <> INVALID_HANDLE_VALUE;
end;
destructor TTapeManage.destroy;
begin
thMng.Terminate;
Closehandle(TapeHWND);
FWorkFile.Free;
inherited;
end;
procedure TTapeManage.DoAddFile(fList: TStrings);
var
i: integer;
iSize, sCount: int64;
begin
if fWorking then
exit;
FWorking := true;
GetStateText;
{if not CheckDeviceFreeSize(fList) then
begin
Application.MessageBox('磁带机空间不够!'#13'或写保护没有打开!'#13'减少要备份的文件或打开写保护后再试。 ', '系统提示');
FWorking := false;
exit;
end;
}
if not CheckDeviceFreeSize(fList) then
begin
Application.MessageBox('The space available on tape is not enough!'#13'or writting is locked!'#13'Please reduce the size of file(s) to be backed up or unlock for writting! ', 'Caution');
FWorking := false;
exit;
end;
FWorkList := nil;
sCount := 0;
FWorkCount := 0;
FIndex := -1;
FileInfo[0].StartPosition := 0;
for i := 0 to 999do
begin
if (FileInfo.FileName = 'END') or (FileInfo.FileLength = 0) then
begin
FIndex := i;
break;
end;
end;
if Findex > -1 then
SetDevicePos(FileInfo[FIndex].StartPosition)
else
begin
First;
Findex := 0;
end;
for i := 0 to fList.Count - 1do
begin
iSize := FileSizeByName(fList.Strings);
if iSize < 1024 then
continue;
//小于1K就不写
inc(sCount, iSize);
inc(FWorkCount);
SetLength(FWorkList, FWorkCount);
FWorkList[FWorkCount - 1] := fList.Strings;
end;
//if FToltalMsg &lt;&gt;
0 then
//begin
SendMessage(FMsgHdle, ToltalMsgA, sCount div 1024, 0);
//end;
FWorkType := wtWrite;
end;
procedure TTapeManage.First;
begin
SetTapePosition(TapeHWND, TAPE_ABSOLUTE_BLOCK, 0, 0, 0, FALSE);
end;
function TTapeManage.GetCutrrentUseContent: int64;
var
i: integer;
begin
Result := 0;
for i := 0 to 999do
begin
if FileInfo.FileLength = 0 then
exit;
inc(Result, FileInfo.FileLength);
end;
end;
procedure TTapeManage.GetFileList(bAbsRead: boolean);
var
iCount, i: integer;
cRead: DWord;
iPos: int64;
begin
iCount := 0;
for i := 0 to 999do
if FileInfo.FileLength > 0 then
inc(iCount)
else
break;
if not bAbsRead and (iCount > 0) then
exit;
First;
iCount := 0;
while truedo
begin
cRead := 0;
ReadFile(TapeHWND, FileInfo[iCount], Sizeof(APEFILEINFO), cRead, nil);
if (cRead = 0) or ((FileInfo[iCount].FileName = 'END') and (FileInfo[iCount].FileLength = 0)) then
begin
cRead := GetLastError;
if cRead = ERROR_NO_DATA_DETECTED then
begin
FileInfo[iCount - 1].FileLength := 0;
FileInfo[iCount - 1].FileName := 'END';
end;
break;
end;
iPos := FileInfo[iCount].StartPosition + FileInfo[iCount].FileLength + 500;
inc(iCount);
SetDevicePos(iPos);
end;
if iCount = 0 then
InitDevice
else
FileInfo[iCount].StartPosition := FileInfo[iCount - 1].StartPosition + FileInfo[iCount - 1].FileLength + 500
end;
procedure TTapeManage.GetFileList2LV(var fLV: TListView);
var
i: integer;
cItem: TListItem;
begin
fLV.Clear;
for i := 0 to 999do
begin
if FileInfo.FileLength = 0 then
exit;
cItem := fLV.Items.Add;
cItem.Caption := ExtractFileName(FileInfo.FileName);
cItem.SubItems.Add(format('%.0n', [round(FileInfo.FileLength / 1024) * 1.0]));
cItem.SubItems.Add(FormatDateTime('yyyy-mm-dd hh:nn:ss', FileInfo.WriteTime));
end;
end;
procedure TTapeManage.GetMadiaparameters;
var
i: integer;
BlockSize: Cardinal;
begin
if fGetState then
exit;
fGetState := true;
BlockSize := 0;
i := 12;
while i <> NO_ERRORdo
begin
i := GetTapeParameters(TapeHWND, GET_TAPE_MEDIA_INFORMATION, BlockSize, @Mparameters);
inc(BlockSize);
if BlockSize > 1000 then
exit;
end;
FTapeTotalContent := Mparameters.Capacity.QuadPart;
fGetState := false;
end;
procedure TTapeManage.GetStateText;
var
i: int64;
i1: integer;
ss: string;
begin
ss := '';
i := 0;
if not fTapeOpen then
i := Tape_No_Device;
if fTapeLoad then
i := i or Tape_Ready or Tape_Read;
if fWorking then
i := i or Tape_Working;
i1 := 0;
while i1 < 10do
begin
if FTapeTotalContent = 0 then
GetMadiaparameters
else
break;
inc(i1);
end;
if not Mparameters.WriteProtected and fTapeLoad then
i := i or Tape_Write;
ss := Inttostr(i) + '^' + Inttostr(GetCutrrentUseContent) + '^' + inttostr(FTapeTotalContent);
//if FShowMsg &lt;&gt;
0 then
SendMessage(FMsgHdle, ShowMsgA, integer(pInteger(pChar(ss))), -1);
end;
procedure TTapeManage.init;
begin
thMng := TManageTheard.create;
end;
procedure TTapeManage.InitD;
var
n: DWORD;
begin
FillChar(FileInfo, Sizeof(FileInfo), 0);
FileInfo[0].StartPosition := 0;
FileInfo[0].FileName := 'END';
CreateTapePartition(TapeHWND, TAPE_INITIATOR_PARTITIONS, 1, 500);
WriteFile(TapeHWND, FileInfo[0], Sizeof(APEFILEINFO), n, nil);
fWorking := false;
GetStateText;
end;
procedure TTapeManage.InitDevice;
begin
if not fTapeOpen or not fTapeLoad then
ShowNoDevice;
fWorking := true;
GetStateText;
FWorkType := wtInit;
end;
function TTapeManage.initialize: boolean;
var
i: integer;
begin
Result := false;
i := 0;
//fGetState := true;
while truedo
begin
if PrepareTape(TapeHWND, TAPE_LOAD, false) = NOERROR then
break;
inc(i);
if i > 10 then
exit;
end;
fGetState := false;
fTapeLoad := true;
GetMadiaparameters;
GetFileList(true);
Result := true;
end;
procedure TTapeManage.RestoreFile(sFile: string;
Index: integer);
var
rFile, rLen: integer;
iPos, iLen: int64;
cBuf: array[0..499] of byte;
rRead: DWORD;
sMsg: string;
begin
//如果还原空间不够的话,需要提示
{if DiskFree(ord(sFile[1]) - 64) &lt;
FileInfo[Index].FileLength then
begin
application.MessageBox('还原空间不够!'#13'请清除数据或更换还原空间后再试!', '系统提示');
exit;
end;
}
if DiskFree(ord(sFile[1]) - 64) < FileInfo[Index].FileLength then
begin
application.MessageBox('The space for restoring is not enough!'#13'Please delete some files in destination or redirect to another destination!', 'Caution');
exit;
end;
//iPos := FileInfo[Index].StartPosition + 500;
IPos := 0;
SetDevicePos(iPos);
//if FShowMsg &lt;&gt;
0 then
//begin
sMsg := ExtractFileName(FileInfo[Index].FileName) + ' ----&gt;
' + sFile;
SendMessage(FMsgHdle, ShowMsgA, integer(pInteger(pChar(sMsg))), 0);
//end;
//if FStepMsg &lt;&gt;
0 then
SendMessage(FMsgHdle, StepMsgA, FileInfo[Index].FileLength, 0);
rFile := FileCreate(sFile);
iLen := 0;
rLen := 500;
while iLen < FileInfo[Index].FileLengthdo
begin
if rLen + iLen > FileInfo[Index].FileLength then
rLen := FileInfo[Index].FileLength - iLen;
rRead := 0;
if not ReadFile(TapeHWND, cBuf[0], rLen, rRead, nil) then
begin
rRead := GetLastError;
if rRead <> 0 then
break;
end;
FileWrite(rFile, cBuf[0], rRead);
inc(iLen, rRead);
//if FStepMsg &lt;&gt;
0 then
PostMessage(FMsgHdle, StepMsgA, FileInfo[Index].FileLength, iLen);
//if FToltalMsg &lt;&gt;
0 then
PostMessage(FMsgHdle, ToltalMsgA, -1, rRead);
end;
FileClose(rFile);
//if FStepMsg &lt;&gt;
0 then
SendMessage(FMsgHdle, StepMsgA, FileInfo[Index].FileLength, FileInfo[Index].FileLength);
GetStateText;
end;
procedure TTapeManage.RestoreFiles(sPath: string;
IDS: TStrings);
var
i: integer;
sCount: int64;
begin
if not fTapeOpen or not fTapeLoad then
ShowNoDevice;
if fWorking then
exit;
fWorking := true;
GetStateText;
FWorkCount := IDS.Count;
SetLength(FWorkList, FWorkCount);
sCount := 0;
for i := 0 to FWorkCount - 1do
begin
FWorkList := sPath + '^' + IDS.Strings;
Inc(sCount, FileInfo[strtoint(IDS.Strings)].FileLength);
end;
//if FToltalMsg &lt;&gt;
0 then
SendMessage(FMsgHdle, ToltalMsgA, sCount div 1024, 0);
FWorkType := wtRead;
end;
procedure TTapeManage.SetDevicePos(nPos: Int64);
var
nLow, nhigh, TapeStatus: Cardinal;
cPos: int64;
begin
cPos := round(nPos / 500);
if cPos * 500 < nPos then
inc(cPos);
nLow := cPos and $FFFFFFFF;
nHigh := cPos shr 32 and $FFFFFFFF;
TapeStatus := SetTapePosition(TapeHWND, TAPE_ABSOLUTE_BLOCK, 0, nLow, nhigh, FALSE);
if TapeStatus <> NOERROR then
begin
//显示一个信息
//Application.MessageBox('定位到磁带机不成功!', pchar(MSG_TITLE));
//Abort;
end;
end;
procedure TTapeManage.SetProgressMsg(hnd: HWND;
ToltalMsg, StepMsg,
ShowMsg: UINT);
begin
FMsgHandle := hnd;
FMsgHdle := hnd;
FToltalMsg := ToltalMsg;
FStepMsg := StepMsg;
FShowMsg := ShowMsg;
//GetStateText;
end;
procedure TTapeManage.ShowNoDevice;
begin
application.MessageBox('No Tape or Tape can''t used!'#13'Please Check it and try agin.', 'sdfs'{pchar(MSG_TITLE)});
abort;
end;
procedure TTapeManage.WriteFileA(sFile: string);
var
cBuf: array[0..499] of byte;
fSize, wPos: int64;
wLen, wFile: integer;
n: Dword;
sMsg: string;
begin
//if FShowMsg &lt;&gt;
0 then
//begin
sMsg := sFile;
SendMessage(FMsgHdle, ShowMsgA, integer(pinteger(pChar(sMsg))), 0);
//end;
fSize := FileSizeByName(sFile);
//if FStepMsg &lt;&gt;
0 then
SendMessage(FMsgHdle, StepMsgA, fSize, 0);
wFile := FileOpen(sFile, fmOpenRead or fmShareDenyNone);
wPos := 0;
while wPos < fSizedo
begin
wLen := 500;
if wLen + wPos > fSize then
wLen := fSize - wPos;
Fileread(wFile, cBuf[0], wLen);
WriteFile(TapeHWND, cBuf[0], wLen, n, nil);
inc(wPos, wLen);
//if FStepMsg &lt;&gt;
0 then
PostMessage(FMsgHdle, StepMsgA, fSize, wPos);
//if FToltalMsg &lt;&gt;
0 then
PostMessage(FMsgHdle, ToltalMsgA, -1, wLen);
end;
FileClose(wFile);
//if FStepMsg &lt;&gt;
0 then
SendMessage(FMsgHdle, StepMsgA, fSize, fSize);
end;
procedure TTapeManage.WriteTail;
var
n: DWORD;
begin
n := 0;
WriteFile(TapeHWND, FileInfo[FIndex], Sizeof(APEFILEINFO), n, nil);
end;
{ TManageTheard }
constructor TManageTheard.create;
begin
inherited Create(false);
FreeOnTerminate := true;
end;
procedure TManageTheard.Execute;
var
i: integer;
begin
{ TapeMng.Working := true;
TapeMng.initialize;
TapeMng.Working := false;
TapeMng.GetStateText;
while not Terminateddo
begin
if not TapeMng.Working then
TapeMng.FWorkType := wtNormal;
case TapeMng.FWorkType of
wtNormal:
begin
sleep(20);
continue;
end;
wtWrite, wtRead:
begin
for i := 0 to TapeMng.FWorkCount - 1do
begin
if Terminated then
exit;
FCurIndex := i + 1;
FCurFile := TapeMng.FWorkList;
if TapeMng.FWorkType = wtWrite then
WriteFile2Tape
else
RestoreFile2Disk;
sleep(10);
end;
if TapeMng.FWorkType = wtWrite then
TapeMng.WriteTail;
//if TapeMng.FToltalMsg &lt;&gt;
0 then
SendMessage(TapeMng.FMsgHdle, ToltalMsgA, -1, -1);
TapeMng.FWorkType := wtNormal;
TapeMng.fWorking := false;
TapeMng.GetStateText;
end;
wtDoWrite:
begin
TapeMng.FWorkType := wtNormal;
TapeMng.fWorking := false;
TapeMng.DoAddFile(TapeMng.FWorkFile);
end;
wtInit:
begin
TapeMng.InitD;
TapeMng.FWorkType := wtNormal;
TapeMng.fWorking := false;
end;
end;
end;
}
end;
procedure TManageTheard.RestoreFile2Disk;
var
sFile: string;
Index: integer;
begin
sFile := Copy(FCurFile, 1, Pos('^', FCurFile) - 1);
delete(FCurFile, 1, Pos('^', FCurFile));
Index := StrToInt(FCurFile);
sFile := sFile + 'Restore_' + ExtractFileName(TapeMng.FileInfo[Index].FileName);
TapeMng.RestoreFile(sFile, Index);
end;
procedure TManageTheard.WriteFile2Tape;
begin
TapeMng.AppendFile(FCurFile);
end;
end.
unit U_TapeManage;
interface
uses
Types, Windows, Classes, SysUtils, ComCtrls, IdGlobal, Forms,
messages;
const
ToltalMsgA = WM_User + 2001;
StepMsgA = WM_User + 2002;
ShowMsgA = WM_User + 2003;
FILE_begin
= 0;
FILE_CURRENT = 1;
FILE_END = 2;
TIME_ZONE_ID_INVALID = $FFFFFFFF;
WAIT_FAILED = $FFFFFFFF;
TAPE_ABSOLUTE_POSITION = $0 ;
TAPE_LOGICAL_POSITION = $1 ;
TAPE_PSEUDO_LOGICAL_POSITION = $2 ;
FILE_FLAG_WRITE_THROUGH = $80000000;
FILE_FLAG_OVERLAPPED = $40000000;
FILE_FLAG_NO_BUFFERING = $20000000;
FILE_FLAG_RANDOM_ACCESS = $10000000;
FILE_FLAG_SEQUENTIAL_SCAN = $08000000;
FILE_FLAG_DELETE_ON_CLOSE = $04000000;
FILE_FLAG_BACKUP_SEMANTICS = $02000000;
FILE_FLAG_POSIX_SEMANTICS = $01000000;
FILE_FLAG_OPEN_REPARSE_POINT = $00200000;
FILE_FLAG_OPEN_NO_RECALL = $00100000;
CREATE_NEW = 1;
CREATE_ALWAYS = 2;
OPEN_EXISTING = 3;
OPEN_ALWAYS = 4;
TRUNCATE_EXISTING = 5;
PROGRESS_CONTINUE = 0;
PROGRESS_CANCEL = 1;
PROGRESS_STOP = 2;
PROGRESS_QUIET = 3;
CALLBACK_CHUNK_FINISHED = $00000000;
CALLBACK_STREAM_SWITCH = $00000001;
//
// Define CopyFileEx option flags
//
COPY_FILE_FAIL_IF_EXISTS = $00000001;
COPY_FILE_RESTARTABLE = $00000002;
COPY_FILE_OPEN_SOURCE_FOR_WRITE = $00000004;
PIPE_ACCESS_INBOUND = $00000001;
PIPE_ACCESS_OUTBOUND = $00000002;
PIPE_ACCESS_DUPLEX = $00000003;
PIPE_CLIENT_END = $00000000;
PIPE_SERVER_END = $00000001;
PIPE_WAIT = $00000000;
PIPE_NOWAIT = $00000001;
PIPE_READMODE_BYTE = $00000000;
PIPE_READMODE_MESSAGE = $00000002;
PIPE_TYPE_BYTE = $00000000;
PIPE_TYPE_MESSAGE = $00000004;
PIPE_UNLIMITED_INSTANCES = 255;
TAPE_INITIATOR_PARTITIONS = $2 ;
TAPE_ERASE_SHORT = $0 ;
TAPE_ERASE_LONG = $1 ;
TAPE_LOAD = $0 ;
TAPE_UNLOAD = $1 ;
TAPE_TENSION = $2 ;
TAPE_LOCK = $3 ;
TAPE_UNLOCK = $4 ;
TAPE_FORMAT = $5 ;
SECURITY_CONTEXT_TRACKING = $00040000;
SECURITY_EFFECTIVE_ONLY = $00080000;
SECURITY_SQOS_PRESENT = $00100000;
SECURITY_VALID_SQOS_FLAGS = $001F0000;
TAPE_REWIND = $0 ;
TAPE_ABSOLUTE_BLOCK = $1 ;
TAPE_LOGICAL_BLOCK = $2 ;
TAPE_PSEUDO_LOGICAL_BLOCK = $3 ;
TAPE_SPACE_END_OF_DATA = $4 ;
TAPE_SPACE_RELATIVE_BLOCKS = $5 ;
TAPE_SPACE_FILEMARKS = $6 ;
TAPE_SPACE_SEQUENTIAL_FMKS = $7 ;
TAPE_SPACE_SETMARKS = $8 ;
TAPE_SPACE_SEQUENTIAL_SMKS = $9 ;
Tape_No_Device = $100;
Tape_Ready = $200;
Tape_Working = $400;
Tape_Read = $800;
Tape_Write = $1000;
type
OVERLAPPED = packed record
Internal: DWORD;
InternalHigh: DWORD;
Offset: DWORD;
OffsetHigh: DWORD;
hEvent: THANDLE;
end;
LPOVERLAPPED = ^OVERLAPPED;
SECURITY_ATTRIBUTES = packed record
nLength: DWORD;
lpSecurityDescriptor: integer;
bInheritHandle: BOOL;
end;
PSECURITY_ATTRIBUTES = ^SECURITY_ATTRIBUTES;
LPSECURITY_ATTRIBUTES = ^SECURITY_ATTRIBUTES;
PROCESS_INFORMATION = packed record
hProcess: THANDLE;
hThread: THANDLE;
dwProcessId: DWORD;
dwThreadId: DWORD;
end;
PPROCESS_INFORMATION = ^PROCESS_INFORMATION;
LPPROCESS_INFORMATION = ^PROCESS_INFORMATION;
FILETIME = packed record
dwLowDateTime: DWORD;
dwHighDateTime: DWORD;
end;
PFILETIME = ^FILETIME;
LPFILETIME = ^FILETIME;
TAPE_SET_POSITION = packed record
Method: DWORD;
Partition: DWORD;
Offset: LARGE_INTEGER;
Immediate: BOOLEAN;
end;
pTAPE_SET_POSITION = ^PTAPE_SET_POSITION;
//
// System time is represented with the following structure:
//
SYSTEMTIME = packed record
wYear: WORD;
wMonth: WORD;
wDayOfWeek: WORD;
wDay: WORD;
wHour: WORD;
wMinute: WORD;
wSecond: WORD;
wMilliseconds: WORD;
end;
PSYSTEMTIME = ^SYSTEMTIME;
LPSYSTEMTIME = ^SYSTEMTIME;
pGET_MEDIA_PARAMETERS = ^GET_MEDIA_PARAMETERS;
GET_MEDIA_PARAMETERS = packed record
Capacity: LARGE_INTEGER;
Remaining: LARGE_INTEGER;
BlockSize: DWORD;
PartitionCount: DWORD;
WriteProtected: BOOLEAN;
end;
GET_DRIVE_PARAMETERS = packed record
ECC: BOOLEAN;
Compression: BOOLEAN;
DataPadding: BOOLEAN;
ReportSetmarks: BOOLEAN;
DefaultBlockSize: DWORD;
MaximumBlockSize: DWORD;
MinimumBlockSize: DWORD;
MaximumPartitionCount: DWORD;
FeaturesLow: DWORD;
FeaturesHigh: DWORD;
EOTWarningZoneSize: DWORD;
end;
pGET_DRIVE_PARAMETERS = ^GET_DRIVE_PARAMETERS;
APEFILEINFO = packed record
FileName: string[116];
//116字节
FileLength: DWORD;
//4字节
StartPosition: int64;
//8字节
WriteTime: TDateTime;
end;
type
TOnChangeFileName = procedure(sFile: string) of object;
TWorkType = (wtNormal, wtWrite, wtRead, wtDoWrite, wtInit);
TManageTheard = class(TThread)
//private
public
FCurFile: string;
FCurIndex: integer;
procedure WriteFile2Tape;
procedure RestoreFile2Disk;
constructor create;
procedure Execute;
override;
end;
TTapeManage = class
//private
public
FTapeTotalContent: Int64;
FileInfo: array[0..999] of APEFILEINFO;
TapeHWND: HWND;
fTapeOpen: boolean;
fTapeLoad: boolean;
fWorking: boolean;
fGetState: boolean;
FIndex: integer;
thMng: TManageTheard;
FWorkType: TWorkType;
FWorkList: array of string;
FWorkCount: integer;
FWorkFile: TStringList;
Mparameters: GET_MEDIA_PARAMETERS;
FMsgHandle: HWND;
FMsgHdle: HWND;
FToltalMsg: UINT;
FStepMsg: UINT;
FShowMsg: UINT;
procedure First;
procedure SetDevicePos(nPos: Int64);
procedure WriteFileA(sFile: string);
procedure GetMadiaparameters;
function initialize: boolean;
procedure WriteTail;
function GetCutrrentUseContent: int64;
procedure GetStateText;
proceduredo
AddFile(fList: TStrings);
procedure InitD;
procedure ShowNoDevice;
constructor create;
destructor destroy;
override;
procedure init;
procedure InitDevice;
function CheckDeviceFreeSize(fList: TStrings): boolean;
procedure AddFile(fList: TStrings);
procedure AppendFile(sFile: string);
procedure GetFileList(bAbsRead: boolean = false);
procedure RestoreFile(sFile: string;
Index: integer);
procedure GetFileList2LV(var fLV: TListView);
procedure RestoreFiles(sPath: string;
IDS: TStrings);
procedure SetProgressMsg(hnd: HWND;
ToltalMsg, StepMsg, ShowMsg: UINT);
property Working: boolean read fWorking write fWorking;
end;
var
TapeMng: TTapeManage;
implementation
//uses U_DefaultValue;
{ TTapeManage }
procedure TTapeManage.AddFile(fList: TStrings);
var
i: integer;
iSize, sCount: int64;
begin
if not fTapeOpen or not fTapeLoad then
ShowNoDevice;
//if fWorking then
exit;
FWorking := true;
FWorkFile.Text := fList.Text;
{GetStateText;
if not CheckDeviceFreeSize(fList) then
begin
Application.MessageBox('磁带机空间不够!'#13'或写保护没有打开!'#13'减少要备份的文件或打开写保护后再试。 ', '系统提示');
FWorking := false;
exit;
end;
FWorkList := nil;
sCount := 0;
FWorkCount := 0;
FIndex := -1;
for i := 0 to 999do
begin
if (FileInfo.FileName = 'END') or (FileInfo.FileLength = 0) then
begin
FIndex := i;
break;
end;
end;
if Findex > -1 then
SetDevicePos(FileInfo[FIndex].StartPosition)
else
begin
First;
Findex := 0;
end;
for i := 0 to fList.Count - 1do
begin
iSize := FileSizeByName(fList.Strings);
if iSize < 1024 then
continue;
//小于1K就不写
inc(sCount, iSize);
inc(FWorkCount);
SetLength(FWorkList, FWorkCount);
FWorkList[FWorkCount - 1] := fList.Strings;
end;
if FToltalMsg <> 0 then
begin
SendMessage(FMsgHdle, FToltalMsg, sCount div 1024, 0);
end;
}
FWorkType := wtDoWrite;
end;
procedure TTapeManage.AppendFile(sFile: string);
var
Index: integer;
iPos: int64;
n: DWORD;
begin
Index := FIndex;
if Index = -1 then
exit;
iPos := FileInfo[Index].StartPosition;
FileInfo[Index].FileName := sFile;
FileInfo[Index].FileLength := FileSizeByName(sFile);
FileInfo[Index].WriteTime := now;
//FileInfo[Index].StartPosition := 500 + iPos + FileInfo[Index].FileLength;
FileInfo[Index + 1].StartPosition := 500 + iPos + FileInfo[Index].FileLength;
FileInfo[Index + 1].FileLength := 0;
FileInfo[Index + 1].FileName := 'END';
n := (FileInfo[Index + 1].StartPosition div 500);
if n * 500 < FileInfo[Index + 1].StartPosition then
Inc;
FileInfo[Index + 1].StartPosition := n * 500;
//SetDevicePos(iPos);
n := 0;
if FileInfo[Index].StartPosition = 0 then
n := 10;
WriteFile(TapeHWND, FileInfo[Index], Sizeof(APEFILEINFO), n, nil);
WriteFileA(sFile);
Inc(FIndex);
GetStateText;
//iPos := FileInfo[Index + 1].StartPosition;
//SetDevicePos(iPos);
//n := 0;
//WriteFile(TapeHWND, FileInfo[Index + 1], Sizeof(APEFILEINFO), n, nil);
end;
function TTapeManage.CheckDeviceFreeSize(fList: TStrings): boolean;
var
i: integer;
iLen, iSize: int64;
begin
Result := false;
iLen := 0;
for i := 0 to fList.Count - 1do
begin
iSize := FileSizeByName(fList.Strings);
//if iSize &lt;
1024 then
Continue;
inc(iLen, iSize);
end;
for i := 0 to 999do
begin
if FileInfo.FileLength > 0 then
Inc(iLen, FileInfo.FileLength)
else
break;
end;
i := 0;
while i < 10do
begin
if FTapeTotalContent = 0 then
GetMadiaparameters
else
break;
inc(i);
end;
if FTapeTotalContent < iLen then
exit;
if Mparameters.WriteProtected then
exit;
Result := true;
end;
constructor TTapeManage.create;
begin
FWorkFile := TStringList.Create;
fGetState := false;
fTapeOpen := false;
fTapeLoad := false;
FMsgHandle := 0;
FMsgHdle := 0;
FToltalMsg := 0;
FStepMsg := 0;
FShowMsg := 0;
FTapeTotalContent := 0;
fWorking := false;
FillChar(FileInfo, Sizeof(FileInfo), 0);
TapeHWND := CreateFile('//./TAPE0', GENERIC_READ + GENERIC_WRITE, FILE_SHARE_READ +
FILE_SHARE_WRITE, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
fTapeOpen := TapeHWND <> INVALID_HANDLE_VALUE;
end;
destructor TTapeManage.destroy;
begin
thMng.Terminate;
Closehandle(TapeHWND);
FWorkFile.Free;
inherited;
end;
procedure TTapeManage.DoAddFile(fList: TStrings);
var
i: integer;
iSize, sCount: int64;
begin
if fWorking then
exit;
FWorking := true;
GetStateText;
{if not CheckDeviceFreeSize(fList) then
begin
Application.MessageBox('磁带机空间不够!'#13'或写保护没有打开!'#13'减少要备份的文件或打开写保护后再试。 ', '系统提示');
FWorking := false;
exit;
end;
}
if not CheckDeviceFreeSize(fList) then
begin
Application.MessageBox('The space available on tape is not enough!'#13'or writting is locked!'#13'Please reduce the size of file(s) to be backed up or unlock for writting! ', 'Caution');
FWorking := false;
exit;
end;
FWorkList := nil;
sCount := 0;
FWorkCount := 0;
FIndex := -1;
FileInfo[0].StartPosition := 0;
for i := 0 to 999do
begin
if (FileInfo.FileName = 'END') or (FileInfo.FileLength = 0) then
begin
FIndex := i;
break;
end;
end;
if Findex > -1 then
SetDevicePos(FileInfo[FIndex].StartPosition)
else
begin
First;
Findex := 0;
end;
for i := 0 to fList.Count - 1do
begin
iSize := FileSizeByName(fList.Strings);
if iSize < 1024 then
continue;
//小于1K就不写
inc(sCount, iSize);
inc(FWorkCount);
SetLength(FWorkList, FWorkCount);
FWorkList[FWorkCount - 1] := fList.Strings;
end;
//if FToltalMsg &lt;&gt;
0 then
//begin
SendMessage(FMsgHdle, ToltalMsgA, sCount div 1024, 0);
//end;
FWorkType := wtWrite;
end;
procedure TTapeManage.First;
begin
SetTapePosition(TapeHWND, TAPE_ABSOLUTE_BLOCK, 0, 0, 0, FALSE);
end;
function TTapeManage.GetCutrrentUseContent: int64;
var
i: integer;
begin
Result := 0;
for i := 0 to 999do
begin
if FileInfo.FileLength = 0 then
exit;
inc(Result, FileInfo.FileLength);
end;
end;
procedure TTapeManage.GetFileList(bAbsRead: boolean);
var
iCount, i: integer;
cRead: DWord;
iPos: int64;
begin
iCount := 0;
for i := 0 to 999do
if FileInfo.FileLength > 0 then
inc(iCount)
else
break;
if not bAbsRead and (iCount > 0) then
exit;
First;
iCount := 0;
while truedo
begin
cRead := 0;
ReadFile(TapeHWND, FileInfo[iCount], Sizeof(APEFILEINFO), cRead, nil);
if (cRead = 0) or ((FileInfo[iCount].FileName = 'END') and (FileInfo[iCount].FileLength = 0)) then
begin
cRead := GetLastError;
if cRead = ERROR_NO_DATA_DETECTED then
begin
FileInfo[iCount - 1].FileLength := 0;
FileInfo[iCount - 1].FileName := 'END';
end;
break;
end;
iPos := FileInfo[iCount].StartPosition + FileInfo[iCount].FileLength + 500;
inc(iCount);
SetDevicePos(iPos);
end;
if iCount = 0 then
InitDevice
else
FileInfo[iCount].StartPosition := FileInfo[iCount - 1].StartPosition + FileInfo[iCount - 1].FileLength + 500
end;
procedure TTapeManage.GetFileList2LV(var fLV: TListView);
var
i: integer;
cItem: TListItem;
begin
fLV.Clear;
for i := 0 to 999do
begin
if FileInfo.FileLength = 0 then
exit;
cItem := fLV.Items.Add;
cItem.Caption := ExtractFileName(FileInfo.FileName);
cItem.SubItems.Add(format('%.0n', [round(FileInfo.FileLength / 1024) * 1.0]));
cItem.SubItems.Add(FormatDateTime('yyyy-mm-dd hh:nn:ss', FileInfo.WriteTime));
end;
end;
procedure TTapeManage.GetMadiaparameters;
var
i: integer;
BlockSize: Cardinal;
begin
if fGetState then
exit;
fGetState := true;
BlockSize := 0;
i := 12;
while i <> NO_ERRORdo
begin
i := GetTapeParameters(TapeHWND, GET_TAPE_MEDIA_INFORMATION, BlockSize, @Mparameters);
inc(BlockSize);
if BlockSize > 1000 then
exit;
end;
FTapeTotalContent := Mparameters.Capacity.QuadPart;
fGetState := false;
end;
procedure TTapeManage.GetStateText;
var
i: int64;
i1: integer;
ss: string;
begin
ss := '';
i := 0;
if not fTapeOpen then
i := Tape_No_Device;
if fTapeLoad then
i := i or Tape_Ready or Tape_Read;
if fWorking then
i := i or Tape_Working;
i1 := 0;
while i1 < 10do
begin
if FTapeTotalContent = 0 then
GetMadiaparameters
else
break;
inc(i1);
end;
if not Mparameters.WriteProtected and fTapeLoad then
i := i or Tape_Write;
ss := Inttostr(i) + '^' + Inttostr(GetCutrrentUseContent) + '^' + inttostr(FTapeTotalContent);
//if FShowMsg &lt;&gt;
0 then
SendMessage(FMsgHdle, ShowMsgA, integer(pInteger(pChar(ss))), -1);
end;
procedure TTapeManage.init;
begin
thMng := TManageTheard.create;
end;
procedure TTapeManage.InitD;
var
n: DWORD;
begin
FillChar(FileInfo, Sizeof(FileInfo), 0);
FileInfo[0].StartPosition := 0;
FileInfo[0].FileName := 'END';
CreateTapePartition(TapeHWND, TAPE_INITIATOR_PARTITIONS, 1, 500);
WriteFile(TapeHWND, FileInfo[0], Sizeof(APEFILEINFO), n, nil);
fWorking := false;
GetStateText;
end;
procedure TTapeManage.InitDevice;
begin
if not fTapeOpen or not fTapeLoad then
ShowNoDevice;
fWorking := true;
GetStateText;
FWorkType := wtInit;
end;
function TTapeManage.initialize: boolean;
var
i: integer;
begin
Result := false;
i := 0;
//fGetState := true;
while truedo
begin
if PrepareTape(TapeHWND, TAPE_LOAD, false) = NOERROR then
break;
inc(i);
if i > 10 then
exit;
end;
fGetState := false;
fTapeLoad := true;
GetMadiaparameters;
GetFileList(true);
Result := true;
end;
procedure TTapeManage.RestoreFile(sFile: string;
Index: integer);
var
rFile, rLen: integer;
iPos, iLen: int64;
cBuf: array[0..499] of byte;
rRead: DWORD;
sMsg: string;
begin
//如果还原空间不够的话,需要提示
{if DiskFree(ord(sFile[1]) - 64) &lt;
FileInfo[Index].FileLength then
begin
application.MessageBox('还原空间不够!'#13'请清除数据或更换还原空间后再试!', '系统提示');
exit;
end;
}
if DiskFree(ord(sFile[1]) - 64) < FileInfo[Index].FileLength then
begin
application.MessageBox('The space for restoring is not enough!'#13'Please delete some files in destination or redirect to another destination!', 'Caution');
exit;
end;
//iPos := FileInfo[Index].StartPosition + 500;
IPos := 0;
SetDevicePos(iPos);
//if FShowMsg &lt;&gt;
0 then
//begin
sMsg := ExtractFileName(FileInfo[Index].FileName) + ' ----&gt;
' + sFile;
SendMessage(FMsgHdle, ShowMsgA, integer(pInteger(pChar(sMsg))), 0);
//end;
//if FStepMsg &lt;&gt;
0 then
SendMessage(FMsgHdle, StepMsgA, FileInfo[Index].FileLength, 0);
rFile := FileCreate(sFile);
iLen := 0;
rLen := 500;
while iLen < FileInfo[Index].FileLengthdo
begin
if rLen + iLen > FileInfo[Index].FileLength then
rLen := FileInfo[Index].FileLength - iLen;
rRead := 0;
if not ReadFile(TapeHWND, cBuf[0], rLen, rRead, nil) then
begin
rRead := GetLastError;
if rRead <> 0 then
break;
end;
FileWrite(rFile, cBuf[0], rRead);
inc(iLen, rRead);
//if FStepMsg &lt;&gt;
0 then
PostMessage(FMsgHdle, StepMsgA, FileInfo[Index].FileLength, iLen);
//if FToltalMsg &lt;&gt;
0 then
PostMessage(FMsgHdle, ToltalMsgA, -1, rRead);
end;
FileClose(rFile);
//if FStepMsg &lt;&gt;
0 then
SendMessage(FMsgHdle, StepMsgA, FileInfo[Index].FileLength, FileInfo[Index].FileLength);
GetStateText;
end;
procedure TTapeManage.RestoreFiles(sPath: string;
IDS: TStrings);
var
i: integer;
sCount: int64;
begin
if not fTapeOpen or not fTapeLoad then
ShowNoDevice;
if fWorking then
exit;
fWorking := true;
GetStateText;
FWorkCount := IDS.Count;
SetLength(FWorkList, FWorkCount);
sCount := 0;
for i := 0 to FWorkCount - 1do
begin
FWorkList := sPath + '^' + IDS.Strings;
Inc(sCount, FileInfo[strtoint(IDS.Strings)].FileLength);
end;
//if FToltalMsg &lt;&gt;
0 then
SendMessage(FMsgHdle, ToltalMsgA, sCount div 1024, 0);
FWorkType := wtRead;
end;
procedure TTapeManage.SetDevicePos(nPos: Int64);
var
nLow, nhigh, TapeStatus: Cardinal;
cPos: int64;
begin
cPos := round(nPos / 500);
if cPos * 500 < nPos then
inc(cPos);
nLow := cPos and $FFFFFFFF;
nHigh := cPos shr 32 and $FFFFFFFF;
TapeStatus := SetTapePosition(TapeHWND, TAPE_ABSOLUTE_BLOCK, 0, nLow, nhigh, FALSE);
if TapeStatus <> NOERROR then
begin
//显示一个信息
//Application.MessageBox('定位到磁带机不成功!', pchar(MSG_TITLE));
//Abort;
end;
end;
procedure TTapeManage.SetProgressMsg(hnd: HWND;
ToltalMsg, StepMsg,
ShowMsg: UINT);
begin
FMsgHandle := hnd;
FMsgHdle := hnd;
FToltalMsg := ToltalMsg;
FStepMsg := StepMsg;
FShowMsg := ShowMsg;
//GetStateText;
end;
procedure TTapeManage.ShowNoDevice;
begin
application.MessageBox('No Tape or Tape can''t used!'#13'Please Check it and try agin.', 'sdfs'{pchar(MSG_TITLE)});
abort;
end;
procedure TTapeManage.WriteFileA(sFile: string);
var
cBuf: array[0..499] of byte;
fSize, wPos: int64;
wLen, wFile: integer;
n: Dword;
sMsg: string;
begin
//if FShowMsg &lt;&gt;
0 then
//begin
sMsg := sFile;
SendMessage(FMsgHdle, ShowMsgA, integer(pinteger(pChar(sMsg))), 0);
//end;
fSize := FileSizeByName(sFile);
//if FStepMsg &lt;&gt;
0 then
SendMessage(FMsgHdle, StepMsgA, fSize, 0);
wFile := FileOpen(sFile, fmOpenRead or fmShareDenyNone);
wPos := 0;
while wPos < fSizedo
begin
wLen := 500;
if wLen + wPos > fSize then
wLen := fSize - wPos;
Fileread(wFile, cBuf[0], wLen);
WriteFile(TapeHWND, cBuf[0], wLen, n, nil);
inc(wPos, wLen);
//if FStepMsg &lt;&gt;
0 then
PostMessage(FMsgHdle, StepMsgA, fSize, wPos);
//if FToltalMsg &lt;&gt;
0 then
PostMessage(FMsgHdle, ToltalMsgA, -1, wLen);
end;
FileClose(wFile);
//if FStepMsg &lt;&gt;
0 then
SendMessage(FMsgHdle, StepMsgA, fSize, fSize);
end;
procedure TTapeManage.WriteTail;
var
n: DWORD;
begin
n := 0;
WriteFile(TapeHWND, FileInfo[FIndex], Sizeof(APEFILEINFO), n, nil);
end;
{ TManageTheard }
constructor TManageTheard.create;
begin
inherited Create(false);
FreeOnTerminate := true;
end;
procedure TManageTheard.Execute;
var
i: integer;
begin
{ TapeMng.Working := true;
TapeMng.initialize;
TapeMng.Working := false;
TapeMng.GetStateText;
while not Terminateddo
begin
if not TapeMng.Working then
TapeMng.FWorkType := wtNormal;
case TapeMng.FWorkType of
wtNormal:
begin
sleep(20);
continue;
end;
wtWrite, wtRead:
begin
for i := 0 to TapeMng.FWorkCount - 1do
begin
if Terminated then
exit;
FCurIndex := i + 1;
FCurFile := TapeMng.FWorkList;
if TapeMng.FWorkType = wtWrite then
WriteFile2Tape
else
RestoreFile2Disk;
sleep(10);
end;
if TapeMng.FWorkType = wtWrite then
TapeMng.WriteTail;
//if TapeMng.FToltalMsg &lt;&gt;
0 then
SendMessage(TapeMng.FMsgHdle, ToltalMsgA, -1, -1);
TapeMng.FWorkType := wtNormal;
TapeMng.fWorking := false;
TapeMng.GetStateText;
end;
wtDoWrite:
begin
TapeMng.FWorkType := wtNormal;
TapeMng.fWorking := false;
TapeMng.DoAddFile(TapeMng.FWorkFile);
end;
wtInit:
begin
TapeMng.InitD;
TapeMng.FWorkType := wtNormal;
TapeMng.fWorking := false;
end;
end;
end;
}
end;
procedure TManageTheard.RestoreFile2Disk;
var
sFile: string;
Index: integer;
begin
sFile := Copy(FCurFile, 1, Pos('^', FCurFile) - 1);
delete(FCurFile, 1, Pos('^', FCurFile));
Index := StrToInt(FCurFile);
sFile := sFile + 'Restore_' + ExtractFileName(TapeMng.FileInfo[Index].FileName);
TapeMng.RestoreFile(sFile, Index);
end;
procedure TManageTheard.WriteFile2Tape;
begin
TapeMng.AppendFile(FCurFile);
end;
end.