Серийный номер винчестера
У меня есть модуль, который позволяет получить имя винчестера и его серийный номер, но этот модуль был создан на Borland Pascal 7.0. Я не проверял как он работает в Delphi, и не стал переводить его комментарии с немецкого, поскольку у меня элементарно нет времени. Может быть он сгодится вам в качестве идеи, в противном случае просто вышвырните его в окно.
|
Unit HardDisk; INTERFACE FUNCTION GetHardDiskNaam : STRING; FUNCTION GetHardDiskSerieNummer : STRING; FUNCTION GetHardDiskControlleNummer : STRING; PROCEDURE GetHardDiskGegevens; CONST CodeerTabel : ARRAY[0..24] OF BYTE = (3,1,2,1,4,1,3,2,6,4,6,5,1,2,6,4,2,6,3,4,6,2,4,1,2); TYPE CharArray = ARRAY[0..24] OF CHAR; VAR HardDiskGegevens : ARRAY[1..256] OF INTEGER; HardDiskNaam : CharArray; SerieNummer : CharArray; ControlleNummer : CharArray; C_HardDiskNaam : STRING; C_HardDiskSerieNummer : STRING; C_HardDiskControlleNummer : STRING; C_LicentieNaam : STRING; IMPLEMENTATION FUNCTION GetHardDiskNaam : STRING; VAR Teller : INTEGER; Lus : INTEGER; BEGIN GetHardDiskNaam := ''; Teller := 1; FOR Lus := 1 TO 18 DO BEGIN HardDiskNaam[Teller] := CHR( ( HardDiskGegevens[27+Lus] DIV 256 )); Inc(Teller); HardDiskNaam[Teller] := CHR( ( HardDiskGegevens[27+Lus] MOD 256 )); Inc(Teller); END; GetHardDiskNaam := HardDiskNaam; END; FUNCTION GetHardDiskSerieNummer : STRING; VAR Teller : INTEGER; Lus : INTEGER; BEGIN GetHardDiskSerieNummer := ''; Teller := 1; FOR Lus := 1 TO 8 DO BEGIN SerieNummer[Teller] := CHR( ( HardDiskGegevens[10+Lus] DIV 256 )); Inc(Teller); SerieNummer[Teller] := CHR( ( HardDiskGegevens[10+Lus] MOD 256 )); Inc(Teller); END; GetHardDiskSerieNummer := SerieNummer; END; FUNCTION GetHardDiskControlleNummer : STRING; VAR Teller : INTEGER; Lus : INTEGER; BEGIN GetHardDiskControlleNummer := ''; Teller := 1; FOR Lus := 1 TO 3 DO BEGIN ControlleNummer[Teller] := CHR( ( HardDiskGegevens[23+Lus] DIV 256 )); Inc(Teller); ControlleNummer[Teller] := CHR( ( HardDiskGegevens[23+Lus] MOD 256 )); Inc(Teller); END; GetHardDiskControlleNummer := ControlleNummer; END; PROCEDURE GetHardDiskGegevens; VAR Lus : INTEGER; BEGIN WHILE ( Port[$1f7] <> $50) DO ; Port[$1F6] := $A0 ; Port[$1F7] := $EC ; WHILE ( Port[$1f7] <> $58 ) DO ; FOR Lus := 1 TO 256 DO BEGIN HardDiskGegevens[Lus] := Portw[$1F0] ; END; END; END. |
|
unit Chiunit4; interface function Chk...(ParamIn ... ,=20 ParamDatabaseNamePchar: pchar ): longint; export; implementation uses SysUtils, DBTables, ExtCtrls ; const ide_drive_C =3D $00A0; ide_Data =3D $1F0; ide_Error =3D $1F1; ide_DriveAndHead =3D $1F6; ide_Command =3D $1F7; ide_command_readpar =3D $EC; ide_Status =3D $1F7; ide_status_busy =3D $80; ide_status_ready =3D $40; ide_status_error =3D $01; ide_Fixed =3D $3F6; ide_Fixed_Irq =3D $02; IntervalleMinimum =3D 0.0000232; { 0.000011574 =3D 1 секунда (.0001 (hh.mmss) (->DEG=3D.0002777) / 24) } { .0000174 =3D 1 1/2 сек } { .0000232 =3D 2 сек } type tIdeRec =3D Record rec : array[0..255] of word; end; var ExitSave : Pointer; IdeRec : tIdeRec; function ConvertToString : string; var i,j : integer; begin FillChar( Result, 20, ' ' ); Result[0] :=3D #20; for i :=3D 1 to 20 do begin j :=3D Trunc( (i-1) /2 ) +10 ; if Lo(IdeRec.Rec[j]) =3D (0) then Result[i]:=3D ' ' else Result[i]:=3D Chr ( Lo( IdeRec.Rec[j] ) ) ; i :=3D i +1; if Hi(IdeRec.Rec[j]) =3D (0) then Result[i]:=3D ' ' else Result[i]:=3D Chr ( Hi( IdeRec.Rec[j] ) ) ; end; end; function DoIt(Numero: string) : longint; var portchar :byte; boo :Boolean; i :integer; S,S1 :String; begin Result:=3D 19 ; { по умолчанию fail } FillChar( IdeRec.Rec, 512, ' ' ) ; { для примера v=E9rifier l'=E9tat } boo :=3D true; { ожидание poll DRQ } i :=3D 5000 ; repeat i :=3D i -1; portchar :=3D Lo(port[ide_status]) ; { получаем статус } until ( i < 1 ) or not ( ( portchar AND ide_status_busy ) =3D ide_status_busy ) ; if i < 1 then begin { Result:=3D 'статус постоянной занятости'; } Result :=3D 180 ; boo :=3D false; end; if boo then try { premi=E8rement выключаем прерывания устройства } port[ide_Fixed] :=3D 0; port[ide_DriveAndHead] :=3D ide_drive_C ; { устанавливаем устройство } portchar :=3D Lo(port[ide_status]) ; { получаем статус } if portchar =3D $ff then begin { Result:=3D 'устанавливаем статус устройства $ff'; } Result :=3D 11 ; boo :=3D false; end; if boo then begin { ожидание poll DRQ } i :=3D 1024 ; repeat i :=3D i -1; portchar :=3D Lo(port[ide_status]) ; until ( i < 1 ) or not ( ( portchar AND ide_status_busy ) =3D ide_status_busy ) ; if i < 1 then begin { Result:=3D 'статус постоянной занятости'; } Result :=3D 181 ; boo :=3D false; end; end; if boo then { проверяем готовность } if ( portchar AND ide_status_ready ) =3D 0 then begin { Result:=3D 'устанавливаем статус устройства "Не готов"'; } Result :=3D 12 ; boo :=3D false; end; if boo then { ok, теперь для readIDE } { требуется посылка команды ReadParameters } port[ide_Command] :=3D ide_command_readpar ; { ожидание poll DRQ } i :=3D 5000 ; repeat i :=3D i -1; portchar :=3D Lo(port[ide_status]) ; until ( i < 1 ) or not ( ( portchar AND ide_status_busy ) =3D ide_status_busy ) ; if i < 1 then begin { Result:=3D 'статус постоянной занятости'; } Result :=3D 182 ; boo :=3D false; end; if boo then { проверяем если нет ошибок} if ( portchar AND ide_status_error ) =3D ide_status_error then begin { Result:=3D 'статус ошибки устройства после ReadPar'; } Result :=3D 13 ; boo :=3D false; end; if boo then { проверяем готовность } if ( portchar AND ide_status_ready ) =3D 0 then begin { Result:=3D 'после ReadPar статус устройства "Не готов"'; } Result :=3D 14 ; boo :=3D false; end; if boo then try { ok, теперь читаем из буфера 256 слов } for i :=3D 0 to 255 do begin IdeRec.Rec[i] :=3D ( portw[ide_Data] ) ; end; except on Exception do begin { ShowMessage( 'Ошибка portw i=3D '+intToStr(i)= ) ; } boo :=3D false; Result :=3D 15 ; end; else begin boo :=3D false; Result :=3D 16 ; raise; end; end; if boo Then begin S :=3D ConvertToString; if length(Numero) < 20 then S1:=3D Numero +' ' else S1:=3D Numero; if CompareStr ( S, Copy(S1,1,20) ) =3D 0 then Result :=3D 10 else Result :=3D 17 ; { Result :=3D '('+S+')<>('+Copy(S1,1,20)+')' ; } end; finally { снова включаем прерывания диска } port[ide_Fixed] :=3D ide_Fixed_Irq ; end; END; procedure MyExit; far; { восстанавливаем параметры диска во избежании того, чтобы другие операции с диском не разрушили его в случае прерывания программы } begin ExitProc :=3D ExitSave; { восстанавливаем предыдущий exitproc } { Port[ide_Command]:=3D$10; { посылаем команду: сбросить текущее устройство } end; function GetParam(ParamAlias: string): String; var i : integer ; t : TTable ; S : String ; begin Result :=3D ''; try t :=3D nil; t :=3D TTable.Create(nil); t.DatabaseName :=3D ParamAlias; t.TableName :=3D ...; t.TableType :=3D ttPARADOX; t.open; ... finally if Assigned(t) then t.free ; end; end; function FixParam(ParamAlias: string): boolean; var i : integer ; t : TTable ; S : String ; begin Result :=3D False; try t :=3D nil; t :=3D TTable.Create(nil); t.DatabaseName :=3D ParamAlias; t.TableName :=3D ; t.TableType :=3D ttPARADOX; t.open; if=20 begin ... t.Edit; t.setFields([nil, S]); t.post; end; t.close; Result :=3D True; finally if Assigned(t) then t.free ; end; end; {----------------------------------------------------} function Chk...(ParamIn: ; ParamDatabaseNamePchar: pchar ): longInt ; var ParamString : String; =20 Temps : Real; Ok : boolean; i: integer; S : string[20]; S6 : string[6]; r : longInt; Label Jump; BEGIN Result:=3D 0 ; { значение d=E9faut } if Ok then i :=3D 0; repeat begin i :=3D i +1 ; r :=3D DoIt(Copy(ParamString,54,20)) ; if r =3D 10 then begin Ok :=3D True ; break end else begin Ok :=3D False ; Result:=3D r; Continue; end; end; until i =3D 3 ; If Ok then begin Ok :=3D FixParam(ParamDatabaseName) ; If Ok then else { Result :=3D 'Ошибка FixParam'; } Result :=3D 2 ; end; If Ok then Result :=3D 1 ; END; Begin ExitSave:=3D ExitProc; ExitProc:=3D @MyExit; end. |
[001957]
Управление метками томов дисков
Управление метками томов дисков из Delphi-приложений
Данный совет содержит исходный код модуля, который может помочь Вам получить, установить и удалить метку тома гибкого или жесткого диска. Код получения метки тома содержит функцию Delphi FindFirst, код для установки и удаления метки тома использует вызов DOS-прерывания 21h и функции 16h и 13h соответственно. Поскольку функция 16h не поддерживается Windows, она должна вызываться через DPMI-прерывание 31h, функцию 300h.
|
{ *** НАЧАЛО КОДА МОДУЛЯ VOLLABEL *** }
unit VolLabel; interface uses Classes, SysUtils, WinProcs; type EInterruptError = class(Exception); EDPMIError = class(EInterruptError); Str11 = String[11]; procedure SetVolumeLabel(NewLabel: Str11; Drive: Char); function GetVolumeLabel(Drive: Char): Str11; procedure DeleteVolumeLabel(Drv: Char); implementation type PRealModeRegs = ^TRealModeRegs; TRealModeRegs = record case Integer of 0: ( EDI, ESI, EBP, EXX, EBX, EDX, ECX, EAX: Longint; Flags, ES, DS, FS, GS, IP, CS, SP, SS: Word); 1: ( DI, DIH, SI, SIH, BP, BPH, XX, XXH: Word; case Integer of 0: ( BX, BXH, DX, DXH, CX, CXH, AX, AXH: Word); 1: ( BL, BH, BLH, BHH, DL, DH, DLH, DHH, CL, CH, CLH, CHH, AL, AH, ALH, AHH: Byte)); end; PExtendedFCB = ^TExtendedFCB; TExtendedFCB = Record ExtendedFCBflag : Byte; Reserved1 : array[1..5] of Byte; Attr : Byte; DriveID : Byte; FileName : array[1..8] of Char; FileExt : array[1..3] of Char; CurrentBlockNum : Word; RecordSize : Word; FileSize : LongInt; PackedDate : Word; PackedTime : Word; Reserved2 : array[1..8] of Byte; CurrentRecNum : Byte; RandomRecNum : LongInt; end; procedure RealModeInt(Int: Byte; var Regs: TRealModeRegs); { процедура работает с прерыванием 31h, функцией 0300h для иммитации } { прерывания режима реального времени для защищенного режима. } var ErrorFlag: Boolean; begin asm mov ErrorFlag, 0 { успешное завершение } mov ax, 0300h { функция 300h } mov bl, Int { прерывание режима реального времени, которое необходимо выполнить } mov bh, 0 { требуется } mov cx, 0 { помещаем слово в стек для копирования, принимаем ноль } les di, Regs { es:di = Regs } int 31h { DPMI-прерывание 31h } jnc @@End { адрес перехода установлен в error } @@Error: mov ErrorFlag, 1 { возвращаем false в error } @@End: end; if ErrorFlag then raise EDPMIError.Create('Неудача при выполнении DPMI-прерывания'); end; function DriveLetterToNumber(DriveLet: Char): Byte; { функция преобразования символа буквы диска в цифровой эквивалент. } begin if DriveLet in ['a'..'z'] then DriveLet := Chr(Ord(DriveLet) -32); if not (DriveLet in ['A'..'Z']) then raise EConvertError.CreateFmt('Не могу преобразовать %s в числовой эквивалент диска', [DriveLet]); Result := Ord(DriveLet) - 64; end; procedure PadVolumeLabel(var Name: Str11); { процедура заполнения метки тома диска строкой с пробелами } var i: integer; begin for i := Length(Name) + 1 to 11 do Name := Name + ' '; end; function GetVolumeLabel(Drive: Char): Str11; { функция возвращает метку тома диска } var SR: TSearchRec; DriveLetter: Char; SearchString: String[7]; P: Byte; begin SearchString := Drive + ':\*.*'; { ищем метку тома } if FindFirst(SearchString, faVolumeID, SR) = 0 then begin P := Pos('.', SR.Name); if P > 0 then begin { если у него есть точка... } Result := ' '; { пространство между именами } Move(SR.Name[1], Result[1], P - 1); { и расширениями } Move(SR.Name[P + 1], Result[9], 3); end else begin Result := SR.Name; { в противном случае обходимся без пробелов } PadVolumeLabel(Result); end; end else Result := ''; end; procedure DeleteVolumeLabel(Drv: Char); { процедура удаления метки тома с данного диска } var CurName: Str11; FCB: TExtendedFCB; ErrorFlag: WordBool; begin ErrorFlag := False; CurName := GetVolumeLabel(Drv); { получение текущей метки тома } FillChar(FCB, SizeOf(FCB), 0); { инициализируем FCB нулями } with FCB do begin ExtendedFCBflag := $FF; { всегда } Attr := faVolumeID; { Аттрибут Volume ID } DriveID := DriveLetterToNumber(Drv); { Номер диска } Move(CurName[1], FileName, 8); { необходимо ввести метку тома } Move(CurName[9], FileExt, 3); end; asm push ds { сохраняем ds } mov ax, ss { помещаем сегмент FCB (ss) в ds } mov ds, ax lea dx, FCB { помещаем смещение FCB в dx } mov ax, 1300h { функция 13h } Call DOS3Call { вызываем int 21h } pop ds { восстанавливаем ds } cmp al, 00h { проверка на успешность выполнения } je @@End @@Error: { устанавливаем флаг ошибки } mov ErrorFlag, 1 @@End: end; if ErrorFlag then raise EInterruptError.Create('Не могу удалить имя тома'); end; procedure SetVolumeLabel(NewLabel: Str11; Drive: Char); { процедура присваивания метки тома диска. Имейте в виду, что } { данная процедура удаляет текущую метку перед установкой новой. } { Это необходимое требование для функции установки метки. } var Regs: TRealModeRegs; FCB: PExtendedFCB; Buf: Longint; begin PadVolumeLabel(NewLabel); if GetVolumeLabel(Drive) <> '' then { если имеем метку... } DeleteVolumeLabel(Drive); { удаляем метку } Buf := GlobalDOSAlloc(SizeOf(PExtendedFCB)); { распределяем реальный буфер } FCB := Ptr(LoWord(Buf), 0); FillChar(FCB^, SizeOf(FCB), 0); { инициализируем FCB нулями } with FCB^ do begin ExtendedFCBflag := $FF; { требуется } Attr := faVolumeID; { Аттрибут Volume ID } DriveID := DriveLetterToNumber(Drive); { Номер диска } Move(NewLabel[1], FileName, 8); { устанавливаем новую метку } Move(NewLabel[9], FileExt, 3); end; FillChar(Regs, SizeOf(Regs), 0); with Regs do begin { Сегмент FCB } ds := HiWord(Buf); { отступ = ноль } dx := 0; ax := $1600; { Функция 16h } end; RealModeInt($21, Regs); { создаем файл } if (Regs.al <> 0) then { проверка на успешность выполнения } raise EInterruptError.Create('Не могу создать метку тома'); end; end. { *** КОНЕЦ КОДА МОДУЛЯ VOLLABEL *** } |
[000628]
BlockRead и текстовый файл
Следующий код демонстрирует использование нетипизированного входного файла для блочного чтения (blockread) текстового файла, сканирование входного буфера в поисках любого символа и их замены на символы перевода строки и возврата каретки. Поскольку код использует входные и выходные буфера размером 16к, то получаемая скорость весьма приемлема.
Примечание: В процессе обработки, если длина строки выходного файла превышает 255 символов и вы хотите прочесть ее с помощью ReadLn, то просто используйте в запросе ReadLn несколько строк, например так:
| ReadLn(infile,string1,string2); |
Так можно прочесть вплоть до 510 символьных строк с 1-й по 255 символ в string1 и остальное в string2;
|
program fixfile;{ Компилируем из DOS-приглашения: DCC FIXFILE.PAS }
uses { запускаем из File Manager }
sysutils,dialogs,forms;
type bufptr = obufr; iobufr = array[0..16384] of char; var infile : file; oufile : textfile; inbufr, oubufr : bufptr; idx: integer; bytesread: integer; bytes2read: integer; totalbytesread: longint; actualfilesize: longint; OpenDialog1: TOpenDialog; infilename, oufilename: string; begin infilename := ''; OpenDialog1 := TOpenDialog.Create(Application); OpenDialog1.Options := []; OpenDialog1.Filter := 'Все файлы|*.*'; OpenDialog1.FilterIndex := 1; OpenDialog1.Title := 'Укажите исходный файл для преобразования'; if OpenDialog1.execute then infilename := OpenDialog1.filename; if infilename='' then begin OpenDialog1.free; halt; end; OpenDialog1.Title := 'Укажите имя создаваемого целевого файла'; if OpenDialog1.execute then oufilename := OpenDialog1.filename; OpenDialog1.free; if oufilename='' then halt; if infilename=oufilename then halt; new(inbufr); new(oubufr); assignfile(infile,infilename); reset(infile,1); actualfilesize := filesize(infile); assignfile(oufile,oufilename); system.settextbuf(oufile,oubufr^); rewrite(oufile); totalbytesread := 0; bytesread := 0; bytes2read := 0; while (totalbytesread<actualfilesize) and (bytes2read=bytesread) and (IOresult=0) do begin if (actualfilesize-totalbytesread)>sizeof(inbufr^) then bytes2read := sizeof(inbufr^) else bytes2read := actualfilesize-totalbytesread; blockread(infile,inbufr^,bytes2read,bytesread); totalbytesread := totalbytesread + bytesread; for idx := 0 to bytesread do if inbufr^ [idx]='''' then { <= преобразуемый символ } writeln(oufile) else write(oufile,inbufr^ [idx]); end; closefile(infile); closefile(oufile); dispose(inbufr); dispose(oubufr); end. |
- Dennis Passmore [000755]
Блокировка файла
...действительно, когда вы запрашиваете о блокировке файла и прерывания DOS, это относится к блокировке записи. Если вы хотите иметь полностью монопольный доступ к файлу, то в этом случае вы должны воспользоваться переменной FileMode. Вот пример кода моей программы, где я использую эту переменную:
|
type FileShareType = (DenyCompatibility,DenyAll,DenyWrite,DenyRead,DenyNone); FileAccessType = (ReadOnly,WriteOnly,ReadWrite); procedure SetFileAccess(AccessMode: FileAccessType;ShareMode: FileShareType); { Устанавливаем режим доступа к файлу для следующего вызова открытия файла } begin FileMode := ord(AccessMode) or (ord(ShareMode) shl 4) end; |
Вот и все. [000367]
Быстрая обработка файла
|
type
TByteSet = set of byte ;
procedure ProcessFile( const InFileName,OutFileName: string; Valid: TByteSet ) ; var InFile, OutFile : file ; InBuf, OutBuf : PByteArray ; InPos, OutPos : word ; BytesRead : word ; begin OutBuf := NIL ; New( InBuf ) ; try New( OutBuf ) ; AssignFile( InFile, InFileName ) ; AssignFile( OutFile, OutFileName ) ; Reset( InFile, 1 ) ; Rewrite( OutFile, 1 ) ; repeat Blockread( InFile, InBuf^, SizeOf( InBuf^ ), BytesRead ) ; OutPos := 0 ; for InPos := 0 to BytesRead - 1 do begin if InBuf^[ InPos ] in Valid then begin inc( OutPos ) ; end ; end ; if OutPos > 0 then BlockWrite( OutFile, OutBuf^, OutPos ) ; until BytesRead <> SizeOf( InBuf^ ) ; CloseFile( InFile ) ; CloseFile( OutFile ) ; finally if OutBuf <> NIL then Dispose( OutBuf ) ; Dispose( InBuf ) ; end ; end; |
Применять это можно приблизительно так:
| ProcessFile( 'SOURCE.RAW', 'NEW.RAW', [ 10, 13, 32..255 ] ) ; |
- Mike Scott [000865]
Быстрое копирование файла
|
procedure CopyFile( Source, Dest : string ); var SrcFile : Integer; DestFile : Integer; S : string; RetCode : Longint; OpenFileBuf : TOFStruct; FName : array[ 0..255 ] of Char; begin StrPCopy( FName, Source ); SrcFile := LZOpenFile( FName, OpenFileBuf, of_Read ); StrPCopy( FName, Dest ); DestFile := LZOpenFile( FName, OpenFileBuf, of_Create ); RetCode := LZCopy( SrcFile, DestFile ); if RetCode >= 0 then begin LZClose( SrcFile ); LZClose( DestFile ); end else begin Str( RetCode, S ); MessageDlg( 'Не могу скопировать ' + Source + ' в ' + Dest + #13 + 'Код ошибки = ' + S, mtError, [mbOk], 0 ); end; end; |
[000351]
Чтение бинарного файла
|
var f: File; c: Char; begin AssignFile(f, 'this.bin'); Reset(f, 1); BlockRead(f, c, sizeof(c)); CloseFile(f); end; |
|
function FindInFile( cFileName : string; cCh : char ) : boolean; var fFile : file; aBuf : array[1..1024] of char; lFound : boolean; x, nRead : integer; begin Assign( fFile, cFileName ); Reset( fFile, 1 ); lFound := False; repeat BlockRead( fFile, aBuf, SizeOf( aBuf ), nRead ); x := 1; while not lFound and ( x <= nRead ) do begin lFound := ( aBuf[ x ] = cCh ) Inc( x ) end; until ( nRead < SizeOf( aBuf ) ) or lFound; FindInFile := lFound end; |
Взгляните на следующий код:
|
var f: file; c: Char; begin AssignFile(f, 'c:\autoexec.bat'); Reset(f, 1); <- Примечание: Размер записи = 1 байту это нормально! while not Eof(f) do begin BlockRead(f, c, SizeOf(c)); {Теперь обрабатываем c} end; CloseFile(f); end; |
Для ускорения этой процедуры не следует за один проход читать по одному символу. Возможно, лучшим решением будет объявление PChar скажем, размером 200, и чтением за один проход блоков размером 200 байт. {например, BlockRead(f, p, 200);} Но для этого требуется немного больше кода, чем показано здесь... (Используйте все тот же recordsize, равный 1, меняется только blocksize). [001701]
Чтение данных из файла
Имеется процедура Flush, которая работает с открытыми файлами:
| flush(f); |
В руководстве четко не сказано, передает ли (сбрасывает) Flush данные непосредственно на диск. Если это не так, то данные сохраняются в других временных буферах. В качестве дополнительной меры безопасности, я "опускаюсь" для этого вызова в dos. Необходимость данного вызова спорна, но пусть он в нашем случае покажет эту возможность.
Ниже дан пример:
|
Uses Sysutils; var F : text; { это ваш текстовый файл } Procedure TextFlush(F : Text); var fhandle : word; begin Flush(F); fhandle := ttextrec(F).Handle; { получаем дескриптор msdos } asm mov ax, $6800 mov bx, handle call DOS3CALL end; end; |
Если файл является "блочным" файлом, пропускаем шаг с командой flush, и используем tfilerec вместо ttextrec.
Переменная Filemode определяет режим открытия файла (По умолчанию режим эксклюзивный). К сожалению, это не срабатывает для текстовых файлов, поэтому вы должны, используя blockreads писать в буфер, и затем конвертировать части буфера в строку, если вы хотите работать с ним как с текстовым файлом.
Assign, или AssignFile, как вы теперь знаете, не может использоваться с файлом, который уже открыт (я проверял это, и это действительно так). В вашем случае рекомендую обратиться к вызову API OpenFile, ничего в этом страшного нет.
Если это текстовый файл, сбросьте сначала текстовый буфер на диск командой flush:
| flush(f) |
Остальное относится ко всем файлам:
Сделайте файлу commit, используя dos-функцию commit, доступную начиная с DOS 5.
| asm mov ax, $6800 { делаем commit файла } mov bx, ttextrec(f).handle { получаем дескриптор файла } call dos3call { это предпочтительный способ, INT $21 также должно работать } end; |
Согласно документации Microsoft, данный вызов также сбрасывает буфера SMARTDRIVE. MSDN10 так описывает алгоритм реализации этого на языке приложения:
Для сброса данных, сохраняемых в буфере SMARTDRV.EXE версии 4.0, вы можете воспользоваться одним из следующих способов: Используйте функцию MS-DOS Commit File (которая записывает измененные данные буфера). Это прерывание 21h, функция 68h. Используйте функцию MS-DOS Disk Reset (которая записывает измененные данные и чистит кэш). Это прерывание 21h, функция 0Dh. [001697]
Чтение и запись данных в/из файлов
|
{ В следующем примере показано как можно осуществить чтение и запись данных в/из файла. Данный пример предполагается в первую очередь использовать тем, кто делает первые шаги в вопросах чтения/записи. Для получения дополнительной информации о каждом объекте, обратитесь к электронной справке. В коде присутствует минимальная обработка исключительных ситуаций, но она никоим образом не является законченным решением. Для оформления программы необходимо установить на форме компонент TMemo с заголовком Запись, и кнопку с заголовком Чтение. Запустите программу, поместите несколько строк в "memo", после чего нажмите на кнопку Запись. Очистите "memo", и нажмите Чтение. } procedure TForm1.BtnWriteClick(Sender: TObject); { автор: Michael Vincze } var FileStream: TFileStream; Writer : TWriter; I : Integer; begin FileStream := TFileStream.Create ('c:\delphi\projects\delta40\fileio\stream.txt', fmCreate or fmOpenWrite or fmShareDenyNone); Writer := TWriter.Create (FileStream, $ff); Writer.WriteListBegin; for I := 0 to Memo1.Lines.Count - 1 do Writer.WriteString (Memo1.Lines[I]); Writer.WriteListEnd; Writer.Destroy; FileStream.Destroy; end; procedure TForm1.BtnReadClick(Sender: TObject); { автор: Michael Vincze } var FileStream: TFileStream; Reader : TReader; begin { пробуем открыть несуществующий файл } try FileStream := TFileStream.Create ('c:\delphi\projects\delta40\fileio\bogus.txt', fmOpenRead); except ; { Destroy не нужен, поскольку Create потерпела неудачу } end; FileStream := TFileStream.Create ('c:\delphi\projects\delta40\fileio\stream.txt', fmOpenRead); Reader := TReader.Create (FileStream, $ff); Reader.ReadListBegin; Memo1.Lines.Clear; while not Reader.EndOfList do Memo1.Lines.Add (Reader.ReadString); Reader.ReadListEnd; Reader.Destroy; FileStream.Destroy; end; |
[001698]
Чтение и запись файлов
1) Направление выходного потока вашей программы в файл.
2) Направление выходного потока вашей программы на принтер.
3) Чтение из входного файла.
Направление выходного потока вашей программы в файл
...часто мои профессора, чтобы убедиться в моей честности и поверить в то, что программа создана моими руками, требуют ее полный листинг или упоминания обо мне в качестве одного из авторов. Далее они хотят, чтобы все генерируемые программой данные выводились в файл. Но как это сделать на Delphi или на простом Паскале???
Просто в Delphi ....
| program CrtApp; uses WinCrt; var outfile: TextFile; begin AssignFile(outfile, 'c:\outfile.txt'); Rewrite(outfile); writeln(outfile, 'Привет из Delphi'); writeln(outfile, 'Моя программа работает, и выводит ' + 'данный текст, чтобы доказать это...'); CloseFile(outfile); end. |
Просто в Паскале.....
| Program HelloWorld; var outfile: text; begin assign(outfile, 'c:\output.txt'); rewrite(outfile); writeln(outfile, 'Здравствуй, мир'); writeln(outfile, 'Моя программа работает, и выводит данный текст, чтобы доказать это...'); close(outfile); end. |
Направление выходного потока вашей программы на принтер
В некоторых случаях может возникнуть необходимость печатать генерируемые программой данные непосредственно на принтер. Вот как это можно сделать:
В Delphi ...
| program CrtApp; uses WinCrt; var outfile: TextFile; begin assignfile(outfile, 'LPT1'); rewrite(outfile); writeln(outfile, 'Привет из Delphi'); writeln(outfile, 'Моя программа работает, и выводит ' + 'данный текст, чтобы доказать это...'); closefile(outfile); end. |
В Паскале ...
| Program HelloWorld; var outfile: text; begin assign(outfile, 'LPT1'); rewrite(outfile); writeln(outfile, 'Здравствуй, мир'); writeln(outfile, 'Моя программа работает, и выводит данный текст, чтобы доказать это...'); close(outfile); end. |
Чтение из входного файла
Весьма полезным будет иметь функцию чтения из файла, который может передаваться другим человеком. Вот пример того, как это можно осуществить.
В Delphi ...
| program CrtApp; uses WinCrt; var infile, outfile: TextFile; num_lines, x: integer; line: string; begin assignfile(infile, 'C:\INFILE.TXT'); assignfile(outfile, 'C:\OUTFILE.TXT'); reset(infile); {перемещаем указатель} {в начало файла.} rewrite(outfile); {очищаем содержимое файла} readln(infile, num_lines); for x:= 1 to num_lines do begin readln(infile, line); writeln(outfile, line); end; closefile(infile); closefile(outfile); end. |
В Паскале ...
| Program ReadInput; var infile, outfile: text; num_lines, x: integer; line: string; begin assign(infile, 'C:\INFILE.TXT'); assign(outfile, 'C:\OUTFILE.TXT'); reset(infile); {перемещаем указатель} {в начало файла.} rewrite(outfile); {очищаем содержимое файла} readln(infile, num_lines); for x:= 1 to num_lines do begin readln(infile, line); writeln(outfile, line); end; close(infile); close(outfile); end. |
{НАЧАЛО INFILE.TXT} 2 Здравствуй, мир Моя программа работает, и этот текст доказательство этому. {КОНЕЦ INFILE.TXT} Для получения дополнительной информации обратитесь к Руководству Разработчика. Ознакомьтесь с описанием функций AssignFile, Assign, Reset, Rewrite, readln, writeln, Close, CloseFile.
Данный документ был написан автором под впечатлением просьбы умоляющего студента и чувством симпатии к нему, поскольку он сам недавно сидел на студенческой скамье..!! [001699]
Чтение из файла длинной строки
Для решения этой задачи на помощь можно призвать потоки (TFileStream, TMemoryStream). Для поиска конца строк нужно искать пары CR/LF, но это делается очень легко, приблизительно так (я сегодня вечером слишком ленивый для реального кода):
|
Start := Stream.Position; End := Start; Repeat Stream.Read(Buffer^, 1024); CRPos := FindCR(Buffer^); { где FindCR возвращает 0..1023 для CR, и 1024, если он не найден} Inc(End, CRPos); Until CRPos < 1024; GetMem(MyPChar, End - Start); { Здесь может быть +-1 -- мне лень сегодня проверять! } Stream.Seek(Start); Stream.Read(MyPChar^, End - Start) |
Затем установите CR в конце MyPChar в 0, и сделайте Seek в конец (End + 1), или что-то еще, чтобы пропустить LF.
LazyMan [001703]
Доступ к нетипизированному файлу
Вы можете организовать доступ к файлу "без определенного типа" следующим образом:
|
Var MyFile : file;
begin
assign(MyFile,Filename);
reset(MyFile,1);
{для записи}
Blockwrite(MyFile,item,sizeof(item));
{для чтения}
BlockRead(MyFile,item,sizeof(item));
close(MyFile); end; |
Имейте в виду, что для чтения/записи нетипизированного файла необходимо использовать функции blockread и blockwrite, т.к. для использования нормальных функций Read/Write компилятору необходимо знать формат файла. [000519]
Файл типа TList
Ок, но это не так просто, как кажется. Тем не менее, с помощью некоторых людей из конференции, мне удалось сделать это и придать коду законченный вид. Ниже приведен исходный код для Toverheadmap...
Обратите внимание на методы объекта ReadData и WriteData, используемые для его записи на диск, и методы SaveToFile и LoadFromFile самого TList. Правильным было бы сделать их более совместимыми (общими), но на это пока у меня не хватило времени. (Т.е., TList должен был бы восстанавливать/сохранять любой объект с помощью метода readdata/writedata.)
|
unit Charactr; interface uses Graphics, StdCtrls, Classes, Sysutils, Winprocs, Ohmap, ohmstuff; type TMapCharacterList = class(TList) private FMap:TOverHeadMap; public procedure RenderVisibleCharacters; virtual; procedure Savetofile(const filename:String); procedure Loadfromfile(const filename:String); procedure Clear; destructor Destroy; override; property MapDisp:TOverHeadMap read FMap write FMap; end; TFrameStore = class(TList) procedure WriteData(Writer:Twriter); virtual; procedure ReadData(Reader:TReader); virtual; procedure Clear; end; TMapCharacter = class(TPersistent) private FName:string; FMap:TOverHeadMap; FFrame:Integer; FFramebm,FFrameMask,FWorkBuf:TBitmap; FFrameStore,FMaskStore:TFrameStore; FXpos,FYpos,FZpos:Integer; FTransColor:TColor; FVisible,FFastMode,FIsClone,FRedrawBackground:Boolean; procedure SetFrame(num:Integer); function GetOnScreen:Boolean; procedure SetVisible(vis:Boolean); procedure MakeFrameMask(trColor: TColor); procedure MakeFrameMasks; {Для переключения в быстрый режим...} procedure ReplaceTransColor(trColor: TColor); procedure SetXPos(x:Integer); procedure SetYPos(y:Integer); procedure SetZPos(z:Integer); procedure SetFastMode(fast:Boolean); public constructor Create(ParentMap:TOverheadmap); virtual; destructor Destroy; override; property Name:string read FName write FName; property Fastmode:Boolean read FFastMode write SetFastMode; property FrameStore:TFrameStore read FFrameStore write FFramestore; property MaskStore:TFrameStore read FMaskStore write FMaskStore; property Frame:integer read FFrame write SetFrame; property Framebm:TBitmap read FFramebm; property FrameMask:TBitmap read FFrameMask; property TransColor:TColor read FTransColor write FTransColor; property Xpos:Integer read FXpos write SetXpos; property YPos:Integer read FYpos write SetYpos; property ZPos:Integer read FZpos write SetZpos; property Map:TOverHeadMap read FMap write FMap; property OnScreen:Boolean read GetOnScreen; property Visible:Boolean read FVisible write SetVisible; property IsClone:Boolean read FIsClone write FIsClone; property RedrawBackground:Boolean read FRedrawBackground write FRedrawBackground; procedure Render; virtual; procedure RenderCharacter(mapcoords:Boolean;cxpos,cypos:Integer;mask,bm, wb:TBitmap); virtual; procedure Clone(Source:TMapCharacter); virtual; procedure SetCharacterCoords(x,y,z:Integer); virtual; procedure WriteData(Writer:Twriter); virtual; procedure ReadData(Reader:TReader); virtual; end; implementation constructor TMapCharacter.Create(ParentMap:TOverheadmap); begin inherited Create; FIsClone:=False; FFramebm:=TBitMap.create; FFrameMask:=TBitmap.Create; FWorkbuf:=TBitMap.Create; if Not(FIsClone) then FFrameStore:=TFrameStore.Create; FTransColor:=clBlack; FFastMode:=False; FMap:=ParentMap; end; destructor TMapCharacter.Destroy; var a,b:Integer; begin FFramemask.free; FFramebm.free; FWorkBuf.Free; if Not(FIsClone) then begin FFrameStore.Clear; FFrameStore.free; end; if (MaskStore<>nil) and Not(FIsClone) then begin MaskStore.Clear; MaskStore.Free; end; inherited Destroy; end; { Данная процедура копирует важную информацию из символа в себя ... Стартуем невидимое клонирование, с нулевыми координатами карты. } procedure TMapCharacter.Clone(Source:TMapCharacter); begin FName:=Source.Name; FFastMode:=Source.FastMode; FFrameStore:=Source.FrameStore; FMaskStore:=Source.MaskStore; FTransColor:=Source.TransColor; FMap:=Source.Map; FVisible:=False; Frame:=Source.Frame; {Ищем фрейм триггера.} FIsClone:=True; end; procedure TMapCharacter.SetXPos(x:Integer); begin Map.Redraw(xpos,ypos,zpos,-1); FXpos:=x; Render; end; procedure TMapCharacter.SetYPos(y:Integer); begin Map.Redraw(xpos,ypos,zpos,-1); FYPos:=y; Render; end; procedure TMapCharacter.SetZPos(z:Integer); begin Map.Redraw(xpos,ypos,zpos,-1); FZpos:=z; Render; end; procedure TMapCharacter.SetCharacterCoords(x,y,z:Integer); begin Map.Redraw(xpos,ypos,zpos,-1); Fxpos:=x; Fypos:=y; Fzpos:=z; Render; end; procedure TMapCharacter.SetFrame(num:Integer); begin if (num<=FFrameStore.count-1) and (num>-1) then begin FFrame:=num; FFramebm.Assign(TBitmap(FFrameStore.items[num])); if Ffastmode=false then begin FFrameMask.Width:=FFramebm.width; FFrameMask.Height:=FFramebm.height; FWorkBuf.Height:=FFramebm.height; FWorkBuf.Width:=FFramebm.width; makeframemask(TransColor); replacetranscolor(TransColor); end else begin FWorkBuf.Height:=FFramebm.height; FWorkBuf.Width:=FFramebm.width; FFrameMask.Assign(TBitmap(FMaskStore.items[num])); end; end; end; procedure TMapCharacter.MakeFrameMask(trColor: TColor); var testbm1,testbm2: TBitmap; trColorInv: TColor; begin testbm1 := TBitmap.Create; testbm1.width := 1; testbm1.height:=1; testbm2 := TBitmap.Create; testbm2.width := 1; testbm2.height:=1; testbm1.Canvas.Pixels[0,0]:=trColor; testbm2.Canvas.CopyMode:=cmSrcInvert; testbm2.Canvas.Draw(0,0,testbm1); trColorInv:=testbm2.Canvas.Pixels[0,0]; testbm1.free; testbm2.free; with FFrameMask.Canvas do begin Brush.Color:= trColorInv; BrushCopy( Rect(0,0,FFrameMask.Width,FFrameMask.Height),FFramebm, Rect(0,0,FFramebm.Width,FFramebm.Height),trColor); CopyMode:=cmSrcInvert; Draw(0,0,FFramebm); end; end; procedure TMapCharacter.ReplaceTransColor(trColor: TColor); begin with FFramebm.Canvas do begin CopyMode:=cmSrcCopy; Brush.Color:= clBlack; BrushCopy( Rect(0,0,FFramebm.Width,FFramebm.Height),FFramebm, Rect(0,0,FFramebm.Width,FFramebm.Height),trColor); end; end; function TMapCharacter.GetOnScreen:Boolean; var dispx,dispy:Integer; begin dispx:=Map.width div map.tilexdim; dispy:=Map.height div map.tileydim; if (xpos>=Map.xpos) and (xpos<=map.xpos+dispx) and (ypos>=map.ypos) and (ypos>=map.ypos+dispy) then result:=true; end; procedure TMapCharacter.SetVisible(vis:Boolean); begin if vis and OnScreen then Render; FVisible:=vis; end; procedure TMapCharacter.SetFastMode(fast:Boolean); begin if fast<>FFastMode then begin if fast=true then begin FMaskStore:=TFrameStore.Create; MakeFrameMasks; FFastMode:=True; frame:=0; end else begin FMaskStore.Free; FFastMode:=False; end; end; end; procedure TMapCharacter.MakeFrameMasks; var a:Integer; bm:TBitMap; begin if FFrameStore.count>0 then begin for a:=0 to FFrameStore.Count-1 do begin Frame:=a; bm:=TBitMap.create; bm.Assign(FFrameMask); FMaskStore.add(bm); end; end; end; procedure TMapCharacter.Render; var x,y:Integer; begin if visible and onscreen then RenderCharacter(true,xpos,ypos,FFramemask,FFramebm,FWorkbuf); end; procedure TMapCharacter.RenderCharacter(mapcoords:Boolean;cxpos,cypos: Integer;mask,bm,wb:TBitmap); var x,y:Integer; begin if map.ready then begin { Если пользователь определил это в mapcoords, то в первую очередь перерисовываем секцию(и). Если нет, делает это он. } if mapcoords then begin if FRedrawBackground then Map.redraw(cxpos,cypos,FMap.zpos,-1); wb.Canvas.Draw(0,0,TMapIcon(FMap.Iconset[map.zoomlevel].items [FMap.Map.Iconat(cxpos,cypos,Map.zpos)]).image); x:=(cxpos-Map.xpos)*FMap.tilexdim; y:=(cypos-Map.ypos)*FMap.tileydim; end else wb.Canvas.Copyrect(rect(0,0,FMap.tilexdim,FMap.tileydim),FMap. Screenbuffer.canvas,rect(x,y,x+FMap.tilexdim, y+FMap.tileydim)); with wb do begin Map.Canvas.CopyMode := cmSrcAnd; Map.Canvas.Draw(0,0,Mask); Map.Canvas.CopyMode := cmSrcPaint; Map.Canvas.Draw(0,0,bm); Map.Canvas.Copymode:=cmSrcCopy; end; Map.Canvas.CopyRect(Rect(x,y,x+FMap.tilexdim,y+FMap.tileydim),wb. canvas, Rect(0,0,FMap.tilexdim,FMap.tileydim)); end; end; procedure TMapCharacter.WriteData(Writer:TWriter); begin with Writer do begin WriteListBegin; WriteString(FName); WriteBoolean(FFastMode); WriteInteger(TransColor); FFrameStore.WriteData(Writer); if FFastMode then FMaskStore.WriteData(Writer); WriteListEnd; end; end; procedure TMapCharacter.ReadData(Reader:TReader); begin with Reader do begin ReadListBegin; Fname:=ReadString; FFastMode:=ReadBoolean; TransColor:=ReadInteger; FFrameStore.ReadData(Reader); if FFastMode then begin FMaskStore:=TFrameStore.Create; FMaskStore.ReadData(Reader); end; ReadListEnd; end; end; procedure TMapCharacterList.RenderVisibleCharacters; var a:Integer; begin for a:=0 to count-1 do TMapCharacter(items[a]).render; end; procedure TMapCharacterList.clear; var obj:TObject; begin {Этот код освобождает все ресурсы, присутствующие в списке} if self.count>0 then begin repeat obj:=self.items[0]; obj.free; self.remove(self.items[0]); until self.count=0; end; end; destructor TMapCharacterList.Destroy; var a:Integer; begin if count>0 then for a:=0 to count-1 do TObject(items[a]).free; inherited destroy; end; procedure TMapCharacterList.loadfromfile(const filename:string); var i:Integer; Reader:Treader; Stream:TFileStream; obj:TMapCharacter; begin stream:=TFileStream.create(filename,fmOpenRead); try reader:=TReader.create(stream,$ff); try with reader do begin try ReadSignature; if ReadInteger<>$6667 then Raise EReadError.Create('Не список сиволов.'); except Raise EReadError.Create('Неверный формат файла.'); end; ReadListBegin; while not EndofList do begin obj:=TMapCharacter.create(FMap); try obj.ReadData(reader); except obj.free; raise EReadError.Create('Ошибка в файле списка символов.'); end; self.add(obj); end; ReadListEnd; end; finally reader.free; end; finally stream.free; end; end; procedure TMapCharacterList.savetofile(const filename:String); var Stream:TFileStream; Writer:TWriter; i:Integer; obj:TMapCharacter; begin stream:=TFileStream.create(filename,fmCreate or fmOpenWrite); try writer:=TWriter.create(stream,$ff); try with writer do begin WriteSignature; WriteInteger($6667); WriteListBegin; for i:=0 to self.count-1 do TMapCharacter(self.items[i]).writedata(writer); WriteListEnd; end; finally writer.free; end; finally stream.free; end; end; procedure TFrameStore.WriteData(Writer:TWriter); var mstream:TMemoryStream; a,size:Longint; begin mstream:=TMemoryStream.Create; try with writer do begin WriteListBegin; WriteInteger(count); for a:=0 to count-1 do begin TBitmap(items[a]).savetostream(mstream); size:=mstream.size; WriteInteger(size); Write(mstream.memory^,size); mstream.position:=0; end; WriteListEnd; end; finally Mstream.free; end; end; procedure TFrameStore.ReadData(Reader:TReader); var mstream:TMemoryStream; a,listcount,size:Longint; newframe:TBitMap; begin mstream:=TMemoryStream.create; try with reader do begin ReadListBegin; Listcount:=ReadInteger; for a:=1 to listcount do begin size:=ReadInteger; mstream.setsize(size); read(mstream.Memory^,size); newframe:=TBitmap.create; newframe.loadfromstream(mstream); add(newframe); end; ReadListEnd; end; finally Mstream.free; end; end; procedure TFrameStore.clear; var Obj:TObject; begin {{Этот код освобождает все ресурсы, присутствующие в списке} if self.count>0 then begin repeat obj:=self.items[0]; obj.free; self.remove(self.items[0]); until self.count=0; end; end; end. |
[001680]
Файловые переменные
Вы просто создаете файловую переменную, чей тип является 'File of ...', где ... - ваша структура записи. Пример:
|
var F : File of TMyRec; R : TMyRec; begin { Заполнение записи R } AssignFile( F, 'somefile.dat' ); Rewrite( F ); Write( F, R ); CloseFile( F ); end; |
Later,
Ray Konopka
Raize Software Solutions
[000384]
Функция определения размера любого файла
Своим опытом делится Slava Kostin:
|
{Стандартная функция Delphi FileSize не может быть использована для определения размера текстовых файлов. Данная функция определяет размер любых файлов посредством вызова соответствующих фукнций WinAPI. Для использования должен быть дключен модуль Windows (uses Windows)} function AnyFileSize(FileName: PChar): LongWord; var hFile: THandle; begin hFile := CreateFile(FileName, GENERIC_READ, FILE_SHARE_READ + FILE_SHARE_WRITE, Nil, OPEN_EXISTING, 0, 0); //Попытка получить размер файла: Result := GetFileSize(hFile, Nil); CloseHandle(hFile); //Возоможно, произошла ошибка... if Result = $FFFFFFFF then begin //Произошла ошибка - возвращаем нулевой размер Result := 0; Exit; end; end; |
[001893]
Функция/процедура CopyFile
Модуль, который будет содердать этот код, должен иметь "LZExpand" в списке "uses" (без кавычек, естественно).
"var"-объявления:
| SourceHandle, DestHandle: Integer; SName,DName: String; |
SName и DName содержат полные пути с именами целевого и исходного файлов.
В теле процедуры:
|
{устанавливаем десктипторы файлов}
SourceHandle := FileOpen(SName,0);
DestHandle := FileCreate(DName);
{устанавливаем буфер, выполняем копирование, очищаем буфер} LZStart; CopyLZFile(SourceHandle,DestHandle); LZDone; {закрываем файлы} FileClose(SourceHandle); FileClose(DestHandle); |
[001678]
Импорт больших файлов с разделителями
Вот две функции, которые я использую почти во всех моих проектах. Пользоваться ею очень просто, например:
|
var s: String; f: TextFile; AssignFile(f, 'D:\INPUT.TXT'); Reset(f); while not EOF(f) do begin ReadLn(s, f); ShowMessage(GetField(s, 1)); {Первое поле} ShowMessage(GetField(s, 6)); {Шестое поле} ShowMessage(GetField(s, 25)); {возвратит '', если нет 25 колонки...} end; CloseFile(f); { ==== Данная функция возвращает поле из строки с разделителем. ==== } function GetField(InpString: String; fieldpos: Integer): String; var c: Char; curpos, i: Integer; begin curpos := 1; for i := 1 to fieldpos do begin result := ''; if curpos > Length(InpString) then Break; repeat c := InpString[curpos]; Inc(curpos, 1); if (c = '"') or (c = #13) or (c = #10) then c := ' '; if c <> ',' then result := result + c; until (c = ',') or (curpos > Length(InpString)) end; if (curpos > Length(InpString)) and (i < fieldpos) then result := ''; result := Trim(result); end; { ==== Данная функция удаляет у строки левые и правые пробелы. ==== } function Trim(inp_str: String): String; var i: Integer; begin for i := 1 to Length(inp_str) do if inp_str[i] <> ' ' then Break; if i > 1 then Delete(inp_str, 1, i - 1); for i := Length(inp_str) downto 1 do if inp_str[i] <> ' ' then Break; if i < Length(inp_str) then Delete(inp_str, i + 1, Length(inp_str)); result := inp_str; if result = ' ' then result := ''; end; |
[001691]
|
function FindWindowsDir : string; var pWindowsDir : array [0..255] of Char; sWindowsDir : string; begin // GetWindowsDirectory(LPTSTR,UINT); // LPTSTR lpBuffer, // адрес буфера для директории Windows // UINT uSize // размер буфера директории GetWindowsDirectory (pWindowsDir, 255); sWindowsDir := StrPas (pWindowsDir); Result := sWindowsDir ; end; |
Пришло письмо от читателя:
Пример процедуры достаточно часто не срабатывает, ну а если относительно меня,- вообще не работает. Предлагаю использовать следующий код (естественно, чтение из реестра)
|
function GetWindowsFolder:string; var TR:TRegIniFile; HK: HKEY; begin RegCreateKey(HKEY_LOCAL_MACHINE,'Software\Microsoft\Windows',HK); Reg:=TRegIniFile.Create(''); Reg.RootKey:=HK; GetWinVersion:=Reg.ReadString('CurrentVersion','SystemRoot',''); Reg.Free; end; |
E-mail to: igp@ukrpost.net.
Дополнение
Пришло письмо от читателя:
Я не знаю почему у некоторых не работает GetWindowsDir, ведь это задокументированная MSW -функция, которая есть и в Win95 и в 98. Может помогут эти небольщие ихменения?
|
function FindWindowsDir : string; var pWindowsDir : array [0..MAX_PATH] of Char; sWindowsDir : string; begin // GetWindowsDirectory(LPTSTR,UINT); // LPTSTR lpBuffer, // адрес буфера для директории Windows // UINT uSize // размер буфера директории GetWindowsDirectory (@pWindowsDir, MAX_PATH); sWindowsDir := StrPas (pWindowsDir); Result := sWindowsDir ; end; |
Subfire [000222]
Использую DeleteFile(). Почему выскакивает ошибка несовместимых типов?
Своим опытом делится Олег Кулабухов:
Надо учитывать, что определение этой функции есть и в SysUtils и в Windows.
Пример ниже показывает использование и того и другого варианта.
|
procedure TForm1.Button1Click(Sender: TObject); var s : string; a : array[0..MAX_PATH - 1] of char; begin s := 'C:\SomeFile'; SysUtils.DeleteFile(s); a := 'C:\SomeFile'; Windows.DeleteFile(@a); end; |
[001885]
Исправление ошибки записи на файл полей с данными
Вот самый простой способ сделать это (никто не спорит, может быть существует лучший способ):
|
var F : TextFile;
S : String;
AssignFile(F, 'FILENAME.TXT'); Reset(F); while Not EOF(F) do begin Readln(F, S); V1:= Copy(S,1,3); V2:= Copy(S,4,6); ... end; CloseFile(F); |
Вот что должно получиться при нормальных обстоятельствах. Но если файл большой, то для его чтения необходимо использовать blockread, после чего сканировать блок. Если вы подумываете об использовании ODBC, я не думаю, что все это может вам понадобиться. [001686]
Итерация подкаталогов
|
procedure TFormList.RecurseDir(PathInicial: string); var SearchRec: TSearchRec; Result: integer; tmpName: string; begin DirectoryListBox1.Directory:=PathInicial; Result:=FindFirst(PathInicial+'\*.*', faAnyFile, SearchRec); While Result = 0 do begin if ExtOk(SearchRec.Name) then { если каталог... } if SearchRec.Attr and faDirectory > 0 then { рекурсивно обрабатываем... } RecurseDir(PathInicial+'\'+SearchRec.Name) else begin tmpName:=PathInicial+'\'+SearchRec.Name; tmpName:=Copy(tmpName, Pos(PathOrigen,tmpName)+Length(PathOrigen), Length(tmpName)-Length(PathOrigen)); ListBox1.Items.Add(LowerCase(tmpName)); end; Application.ProcessMessages; Result:=FindNext(SearchRec); end; DirectoryListBox1.Directory:=PathInicial; end; |
[001693]
Изменение расширения BITMAP???
Я изменил расширение изображения с BMP на 3LG. Затем для загрузки *.3LG-файла в виде изображения в компонент Image1 я даю команду
| Image1.Picture.LoadFromFile('C:\TEST.3LG'); |
я получаю ошибку, говорящую о неверном расширении. Как мне обойти это? (это тот же BMP, но я просто изменил ему расширение)
Смотри процедуру RegisterFileFormat.
- Steve Schafer [000998]
Как избавиться от утечек памяти при использовании FindFirst, FindNext?
Своим опытом делится Олег Кулабухов:
Необходимо использовать эти функции, явно указывая их определение в модуле SysUtils. Ниже приведен пример:
|
begin Result := SysUtils.FindFirst(Path, Attr, SearchRec); while Result = 0 do begin ProcessSearchRec(SearchRec); Result := SysUtils.FindNext(SearchRec); end; SysUtils.FindClose(SearchRec); end; |
[001865]
Как мне открыть файл общего доступа?
Какие предложения по открытию файла общего доступа из Delphi-приложения?
Проверьте переменную FileMode и сравните ее значение с приведенным ниже списком:
|
Const
fmReadOnly = $00;
fmWriteOnly = $01;
fmReadWrite = $02;
fmDenyAll = $10; fmDenyWrite = $20; fmDenyRead = $30; fmDenyNone = $40; fmNoInherit = $80; |
Вы можете использовать их совместно, например так:
| FileMode := fmReadWrite + fmDenyAll; |
или так:
| FileMode := fmReadOnly + fmDenyNone; |
Успехов,
Dr. Bob (drbob@pi.net)
[000723]
Как мне подсчитать занимаемое директорией место?
Попробуйте следующий код (он просматривает скрытые, системные, архивные и нормальные файлы, использует рекурсивный алгоритм для просмотра всех вложенных поддиректорий: достаточно указать стартовый каталог и функция возвратит результат в переменной DirBytes, имейте в виду, что для определения типа (файл или директория) код использует функции FileExists и DirectoryExists вместо просмотра атрибутов файла. Причина этого проста - при просмотре CD-ROM функции FindFirst и FindNext иногда заявляют, что файл является каталогом. В коде я обошел эту ошибку. Возвращаемая размерность - байты.):
|
var DirBytes : integer; function TFileBrowser.DirSize(Dir:string):integer; var SearchRec : TSearchRec; Separator : string; begin if Copy(Dir,Length(Dir),1)='\' then Separator := '' else Separator := '\'; if FindFirst(Dir+Separator+'*.*',faAnyFile,SearchRec) = 0 then begin if FileExists(Dir+Separator+SearchRec.Name) then begin DirBytes := DirBytes + SearchRec.Size; {Memo1.Lines.Add(Dir+Separator+SearchRec.Name);} end else if DirectoryExists(Dir+Separator+SearchRec.Name) then begin if (SearchRec.Name<>'.') and (SearchRec.Name<>'..') then begin DirSize(Dir+Separator+SearchRec.Name); end; end; while FindNext(SearchRec) = 0 do begin if FileExists(Dir+Separator+SearchRec.Name) then begin DirBytes := DirBytes + SearchRec.Size; {Memo1.Lines.Add(Dir+Separator+SearchRec.Name);} end else if DirectoryExists(Dir+Separator+SearchRec.Name) then begin if (SearchRec.Name<>'.') and (SearchRec.Name<>'..') then begin DirSize(Dir+Separator+SearchRec.Name); end; end; end; end; FindClose(SearchRec); end; |
Как мне преобразовать "Long File Name.pas" в "longfi~1.pas"?
Попробуйте эти процедуры:
|
Function GetShortFileName(Const FileName : String) : String; var aTmp: array[0..255] of char; begin if GetShortPathName(PChar(FileName),aTmp,Sizeof(aTmp)-1)=0 then Result:= FileName else Result:=StrPas(aTmp); end; Function GetLongFileName(Const FileName : String) : String; var aInfo: TSHFileInfo; begin if SHGetFileInfo(PChar(FileName),0,aInfo,Sizeof(aInfo),SHGFI_DISPLAYNAME)<>0 then Result:= String(aInfo.szDisplayName) else Result:= FileName; end; |
Как можно получить длинное имя файла по его короткому имени?
Своим опытом делится Олег Кулабухов:
Используйте Win32_Find_Data от TsearchRec:
|
procedure TForm1.Button1Click(Sender: TObject); var SearchRec : TSearchRec; Success : integer; begin Success := SysUtils.FindFirst('C:\DownLoad\dial-u~1.htm', faAnyFile, SearchRec); if Success = 0 then begin ShowMessage(SearchRec.FindData.CFileName); end; SysUtils.FindClose(SearchRec); end; |
[001869]
Своим опытом делится Олег Кулабухов:
Используем ShFormatDrive:
|
const SHFMT_DRV_A = 0; const SHFMT_DRV_B = 1; const SHFMT_ID_DEFAULT = $FFFF; const SHFMT_OPT_QUICKFORMAT = 0; const SHFMT_OPT_FULLFORMAT = 1; const SHFMT_OPT_SYSONLY = 2; const SHFMT_ERROR = -1; const SHFMT_CANCEL = -2; const SHFMT_NOFORMAT = -3; function SHFormatDrive(hWnd : HWND; Drive : Word; fmtID : Word; Options : Word) : Longint stdcall; external 'Shell32.dll' name 'SHFormatDrive'; procedure TForm1.Button1Click(Sender: TObject); var FmtRes : longint; begin try FmtRes:= ShFormatDrive(Handle, SHFMT_DRV_A, SHFMT_ID_DEFAULT, SHFMT_OPT_QUICKFORMAT); case FmtRes of SHFMT_ERROR : ShowMessage('Error formatting the drive'); SHFMT_CANCEL : ShowMessage('User canceled formatting the drive'); SHFMT_NOFORMAT : ShowMessage('No Format') else ShowMessage('Disk has been formatted'); end; except end; end; |
[001831]
Как получить хэндл файла при использовании файловых переменных в Delphi?
Своим опытом делится Олег Кулабухов:
При использовании текстового файла:
| TheHandle := TTextRec(MyFile).handle; |
Для бинарных файлов следует писать так:
| TheHandle := TFileRec(MyFile).handle; |
[001927]
Как получить имя папки pабочего стола (не чеpез registry)?
Nomadic советует:
Пpосто очень хочется поpаботать с shell functions.
В этом примере делается и это -
|
procedure TForm1.Button1Click(Sender: TObject); procedure madd(s:string); begin memo1.lines.add(s); end; VAR ppmalloc:imalloc; id:ishellfolder; pi:pitemidlist; lpname:tstrret; begin if succeeded(shgetspecialfolderlocation(0,CSIDL_PROGRAMS,pi)) then begin madd('Succeeded programs location'); if succeeded(shgetdesktopfolder(id)) then begin madd('Succeeded get desktop folder'); if succeeded(id.getdisplaynameof(pi,0,lpname)) then begin madd('Succeeded get display name'); if lpname.uType=2 then begin madd(lpname.cstr); end; end else madd('UnSucceeded get display name'); end else madd('UnSucceeded get desktop folder'); end else madd('UNSucceeded programs location'); end; |
[001183]
Как получить информацию о версии файла?
Своим опытом делится Олег Кулабухов:
Как всегда, обращаемся к функциям Windows-API.
|
function TForm1.CheckShell32Version: Boolean; procedure GetFileVersion(FileName: string; var Major1, Major2, Minor1, Minor2: Integer); { Helper function to get the actual file version information } var Info: Pointer; InfoSize: DWORD; FileInfo: PVSFixedFileInfo; FileInfoSize: DWORD; Tmp: DWORD; begin // Get the size of the FileVersionInformatioin InfoSize := GetFileVersionInfoSize(PChar(FileName), Tmp); // If InfoSize = 0, then the file may not exist, or // it may not have file version information in it. if InfoSize = 0 then raise Exception.Create('Can''t get file version information for ' + FileName); // Allocate memory for the file version information GetMem(Info, InfoSize); try // Get the informationM GetFileVersionInfo(PChar(FileName), 0, InfoSize, Info); // Query the information for the version VerQueryValue(Info, '\', Pointer(FileInfo), FileInfoSize); // Now fill in the version information Major1 := FileInfo.dwFileVersionMS shr 16; Major2 := FileInfo.dwFileVersionMS and $FFFF; Minor1 := FileInfo.dwFileVersionLS shr 16; Minor2 := FileInfo.dwFileVersionLS and $FFFF; finally FreeMem(Info, FileInfoSize); end; end; var tmpBuffer: PChar; Shell32Path: string; VersionMajor: Integer; VersionMinor: Integer; Blank: Integer; begin tmpBuffer := AllocMem(MAX_PATH); // Get the shell32.dll path try GetSystemDirectory(tmpBuffer, MAX_PATH); Shell32Path := tmpBuffer + '\shell32.dll'; finally FreeMem(tmpBuffer); end; // Check to see if it exists if FileExists(Shell32Path) then begin // Get the file version GetFileVersion(Shell32Path, VersionMajor, VersionMinor, Blank, Blank); // Do something, such as require a certain version // (such as greater than 4.71) if (VersionMajor >= 4) and (VersionMinor >= 71) then Result := True else Result := False; end else Result := False; end; |
[001922]
Как прочесть атрибут файла "Last Accessed" (последний доступ)?
Если в Проводнике Windows 95 на любом файле нажать правую кнопку мыши и выбрать пункт "Свойства", можно увидеть время последнего доступа к данному файлу.
Как мне это сделать через Delphi/API???
|
procedure TForm1.Button1Click(Sender: TObject); var FileHandle : THandle; LocalFileTime : TFileTime; DosFileTime : DWORD; LastAccessedTime : TDateTime; FindData : TWin32FindData; begin FileHandle := FindFirstFile('AnyFile.FIL', FindData); if FileHandle <> INVALID_HANDLE_VALUE then begin Windows.FindClose(Handle); if (FindData.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) = 0 then begin FileTimeToLocalFileTime(FindData.ftLastWriteTime, LocalFileTime); FileTimeToDosDateTime(LocalFileTime, LongRec(DosFileTime).Hi,LongRec(DosFileTime).Lo); LastAccessedTime := FileDateToDateTime(DosFileTime); Label1.Caption := DateTimeToStr(LastAccessedTime); end; end; end; |
Как сбросить на диск кэшированную информацию о бинарном файле?
Своим опытом делится Олег Кулабухов:
|
procedure TForm1.Button1Click(Sender: TObject); var f : file; i : integer; begin i := 10; AssignFile(f, 'C:\DownLoad\Test.Bin'); ReWrite(f, 1); BlockWrite(f, i, sizeof(i)); FlushFileBuffers(TFileRec(f).Handle); CloseFile(f); end; |
[001853]
Как сделать рекурсию директорий и файлов?
Своим опытом делится Олег Кулабухов:
Учтите, что рекурсия занимает много памяти, поэтому подразумевается, что вы не будете использовать пример в чистом виде, а будете выгружать результат в файл или еще куда-нибудь, поскольку существует ограничение на количество пунктов, помещаемых в ListBox и ему подобных компонентов.
|
procedure GetDirectories(const DirStr : string; ListBox : TListBox); var DirInfo: TSearchRec; r : Integer; begin r := FindFirst(DirStr + '\*.*', FaDirectory, DirInfo); while r = 0 do begin Application.ProcessMessages; if ((DirInfo.Attr and FaDirectory = FaDirectory) and (DirInfo.Name <> '.') and (DirInfo.Name <> '..')) then ListBox.Items.Add(DirStr + '\' + DirInfo.Name); r := FindNext(DirInfo); end; SysUtils.FindClose(DirInfo); end; procedure GetFiles(const DirStr : string; ListBox : TListBox); var DirInfo: TSearchRec; r : Integer; begin r := FindFirst(DirStr + '\*.*', FaAnyfile, DirInfo); while r = 0 do begin Application.ProcessMessages; if ((DirInfo.Attr and FaDirectory <> FaDirectory) and (DirInfo.Attr and FaVolumeId <> FaVolumeID)) then ListBox.Items.Add(DirStr + '\' + DirInfo.Name); r := FindNext(DirInfo); end; SysUtils.FindClose(DirInfo); end; procedure TForm1.FormCreate(Sender: TObject); var i : integer; begin ListBox1.Items.Clear; ListBox2.Items.Clear; ListBox1.Items.Add('C:\Delphi'); GetDirectories('C:\Delphi', ListBox1); i := 1; while i < ListBox1.Items.Count do begin GetDirectories(ListBox1.Items[i], ListBox1); Inc(i); end; end; procedure TForm1.ListBox1Click(Sender: TObject); begin ListBox2.Clear; GetFiles(ListBox1.Items[ListBox1.ItemIndex], ListBox2); end; |
[001901]
Как удалить директорию со всеми файлами в ней находящимися?
Своим опытом делится Олег Кулабухов:
Нужно просто удалить все файлы в ней и затем саму директорию:
|
procedure TForm1.Button1Click(Sender: TObject); var DirInfo: TSearchRec; r : Integer; begin r := FindFirst('C:\Download\Test\*.*', FaAnyfile, DirInfo); while r = 0 do begin if ((DirInfo.Attr and FaDirectory <> FaDirectory) and (DirInfo.Attr and FaVolumeId <> FaVolumeID)) then if DeleteFile(pChar('C:\Download\test\' + DirInfo.Name)) = false then ShowMessage('Unable to delete : C:\Download\test\' + DirInfo.Name); r := FindNext(DirInfo); end; SysUtils.FindClose(DirInfo); if RemoveDirectory('C:\Download\Test') = false then ShowMessage('Unable to delete direcotry : C:\Download\test'); end; |
[001779]
Как указать системе на необходимость сбросить буфера *.INI-файла на диск?
Nomadic советует:
|
procedure FlushIni(FileName: string); var {$IFDEF WIN32} CFileName: array[0..MAX_PATH] of WideChar; {$ELSE} CFileName: array[0..127] of Char; {$ENDIF} begin {$IFDEF WIN32} if (Win32Platform = VER_PLATFORM_WIN32_NT) then begin WritePrivateProfileStringW(nil, nil, nil, StringToWideChar(FileName, CFileName, MAX_PATH)); end else begin WritePrivateProfileString(nil, nil, nil, PChar(FileName)); end; {$ELSE} WritePrivateProfileString(nil, nil, nil, StrPLCopy(CFileName, FileName, SizeOf(CFileName) - 1)); {$ENDIF} end; |
[001106]
Как узнать дату и время последнего доступа к файлу?
Своим опытом делится Олег Кулабухов:
Нижеприведенный пример добывает требуемые сведения. Только учтите, что не все файловые системы поддерживают эту возможность.
|
procedure TForm1.Button1Click(Sender: TObject); var SearchRec : TSearchRec; Success : integer; DT : TFileTime; ST : TSystemTime; begin Success := SysUtils.FindFirst('C:\autoexec.bat', faAnyFile, SearchRec); if (Success = 0) and (( SearchRec.FindData.ftLastAccessTime.dwLowDateTime <> 0) or ( SearchRec.FindData.ftLastAccessTime.dwHighDateTime <> 0)) then begin FileTimeToLocalFileTime(SearchRec.FindData.ftLastAccessTime,DT); FileTimeToSystemTime(DT,ST); Memo1.Lines.Clear; Memo1.Lines.Add('AutoExec.Bat was last accessed at:'); Memo1.Lines.Add('Year := ' + IntToStr(st.wYear)); Memo1.Lines.Add('Month := ' + IntToStr(st.wMonth)); Memo1.Lines.Add('DayOfWeek := ' + IntToStr(st.wDayOfWeek)); Memo1.Lines.Add('Day := ' + IntToStr(st.wDay)); Memo1.Lines.Add('Hour := ' + IntToStr(st.wHour)); Memo1.Lines.Add('Minute := ' + IntToStr(st.wMinute)); Memo1.Lines.Add('Second := ' + IntToStr(st.wSecond)); Memo1.Lines.Add('Milliseconds := ' + IntToStr(st.wMilliseconds)); end; SysUtils.FindClose(SearchRec); end; |
[001861]
Как в Delphi определить, где установлена Windows?
Nomadic отвечает:
GetWindowsDirectory
Пример:
| var Windir : String; WindirP : PChar; ................................................ WinDirP := StrAlloc(MAX_PATH); Res := GetWindowsDirectory(WinDirP, MAX_PATH); if Res > 0 then WinDir := StrPas(WinDirP); ................................................ |
[001640]
Количество строк в текстовом файле
Если файлы не слишком велики, вы можете сделать так:
|
List := TStringList.Create; try List.LoadFromFile('C:\FILE.TXT'); Gauge.MaxValue := List.Count; finally List.Free; end; |
Мы читаем в память весь текст, и кроме подсчета строк этот код ничего не делает. Другая идея заключается в использовании не счетчика строк, а счетчика байт. В самом начале вы запрашиваете размер файла (используя функцию Delphi FileSize), и в цикле проходите все байты, как вы делали это со строками. Цикл может выглядеть примерно так (предположим, вы используете стандартный паскалевский тип TEXT):
|
Gauge.MaxValue := FileSize(TextFile); Reset(TextFile); while not eof(TextFile) do begin Readln(TextFile, Line); { Обработка строки } with Gauge do begin Progress := Progress + Length(Line) + 2; { 2 для CR/LF } Refresh; end; end; |
[001372]
Конец файла
Я не уверен в том, что вы используете eof() в правильном контексте. eof() просто ПРОВЕРЯЕТ, находитесь ли вы в конце "f"-файла. При этом вы никуда не перемещаетесь. А вот пример, как переместиться в конец файла:
|
procedure gotoeof (f : file);
{ прыгаем в конец (eof) }
begin seek (f, 0); { перемещаемся в начало } seek (f, filesize(f)); { перемещаемся вперед на "x" количество байт, в нашем случае это размер файла! } end; {gotoeof} |
Eof() только проверяет, достигнут ли конец файла. Для установления файлового курсора на конец файла, вам необходимо использовать Seek() или SeekEof(). [001679]
Копирование файлов I
У меня есть проблема с копированием файлов. Delphi не хочет компилировать команду LZCopy.
Данный способ очень медленный:
|
pbBuf := PChar( LocalAlloc(LMEM_FIXED, 1) ); FileSeek(source,0,0); FileSeek(dest,0,0); repeat cbRead := Fileread(source, pbBuf, 1); FileWrite(dest, pbBuf, cbRead); until (cbRead = 0); |
Решение 1
|
{ Не забудьте добавить LZExpand в список используемых модулей (USES LZExpand;) } function CopyFile(SrcF,DestF : string) : boolean;L var SFile, DFile : integer; Res : longint; Msg : string; begin SFile := FileOpen(SrcF,0); { Открытие ReadOnly = 0, Write=1, Readwrite=2} DFile := FileCreate(DestF); Res := LZCopy(SFile,DFile); FileClose(SFile); FileClose(DFile); if Res < 0 then begin Msg := 'Неизвестная ошибка'; case Res of LZERROR_BADINHANDLE : Msg := 'Неверный дескриптор исходного файла'; LZERROR_BADOUTHANDLE : Msg := 'Неверный дескриптор файла-приемника'; LZERROR_BADVALUE : Msg := 'Входной параметр вышел за границы диапазона'; LZERROR_GLOBALLOC : Msg := 'Недостаточно памяти для требуемого буфера'; LZERROR_GLOBLOCK : Msg := 'Неверный дескриптор структуры внутренних данных'; LZERROR_READ : Msg := 'Неверный формат исходного файла'; LZERROR_UNKNOWNALG : Msg := 'Исходный файл был сжат неизвестным алгоритмом сжатия'; LZERROR_WRITE : Msg := 'Недостаточно места для выходного файла'; end; MessageDlg(Msg,mtERROR,[mbOK],0); result := FALSE end else result := TRUE; end; |
Решение 2
Конечно это будет медленным! Ты же читаешь по одному символу за раз... Попробуй распределить 8192 байт памяти и читать каждый проход по 8192 байт. Это должно немного ускорить процесс...
Решение 3
Самый простой способ копирования файлов:
|
VAR sI,dI:Longint; sD,sS:TFilename; USES LZExpand; ............ sI := FileOpen(sS,fmShareDenyWrite); dI := FileCreate(sD); { Копирование файла } CopyLZFile(sI,dI); { Закрытие файла } FileClose(sI); FileClose(dI); ............ |
[000088]
Копирование файлов II
Как мне скопировать файл?
Вот три способа:
|
{Данный способ использует файловый поток.} Procedure FileCopy( Const sourcefilename, targetfilename: String ); Var S, T: TFileStream; Begin S := TFileStream.Create( sourcefilename, fmOpenRead ); try T := TFileStream.Create( targetfilename, fmOpenWrite or fmCreate ); try T.CopyFrom(S, S.Size ) ; finally T.Free; end; finally S.Free; end; End; {Данный способ для чтения/записи использует блоки памяти.} procedure FileCopy(const FromFile, ToFile: string); var FromF, ToF: file; NumRead, NumWritten: Word; Buf: array[1..2048] of Char; begin AssignFile(FromF, FromFile); Reset(FromF, 1); { Размер записи = 1 } AssignFile(ToF, ToFile); { Открываем выходной файл } Rewrite(ToF, 1); { Размер записи = 1 } repeat BlockRead(FromF, Buf, SizeOf(Buf), NumRead); BlockWrite(ToF, Buf, NumRead, NumWritten); until (NumRead = 0) or (NumWritten <> NumRead); ClloseFile(FromF); CloseFile(ToF); end; {Данный способ использует LZCopy, добавьте в список USES модуль LZExpand.} procedure CopyFile(FromFileName, ToFileName: string); var FromFile, ToFile: File; begin AssignFile(FromFile, FromFileName); { Присваиваем FromFile FromFileName } AssignFile(ToFile, ToFileName); { Присваиваем ToFile ToFileName } Reset(FromFile); { Открываем файл для чтения } try Rewrite(ToFile); { Создаем файл для записи } try { копируем файл, если возвращена отрицательная величина } { возбуждаем исключение } if LZCopy(TFileRec(FromFile).Handle, TFileRec(ToFile).Handle) < 0 then raise EInOutError.Create('Ошибка использования LZCopy') finally CloseFile(ToFile); { Закрываем ToFile } end; finally CloseFile(FromFile); { Закрываем FromFile } end; end; |
[000621]
Копирование файлов III
Nomadic советует:
Можно так:
|
procedure CopyFile(const FileName, DestName: TFileName); var CopyBuffer: Pointer; { buffer for copying } TimeStamp, BytesCopied: Longint; Source, Dest: Integer; { handles } Destination: TFileName; { holder for expanded destination name } const ChunkSize: Longint = 8192; { copy in 8K chunks } begin Destination := ExpandFileName(DestName); { expand the destination path } if HasAttr(Destination, faDirectory) then { if destination is a directory... } Destination := Destination + '\' + ExtractFileName(FileName); { ...clone file name } TimeStamp := FileAge(FileName); { get source's time stamp } GetMem(CopyBuffer, ChunkSize); { allocate the buffer } try Source := FileOpen(FileName, fmShareDenyWrite); { open source file } if Source < 0 then raise EFOpenError.Create(FmtLoadStr(SFOpenError, [FileName])); try Dest := FileCreate(Destination); { create output file; overwrite existing } if Dest < 0 then raise EFCreateError.Create(FmtLoadStr(SFCreateError, [Destination])); try repeat BytesCopied := FileRead(Source, CopyBuffer^, ChunkSize); { read chunk } if BytesCopied > 0 then { if we read anything... } FileWrite(Dest, CopyBuffer^, BytesCopied); { ...write chunk } until BytesCopied < ChunkSize; { until we run out of chunks } finally FileClose(Dest); { close the destination file } { SetFileTimeStamp(Destination, TimeStamp);} { clone source's time stamp }{!!!} end; finally FileClose(Source); { close the source file } end; finally FreeMem(CopyBuffer, ChunkSize); { free the buffer } end; FileSetDate(Dest,FileGetDate(Source)); end; |
Хм. IMHO кpутовато будет такие функции писать, когда в большинстве случаев достаточно что-нубудь типа нижепpиводимого, пpичем оно даже гибче, так как позволяет скопиpовать как весь файл пpи From и Count = 0, так и пpоизвольный его кусок.
|
function CopyFile( InFile,OutFile: String; From,Count: Longint ): Longint; var InFS,OutFS: TFileStream; begin InFS := TFileStream.Create( InFile, fmOpenRead ); OutFS := TFileStream.Create( OutFile, fmCreate ); InFS.Seek( From, soFromBeginning ); Result := OutFS.CopyFrom( InFS, Count ); InFS.Free; OutFS.Free; end; |
try..except pасставляются по вкусу, а навоpоты вpоде установки атpибутов,даты и вpемени файла и т.п. для ясности удалены, да и не нужны они в основном никогда.
Конечно, под Win32 имеет смысл использовать функции CopyFile, SHFileOperation [001124]
Копирование файлов IV
Igor Nikolaev aKa The Sprite советует:
| Copyfile('C:\1.txt','C:\files\2.txt',0); |
где первый параметр - путь и имя нужного файла, а второй путь и имя нового(скопированого) файла
Если же необходимо задавать имена файлов через Edit, то:
| Copyfile(PChar(edit1.text),PChar(edit2.text),0); |
[001403]
LZCopy
Вот простой пример копирования файла (сжатого или нет):
|
Var
srcHandle, destHandle: Integer;
srcBuf, destBuf: TOFStruct;
srcHandle := LZOpenFile( f_source, srcBuf, OF_READ or OF_SHARE_DENY_NONE ); If srcHandle = -1 Then CopyFailed Else Begin destHandle := LZOpenFile( f_target, destBuf, OF_CREATE or OF_SHARE_EXCLUSIVE ); If destHandle = -1 Then CopyFailed Else Begin If LZCopy( srcHandle, destHandle ) < 0 Then CopyFailed; LZClose( destHandle ); End; { Else } LZClose( srcHandle ); End; { Else } |
f_source и f_target - указатели на терминированные нулем строки (PChars) с именем исходного и целевого файла. CopyFailed - просто процедура для вывода сообщения об ошибке, создайте ее сами.
Если вам необходимо скопировать сразу несколько файлов, эффективнее использовать последовательность:
| LZStart; For i:=1 to numSourcefiles Do Begin scrHandle := _lopen( имя исходного файла ... ); targetHandle := _lcreat( имя целевого файла... ); CopyLZFile( scrHandle, targetHandle ); _lclose( srcHandle ); _lclose( targetHandle ); End; LZDone; (* добавьте проверку на ошибку в каждом шаге! *) |
Все имена файлов должны терминироваться нулем, не используйте паскалевские строки! Самый простой путь для добавления нуля в конец строки - добавление символа #0 и передача адреса первого символа строки, например (@str[1]).
|
Var
source: string;
sourceHandle: Word;
.... source:= 'a:\anyfile.ext'; .... source := source+#0; sourceHandle := _lopen( @source[1], READ or OF_SHARE_DENY_NONE ); |
[000373]
Медленное копирование с диска на дискетту и обратно
Вместо чтения байта за байтом, вы должны открыть файл с размером записи, равным 64K или около того, и читать блоками. Это ускорит операцию. Если вам необходимо это сделать очень быстро и без особых затрат на программирование, поищите свободнораспространяемые компоненты для копирования файлов....
Пример процедуры копирования файла copyfile:
|
Function CopyFile(FromPath,ToPath : String) : integer;
Var F1 : file; F2 : file; NumRead : word; NumWritten : word; Buf : pointer; BufSize : longint; Totalbytes : longint; TotalRead : longint; Begin Result := 0; Assignfile(f1,FromPath); Assignfile(F2,ToPath); reset(F1,1); TotalBytes := Filesize(F1); Rewrite(F2,1); BufSize := 16384; GetMem(buf,BufSize); TotalRead :=0; repeat BlockRead(F1, Buf^, BufSize, NumRead); inc(TotalRead,NumRead); BlockWrite(F2, Buf^, NumRead, NumWritten); until (NumRead = 0) or (NumWritten <> NumRead); if (NumWritten <> NumRead) then begin {ошибка } result := -1; end closefile(f1); Closefile(f2); End; |
Если у вас есть file of byte (бинарный файл), или просто File, вы должны использовать Blockread, который позволяет устанавливать размер буфера, равный 64Кб. Ниже я предоставляю вашему вниманию "быстрый" способ достижения цели. Воспользуйтесь Compress (который, я надеюсь, вы найдете в поставке Delphi, в противном случае обратитесь на сайт Microsoft), который позволит вам создавать файлы типа filename.ex_. Это означает, что для копирования информации требуется гораздо меньше усилий.
Ниже приведен некоторый код, позволяющий копировать файлы. Будет даже лучше, если файлы будут в их текущем состоянии, поскольку, если они сжатые, процедура их просто не скопирует!
|
function TInstallForm.UnCompress(src, dest: String; Var Error : LongInt): Boolean; var s, d: TOFStruct; fs, fd: Integer; fnSrc, fnDest: PChar; begin src:=src + #0; dest:=dest + #0; fnSrc:=@src[1]; { Хитро преобразуем строки в ASCIIZ } fnDest:=@dest[1]; fs := LZOpenFile(fnSrc, s, OF_READ); { Получаем дескриптор файла } fd := LZOpenFile(fnDest, d, OF_CREATE); Error:=LZCopy(fs, fd); { Вот магический вызов API } Result:=(Error > -1); LZClose( fs ); { Убедитесь, что закрыли! } LZClose( fd ); end; Procedure UnCompressError(Error : LongInt); Begin Case Error Of LZERROR_BADINHANDLE : S:='Неверный дескриптор исходного файла'; LZERROR_BADOUTHANDLE: S:='Неверный дескриптор целевого файла'; LZERROR_BADVALUE : S:='Входной параметр вышел за границы диапазона'; LZERROR_GLOBALLOC : S:='Недостаточно памяти для требуемого буфера'; LZERROR_GLOBLOCK : S:='Неверный дескриптор структуры внутренних данных'; LZERROR_READ : S:='Неверный формат исходного файла'; LZERROR_UNKNOWNALG : S:='Исходный файл был упакован с использованием неизвестного алгоритма сжатия'; LZERROR_WRITE : S:='Недостаточно места для выходного файла' Else S:='Неизвестная проблема с распаковкой' End; MessageDlg(S, mtConfirmation,[mbOK],0); Close End; |
|
function CopyFile( SrcName,DestName : string ): boolean; { базовый метод копирования файла; требует полный путь & имя для исходного & целевого файла } var Buf: array[1..1024*4] of byte; { этот размер может быть изменен.. объявляя указатель, вы можете использовать GetMem для создания в куче большого буфера } TotalRead: longint; NumRead, NumWritten: word; TotalWritten: longint; FromFileSize: longint; FrF,ToF : file; FileTime : longint; begin FGetTime(SrcName,FileTime); Assign(FrF,SrcName); Reset(FrF,1); FromFileSize := FileSize(FrF); Assign(ToF,DestName); Rewrite(ToF,1); TotalRead := 0; TotalWritten := 0; REPEAT BlockRead (FrF, Buf, SizeOf(Buf), NumRead); TotalRead := TotalRead + NumRead; BlockWrite(ToF, Buf, NumRead, NumWritten); TotalWritten := TotalWritten + NumWritten; UNTIL (NumRead = 0) OR (NumWritten <> NumRead); Close(FrF); Close(ToF); { возвращаем true, если они равны, в противном случае возвращаем false } CopyFile := (TotalWritten = FromFileSize); end; |
[001713]
По моему глубокому убеждению для
По моему глубокому убеждению для получения метки диска в среде Win95 необходимо использовать FindFile. Но это не работает, так?
Правильно, FindFile в Win32 больше не возвращает имя диска, поскольку в не-FAT файловых системах (например, в NTFS) это работает иначе, чем в FAT. Вместо этого используйте функцию API GetVolumeInformation.
- Peter Below [001056]
Открытие файла только на чтение
Перед открытием или созданием файла, установите переменную FileMode. Чтобы установить ее, воспользуйтесь 'File Open Mode constants' (константы режима открытия файла). Взгляните на описание модуля Sysutils. Где-то во второй части описания находится перечень 'File Open Mode constants'. Вот они-то как раз и используются в переменной FileMode. Константы лучше связывать логическим оператором OR... например с fmOpen... или с константой fmShare... константы устанавливают режим.
Ознакомьтесь в файле помощи с описанием переменной FileMode. Если перед открытием файла вы установили ее в ноль, файл будет открыт только для чтения. По-умолчанию read/write (чтение/запись) для нетипизированных файлов.
Вы можете просто попробовать установить filemode после того, как сделаете файлу assign. Например:
| AssignFile(F, FileName); FileMode := 0; { устанавливаем доступ к файлу только для чтения } Reset(F); . . . CloseFile(F); |
[001695]
Переименование каталога
Функция RenameFile (модуль SysUtils) работает как для файлов, так и для каталогов. [001690]
Поиск на винчестере
Я ищу метод или компонент, производящий поиск каких-либо файлов на винчестере, например, (*.exe)...
|
unit Audit1; interface uses windos; var dest:string; procedure dorecurse(dir:string); implementation {$R *.DFM} Procedure Process (dir:string; Searchrec:tsearchrec); begin showmessage (Searchrec.name); case Searchrec.attr of $10: if (searchrec.name<>'.') and (searchrec.name<>'..') then begin dorecurse (dir+'\'+searchrec.name); writeln (dir); end; end; end; Procedure Dorecurse(dir:string); var Searchrec:Tsearchrec; pc: array[0..79] of Char; begin StrPCopy(pc, dir+'\*.*'); FindFirst(pc, FaAnyfile, SearchRec); Process (dir,SearchRec); while FindNext(SearchRec)<>-18 do begin Process (dir,SearchRec); end; end; Procedure startsearch; begin dorecurse (paramstr(1)); end; begin startsearch; end. |
[000126]
