OpenDialog1.Filter := 'icons (*.ico)|*.ICO'; OpenDialog1.Options := [ofOverwritePrompt, ofFileMustExist, ofHideReadOnly ]; if OpenDialog1.Execute then begin Icon := TIcon.Create; try Icon.Loadfromfile(OpenDialog1.FileName); s:= ChangeFileExt(OpenDialog1.FileName,'.BMP'); Image1.Width := Icon.Width; Image1.Height := Icon.Height; Image1.Canvas.Draw(0,0,Icon); Image1.Picture.SaveToFile(s);
ShowMessage(OpenDialog1.FileName + ' Saved to ' + s); finally Icon.Free; end; end; end; # SaveToFile, Create, Height, Width, Canvas, ChangeFileExt example ---------- ExpandFileName 将档案名称加在目前所在之路径全名之後 ---------- Unit SysUtils 函数原型 function ExpandFileName(const FileName: string): string; 说明 设目前目录为 c:\windows 档案名称为 abc.txt 则结果为 c:\windows\abc.txt **** 此函数并不是求abc.txt的所在路径. 范例 procedure TForm1.Button1Click(Sender: TObject); var S: String; begin S:=ExpandFileName('abc.txt'); Label1.Caption:=S; end; 范例 procedure TForm1.Button1Click(Sender: TObject) begin ListBox1.Items.Add(ExpandFileName(Edit1.Text)); end;
---------- DirectoryExists 目录是否存在---------- Unit FileCtrl
uses FileCtrl;
procedure TForm1.Button1Click(Sender: TObject); begin if not DirectoryExists('c:\temp') then if not CreateDir('C:\temp') then raise Exception.Create('Cannot create c:\temp'); end; ---------- ForceDirectories 目录 ---------- Unit FileCtrl 函数原型 function ForceDirectories(Dir: string): Boolean;
procedure TForm1.Button1Click(Sender: TObject); var Dir: string; begin Dir := 'C:\APPS\SALES\LOCAL'; if DirectoryExists(Dir) then Label1.Caption := Dir + ' was created' end; ---------- ExpandUNCFileName 同上(只是得到网路上的路径) ---------- Unit SysUtils 函数原型 function ExpandUNCFileName(const FileName: string):string; ExtractFileDir 分析字串中的路径 Unit SysUtils 函数原型 function ExtractFileDir(const FileName: string): string; 说明 设S字串为 c:\windows\abc.txt 则结果为 c:\windows **** 功能在於由任何部份传来的叁数,加以分析它的路径 范例 procedure TForm1.Button1Click(Sender: TObject); var S: String; P1:String; begin P1:='c:\windows\abc.txt'; S:=ExtractFileDir(P1); Label1.Caption:=S; end;
S=='c:\windows'
P1:='abc.txt' S=='
P1:='c:abc.txt' S=='c:'
P1:='c:\abc.txt' S=='c:\' ---------- ExtractFileDrive 分析字串中的磁碟机名称 ---------- Unit SysUtils 函数原型 function ExtractFileDrive(const FileName: string): string; **** 功能同上,只是传回磁碟机名称. 范例 procedure TForm1.Button1Click(Sender: TObject); var S: String; P1:String; begin P1:='c:\windows\abc.txt'; S:=ExtractFileDrive(P1); Label1.Caption:=S; end;
S:='c:'
P1:='abc.txt' S==' ---------- ExtractFileExt 分析字串中的档案名称的副档名 ---------- Unit SysUtils 函数原型 function ExtractFileExt(const FileName: string): string; 范例 procedure TForm1.Button1Click(Sender: TObject); var S: String; P1:String; begin P1:='c:\windows\abc.txt'; S:=ExtractFileExt(P1); Label1.Caption:=S; end;
S=='.txt'
P1:='c:\windows\abc' S==' 范例 MyFilesExtension := ExtractFileExt(MyFileName); ---------- ExtractFileName 分析字串中的档案名称(只传回档案名称) ---------- Unit SysUtils 函数原型 function ExtractFileName(const FileName: string): string; 范例 procedure TForm1.Button1Click(Sender: TObject); var S: String; P1:String; begin P1:='c:\windows\abc.txt'; S:=ExtractFileName(P1); Label1.Caption:=S; end;
S=='abc.txt' 范例 procedure TForm1.Button1Click(Sender: TObject); var BackupName: string; FileHandle: Integer; StringLen: Integer; X: Integer; Y: Integer; begin if SaveDialog1.Execute then begin if FileExists(SaveDialog1.FileName) then begin BackupName := ExtractFileName(SaveDialog1.FileName); BackupName := ChangeFileExt(BackupName, '.BAK'); if not RenameFile(SaveDialog1.FileName, BackupName) then raise Exception.Create('Unable to create backup file.'); end; FileHandle := FileCreate(SaveDialog1.FileName); { Write out the number of rows and columns in the grid. } FileWrite(FileHandle, StringGrid1.ColCount, SizeOf(StringGrid1.ColCount)); FileWrite(FileHandle, StringGrid1.RowCount, SizeOf(StringGrid1.RowCount)); for X := 0 to StringGrid1.ColCount ? 1 do begin for Y := 0 to StringGrid1.RowCount ? 1 do begin { Write out the length of each string, followed by the string itself. } StringLen := Length(StringGrid1.Cells[X,Y]); FileWrite(FileHandle, StringLen, SizeOf(StringLen)); FileWrite(FileHandle, StringGrid1.Cells[X,Y], Length(StringGrid1.Cells[X,Y]); end; end; FileClose(FileHandle); end; end; ##FileExists, RenameFile, FileCreate, FileWrite, FileClose, ExtractFileName Example ---------- ExtractFilePath 分析字串中的路径 ---------- Unit SysUtils 函数原型 function ExtractFilePath(const FileName: string): string; 说明 设S字串为 c:\windows\abc.txt 则结果为 c:\windows范例 procedure TForm1.Button1Click(Sender: TObject); var S: String; P1:String; begin P1:='c:\windows\abc.txt'; S:=ExtractFilePath(P1); Label1.Caption:=S; end; 范例 begin with Session do begin ConfigMode := cmSession; try AddStandardAlias('TEMPDB', ExtractFilePath(ParamStr(0)), 'PARADOX'); finally ConfigMode := cmAll; end; end; ##ConfigMode, AddStandardAlias, ExtractFilePath example ---------- FileSearch 寻找档案在磁碟机中的正确路径 ---------- Unit SysUtils 函数原型 function FileSearch(const Name, DirList: string): string; 范例 var s:string; begin s:= FileSearch('abc.txt', 'c:\window\'); Label1.Caption:=s; end; 说明 找到传回c:\window\abc.txt 找不到传回空字串. 范例 procedure TForm1.Button1Click(Sender: TObject); var buffer: array [0..255] of char; FileToFind: string; begin GetWindowsDirectory(buffer, SizeOf(buffer)); FileToFind := FileSearch(Edit1.Text, GetCurrentDir + ';' + buffer); if FileToFind = ' then ShowMessage('Couldn't find ' + Edit1.Text + '.') else ShowMessage('Found ' + FileToFind + '.'); end; ##FileSearch, ShowMessage Example ---------- FileAge 传回档案的日期及时间(DOS型态). ---------- Unit SysUtils 函数原型 function FileAge(const FileName: string): Integer; 说明 就是档案总管中档案内容裹面的修改日期. 范例 procedure TForm1.Button1Click(Sender: TObject); var S: String; FileDate1:Integer; DateTime1:TDateTime; begin FileDate1 := FileAge('c:\delphi_d\delphi_help1.txt'); DateTime1 := FileDateToDateTime(FileDate1); S := DateTimeToStr(DateTime1); Label1.Caption:=S; end; ---------- FileDateToDateTime 将DOS型态的日期时间转换为TDateTime型态. ---------- Unit SysUtils 函数原型 function FileDateToDateTime(FileDate: Integer):TDateTime; ---------- DateTimeToFileDate 将TDateTime型态的日期时间转换为 DOS型态. ---------- Unit SysUtils 函数原型 function DateTimeToFileDate(DateTime: TDateTime):Integer; FileGetDate 传回档案的日期及时间(DOS型态). Unit SysUtils 函数原型 function FileGetDate(Handle: Integer): Integer; 说明 就是档案总管中档案内容裹面的修改日期. 范例 procedure TForm1.Button1Click(Sender: TObject); var FileHandle:Integer; S: String; FileDate1:Integer; DateTime1:TDateTime; begin FileHandle :=FileOpen('c:\delphi_d\delphi_help2.txt', fmOpenReadWrite); if FileHandle > 0 then Begin FileDate1 := FileGetDate(FileHandle); DateTime1 := FileDateToDateTime(FileDate1); S := DateTimeToStr(DateTime1); FileClose(FileHandle); End else S := 'Open File Error'; Label1.Caption:=S; end; ---------- FileSetDate 设定档案的日期及时间(DOS型态). ---------- Unit SysUtils 函数原型 function FileSetDate(Handle: Integer; Age: Integer): Integer; 说明 传回值为0表示成功. ---------- DeleteFile 删除档案 ---------- Unit SysUtils 函数原型 function DeleteFile(const FileName: string): Boolean; 范例 一 DeleteFile('DELETE.ME');
范例 二 if FileExists(FileName) then if MessageDlg('Do you really want to delete ' + ExtractFileName(FileName) + '?'), []) = IDYes then DeleteFile(FileName); ##FileExists, DeleteFile Example ---------- RenameFile 更改档名 ---------- Unit SysUtils 函数原型 function RenameFile(const OldName, NewName: string):Boolean; 范例 procedure TForm1.Button1Click(Sender: TObject); var BackupName: string; FileHandle: Integer; StringLen: Integer; X: Integer; Y: Integer; begin if SaveDialog1.Execute then begin if FileExists(SaveDialog1.FileName) then begin BackupName := ExtractFileName(SaveDialog1.FileName); BackupName := ChangeFileExt(BackupName, '.BAK'); if not RenameFile(SaveDialog1.FileName, BackupName) then raise Exception.Create('Unable to create backup file.'); end; FileHandle := FileCreate(SaveDialog1.FileName); { Write out the number of rows and columns in the grid. } FileWrite(FileHandle, StringGrid1.ColCount, SizeOf(StringGrid1.ColCount)); FileWrite(FileHandle, StringGrid1.RowCount, SizeOf(StringGrid1.RowCount)); for X := 0 to StringGrid1.ColCount ? 1 do begin for Y := 0 to StringGrid1.RowCount ? 1 do begin { Write out the length of each string, followed by the string itself. } StringLen := Length(StringGrid1.Cells[X,Y]); FileWrite(FileHandle, StringLen, SizeOf(StringLen)); FileWrite(FileHandle, StringGrid1.Cells[X,Y], Length(StringGrid1.Cells[X,Y]); end; end; FileClose(FileHandle); end; end; ---------- DiskFree 磁碟机剩馀空间(Bytes) ---------- Unit SysUtils 函数原型 function DiskFree(Drive: Byte): Integer; 范例 var S: string; begin S := IntToStr(DiskFree(0) div 1024) + ' Kbytes free.'; Label1.Caption:=S; end; 说明 Drive 0=目前磁碟机,1=A磁碟机,2=B磁碟机...传回值若为-1,表示磁碟机侦测错误. 范例 var S: string; AmtFree: Int64; Total: Int64; begin AmtFree := DiskFree(0); Total := DiskSize(0); S := IntToStr(AmtFree div Total) + 'percent of the space on drive 0 is free: ' (AmtFree div 1024) + ' Kbytes free. '; Canvas.TextOut(10, 10, S); end; ##DiskFree, DiskSize Example ---------- DiskSize 磁碟机空间大小(Bytes) ---------- Unit SysUtils 函数原型 function DiskSize(Drive: Byte): Integer; 范例 var S: string; begin S := IntToStr(DiskSize(0) div 1024) + ' Kbytes free.'; Label1.Caption:=S; end; 说明 Drive 0=目前磁碟机,1=A磁碟机,2=B磁碟机....传回值若为-1,表示磁碟机侦测错误. ##DiskFree, DiskSize Example ---------- FileExists 判断档案是否存在. ---------- Unit SysUtils 函数原型 function FileExists(const FileName: string): Boolean; 类似 FileExists, RenameFile, FileCreate, FileWrite, FileClose, ExtractFileName Example 范例 procedure TForm1.Button1Click(Sender: TObject); var BackupName: string; FileHandle: Integer; StringLen: Integer; X: Integer; Y: Integer; begin if SaveDialog1.Execute then begin if FileExists(SaveDialog1.FileName) then begin BackupName := ExtractFileName(SaveDialog1.FileName); BackupName := ChangeFileExt(BackupName, '.BAK'); if not RenameFile(SaveDialog1.FileName, BackupName) then raise Exception.Create('Unable to create backup file.'); end; FileHandle := FileCreate(SaveDialog1.FileName); { Write out the number of rows and columns in the grid. } FileWrite(FileHandle, StringGrid1.ColCount, SizeOf(StringGrid1.ColCount)); FileWrite(FileHandle, StringGrid1.RowCount, SizeOf(StringGrid1.RowCount)); for X := 0 to StringGrid1.ColCount ? 1 do begin for Y := 0 to StringGrid1.RowCount ? 1 do begin { Write out the length of each string, followed by the string itself. } StringLen := Length(StringGrid1.Cells[X,Y]); FileWrite(FileHandle, StringLen, SizeOf(StringLen)); FileWrite(FileHandle, StringGrid1.Cells[X,Y], Length(StringGrid1.Cells[X,Y]); end; end; FileClose(FileHandle); end; end; ##FileExists, DeleteFile Example ##FileExists, RenameFile, FileCreate, FileWrite, FileClose, ExtractFileName Example ---------- FileOpen 开档. ---------- Unit SysUtils 函数原型 function FileOpen(const FileName: string; Mode: Integer):Integer; **** 开档失败传回-1. 说明 以下有关档案读取都属低阶,如Dos Int 21h中有关档案的部 分. fmOpenRead = $0000; fmOpenWrite = $0001; fmOpenReadWrite = $0002; fmShareCompat = $0000; fmShareExclusive = $0010; fmShareDenyWrite = $0020; fmShareDenyRead = $0030; fmShareDenyNone = $0040;
fmOpenRead Open for read access only. FmOpenWrite Open for write access only. FmOpenReadWrite Open for read and write access. fmShareCompat Compatible with the way FCBs are opened. fmShareExclusive Read and write access is denied. fmShareDenyWrite Write access is denied. fmShareDenyRead Read access is denied. fmShareDenyNone Allows full access for others. 范例 procedure OpenForShare(const FileName: String); var FileHandle : Integer; begin FileHandle := FileOpen(FileName, fmOpenWrite or fmShareDenyNone); if FileHandle > 0 then {valid file handle} else {Open error: FileHandle = negative DOS error code} end; 范例 procedure TForm1.Button1Click(Sender: TObject); var iFileHandle: Integer; iFileLength: Integer; iBytesRead: Integer; Buffer: PChar; i: Integer begin if OpenDialog1.Execute then begin try iFileHandle := FileOpen(OpenDialog1.FileName, fmOpenRead); iFileLength := FileSeek(iFileHandle,0,2); FileSeek(iFileHandle,0,0); Buffer := PChar(AllocMem(iFileLength + 1)); iBytesRead = FileRead(iFileHandle, Buffer, iFileLength); FileClose(iFileHandle); for i := 0 to iBytesRead-1 do begin StringGrid1.RowCount := StringGrid1.RowCount + 1; StringGrid1.Cells[1,i+1] := Buffer[i]; StringGrid1.Cells[2,i+1] := IntToStr(Integer(Buffer[i])); end; finally FreeMem(Buffer); end; end; end; ##FileOpen, FileSeek, FileRead Example ---------- FileCreate 建档 ---------- Unit SysUtils 函数原型 function FileCreate(const FileName: string): Integer;
范例 procedure TForm1.Button1Click(Sender: TObject); var BackupName: string; FileHandle: Integer; StringLen: Integer; X: Integer; Y: Integer; begin if SaveDialog1.Execute then begin if FileExists(SaveDialog1.FileName) then begin BackupName := ExtractFileName(SaveDialog1.FileName); BackupName := ChangeFileExt(BackupName, '.BAK'); if not RenameFile(SaveDialog1.FileName, BackupName) then
raise Exception.Create('Unable to create backup file.'); end; FileHandle := FileCreate(SaveDialog1.FileName); { Write out the number of rows and columns in the grid. } FileWrite(FileHandle, StringGrid1.ColCount, SizeOf(StringGrid1.ColCount)); FileWrite(FileHandle, StringGrid1.RowCount, SizeOf(StringGrid1.RowCount)); for X := 0 to StringGrid1.ColCount ? 1 do begin
for Y := 0 to StringGrid1.RowCount ? 1 do begin { Write out the length of each string, followed by the string itself. } StringLen := Length(StringGrid1.Cells[X,Y]); FileWrite(FileHandle, StringLen, SizeOf(StringLen)); FileWrite(FileHandle, StringGrid1.Cells[X,Y], Length(StringGrid1.Cells[X,Y]); end; end; FileClose(FileHandle); end;
end; ##FileExists, RenameFile, FileCreate, FileWrite, FileClose, ExtractFileName Example ---------- FileClose 关档 ---------- Unit SysUtils 函数原型 procedure FileClose(Handle: Integer); 范例 procedure TForm1.Button1Click(Sender: TObject); var BackupName: string; FileHandle: Integer; StringLen: Integer; X: Integer; Y: Integer; begin if SaveDialog1.Execute then begin if FileExists(SaveDialog1.FileName) then begin BackupName := ExtractFileName(SaveDialog1.FileName); BackupName := ChangeFileExt(BackupName, '.BAK'); if not RenameFile(SaveDialog1.FileName, BackupName) then raise Exception.Create('Unable to create backup file.'); end; FileHandle := FileCreate(SaveDialog1.FileName); { Write out the number of rows and columns in the grid. } FileWrite(FileHandle, StringGrid1.ColCount, SizeOf(StringGrid1.ColCount)); FileWrite(FileHandle, StringGrid1.RowCount, SizeOf(StringGrid1.RowCount)); for X := 0 to StringGrid1.ColCount ? 1 do begin for Y := 0 to StringGrid1.RowCount ? 1 do begin { Write out the length of each string, followed by the string itself. } StringLen := Length(StringGrid1.Cells[X,Y]); FileWrite(FileHandle, StringLen, SizeOf(StringLen)); FileWrite(FileHandle, StringGrid1.Cells[X,Y], Length(StringGrid1.Cells[X,Y]); end; end; FileClose(FileHandle); end; end; ##FileExists, RenameFile, FileCreate, FileWrite, FileClose, ExtractFileName Example
========== **** 它是以Handle为叁数. ========== FileRead 读取档案 ---------- Unit SysUtils 函数原型 function FileRead(Handle: Integer; var Buffer; Count: Integer):Integer; 范例 procedure TForm1.Button1Click(Sender: TObject);
var iFileHandle: Integer; iFileLength: Integer; iBytesRead: Integer; Buffer: PChar; i: Integer begin if OpenDialog1.Execute then begin try iFileHandle := FileOpen(OpenDialog1.FileName, fmOpenRead); iFileLength := FileSeek(iFileHandle,0,2); FileSeek(iFileHandle,0,0); Buffer := PChar(AllocMem(iFileLength + 1)); iBytesRead = FileRead(iFileHandle, Buffer, iFileLength); FileClose(iFileHandle); for i := 0 to iBytesRead-1 do begin StringGrid1.RowCount := StringGrid1.RowCount + 1; StringGrid1.Cells[1,i+1] := Buffer[i]; StringGrid1.Cells[2,i+1] := IntToStr(Integer(Buffer[i])); end; finally FreeMem(Buffer); end; end; end; ##FileOpen, FileSeek, FileRead Example ---------- FileWrite 写入档案 ---------- Unit SysUtils 函数原型 function FileWrite(Handle: Integer; const Buffer; Count: Integer): Integer; 范例 procedure TForm1.Button1Click(Sender: TObject); var BackupName: string; FileHandle: Integer; StringLen: Integer; X: Integer; Y: Integer; begin if SaveDialog1.Execute then begin if FileExists(SaveDialog1.FileName) then begin BackupName := ExtractFileName(SaveDialog1.FileName); BackupName := ChangeFileExt(BackupName, '.BAK'); if not RenameFile(SaveDialog1.FileName, BackupName) then raise Exception.Create('Unable to create backup file.'); end; FileHandle := FileCreate(SaveDialog1.FileName); { Write out the number of rows and columns in the grid. } FileWrite(FileHandle, StringGrid1.ColCount, SizeOf(StringGrid1.ColCount)); FileWrite(FileHandle, StringGrid1.RowCount, SizeOf(StringGrid1.RowCount)); for X := 0 to StringGrid1.ColCount do begin for Y := 0 to StringGrid1.RowCount do begin { Write out the length of each string, followed by the string itself. } StringLen := Length(StringGrid1.Cells[X,Y]); FileWrite(FileHandle, StringLen, SizeOf(StringLen)); FileWrite(FileHandle, StringGrid1.Cells[X,Y], Length(StringGrid1.Cells[X,Y]);//?????????/ end; end; FileClose(FileHandle); end; end; ##FileExists, RenameFile, FileCreate, FileWrite, FileClose, ExtractFileName Example ---------- FileSeek 移动档案指标位置 ---------- Unit SysUtils 函数原型 function FileSeek(Handle, Offset, Origin: Integer): Integer; 说明 Origin=0读/写指标由档案开头算起. Origin=1读/写指标由目前位置算起. Origin=2读/写指标移动到档案结束处. **** 功能与Dos Int 21h 插断 42h 的功能相同. 失败传回-1. 范例 procedure TForm1.Button1Click(Sender: TObject); var FileHandle : Integer; FileName : String; Buffer : PChar; S : String; ReadBytes : Integer; begin FileName:='c:\delphi_test\abc.ttt'; S:='1234567890'; if FileExists(FileName) then FileHandle := FileOpen(FileName, fmOpenReadWrite) else FileHandle := FileCreate(FileName); if FileHandle < 0 then Begin MessageDlg('开档失败', mtInformation, [mbOk], 0); Exit; End;
var iFileHandle: Integer; iFileLength: Integer; iBytesRead: Integer; Buffer: PChar; i: Integer begin if OpenDialog1.Execute then begin try iFileHandle := FileOpen(OpenDialog1.FileName, fmOpenRead); iFileLength := FileSeek(iFileHandle,0,2); FileSeek(iFileHandle,0,0); Buffer := PChar(AllocMem(iFileLength + 1)); iBytesRead = FileRead(iFileHandle, Buffer, iFileLength); FileClose(iFileHandle); for i := 0 to iBytesRead-1 do begin StringGrid1.RowCount := StringGrid1.RowCount + 1; StringGrid1.Cells[1,i+1] := Buffer[i]; StringGrid1.Cells[2,i+1] := IntToStr(Integer(Buffer[i])); end; finally FreeMem(Buffer); end; end; end; ##FileOpen, FileSeek, FileRead Example ---------- FileGetAttr 档案属性 ---------- Unit SysUtils 函数原型 function FileGetAttr(const FileName: string): Integer; 说明 faReadOnly = $00000001; faHidden = $00000002; faSysFile = $00000004; faVolumeID = $00000008; faDirectory = $00000010; faArchive = $00000020; faAnyFile = $0000003F; 范例 procedure TForm1.Button1Click(Sender: TObject); var S: String; begin S:=IntToStr(FileGetAttr('c:\delphi_d\delphi_help1.txt')); Label1.Caption := S; end; ---------- FileSetAttr 设定档案属性 ---------- Unit SysUtils 函数原型 function FileSetAttr(const FileName: string; Attr: Integer): Integer; 说明 设定成功传回0 ---------- FindClose 结束FindFirst/FindNext ---------- procedure TForm1.Button1Click(Sender: TObject);
var sr: TSearchRec; FileAttrs: Integer; begin StringGrid1.RowCount := 1; if CheckBox1.Checked then FileAttrs := faReadOnly else FileAttrs := 0; if CheckBox2.Checked then FileAttrs := FileAttrs + faHidden; if CheckBox3.Checked then FileAttrs := FileAttrs + faSysFile; if CheckBox4.Checked then FileAttrs := FileAttrs + faVolumeID; if CheckBox5.Checked then
FileAttrs := FileAttrs + faDirectory; if CheckBox6.Checked then FileAttrs := FileAttrs + faArchive; if CheckBox7.Checked then
FileAttrs := FileAttrs + faAnyFile;
if FindFirst(Edit1.Text, FileAttrs, sr) = 0 then
begin with StringGrid1 do begin if (sr.Attr and FileAttrs) = sr.Attr then begin Cells[1,RowCount-1] := sr.Name; Cells[2,RowCount-1] := IntToStr(sr.Size); end; while FindNext(sr) = 0 do begin if (sr.Attr and FileAttrs) = sr.Attr then begin RowCount := RowCount + 1; Cells[1, RowCount-1] := sr.Name;
var sr: TSearchRec; FileAttrs: Integer; begin StringGrid1.RowCount := 1; if CheckBox1.Checked then FileAttrs := faReadOnly else FileAttrs := 0; if CheckBox2.Checked then FileAttrs := FileAttrs + faHidden; if CheckBox3.Checked then FileAttrs := FileAttrs + faSysFile; if CheckBox4.Checked then FileAttrs := FileAttrs + faVolumeID; if CheckBox5.Checked then
FileAttrs := FileAttrs + faDirectory; if CheckBox6.Checked then FileAttrs := FileAttrs + faArchive; if CheckBox7.Checked then
FileAttrs := FileAttrs + faAnyFile;
if FindFirst(Edit1.Text, FileAttrs, sr) = 0 then
begin with StringGrid1 do begin if (sr.Attr and FileAttrs) = sr.Attr then begin Cells[1,RowCount-1] := sr.Name; Cells[2,RowCount-1] := IntToStr(sr.Size); end; while FindNext(sr) = 0 do begin if (sr.Attr and FileAttrs) = sr.Attr then begin RowCount := RowCount + 1; Cells[1, RowCount-1] := sr.Name; Cells[2, RowCount-1] := IntToStr(sr.Size); end; end; FindClose(sr); end; end; end; ##FindFirst, FindNext, FindClose Example ---------- FindNext 寻找下一个符合的档案. ---------- Unit SysUtils 函数原型 procedure FindClose(var F: TSearchRec); 函数原型 function FindFirst(const Path: string; Attr: Integer; var F: TSearchRec): Integer; 函数原型 function FindNext(var F: TSearchRec): Integer; 说明 成功传回0 范例 var SRec: TSearchRec; procedure TForm1.SearchClick(Sender: TObject); begin FindFirst('c:\delphi\bin\*.*', faAnyFile, SRec); Label1.Caption := SRec.Name + ' is ' + IntToStr(SRec.Size) + ' bytes in size'; end; procedure TForm1.AgainClick(Sender: TObject); begin FindNext(SRec); Label1.Caption := SRec.Name + ' is ' + IntToStr(SRec.Size) + ' bytes in size'; end; procedure TForm1.FormClose(Sender: TObject); begin FindClose(SRec); end
========== Floating-point conversion routines 浮点数转换函式 ========== FloatToDecimal 将浮点数转换为十进位数. ---------- Unit SysUtils 函数原型 procedure FloatToDecimal(var Result: TFloatRec; const Value; ValueType: TFloatValue; Precision, Decimals: Integer); ---------- FloatToStrF 将浮点数转换为格式化字串. ---------- Unit SysUtils 函数原型 function FloatToStrF(Value: Extended; Format: TFloatFormat; Precision,Digits: Integer): string; ---------- FloatToStr 将浮点数转换为字串. ---------- Unit SysUtils 函数原型 function FloatToStr(Value: Extended): string; ---------- FloatToText 将浮点数转换为格式化十进位. ---------- Unit SysUtils 函数原型 function FloatToText(Buffer: PChar; const Value; ValueType: TFloatValue;Format: TFloatFormat; Precision, Digits: Integer): Integer; ---------- FloatToTextFmt 将浮点数转换为格式化十进位. ---------- Unit SysUtils 函数原型 function FloatToTextFmt(Buffer: PChar; const Value; ValueType: TFloatValue; Format: PChar): Integer; ---------- FormatFloat 将浮点数转换为格式化字串. ---------- Unit SysUtils 函数原型 function FormatFloat(const Format: string; Value: Extended): string; ---------- StrToFloat 将字串转换为浮点数. ---------- Unit SysUtils 函数原型 function StrToFloat(const S: string): Extended; 范例 procedure TForm1.Button1Click(Sender: TObject); var Value:Double; S:String; begin S:=' 1234.56 '; Value:=StrToFloat(S); Label1.Caption:=Format('转换为 [%9.3f]',[Value]); end;
注意 若S字串含有非数字字元,会产生错误讯号. ---------- TextToFloat 将 null-terminated 字串转换为浮点数. ---------- Unit SysUtils 函数原型 function TextToFloat(Buffer: PChar; var Value; ValueType: TFloatValue): Boolean;
========== Flow-control routines 流程控制常式 ========== Break 从 for, while, or repeat 终止跳出. ---------- Unit System 函数原型 procedure Break; 范例 var S: string; begin while True do begin ReadLn(S); try if S = ' then Break; WriteLn(S); finally { do something for all cases } end; end; end; ---------- Continue 从 for, while, or repeat 继续执行. ---------- Unit System 函数原型 procedure Continue; 范例 var F: File; i: integer; begin for i := 0 to (FileListBox1.Items.Count - 1) do begin try if FileListBox1.Selected[i] then begin if not FileExists(FileListBox1.Items.Strings[i]) then begin MessageDlg('File: ' +FileListBox1.Items.Strings[i] + ' not found', mtError, [mbOk], 0); Continue; end; AssignFile(F, FileListBox1.Items.Strings[i]); Reset(F, 1); ListBox1.Items.Add(IntToStr(FileSize(F))); CloseFile(F); end; finally { do something here } end; end; end; 范例 var F: File; i: Integer; begin for i := 0 to (FileListBox1.Items.Count - 1) do begin try if FileListBox1.Selected[i] then begin if not FileExists(FileListBox1.Items.Strings[i]) then begin MessageDlg('File: ' + FileListBox1.Items.Strings[i] + ' not found', mtError, [mbOk], 0); Continue; end; AssignFile(F, FileListBox1.Items.Strings[i]);
Reset(F, 1); ListBox1.Items.Add(IntToStr(FileSize(F))); CloseFile(F); end; finally { do something here } end; end; end; ## Continue, Items, Selected Example ---------- Exit 直接离开一个程序. ---------- Unit System 函数原型 procedure Exit; ---------- Halt 结束程式返回作业系统. ---------- Unit System 函数原型 procedure Halt [ ( Exitcode: Integer) ]; 范例 begin if 1 = 1 then begin if 2 = 2 then begin if 3 = 3 then begin Halt(1); { Halt right here! } end; end; end; Canvas.TextOut(10, 10, 'This will not be executed'); end; ---------- RunError 停止程式执行且执行run-time error. ---------- Unit System 函数原型 procedure RunError [ ( Errorcode: Byte ) ]; 范例 begin {$IFDEF Debug} if P = nil then RunError(204); {$ENDIF} end;
========== I/O routines I/O常式 ========== AssignFile 指定档案给一个档案变数. ---------- Unit System 函数原型 procedure AssignFile(var F; FileName: string); 说明 **一个档案不可重复执行AssignFile两次以上. Example var F: TextFile; S: string; begin if OpenDialog1.Execute then { Display Open dialog box } begin AssignFile(F, OpenDialog1.FileName); { File selected in dialog box } Reset(F); Readln(F, S); { Read the first line out of the file } Edit1.Text := S; { Put string in a TEdit control } CloseFile(F); end; end; ## AssignFile, OpenDialog, Readln, CloseFile Example ---------- CloseFile 关闭档案. ---------- Unit System 函数原型 procedure CloseFile(var F); #### AssignFile, OpenDialog, Readln, CloseFile Example ---------- IOResult 传回最近一次执行I/O函数,是否有错误. ---------- Unit System 函数原型 function IOResult: Integer; 范例 var F: file of Byte; S: String; begin S:= 'c:\ka\aaa.txt'; AssignFile(F, S); {$I-} Reset(F); {$I+} if IOResult = 0 then Label1.Caption:='File size in bytes: ' + IntToStr(FileSize(F); else Label1.Caption:='开档失败'; end; 说明 传回0表示没有错误. EXAMPLE var F: file of Byte; begin if OpenDialog1.Execute then begin AssignFile(F, OpenDialog1.FileName); {$I-} Reset(F); {$I+} if IOResult = 0 then MessageDlg('File size in bytes: ' + IntToStr(FileSize(F)), mtInformation, [mbOk], 0) else MessageDlg('File access error', mtWarning, [mbOk], 0); end; end; ---------- Reset 开起一个可供读取的档案. ---------- Unit System 函数原型 procedure Reset(var F [: File; RecSize: Word ] ); ---------- Rewrite 建立一个可供写入的新档案. ---------- Unit System 函数原型 procedure Rewrite(var F: File [; Recsize: Word ] ); 范例 procedure TForm1.Button1Click(Sender: TObject); var F: TextFile; I1,I2,I3:Integer; S1,S2,S3:String; begin I1:=1234; I2:=5678; I3:=90; S1:='abcd'; S2:='efgh'; S3:='ij'; AssignFile(F,'c:\ka\aaa.txt'); Rewrite(F); Write(F,I1); Write(F,I2); Write(F,I3); Write(F,S1); Write(F,S2); Write(F,S3); Write(F,I1,I2,I3); Write(F,S1,S2,S3); Writeln(F,I1); Writeln(F,I2); Writeln(F,I3); Writeln(F,S1); Writeln(F,S2); Writeln(F,S3); Writeln(F,I1,I2,I3); Writeln(F,S1,S2,S3);
范例 procedure TForm1.Button1Click(Sender: TObject); var F: file of Byte; I1,I2,I3:Byte; begin I1:=16; I2:=32; I3:=48; AssignFile(F,'c:\ka\aaa.txt'); Rewrite(F); Write(F,I1); Write(F,I2); Write(F,I3); Write(F,I1,I2,I3);
I1:=0; Reset(F); Read(F, I1);
Label1.Caption:=IntToStr(I1); CloseFile(F); end;
结果 file of Byte 及 file of record 只能以Write及Read,来写入及读取, 不可以Writeln及Readln.
范例 procedure TForm1.Button1Click(Sender: TObject); type ppRec = record pp_No:String[5]; pp_Name:String[10]; pp_Age:Integer; pp_Sum:Double; end; var Rec : ppRec; Rec2: ppRec; F: file of ppRec; begin With Rec do Begin pp_No:='0001'; pp_Name:='abc'; pp_Age:=12; pp_Sum:=600; End;
整个Record以16的倍数存档. EXAMPLE var F: TextFile; begin AssignFile(F, 'NEWFILE.$$$'); Rewrite(F); Writeln(F, 'Just created file with this text in it...'); CloseFile(F); end; ---------- Seek 移动档案指标. ---------- Unit System 函数原型 procedure Seek(var F; N: Longint); 说明 Seek从0开始. Example var f: file of Byte; size : Longint; S: string; y: Integer; begin if OpenDialog1.Execute then begin AssignFile(f, OpenDialog1.FileName); Reset(f); size := FileSize(f); S := 'File size in bytes: ' + IntToStr(size); y := 10; Canvas.TextOut(5, y, S); y := y + Canvas.TextHeight(S) + 5; S := 'Seeking halfway into file...'; Canvas.TextOut(5, y, S); y := y + Canvas.TextHeight(S) + 5; Seek(f,size div 2); S := 'Position is now ' + IntToStr(FilePos(f)); Canvas.TextOut(5, y, S); CloseFile(f); end; end; ## FileSize, Seek, FilePos Example ---------- Truncate 将目前档案指标位置之後的档案内容全部删除. ---------- Unit System 函数原型 procedure Truncate(var F); 范例 var
f: file of Integer; i,j: Integer; begin AssignFile(f,'TEST.INT'); Rewrite(f); for i := 1 to 6 do Write(f,i); Writeln('File before truncation:'); Reset(f); while not Eof(f) do begin Read(f,i); Writeln(i); end; Reset(f); for i := 1 to 3 do Read(f,j); { Read ahead 3 records } Truncate(f); { Cut file off here }
Writeln; Writeln('File after truncation:'); Reset(f); while not Eof(f) do begin Read(f,i); Writeln(i); end; CloseFile(f); Erase(f); end; ---------- FilePos 传回目前档案的位置. ---------- Unit System 函数原型 function FilePos(var F): Longint 说明 F 不可为 Text File 档头 :FilePos(F):=0; 档尾 :Eof(F):=True; 范例 var f: file of Byte; S: string; begin S:= 'c:\ka\abc.txt'; AssignFile(f, S); Reset(f); Seek(f,1); Label1.Caption := '现在位置 : ' + IntToStr(FilePos(f)); end; Example var f: file of Byte; size : Longint; S: string; y: Integer; begin if OpenDialog1.Execute then begin AssignFile(f, OpenDialog1.FileName); Reset(f); size := FileSize(f); S := 'File size in bytes: ' + IntToStr(size); y := 10; Canvas.TextOut(5, y, S); y := y + Canvas.TextHeight(S) + 5; S := 'Seeking halfway into file...'; Canvas.TextOut(5, y, S);
y := y + Canvas.TextHeight(S) + 5; Seek(f,size div 2); S := 'Position is now ' + IntToStr(FilePos(f)); Canvas.TextOut(5, y, S); CloseFile(f); end; end; ##FileSize, Seek, FilePos Example ---------- FileSize 档案长度. ---------- Unit System 函数原型 function FileSize(var F): Integer; 说明 F 不可为 Text File 如果F为record file,则传回record数, 否则传回Byte数. ## FileSize, Seek, FilePos Example ---------- Eof 测试档案是否结束. ---------- Unit System 函数原型 function Eof(var F): Boolean; 函数原型 function Eof [ (var F: Text) ]: Boolean; 范例 var F1, F2: TextFile; Ch: Char; begin if OpenDialog1.Execute then begin AssignFile(F1, OpenDialog1.Filename); Reset(F1); if SaveDialog1.Execute then begin AssignFile(F2, OpenDialog1.Filename); Rewrite(F2); while not Eof(F1) do begin Read(F1, Ch); Write(F2, Ch); end; CloseFile(F2); end; CloseFile(F1); end; end; Example var
F1, F2: TextFile; Ch: Char; begin if OpenDialog1.Execute then begin AssignFile(F1, OpenDialog1.Filename); Reset(F1); if SaveDialog1.Execute then begin AssignFile(F2, SaveDialog1.Filename); Rewrite(F2); while not Eof(F1) do begin Read(F1, Ch); Write(F2, Ch); end; CloseFile(F2); end; CloseFile(F1); end; end; ---------- OpenPictureDialog OpenDialog 开启档案. ---------- //SavePictureDialog1.DefaultExt := GraphicExtension(TBitmap); //SavePictureDialog1.Filter := GraphicFilter(TBitmap);
procedure TForm1.Button1Click(Sender: TObject); var Done: Boolean; begin OpenPictureDialog1.DefaultExt := GraphicExtension(TIcon); OpenPictureDialog1.FileName := GraphicFileMask(TIcon); OpenPictureDialog1.Filter := GraphicFilter(TIcon); OpenPictureDialog1.Options := [ofFileMustExist, ofHideReadOnly, ofNoChangeDir ]; while not Done do begin if OpenPictureDialog1.Execute then begin if not (ofExtensionDifferent in OpenPictureDialog1.Options) then
begin Application.Icon.LoadFromFile(OpenPictureDialog1.FileName); Done := True; end else OpenPictureDialog1.Options := OpenPictureDialog1.Options - ofExtensionDifferent; end else { User cancelled } Done := True; end; end;
## Eof, Read, Write Example ---------- Erase 删除档案. ---------- Unit System 函数原型 procedure Erase(var F); 说明 要先关档後才可以执行. 范例 procedure TForm1.Button1Click(Sender: TObject); var F: Textfile; begin OpenDialog1.Title := 'Delete File'; if OpenDialog1.Execute then begin AssignFile(F, OpenDialog1.FileName); try Reset(F); if MessageDlg('Erase ' + OpenDialog1.FileName + '?',mtConfirmation, [mbYes, mbNo], 0) = mrYes then begin CloseFile(F); Erase(F); end; except on EInOutError do MessageDlg('File I/O error.', mtError, [mbOk], 0); end; end; end; Example procedure TForm1.Button1Click(Sender: TObject);
var F: Textfile; begin OpenDialog1.Title := 'Delete File'; if OpenDialog1.Execute then begin AssignFile(F, OpenDialog1.FileName); try Reset(F); if MessageDlg('Erase ' + OpenDialog1.FileName + '?', mtConfirmation, [mbYes, mbNo], 0) = mrYes then begin CloseFile(F); Erase(F); end; except on EInOutError do
MessageDlg('File I/O error.', mtError, [mbOk], 0); end; end; end; ##Erase, OpenDialog.Title, OpenDialog.FileName Example ---------- Rename 更改档名. ---------- Unit System 函数原型 procedure Rename(var F; Newname); 范例 uses Dialogs; var f : file; begin OpenDialog1.Title := 'Choose a file... '; if OpenDialog1.Execute then begin SaveDialog1.Title := 'Rename to...'; if SaveDialog1.Execute then begin AssignFile(f, OpenDialog1.FileName); Canvas.TextOut(5, 10, 'Renaming ' + OpenDialog1.FileName +' to ' + SaveDialog1.FileName); Rename(f, SaveDialog1.FileName); end; end; end; Example uses Dialogs; var
f : file; begin OpenDialog1.Title := 'Choose a file... '; if OpenDialog1.Execute then begin SaveDialog1.Title := 'Rename to...'; if SaveDialog1.Execute then begin AssignFile(f, OpenDialog1.FileName); Canvas.TextOut(5, 10, 'Renaming ' + OpenDialog1.FileName + ' to ' + SaveDialog1.FileName); Rename(f, SaveDialog1.FileName); end; end; end; ---------- GetDir 传回指定磁碟机的目录. ---------- Unit System 函数原型 procedure GetDir(D: Byte; var S: string); 说明 D 0=目前磁碟机,1=A磁碟机,2=B磁碟机.... **此函式不检查磁碟机错误. 范例 var s : string; begin GetDir(0,s); { 0 = Current drive } MessageDlg('Current drive and directory: ' + s, mtInformation, [mbOk] , 0); end; ---------- MkDir 建立子目录. ---------- Unit System 函数原型 procedure MkDir(S: string); 范例 uses Dialogs; begin {$I-} { Get directory name from TEdit control } MkDir(Edit1.Text); if IOResult <> 0 then MessageDlg('Cannot create directory', mtWarning, [mbOk], 0) else MessageDlg('New directory created', mtInformation, [mbOk], 0); end; ---------- RmDir 删除一个空的子目录. ---------- Unit System 函数原型 procedure RmDir(S: string); 范例 uses Dialogs; begin {$I-} { Get directory name from TEdit control } RmDir(Edit1.Text); if IOResult <> 0 then MessageDlg('Cannot remove directory', mtWarning, [mbOk], 0) else MessageDlg('Directory removed', mtInformation, [mbOk], 0); end; ---------- ChDir 改变目前目录. ---------- Unit System 函数原型 procedure ChDir(S: string); 范例 begin {$I-} { Change to directory specified in Edit1 } ChDir(Edit1.Text); if IOResult <> 0 then MessageDlg('Cannot find directory', mtWarning,[mbOk], 0); end;
========== Memory-management routines 记忆体管理常式 ========== AllocMem 配置记忆体. ---------- Unit SysUtils 函数原型 function AllocMem(Size: Cardinal): Pointer; 说明 FreeMem释放记忆体. ---------- GetHeapStatus 传回目前Heap区的记忆体配置状态. ---------- Unit System 函数原型 function GetHeapStatus: THeapStatus; ---------- GetMemoryManager 传回目前Heap区的记忆体配置 的进入点. ---------- Unit System 函数原型 procedure GetMemoryManager(var MemMgr: TMemoryManager); EXample var
procedure SetNewMemMgr; begin GetMemoryManager(OldMemMgr); SetMemoryManager(NewMemMgr); end; ##GetMemoryManager, SetMemoryManager Example
========== Miscellaneous routines 其他常式 ========== Exclude 删除一组元素中的一个元素. ---------- Unit System 函数原型 procedure Exclude(var S: set of T;I:T); 说明 删除S中的I元素. ---------- FillChar 填入元素. ---------- Unit System 函数原型 procedure FillChar(var X; Count: Integer; value); 说明 以value填入X中Count个.
范例 Example var S: array[0..79] of char; begin { Set to all spaces } FillChar(S, SizeOf(S), Ord(' ')); MessageDlg(S, mtInformation, [mbOk], 0); end; ---------- Hi 传回高位元数字. ---------- Unit System 函数原型 function Hi(X): Byte; 范例 var B: Byte; begin B := Hi($1234); { $12 } end; ---------- Include 加入一个元素到一组元素. ---------- Unit System 函数原型 procedure Include(var S: set of T; I:T); 说明 加入I元素到S中. ---------- Lo 传回高位元数字. ---------- Unit System 函数原型 function Lo(X): Byte; 范例 var B: Byte; begin B := Lo($1234); { $34 } end; ---------- Move 从来源变数拷贝n个Bytes到目的变数. ---------- Unit System 函数原型 procedure Move(var Source, Dest; Count: Integer); 范例 var A: array[1..4] of Char; B: Integer; begin Move(A, B, SizeOf(B)); { SizeOf = safety! } end; ---------- ParamCount 直接由执行档後加上传入变数的个数.(arj.exe a dr.arj d:*.*) ---------- Unit System 函数原型 function ParamCount: Integer; 说明 如上例则传回3 Example var
I: Integer; ListItem: string; begin for I := 0 to IBQuery1.ParamCount - 1 do begin ListItem := ListBox1.Items[I]; case IBQuery1.Params[I].DataType of ftString: IBQuery1.Params[I].AsString := ListItem; ftSmallInt: IBQuery1.Params[I].AsSmallInt := StrToIntDef(ListItem, 0); ftInteger: IBQuery1.Params[I].AsInteger := StrToIntDef(ListItem, 0); ftWord:
IBQuery1.Params[I].AsWord := StrToIntDef(ListItem, 0); ftBoolean: begin if ListItem = 'True' then IBQuery1.Params[I].AsBoolean := True else IBQuery1.Params[I].AsBoolean := False; end; ftFloat: IBQuery1.Params[I].AsFloat := StrToFloat(ListItem); ftCurrency: IBQuery1.Params[I].AsCurrency := StrToFloat(ListItem); ftBCD:
IBQuery1.Params[I].AsBCD := StrToCurr(ListItem); ftDate: IBQuery1.Params[I].AsDate := StrToDate(ListItem); ftTime: IBQuery1.Params[I].AsTime := StrToTime(ListItem); ftDateTime: IBQuery1.Params[I].AsDateTime := StrToDateTime(ListItem); end; end; end; ##ParamCount, DataType, StrToIntDef, AsXXX Example ---------- ParamStr ---------- Unit System 函数原型 function ParamStr(Index: Integer): string; 说明 ParamStr(0);传回执行档的名称及完整目录. (C:\ZIP\ARJ.EXE) 范例 var I: Word; Y: Integer; begin Y := 10; for I := 1 to ParamCount do begin Canvas.TextOut(5, Y, ParamStr(I)); Y := Y + Canvas.TextHeight(ParamStr(I)) + 5; end; end;
Example procedure TForm1.FormCreate(Sender: TObject);
var i: Integer; for i := 0 to ParamCount -1 do begin if LowerCase(ParamStr(i)) = 'beep' then Windows.Beep(10000,1000) else if (LowerCase(ParamStr(i)) = 'exit' then Application.Terminate; end; end; ##ParamCount, ParamStr Example ---------- Random 乱数 ---------- Unit System 函数原型 function Random [ ( Range: Integer) ]; 说明 0<=X<Range 范例 var I: Integer; begin Randomize; for I := 1 to 50 do begin { Write to window at random locations } Canvas.TextOut(Random(Width), Random(Height), 'Boo!'); end; end; ---------- Randomize 乱数种子. ---------- Unit System 函数原型 procedure Randomize; Example var
I: Integer; begin Randomize; for I := 1 to 50 do begin { Write to window at random locations } Canvas.TextOut(Random(Width), Random(Height), 'Boo!'); end; end; ##Randomize, Random Example ---------- SizeOf 传回X变数的位元数. ---------- Unit System 函数原型 function SizeOf(X): Integer; 范例 type CustRec = record Name: string[30]; Phone: string[14]; end; var P: ^CustRec; begin GetMem(P, SizeOf(CustRec)); Canvas.TextOut(10, 10, 'The size of the record is ' + IntToStr(SizeOf(CustRec))); FreeMem (P, SizeOf(CustRec)); Readln; end; ---------- Swap 将一组变数的高低位元交换. ---------- Unit System 函数原型 function Swap(X); 范例 var X: Word; begin X := Swap($1234); { $3412 } end; ---------- UpCase 将一字元转为大写字母. ---------- Unit System 函数原型 function UpCase(Ch: Char): Char; 范例 uses Dialogs; var s : string; i : Integer; begin { Get string from TEdit control } s := Edit1.Text; for i := 1 to Length(s) do s[i] := UpCase(s[i]); MessageDlg('Here it is in all uppercase: ' + s, mtInformation, [mbOk], 0); end; Example var
s : string; i : Integer; begin { Get string from TEdit control } s := Edit1.Text; for i := 1 to Length(s) do if i mod 2 = 0 then s[i] := UpCase(s[i]); Edit1.Text := s; end;
========== Ordinal routines 序列常式 ========== Dec 使变数递减. ---------- Unit System 函数原型 procedure Dec(var X[ ; N: Longint]); 说明 Dec(X) ==> X:=X-1; Dec(X,N) ==> X:=X-N; 范例 var IntVar: Integer; LongintVar: Longint; begin Intvar := 10; LongintVar := 10; Dec(IntVar); { IntVar := IntVar - 1 } Dec(LongintVar, 5); { LongintVar := LongintVar - 5 } end; ---------- Inc 使变数递增. ---------- Unit System 函数原型 procedure Inc(var X [ ; N: Longint ] ); 说明 Inc(X) ==> X:=X-1; Inc(X,N) ==> X:=X-N; 范例 var IntVar: Integer; LongintVar: Longint; begin Inc(IntVar); { IntVar := IntVar + 1 } Inc(LongintVar, 5); { LongintVar := LongintVar + 5 } end; ---------- Odd 检查是否为奇数. ---------- Unit System 函数原型 function Odd(X: Longint): Boolean; Example begin
if Odd(5) then Canvas.TextOut(10, 10, '5 is odd.') else Canvas.TextOut(10, 10, 'Something is odd!'); end; ========== Pointer and address routines 位址常式 ========== Addr 传回一个物件的位址. ---------- Unit System 函数原型 function Addr(X): Pointer; Example var I : Integer; NodeNumbers: array [0 .. 100] of Integer; begin with TreeView1 do begin for I := 0 to Items.Count - 1 do begin NodeNumbers[I] := CalculateValue(Items[I]); Items[I].Data := Addr(NodeNumber[I]); end; end; end; ---------- Assigned 测试指标变数是否为nil. ---------- Unit System 函数原型 function Assigned(var P): Boolean; 说明 当@P=nil ==> 传回FALSE 范例 var P: Pointer; begin P := nil; if Assigned (P) then Writeln ('You won't see this'); GetMem(P, 1024); {P valid} FreeMem(P, 1024); {P no longer valid and still not nil} if Assigned (P) then Writeln ('You'll see this'); end ========== String-formatting routines 字串格式化 ========== FmtStr 格式化. ---------- FmtStr(var StrResult: string;const Format: string;const Args: array of string );
---------- Format Format(const Format: string;const Args: array of string ): string; ---------- Unit SysUtils 函数原型 procedure FmtStr(var Result: string; const Format: string; const Args: array of const); function Format(const Format: string; const Args: array of const): string; 说明 %d : 整数 %e : 科学式 %f : 定点实数 %g : 实数 %n : 实数(-d,ddd,ddd.dd ...) %m: 金钱格式 %p : point %s : 字串 %x : Hex 范例 var i: Integer; j: Double; s: String; t: String; begin t:=Format('%d %8.2f %s',[i,j,s]); ListBox1.Item.Add(t); end;
BubbleSeries1.PercentFormat := '##0.0# %'; Example procedure TForm1.Table1AfterDelete(DataSet: TDataSet); begin StatusBar1.SimpleText := Format('There are now %d records in the table', [DataSet.RecordCount]); end;
========== String-handling routines (Pascal-style) 字串函式 ========== AnsiCompareStr 比较两个字串的大小.依安装的 language driver. ---------- AnsiCompareText ( AnsiCompareText 此项不分大小写 ). ---------- Unit SysUtils var
S1,S2: string; I: Integer;
begin
S1:= 'A????'; S2:= '?????'; I:= CompareStr(S1, S2); { I = 0, ?.?. S1 = S2 } if I=0 then MessageDlg(S1, '=', S2, mtWarning, [mbOK], 0); end;
函数原型 function AnsiCompareStr(const S1, S2: string):Integer; 函数原型 function AnsiCompareText(const S1, S2: string):Integer; ---------- AnsiLowerCase 将字串全部转为小写字母.依安装的 language driver. ---------- AnsiUpperCase 将字串全部转为大写字母.依安装的 language drive ---------- Unit SysUtils 函数原型 function AnsiLowerCase(const S: string): string; 函数原型 function AnsiUpperCase(const S: string): string; ---------- CompareStr 比较两个字串的大小. ---------- CompareText ( CompareText 此项不分大小写 ). ---------- Unit SysUtils 函数原型 function CompareStr(const S1, S2: string): Integer; 函数原型 function CompareText(const S1, S2: string): Integer; 范例 var String1, String2 : string; I : integer; begin String1 := 'STEVE'; String2 := 'STEVe'; I := CompareStr(String1, String2); { I < 0 } if I < 0 then MessageDlg('String1 < String2', mtWarning, [mbOK], 0); end;
var String1, String2 : string; I : integer; begin String1 := 'ABC'; String2 := 'aaa'; I := CompareStr(String1, String2); { I < 0 } if I < 0 then MessageDlg(' String1 < String2', mtWarning, [mbOK], 0); end; Examlpe var ColumnToSort: Integer;
The OnColumnClick event handler sets the global variable to indicate the column to sort and calls AlphaSort:
begin ColumnToSort := Column.Index; (Sender as TCustomListView).AlphaSort; end;
The OnCompare event handler causes the list view to sort on the selected column:
procedure TForm1.ListView1Compare(Sender: TObject; Item1, Item2: TListItem; Data: Integer; var Compare: Integer); var ix: Integer; begin if ColumnToSort = 0 then Compare := CompareText(Item1.Caption,Item2.Caption) else begin ix := ColumnToSort - 1; Compare := CompareText(Item1.SubItems[ix],Item2.SubItems[ix]); end; end; ## OnColumnClick, AlphaSort, OnCompare, CompareText example ---------- Concat 将字串相加. ---------- Unit System 函数原型 function Concat(s1 [, s2,..., sn]: string): string; 说明 与 S := S1 + S2 + S3 ...; 相同. 范例 var S: string; begin S := Concat('ABC', 'DEF'); { 'ABCDE' } end;
var S: string; begin S:= '? '+ '???? '+ '???????? ??????'; S:= Concat('? ', '???? ', '???????? ??????'); // ? ????? ??????? S := '? ???? ???????? ??????' end; ---------- Copy 从母字串拷贝至另一个字串. ---------- Unit System 函数原型 function Copy(S: string; Index, Count: Integer): string; 说明 S : 字串. Indexd : 从第几位开始拷贝. Count : 总共要拷贝几位. 范例 var S: string; begin S := 'ABCDEF'; S := Copy(S, 2, 3); { 'BCD' } end; ---------- var S: string; begin S:= '??????'; S:= Copy( S, 3, 4); // S := '????' end; ---------- Example procedure TForm1.ComboBox1KeyPress(Sender: TObject; var Key: Char); var Found: boolean; i,SelSt: Integer; TmpStr: string; begin { first, process the keystroke to obtain the current string } { This code requires all items in list to be uppercase} if Key in ['a'..'z'] then Dec(Key,32); {Force Uppercase only!} with (Sender as TComboBox) do begin SelSt := SelStart; if (Key = Chr(vk_Back)) and (SelLength <> 0) then TmpStr := Copy(Text,1,SelStart)+Copy(Text,SelLength+SelStart+1,255)
else if Key = Chr(vk_Back) then {SelLength = 0} TmpStr := Copy(Text,1,SelStart-1)+Copy(Text,SelStart+1,255) else {Key in ['A'..'Z', etc]} TmpStr := Copy(Text,1,SelStart)+Key+Copy(Text,SelLength+SelStart+1,255); if TmpStr = ' then Exit; { update SelSt to the current insertion point }
if (Key = Chr(vk_Back)) and (SelSt > 0) then Dec(SelSt)
else if Key <> Chr(vk_Back) then Inc(SelSt); Key := #0; { indicate that key was handled } if SelSt = 0 then begin Text:= '; Exit; end;
{Now that TmpStr is the currently typed string, see if we can locate a match }
Found := False; for i := 1 to Items.Count do if Copy(Items[i-1],1,Length(TmpStr)) = TmpStr then begin Text := Items[i-1]; { update to the match that was found } ItemIndex := i-1; Found := True; Break; end; if Found then { select the untyped end of the string } begin SelStart := SelSt; SelLength := Length(Text)-SelSt;
end else Beep; end; end; ---------- procedure TComponentEditor.Copy; var AFormat : Word; AData,APalette : THandle; begin with Component as TImage do begin Picture.SaveToClipBoardFormat(AFormat,AData,APalette); ClipBoard.SetAsHandle(AFormat,AData); end; end;
## Copy, Chr, SelStart, SelLength example
---------- Delete 删除字串中的数个字元. ---------- Unit System 函数原型 procedure Delete(var S: string; Index, Count:Integer); 说明 S : 字串. Indexd : 从第几位开始删. Count : 总共要删几位. 范例 var s: string; begin s := 'Honest Abe Lincoln'; Delete(s,8,4); Canvas.TextOut(10, 10, s); { 'Honest Lincoln' } end; var S: string; begin S:= '???????, ??????, ??????????!'; Delete(S, 8, 1); // S := '??????? ??????, ??????????!' MessageDlg(S, mtWarning, [mbOK],0); end; ---------- NewStr 在 heap 中配置一个新的字串空间给PString 指标. ---------- DisposeStr 在 heap 中释放一个字串空间 PString指标. ---------- Unit SysUtils 函数原型 function NewStr(const S: string): PString; 函数原型 procedure DisposeStr(P: PString); 说明 S : 字串. Pstring : 新的字串指标. 范例 var P: PString; S: string; begin S := 'Ask me about Blaise'; P := NewStr(S); DisposeStr(P): end; ---------- Insert 将一个子字串插入另一个字串中. ---------- Unit System 函数原型 procedure Insert(Source: string; var S: string; Index: Integer); 说明 Source : 子字串. S : 被插入的母字串. Indexd : 从第几位开始插入. 范例 var S: string; begin S := 'Honest Lincoln'; Insert('Abe ', S, 8); { 'Honest Abe Lincoln' } end; var S: string; begin S:= '??????? ?????? ??????????.'; Insert( '!', S, 8); { S := '???????! ?????? ??????????.'} MessageDlg( S, mtWarning, [mbOK],0); end; ---------- IntToHex 将 Int 转为 Hex. ---------- procedure TForm1.Button1Click(Sender: TObject);
var i: Integer; begin Label1.Caption := '; for i := 1 to Length(Edit1.Text) do begin try Label1.Caption := Label1.Caption + IntToHex(Edit1.Text[i],4) + ' '; except Beep; end; end; end;
Exam:
Edit2.text:=(strtoint(Edit1.text),6); ---------- IntToStr 将 Int 转为 Str. ---------- procedure TForm1.Button1Click(Sender: TObject); begin try Label1.Caption := IntToStr(StrToInt(Edit1.Text) * StrToInt(Edit2.Text)); except ShowMessage('You must specify integer values. Please try again.'); end; end; ---------- StrToInt 将 Str 转为 Int. ---------- procedure TForm1.Button1Click(Sender: TObject); var I: Integer; J: Integer; begin I := StrToInt(Edit1.Text); J := StrToInt(Edit2.Text); ShowMessage(IntToStr(I + J)); end; ---------- StrToIntDef 将 Str 转为 Int.当转换有误时,则传回 Default 的值. ---------- Unit SysUtils 函数原型 function IntToHex(Value: Integer; Digits: Integer): string; 函数原型 function IntToStr(Value: Integer): string; 函数原型 function StrToInt(const S: string): Integer; 函数原型 function StrToIntDef(const S: string; Default: Integer): Integer; 说明 Value : 欲转换的整数. Digits : 欲转换为几位数的 Hex. 范例 procedure TForm1.Button1Click(Sender: TObject); begin Edit2.Text := IntToHex(StrToInt(Edit1.Text), 6); end;
procedure TForm1.Button1Click(Sender: TObject); var Value: Integer; begin Value := 1234; Edit1.Text := IntToStr(Value); end;
procedure TForm1.Button1Click(Sender: TObject); var S: string; I: Integer; begin S := '22467'; I := StrToInt(S); Inc(I); Edit1.Text := IntToStr(I); end;
procedure TForm1.Button1Click(Sender: TObject); var NumberString: string; Number: Integer; begin NumberString := Edit1.Text; Number := StrToIntDef(NumberString, 1000); Edit2.Text := IntToStr(Number); end; Example var
I: Integer; ListItem: string; begin for I := 0 to Query1.ParamCount - 1 do begin ListItem := ListBox1.Items[I]; case Query1.Params[I].DataType of ftString: Query1.Params[I].AsString := ListItem; ftSmallInt: Query1.Params[I].AsSmallInt := StrToIntDef(ListItem, 0); ftInteger: Query1.Params[I].AsInteger := StrToIntDef(ListItem, 0); ftWord: Query1.Params[I].AsWord := StrToIntDef(ListItem, 0);
ftBoolean: begin if ListItem = 'True' then Query1.Params[I].AsBoolean := True else Query1.Params[I].AsBoolean := False; end; ftFloat: Query1.Params[I].AsFloat := StrToFloat(ListItem); ftCurrency: Query1.Params[I].AsCurrency := StrToFloat(ListItem); ftBCD: Query1.Params[I].AsBCD := StrToCurr(ListItem); ftDate:
Query1.Params[I].AsDate := StrToDate(ListItem); ftTime: Query1.Params[I].AsTime := StrToTime(ListItem); ftDateTime: Query1.Params[I].AsDateTime := StrToDateTime(ListItem); end; end; end; ---------- procedure TForm1.Button1Click(Sender: TObject); var Number: Integer; begin Number := StrToIntDef(Edit1.Text, 1000); Edit2.Text := IntToStr(Number); end; ---------- ## ParamCount, DataType, StrToIntDef, AsXXX Example ---------- Str 将数值转换为格式化的字串. ---------- Unit System 函数原型 procedure Str(X [: Width [: Decimals ]]; var S); 说明 X : 欲转换的整数 or 实数. Width : 格式化长度.(Integer) Decimals : 小数点位数.(Integer) 范例 function MakeItAString(I: Longint): string; { Convert any integer type to a string } var S: string[11]; begin Str(I, S); MakeItAString:= S; end; begin Canvas.TextOut(10, 10, MakeItAString(-5322)); end; ---------- Val 将字串转为数字. ---------- Unit System 函数原型 procedure Val(S; var V; var Code: Integer); 说明 S : 欲转换的字串. V : 转换後的整数 or 实数. Code : Code = 0 表示转换成功. 范例 uses Dialogs; var I, Code: Integer; begin { Get text from TEdit control } Val(Edit1.Text, I, Code); { Error during conversion to integer? } if code <> 0 then MessageDlg('Error at position: ' + IntToStr(Code), mtWarning, [mbOk], 0); else Canvas.TextOut(10, 10, 'Value = ' + IntToStr(I)); Readln; end; ---------- Length 字串长度. ---------- Unit System 函数原型 function Length(S: string): Integer; 说明 S : 欲转换的字串. 范例 var S: string; begin S := 'The Black Knight'; Canvas.TextOut(10, 10, 'String Length = ' + IntToStr(Length(S))); end; Example procedure TForm1.Button1Click(Sender: TObject);
var i: Integer; begin Label1.Caption := '; for i := 1 to Length(Edit1.Text) do begin try Label1.Caption := Label1.Caption + IntToHex(Edit1.Text[i],4) + ' '; except Beep; end; end; end;
范例 procedure TForm1.Button1Click(Sender: TObject); var S: string; begin S := memo1.text; Label1.caption :=' ' + IntToStr(Length(S)); end;
var S: string; I: Integer; begin S:= '? ???? ???????? ??????'; I:= Length(S); // I:= 22 MessageDlg( '????? ??????='+ IntToStr(I), mtWarning, [mbOK], 0); end; ## Length, IntToHex Example ---------- Pos 寻找子字串在母字串中的位置. ---------- Unit System 函数原型 function Pos(Substr: string; S: string): Integer; 说明 Substr : 子字串. S : 母字串. 范例 procedure TForm1.Button1Click(Sender: TObject); var S: string; begin S := ' 1234.5 '; { Convert spaces to zeroes } while Pos(' ', S) > 0 do S[Pos(' ', S)] := '0'; Label1.Caption := S; Label1.Font.Size := 16; end;
var S: string; I: Integer; begin S:= '? ???? ???????? ??????'; I:= Pos( '???', S); // I:= 3 end; //DEMO 001234.50 //空白字串补零 ---------- LowerCase 将字串全部转为小写字母. ---------- Unit System 函数原型 function LowerCase(const S: string): string; 范例 procedure TForm1.Button1Click(Sender: TObject); begin Edit2.Text := LowerCase(Edit1.Text); end; Example procedure TForm1.Button1Click(Sender: TObject); begin Label1.Caption := LowerCase(Edit1.Text); end; var S: string; begin S:= LowerCase( '????????.TXT') ; // S := '????????.txt' end; ---------- UpperCase 将字串全部转为大写字母. ---------- Unit SysUtils 函数原型 function UpperCase(const S: string): string; 范例 procedure TForm1.Button1Click(Sender: TObject); var I: Integer; begin for I := 0 to ListBox1.Items.Count -1 do ListBox1.Items[I] := UpperCase(ListBox1.Items[I]); end; Example procedure TForm1.Button1Click(Sender: TObject); var I: Integer; begin for I := 0 to ListBox1.Items.Count -1 do ListBox1.Items[I] := UpperCase(ListBox1.Items[I]); end; ---------- Trim 将字串前後的空白及控制字元清掉. Trim ( const S: string ): string; SysUtils var S: string; L: Integer; begin S:= #13' ???! '#13; L:= length( S); // L := 10 S:= Trim( S); // S := '???!' L:= L-length( S); // L := 5 MessageDlg( '??????? ???????? - '+ IntToStr(L), mtInformation, [mbOk], 0); end;
---------- TrimLeft 将字串左边的空白及控制字元清掉. SysUtils var S: string; L: Integer; begin S:= #13' ???! '#13; L:= length( S); // L := 10 S:= TrimLeft( S); // S := '???! '#13 L:= L-length( S); // L := 3 MessageDlg( '??????? ???????? - '+IntToStr(L), mtInformation, [mbOk], 0); end; ---------- TrimRight 将字串右边的空白及控制字元清掉. ---------- Unit SysUtils 函数原型 function Trim(const S: string): string; 函数原型 function TrimLeft(const S: string): string; 函数原型 function TrimRight(const S: string): string;
var S: string; L: Integer; begin S:= #13' ???! '#13; L:= length( S); // L := 10 S:= TrimRight( S); // S := #13' ???!' L:= L-length( S); // L := 2 MessageDlg( '??????? ???????? - '+IntToStr(L), mtInformation, [mbOk], 0); end; ---------- AdjustLineBreaks 将字串的换行符号全部改为#13#10 ---------- Unit SysUtils 函数原型 function AdjustLineBreaks(const S: string): string;
========== String-handling routines (null-terminated)字串函式 ========== StrAlloc 配置字串空间. ---------- Unit SysUtils 函数原型 function StrAlloc(Size: Cardinal): PChar; 说明 Size=字串最大空间+1 ---------- StrBufSize 传回由 StrAlloc 配置空间的大小 ---------- Unit SysUtils 函数原型 function StrBufSize(Str: PChar): Cardinal; ---------- StrCat 字串相加. ---------- Unit SysUtils 函数原型 function StrCat(Dest, Source: PChar): PChar; 范例 uses SysUtils; const Obj: PChar = 'Object'; Pascal: PChar = 'Pascal'; var S: array[0..15] of Char; begin StrCopy(S, Obj); StrCat(S, ' '); StrCat(S, Pascal); Canvas.TextOut(10, 10, StrPas(S)); end; Example procedure TForm1.Button1Click(Sender: TObject); var Buffer: PChar; begin GetMem(Buffer,Length(Label1.Caption) + Length(Edit1.Text) + 1); StrCopy(Buffer, PChar(Label1.Caption)); StrCat(Buffer, PChar(Edit1.Text)); Label1.Caption := Buffer; Edit1.Clear; FreeMem(Buffer); end;
##StrCopy, StrCat Example ---------- StrComp 比较两字串大小. ---------- Unit SysUtils 函数原型 function StrComp(Str1, Str2 : PChar): Integer; 范例 uses SysUtils; const S1: PChar = 'Wacky'; S2: PChar = 'Code'; var C: Integer; Result: string; begin C := StrComp(S1, S2); if C < 0 then Result := ' is less than ' else if C > 0 then Result := ' is greater than ' else Result := ' is equal to '; Canvas.TextOut(10, 10, StrPas(S1) + Result + StrPas(S2)); end; Example uses SysUtils; procedure TForm1.Button1Click(Sender: TObject);
var Msg: string; CompResult: Integer; begin Msg := Edit1.Text; CompResult := StrComp(PChar(Edit1.Text), PChar(Edit2.Text)); if CompResult < 0 then Msg := Msg + ' is less than ' else if CompResult > 0 then Msg := Msg + ' is greater than ' else Msg := Msg + ' is equal to ' Msg := Msg + Edit2.Text; ShowMessage(Msg); end;
var S1,S2: PChar; I: Integer; Res: string; begin S1:= 'Company'; S2:= 'COMPANY'; I:= StrComp(S1, S2); if I>0 then Res:= '>' else if I<0 then Res:= '<' else Res:= '='; MessageDlg(S1+ Res+ S2, mtInformation, [mbOk], 0); end; ---------- StrCopy 拷贝字串. ---------- Unit SysUtils 函数原型 function StrCopy(Dest, Source: PChar): PChar; 范例 uses SysUtils; var S: array[0..12] of Char; begin StrCopy(S, 'ObjectPascal'); Canvas.TextOut(10, 10, StrPas(S)); end; Example procedure TForm1.Button1Click(Sender: TObject); var Buffer: PChar; begin GetMem(Buffer,Length(Label1.Caption) + Length(Edit1.Text) + 1); StrCopy(Buffer, PChar(Label1.Caption)); StrCat(Buffer, PChar(Edit1.Text)); Label1.Caption := Buffer; Edit1.Clear; FreeMem(Buffer); end; ## StrCopy, StrCat Example ---------- StrDispose 释放StrAlloc or StrNew所配置的空间. ---------- Unit SysUtils 函数原型 procedure StrDispose(Str: PChar); 范例 uses SysUtils; const S: PChar = 'Nevermore'; var P: PChar; begin P := StrNew(S); Canvas.TextOut(10, 10, StrPas(P)); StrDispose(P); end; ---------- StrECopy 拷贝字串并传回字串结束位址. ---------- Unit SysUtils 函数原型 function StrECopy(Dest, Source: PChar): PChar; 范例 uses SysUtils; const Turbo: PChar = 'Object'; Pascal: PChar = 'Pascal'; var S: array[0..15] of Char; begin StrECopy(StrECopy(StrECopy(S, Turbo), ' '), Pascal); Canvas.TextOut(10, 10, StrPas(S)); end; Example uses SysUtils; const
Turbo: PChar = 'Object'; Pascal: PChar = 'Pascal'; var S: array[0..15] of Char; begin StrECopy(StrECopy(StrECopy(S, Turbo), ' '), Pascal); Canvas.TextOut(10, 10, string(S)); end; ---------- StrEnd 传回字串结束位址. ---------- Unit SysUtils 函数原型 function StrEnd(Str: PChar): PChar; 范例 uses SysUtils; const S: PChar = 'Yankee Doodle'; begin Canvas.TextOut(5, 10, 'The string length of "' + StrPas(S) + '" is ' +IntToStr(StrEnd(S) - S)); end; Example procedure TForm1.Button1Click(Sender: TObject);
var TextBuffer: PChar; Ptr: PChar; begin GetMem(TextBuffer, Length(Edit1.Text)+1); StrCopy(TextBuffer, PChar(Edit1.Text)); Ptr := StrEnd(TextBuffer); Label1.Caption := '; while Ptr >= TextBuffer do begin Ptr := Ptr ? 1; Label1.Caption := Label1.Caption + Ptr^; end; FreeMem(TextBuffer); end;
var Str: PChar; L: Word; begin ... L:= StrEnd(Str) - Str; ... end; ---------- StrIComp 比较两字串大小.(不分大小写) ---------- Unit SysUtils 函数原型 function StrIComp(Str1, Str2:PChar): Integer; 范例 uses SysUtils; const S1: PChar = 'Wacky'; S2: PChar = 'Code'; var C: Integer; Result: string; begin C := StrIComp(S1, S2); if C < 0 then Result := ' is less than ' else if C > 0 then Result := ' is greater than ' else Result := ' is equal to '; Canvas.TextOut(10, 10, StrPas(S1) + Result + StrPas(S2)); end; xample uses SysUtils; procedure TForm1.Button1Click(Sender: TObject);
var Msg: string; CompResult: Integer; begin Msg := Edit1.Text; CompResult := StrIComp(PChar(Edit1.Text), PChar(Edit2.Text)); if CompResult < 0 then Msg := Msg + ' is less than ' else if CompResult > 0 then Msg := Msg + ' is greater than ' else Msg := Msg + ' is equal to ' Msg := Msg + Edit2.Text; ShowMessage(Msg); end;
var S1,S2: PChar; I: Integer; Res: string; begin S1:= 'ABC'; S2:= 'abc'; I:= StrIComp(S1, S2); { I := 0, ?.?. S1 = S2 } if I>0 then Res:= '>' else if I<0 then Res:= '<' else Res:= '='; MessageDlg( S1 + Res + S2, mtInformation, [mbOk], 0); end; ---------- StrLCat 字串相加.(指定长) ---------- Unit SysUtils 函数原型 function StrLCat(Dest, Source: PChar; MaxLen: Cardinal): PChar; 范例 uses SysUtils; var S: array[0..13] of Char; begin StrLCopy(S, 'Object', SizeOf(S) - 1); StrLCat(S, ' ', SizeOf(S) - 1); StrLCat(S, 'Pascal', SizeOf(S) - 1); Canvas.TextOut(10, 10, StrPas(S)); end; Example procedure TForm1.Button1Click(Sender: TObject); var FirstHalf: PChar; SecondHalf: PChar; HalfLen: Integer; begin HalfLen := StrLen(PChar(Edit1.Text)) div 2; GetMem(FirstHalf,HalfLen+2); GetMem(SecondHalf,HalfLen+2); FirstHalf^ := Chr(0); SecondHalf^ := Chr(0); StrLCat(FirstHalf, PChar(Edit1.Text), HalfLen); StrCat(SecondHalf, PChar(Edit1.Text) + HalfLen); Application.MessageBox(FirstHalf, 'First Half', MB_OK); Application.MessageBox(SecondHalf, 'Second Half', MB_OK); FreeMem(FirstHalf); FreeMem(SecondHalf); end;
const S1: PChar = '???'; S2: PChar = '?????????'; var S: array[0..13] of Char; begin StrLCopy(S, S1, StrLen(S1)); StrLCat(S, S2, 6); { S :='??????' } MessageDlg(S, mtInformation, [mbOk], 0); end; ## StrLen, StrLCat Example ---------- StrLComp 比较两字串大小.(指定长) ---------- Unit SysUtils 函数原型 function StrLComp(Str1, Str2: PChar; MaxLen: Cardinal): Integer; 范例 uses SysUtils; const S1: PChar = 'Enterprise' S2: PChar = 'Enter' var Result: string; begin if StrLComp(S1, S2, 5) = 0 then Result := 'equal' else Result := 'different'; Canvas.TextOut(10, 10, 'The first five characters are ' + Result); end; example uses SysUtils; const S1: PChar = 'Enterprise' S2: PChar = 'Enter' var ComStr: string; begin if StrLComp(S1, S2, 5) = 0 then ComStr := 'equal' else ComStr := 'different'; Canvas.TextOut(10, 10, 'The first five characters are ' + ComStr); end; const S1: PChar = '?????????'; S2: PChar = '????????'; var I: Integer; S: string; begin I:= 5; if StrLComp( S1, S2, I) = 0 then S:= '?????' else S:= '????????'; MessageDlg( '?????? '+ IntToStr(I)+ ' ???????? ????? '+ S, mtInformation,[mbOk], 0); end;
---------- StrLCopy 拷贝字串.(指定长) ---------- Unit SysUtils 函数原型 function StrLCopy(Dest, Source: PChar; MaxLen: Cardinal): PChar; 范例 uses SysUtils; var S: array[0..11] of Char; begin StrLCopy(S, 'ObjectPascal', SizeOf(S) - 1); Canvas.TextOut(10, 10, StrPas(S)); end; Example uses SysUtils;
const MAX_BUFFER = 10; procedure TForm1.Button1Click(Sender TObject); var Buffer: array [0..MAX_BUFFER] of char; begin StrLCopy(Buffer, PChar(Edit1.Text), MAX_BUFFER); Application.MessageBox(Buffer, 'StrLCopy Example', MB_OK); end;
var S: PChar; begin StrLCopy( S, '?????????', 5); { S := '?????' } ... end; ---------- StrLen 传回字串长度.(不含终止位元) ---------- Unit SysUtils 函数原型 function StrLen(Str: PChar): Cardinal; 范例 uses SysUtils; const S: PChar = 'E Pluribus Unum'; begin Canvas.TextOut(5, 10, 'The string length of "' + StrPas(S) + '" is ' + IntToStr(StrLen(S))); end; Example procedure TForm1.Button1Click(Sender: TObject); var FirstHalf: PChar; SecondHalf: PChar; HalfLen: Integer; begin HalfLen := StrLen(PChar(Edit1.Text)) div 2; GetMem(FirstHalf,HalfLen+2); GetMem(SecondHalf,HalfLen+2); FirstHalf^ := Chr(0); SecondHalf^ := Chr(0); StrLCat(FirstHalf, PChar(Edit1.Text), HalfLen); StrCat(SecondHalf, PChar(Edit1.Text) + HalfLen); Application.MessageBox(FirstHalf, 'First Half', MB_OK); Application.MessageBox(SecondHalf, 'Second Half', MB_OK); FreeMem(FirstHalf); FreeMem(SecondHalf); end;
const S: PChar = '????? ????? ????? ????????!'; begin MessageDlg( S+ #13#10 + '?????????? ???????? = ' + IntToStr( StrLen( S)), mtInformation, [mbOk], 0); end; ## StrLen, StrLCat Example ---------- StrLIComp 比较两字串大小.(指定长,不分大小写) ---------- Unit SysUtils 函数原型 function StrLIComp(Str1, Str2: PChar; MaxLen: Cardinals): Integer; 范例 uses SysUtils; const S1: PChar = 'Enterprise' S2: PChar = 'Enter' var Result: string; begin if StrLIComp(S1, S2, 5) = 0 then Result := 'equal' else Result := 'different'; Canvas.TextOut(10, 10, 'The first five characters are ' + Result); end; Examply uses SysUtils; const
S1: PChar = 'Enterprise' S2: PChar = 'Enter'
var ComStr: string; begin if StrLIComp(S1, S2, 5) = 0 then ComStr := 'equal' else ComStr := 'different'; Canvas.TextOut(10, 10, 'The first five characters are ' + ComStr); end;
const S1: PChar = '?????????'; S2: PChar = '????????'; var S: string; begin if StrLIComp( S1, S2, 5) = 0 then S:= '?????' else S:= '????????'; MessageDlg( S1 + #13 + S2 + #13 + '?????? ' + IntToStr( I) + ' ???????? ????? ' + S, mtInformation, [mbOk], 0); end; ---------- StrLower 将字串全部转为小写字母. ---------- Unit SysUtils 函数原型 function StrLower(Str: PChar): PChar; 范例 uses SysUtils; const S: PChar = 'A fUnNy StRiNg' begin Canvas.TextOut(5, 10, StrPas(StrLower(S)) + ' ' + StrPas(StrUpper(S))); end; ---------- StrMove 从来源字串拷贝n个Bytes到目爬r串.(不含终止位元) ---------- Unit SysUtils 函数原型 function StrMove(Dest, Source: PChar; Count: Cardinal): PChar; 范例 uses SysUtils; function AHeapaString(S: PChar): PChar; { Allocate string on heap } var L: Cardinal; P: PChar; begin StrNew := nil; if (S <> nil) and (S[0] <> #0) then begin L := StrLen(S) + 1; GetMem(P, L); StrNew := StrMove(P, S, L); end; end; procedure DisposeDaString(S: PChar); { Dispose string on heap } begin if S <> nil then FreeMem(S, StrLen(S) + 1); end; var S: PChar; begin AHeapaString(S); DisposeDaString(S); end; var S1, S2: PChar; begin S1:= 'ABcdEFgh'; StrMove( S2, S1, StrLen( S1) + 1 ); StrLower( S1); { S1:= 'abcdefgh' } StrUpper( S2); { S2:= 'ABCDEFGH' } MessageDlg( S1 + #13#10 + S2, mtInformation, [mbOk], 0); end;
---------- StrNew 配置字串空间. ---------- Unit SysUtils 函数原型 function StrNew(Str: PChar): PChar; Example uses Sysutils; procedure TForm1.Button1Click(Sender: TObject);
var Temp: PChar; begin // Allocate memory. Temp := StrNew(PChar(Edit1.Text)); Application.MessageBox(Temp, 'StrNew, StrDispose Example', MB_OK); // Deallocate memory. StrDispose(Temp); end;
const S: PChar = '?????????? ??????'; var SNew: PChar; begin SNew:= StrNew( S); MessageDlg( 'S: ' + S + #13 + 'SNew: ' + SNew, mtInformation, [mbOk], 0); StrDispose(SNew); end;
## StrNew, StrDispose Example ---------- StrPas 将 null-terminated 字串转为Pascal-style 字串. ---------- Unit SysUtils 函数原型 function StrPas(Str: PChar): string; 范例 uses SysUtils; const A: PChar = 'I love the smell of Object Pascal in the morning.'; var S: string[79]; begin S := StrPas(A); Canvas.TextOut(10, 10, S); { note that the following also works } Canvas.TextOut(10, 10, A); end; ---------- StrPCopy 拷贝 Pascal-style 字串到null-terminated 字串. ---------- Unit SysUtils 函数原型 function StrPCopy(Dest: PChar; Source: string): PChar; 范例 uses SysUtils; var A: array[0..79] of Char; S: String; begin S := 'Honk if you know Blaise.'; StrPCopy(A, S); Canvas.TextOut(10, 10, StrPas(A)); end;
var Source: string; Dest: array[0..20] of Char; begin Source:= '???????? ??????'; StrPCopy( Dest, Source); MessageDlg( Dest, mtInformation, [mbOk], 0); end; ---------- StrPLCopy 拷贝 Pascal-style 字串到null-terminated 字串.(指定长) ---------- Unit SysUtils 函数原型 function StrPLCopy(Dest: PChar; const Source: string; MaxLen: Cardinal): PChar; ---------- StrPos 子字串在母字串中的位置.(第一个位置) ---------- Unit SysUtils 函数原型 function StrPos(Str1, Str2: PChar): PChar; 说明 Str1 母字串 Str2 子字串 Example uses SysUtils;
procedure TForm1.Button1Click(Sender TObject); var Location: PChar; begin if StrPos(PChar(Edit1.Text), PChar(Edit2.Text)) <> nil then ShowMessage('Substring found') else ShowMessage('Substring not found'); end; ---------- const SubStr: PChar = 'www'; var S, R: PChar; begin S:= 'http://www.atrussk.ru/delphi/'; R:= StrPos(S, SubStr); if R<>nil then MessageDlg( R, mtInformation, [mbOk], 0) else MessageDlg( '?? ????????? ?????? URL!', mtError, [mbOk], 0); end; ---------- StrRScan 子字元在母字串中的位置的下一个位址. ---------- Unit SysUtils 函数原型 function StrRScan(Str: PChar; Chr: Char): PChar; 范例 { Return pointer to name part of a full path name } uses SysUtils; function NamePart(FileName: PChar): PChar; var P: PChar; begin P := StrRScan(FileName, '\'); if P = nil then begin P := StrRScan(FileName, ':'); if P = nil then P := FileName; end; NamePart := P; end; var S : string; begin S := StrPas(NamePart('C:\Test.fil')); Canvas.TextOut(10, 10, S); end; const S: PChar = 'MyFile.zzz'; var R: PChar; begin R:= StrRScan( S, '.'); { R := '.zzz' } MessageDlg( R, mtInformation, [mbOk], 0); end; ---------- StrScan 子字元在母字串中的位置. ---------- Unit SysUtils 函数原型 function StrScan(Str: PChar; Chr: Char): PChar; 范例 uses SysUtils; function HasWildcards(FileName: PChar): Boolean; { Return true if file name has wildcards in it } begin HasWildcards := (StrScan(FileName, '*') <> nil) or (StrScan(FileName, '?') <> nil); end; const P: PChar = 'C:\Test.* '; begin if HasWildcards(P) then Canvas.TextOut(20, 20, 'The string has wildcards') else Canvas.TextOut(20, 20, 'The string doesn't have wildcards') end; const S: PChar = 'http://www.atrussk.ru'; var R: PChar; begin R:= StrScan( S, 'w'); { R := 'www.atrussk.ru' } MessageDlg( R, mtInformation, [mbOk], 0); end; ---------- StrUpper 将字串全部转为大写字母. ---------- Unit SysUtils 函数原型 function StrUpper(Str: PChar): PChar; 范例 uses SysUtils; const S: PChar = 'A fUnNy StRiNg' begin Canvas.TextOut(5, 10, StrPas(StrLower(S)) + ' ' + StrPas(StrUpper(S))); end; ========== Text-file routines Text-file常式 ========== Append 开起一个可供Append的档案. ---------- Unit System 函数原型 procedure Append(var f: Text); 范例 var F: TextFile; begin if OpenDialog1.Execute then { Bring up open file dialog } begin AssignFile(F, OpenDialog1.FileName); { Open file selected in dialog } Append(F); { Add more text onto end } Writeln(F, 'appended text'); CloseFile(F); { Close file, save changes } end; end; Example var
f: TextFile; begin if OpenDialog1.Execute then begin { open a text file } AssignFile(f, OpenDialog1.FileName); Append(f); Writeln(f, 'I am appending some stuff to the end of the file.'); { insert code here that would require a Flush before closing the file } Flush(f); { ensures that the text was actually written to file } CloseFile(f); end; end; ## Append, Flush Example ---------- Eoln 测试档案是否结束.(For text file.) ---------- Unit System 函数原型 function Eoln [(var F: Text) ]: Boolean; Flush 将Buffer中的资料存入磁碟. (For text file) Unit System 函数原型 procedure Flush(var F: Text); 范例 var f: TextFile; begin if OpenDialog1.Execute then begin { open a text file } AssignFile(f, OpenDialog1.FileName); Append(f); Writeln(f, 'I am appending some stuff to the end of the file.'); Flush(f); { ensures that the text was actually written to file } { insert code here that would require a Flush before closing the file } CloseFile(f); end; end; Example begin { Tells program to wait for keyboard input } WriteLn(Eoln); end; ---------- Read 读档. ---------- Unit System 函数原型 procedure Read(F , V1 [, V2,...,Vn ] ); procedure Read( [ var F: Text; ] V1 [, V2,...,Vn ] ); 范例 uses Dialogs; var F1, F2: TextFile; Ch: Char; begin if OpenDialog1.Execute then begin AssignFile(F1, OpenDialog1.Filename); Reset(F1); if SaveDialog1.Execute then begin AssignFile(F2, OpenDialog1.Filename); Rewrite(F2); While not Eof(F1) do begin Read(F1, Ch); Write(F2, Ch); end; CloseFile(F2); end; CloseFile(F1); end; end. ---------- Readln 读档. ---------- Unit System 函数原型 procedure Readln([ var F: Text; ] V1 [, V2, ...,Vn ]); 范例 var s : string; begin Write('Enter a line of text: '); Readln(s); Writeln('You typed: ',s); Writeln('Hit <Enter> to exit'); Readln; end; ---------- SeekEof 测试档案是否结束. ---------- Unit System 函数原型 function SeekEof [ (var F: Text) ]: Boolean; 范例 var f : System.TextFile; i, j, Y : Integer; begin AssignFile(f,'TEST.TXT'); Rewrite(f); { Create a file with 8 numbers and some whitespace at the ends of the lines } Writeln(f,'1 2 3 4 '); Writeln(f,'5 6 7 8 '); Reset(f); { Read the numbers back. SeekEoln returns TRUE if there are no more numbers on the current line; SeekEof returns TRUE if there is no more text (other than whitespace) in the file. } Y := 5; while not SeekEof(f) do begin if SeekEoln(f) then Readln; { Go to next line } Read(f,j); Canvas.TextOut(5, Y, IntToStr(j)); Y := Y + Canvas.TextHeight(IntToStr(j)) + 5; end; end; ---------- SeekEoln 测试档案中行是否结束. ---------- Unit System 函数原型 function SeekEoln [ (var F: Text) ]: Boolean; Example var
f : System.TextFile; i, j, Y : Integer; begin AssignFile(f,'TEST.TXT'); Rewrite(f); { Create a file with 8 numbers and some whitespace at the ends of the lines } Writeln(f,'1 2 3 4 '); Writeln(f,'5 6 7 8 '); Reset(f); { Read the numbers back. SeekEoln returns TRUE if there are no more numbers on the current line; SeekEof returns TRUE if there is no more text (other than whitespace) in the file. }
Y := 5; while not SeekEof(f) do begin if SeekEoln(f) then Readln; { Go to next line } Read(f,j); Canvas.TextOut(5, Y, IntToStr(j)); Y := Y + Canvas.TextHeight(IntToStr(j)) + 5; end; end; ## SeekEoln, SeekEof Example ---------- SetTextBuf 指定 I/O buffer 给 text file. ---------- Unit System 函数原型 procedure SetTextBuf(var F: Text; var Buf [ ; Size: Integer] ); 范例 uses Dialogs; var F, FTwo: System.TextFile; Ch: Char; Buf: array[1..4095] of Char; { 4K buffer } begin if OpenDialog1.Execute then begin AssignFile(F, ParamStr(1)); { Bigger buffer for faster reads } SetTextBuf(F, Buf); Reset(F); { Dump text file into another file } AssignFile(FTwo, 'WOOF.DOG'); Rewrite(FTwo); while not Eof(f) do begin Read(F, Ch); Write(FTwoCh); end; System.CloseFile(F); System.CloseFile(FTwo); end; end; ---------- Write 写入档案. ---------- Unit System
var Stream: TBlobStream; S: string; begin with Table1 do begin
Edit;
Stream := CreateBlobStream(FieldByName('Notes'), bmReadWrite); try Stream.Seek(0, 2); {Seek 0 bytes from the stream's end point} S := ' This line will be added to the end.'; Stream.Write(PChar(S), Length(S)); finally Stream.Free; end; Post; end; end; ---------- Writeln 写入档案. ---------- Unit System 函数原型 procedure Writeln([ var F: Text; ] P1 [, P2, ...,Pn ] ); 范例 var s : string; begin Write('Enter a line of text: '); Readln(s); Writeln('You typed: ',s); Writeln('Hit <Enter> to exit'); Readln; end; ========== Transfer routines 转换函式 ========== Chr 将 Byte 转为字元. ---------- Unit System 函数原型 function Chr(X: Byte): Char; 范例 begin Canvas.TextOut(10, 10, Chr(65)); { The letter 'A'} end; Example procedure TForm1.ComboBox1KeyPress(Sender: TObject; var Key: Char);
var Found: boolean; i,SelSt: Integer; TmpStr: string; begin { first, process the keystroke to obtain the current string } { This code requires all items in list to be uppercase} if Key in ['a'..'z'] then Dec(Key,32); {Force Uppercase only!} with (Sender as TComboBox) do begin SelSt := SelStart; if (Key = Chr(vk_Back)) and (SelLength <> 0) then TmpStr := Copy(Text,1,SelStart)+Copy(Text,SelLength+SelStart+1,255)
else if Key = Chr(vk_Back) then {SelLength = 0} TmpStr := Copy(Text,1,SelStart-1)+Copy(Text,SelStart+1,255) else {Key in ['A'..'Z', etc]} TmpStr := Copy(Text,1,SelStart)+Key+Copy(Text,SelLength+SelStart+1,255); if TmpStr = ' then Exit; { update SelSt to the current insertion point }
if (Key = Chr(vk_Back)) and (SelSt > 0) then Dec(SelSt)
else if Key <> Chr(vk_Back) then Inc(SelSt); Key := #0; { indicate that key was handled } if SelSt = 0 then begin Text:= '; Exit; end;
{Now that TmpStr is the currently typed string, see if we can locate a match }
Found := False; for i := 1 to Items.Count do if Copy(Items[i-1],1,Length(TmpStr)) = TmpStr then begin Text := Items[i-1]; { update to the match that was found } ItemIndex := i-1; Found := True; Break; end; if Found then { select the untyped end of the string } begin SelStart := SelSt; SelLength := Length(Text)-SelSt;
end else Beep; end; end; ## Copy, Chr, SelStart, SelLength example ---------- High 传回注脚的最大值. ---------- Unit System 函数原型 function High(X); 范例 [Ordinal type] procedure TForm1.Button1Click(Sender: TObject); var Low_S:String; High_S:string; S:String; begin High_S:=' High='+IntToStr(High(Word)); Low_S:='Low='+IntToStr(Low(Word)); S:=Low_S+High_S; Label1.Caption:=S; end;
S:=Low=0 High=65535
[Array type] procedure TForm1.Button1Click(Sender: TObject); var P : Array[5..21] of Double; Low_S:String; High_S:string; S:String; begin High_S:=' High='+IntToStr(High(P)); Low_S:='Low='+IntToStr(Low(P)); S:=Low_S+High_S; Label1.Caption:=S; end;
S:=Low=5 High=21
[String type] procedure TForm1.Button1Click(Sender: TObject); var P : String[23]; Low_S:String; High_S:string; S:String; begin High_S:=' High='+IntToStr(High(P)); Low_S:='Low='+IntToStr(Low(P)); S:=Low_S+High_S; Label1.Caption:=S; end;
S:=Low=0 Hight=23
P:ShortString; S:=Low=0 Hight=255
P:String; 长字串不可,会有错误讯号.
[Open array] function Sum( var X: array of Double): Double; var I: Word; S: Double; begin S := 0; { Note that open array index range is always zero-based. } for I := 0 to High(X) do S := S + X[I]; Sum := S; end; Example function Sum( var X: array of Double): Double;
var I: Word; S: Real; begin S := 0; { Note that open array index range is always zero-based. } for I := 0 to High(X) do S := S + X[I]; Sum := S; end;
procedure TForm1.Button1Click(Sender: TObject);
var List1: array[0..3] of Double; List2: array[5..17] of Double; X: Word; S, TempStr: string; begin for X := Low(List1) to High(List1) do List1[X] := X * 3.4; for X := Low(List2) to High(List2) do List2[X] := X * 0.0123; Str(Sum(List1):4:2, S); S := 'Sum of List1: ' + S + #13#10; S := S + 'Sum of List2: '; Str(Sum(List2):4:2, TempStr);
S := S + TempStr; MessageDlg(S, mtInformation, [mbOk], 0); end; ## Low, High Example ---------- Low 传回注脚的最小值. ---------- Unit System 函数原型 function Low(X); 说明 Ordinal type The lowest value in the range of the type Array type The lowest value within the range of the index type of the array String type Returns 0 Open array Returns 0 String parameter Returns 0 ---------- Ord 传回列举型态的数值. ---------- Unit System 函数原型 function Ord(X): Longint; 范例 procedure TForm1.Button1Click(Sender: TObject); type Colors = (RED,BLUE,GREEN); var S: string; begin S := 'BLUE has an ordinal value of ' + IntToStr(Ord(RED)) + #13#10; S := S+'The ASCII code for "c" is ' + IntToStr(Ord('c')) + ' decimal'; MessageDlg(S, mtInformation, [mbOk], 0); end; ---------- Round 将实数转为整数.(有四舍五入) ---------- Unit System 函数原型 function Round(X: Extended): Longint; 范例 var S, T: string; begin Str(1.4:2:1, T); S := T + ' rounds to ' + IntToStr(Round(1.4)) + #13#10; Str(1.5:2:1, T); S := S + T + ' rounds to ' + IntToStr(Round(1.5)) + #13#10; Str(-1.4:2:1, T); S := S + T + ' rounds to ' + IntToStr(Round(-1.4)) + #13#10; Str(-1.5:2:1, T); S := S + T + ' rounds to ' + IntToStr(Round(-1.5)); MessageDlg(S, mtInformation, [mbOk], 0); end; ---------- Trunc 将实数转为整数.(小数直接舍弃) ---------- Unit System 函数原型 function Trunc(X: Extended): Longint; Untyped file routines var S, T: string; begin Str(1.4:2:1, T); S := T + ' Truncs to ' + IntToStr(Trunc(1.4)) + #13#10; Str(1.5:2:1, T); S := S + T + ' Truncs to ' + IntToStr(Trunc(1.5)) + #13#10; Str(-1.4:2:1, T); S := S + T + ' Truncs to ' + IntToStr(Trunc(-1.4)) + #13#10; Str(-1.5:2:1, T); S := S + T + ' Truncs to ' + IntToStr(Trunc(-1.5)); MessageDlg(S, mtInformation, [mbOk], 0); end; ---------- var
f: file of Integer; i,j: Integer; begin AssignFile(f,'TEST.INT'); Rewrite(f); for i := 1 to 6 do Write(f,i); Writeln('File before truncation:'); Reset(f); while not Eof(f) do begin Read(f,i); Writeln(i); end; Reset(f); for i := 1 to 3 do Read(f,j); { Read ahead 3 records } Truncate(f); { Cut file off here }
Writeln; Writeln('File after truncation:'); Reset(f); while not Eof(f) do
begin Read(f,i); Writeln(i); end; CloseFile(f); Erase(f); end;
---------- BlockRead 读取档案至记忆体区块. ---------- procedure TForm1.Button1Click(Sender: TObject); var FromF, ToF: file; NumRead, NumWritten: Integer; Buf: array[1..2048] of Char; begin if OpenDialog1.Execute then { 开档对话盒} begin AssignFile(FromF, OpenDialog1.FileName);{} Reset(FromF, 1); { Record size = 1 } if SaveDialog1.Execute then { Display Save dialog box} begin AssignFile(ToF, SaveDialog1.FileName);{ Open output file }
Rewrite(ToF, 1); { Record size = 1 } Canvas.TextOut(10, 10, 'Copying ' + IntToStr(FileSize(FromF))+'bytes...'); repeat BlockRead(FromF, Buf, SizeOf(Buf), NumRead); BlockWrite(ToF, Buf, NumRead, NumWritten); until (NumRead = 0) or (NumWritten <> NumRead); CloseFile(FromF); CloseFile(ToF); end; end; end; ## BlockRead, BlockWrite, SaveDialog Example ---------- BlockWrite 将记忆体区块写入档案. ---------- Unit System 函数原型 procedure BlockRead(var F: File; var Buf; Count: Integer [; var Result: Integer]); 函数原型 procedure BlockWrite(var f: File; var Buf; Count: Integer [; var Result: Integer]); 范例 var FromF, ToF: file; NumRead, NumWritten: Integer; Buf: array[1..2048] of Char; begin if OpenDialog1.Execute then { Display Open dialog box } begin AssignFile(FromF, OpenDialog1.FileName); Reset(FromF, 1); { Record size = 1 } if SaveDialog1.Execute then { Display Save dialog box } begin AssignFile(ToF, SaveDialog1.FileName); { Open output file } Rewrite(ToF, 1); { Record size = 1 } Canvas.TextOut(10, 10,'Copying '+ IntToStr(FileSize(FromF))+ ' bytes...'); repeat BlockRead(FromF, Buf, SizeOf(Buf), NumRead); BlockWrite(ToF, Buf, NumRead, NumWritten); until (NumRead = 0) or (NumWritten <> NumRead); CloseFile(FromF); CloseFile(ToF); end; end; end; ========== Variant support routines 鬼牌变数函式 ========== VarArrayCreate 建立一个variant array. ---------- Unit System 函数原型 function VarArrayCreate(const Bounds: array of Integer; VarType: Integer): Variant; 范例 procedure TForm1.Button1Click(Sender: TObject); var A:Variant; S:String; begin A:=VarArrayCreate([0,4],varVariant); A[0]:=1; A[1]:=1234.5678; A[2]:='Hello world'; A[3]:=TRUE; A[4]:=VarArrayOf([1 ,10 ,100 ,10000]); S:=A[4][2]; S:=A[2]+' '+S; Label1.Caption:=S; end; 说明 S:=A[4][2]; Variant可以不用函数来做转换. 只能单独使用,如为下列则有误. S:=A[2]+' '+A[4][2];
VarType varEmpty $0000 The variant is Unassigned. varNull $0001 The variant is Null. varSmallint $0002 16-bit signed integer (type Smallint). varInteger $0003 32-bit signed integer (type Integer). varSingle $0004 Single-precision floating-point value (type Single). varDouble $0005 Double-precision floating-point value (type Double). varCurrency $0006 Currency floating-point value (type Currency). VarDate $0007 Date and time value (type TDateTime). VarOleStr $0008 Reference to a dynamically allocated UNICODE string. varDispatch $0009 Reference to an OLE automation object (an IDispatch interface pointer). VarError $000A Operating system error code. varBoolean $000B 16-bit boolean (type WordBool). varVariant $000C Variant (used only with variant arrays). varUnknown $000D Reference to an unknown OLE object (an IUnknown interface pointer). varByte $0011 8-bit unsigned integer (type Byte). VarString $0100 Reference to a dynamically-allocated long string (type AnsiString). varTypeMask $0FFF Bit mask for extracting type code. This constant is a mask that can be combined with the VType field using a bit-wise AND.. varArray $2000 Bit indicating variant array. This constant is a mask that can be combined with the VType field using a bit-wise AND to determine if the variant contains a single value or an array of values. VarByRef $4000 This constant can be AND'd with Variant.VType to determine if the variant contains a pointer to the indicated data instead of containing the data itself.
范例 var V1, V2, V3, V4, V5: Variant; I: Integer; D: Double; S: string; begin V1 := 1; { Integer value } V2 := 1234.5678; { Real value } V3 := 'Hello world'; { String value } V4 := '1000'; { String value } V5 := V1 +V2 +V4; { Real value 2235.5678 } I := V1; { I = 1 } D := V2; { D = 1234.5678 } S := V3; { S = 'Hello world' } I := V4; { I = 1000 } S := V5; { S = '2235.5678' } end; ---------- VarArrayOf 建立一个简单的一维variant array ---------- Unit System 函数原型 function VarArrayOf(const Values: array of Variant): Variant; 范例 var A:Variant; begin A:=VarArrayOf([1 ,10 ,'Hello ,10000]); S:=A[1]+' '+IntToStr(A[2]); Label1.Caption:=S; end; ---------- VarArrayRedim 重定variant阵列中高维部分的高注脚. ---------- Unit System ---------- 函数原型 procedure VarArrayRedim(var A: Variant; HighBound:Integer); ---------- VarArrayDimCount 传回Variant阵列的维数. ---------- Unit System 函数原型 function VarArrayDimCount(const A: Variant): Integer; ---------- VarArrayHighBound 传回Variant阵列中一维的高注脚. ---------- Unit System 函数原型 function VarArrayHighBound(const A: Variant; Dim: Integer):Integer; ---------- VarArrayLowBound 传回Variant阵列中一维的低注脚. ---------- Unit System 函数原型 function VarArrayLowBound(const A: Variant; Dim: Integer): Integer; 范例 procedure TForm1.Button1Click(Sender: TObject); var A:Variant; Count:Integer; HighBound:Integer; LowBound:Integer; i:Integer; S:String; begin A:=VarArrayCreate([0,5, 1,3],varVariant); Count:=VarArrayDimCount(A); S:=#13+'维数:'+IntToStr(Count)+#13; for i:=1 To Count do Begin HighBound:=VarArrayHighBound(A,i); LowBound:=VarArrayLowBound(A,i); S:=S+'HighBound: '+IntToStr(HighBound)+#13; S:=S+'LowBound : '+IntToStr(LowBound)+#13; End; ShowMessage(S); end; ---------- VarArrayLock 将variant阵列==>指定给一阵列变数. ---------- VarArrayUnLock 解除上述的指定. ---------- Unit System 函数原型 function VarArrayLock(var A: Variant): Pointer; 函数原型 procedure VarArrayUnlock(var A: Variant); 范例 procedure TForm1.Button1Click(Sender: TObject); Const HighVal=12; type TData=array[0..HighVal, 0..HighVal] of Integer; var A:Variant; i,j:Integer; Data:^TData; begin A:=VarArrayCreate([0,HighVal, 0,HighVal],varInteger); for i:=0 to HighVal do for j:=0 to HighVal do A[i,j]:=i*j; Data:=VarArrayLock(A); for i:=0 to HighVal do for j:=0 to HighVal do Grid1.Cells[i+1,j+1]:=IntToStr(Data^[i,j]); VarArrayUnLock(A); end; ---------- VarIsArray 传回Variant是否为一个阵列. ---------- Unit System 函数原型 function VarIsArray(const V: Variant): Boolean; VarIsEmpty 传回Variant是否尚未注册.(空的) Unit System 函数原型 function VarIsEmpty(const V: Variant): Boolean; 范例 procedure TForm1.Button1Click(Sender: TObject); var A:Variant; S:String; begin A:=VarArrayCreate([0,5, 0,7],varVariant); if VarIsEmpty(A) Then S:='True' else S:='False'; Label1.Caption:=S; end; ---------- ** S:=False,A以经建立了. ---------- VarIsNull 传回Variant是否为NULL. ---------- Unit System 函数原型 function VarIsNull(const V: Variant): Boolean; ---------- VarAsType 将Variant转为另外一个型态的Variant. ---------- VarCast ---------- Unit System 函数原型 function VarAsType(const V: Variant; VarType: Integer): Variant; 函数原型 procedure VarCast(var Dest: Variant; const Source: Variant; VarType: Integer); 说明 VarType不可为varArray or varByRef. ---------- VarType 传回Variant的型态. ---------- Unit System 函数原型 function VarType(const V: Variant): Integer; ---------- VarClear 将variant清除,成为Unassigned状态. ---------- Unit System 函数原型 procedure VarClear(var V: Variant); ---------- VarCopy 拷贝一个variant. ---------- Unit System 函数原型 procedure VarCopy(var Dest: Variant; const Source: Variant); 说明 与Dest:=Source;效果一样. ---------- VarFromDateTime 将DateTime转为Variant. ---------- VarToDateTime 将Variant转为DateTime. ---------- Unit System 函数原型 function VarFromDateTime(DateTime: TDateTime): Variant; 函数原型 function VarToDateTime(const V: Variant): TDateTime;
var HeaderSection: THeaderSection; I: Integer; begin for I := 0 to 4 do begin HeaderSection := HeaderControl1.Sections.Add; HeaderSection.Text := 'Text Section ' + IntToStr(I); HeaderSection.MinWidth := length(HeaderSection.Text) * Font.Size; // Owner draw every other section if (I mod 2 = 0) then HeaderSection.Style := hsOwnerDraw else HeaderSection.Style := hsText;
end; end;
procedure TForm1.HeaderControl1DrawSection(HeaderControl: THeaderControl; Section: THeaderSection; const Rect: TRect; Pressed: Boolean); begin with HeaderControl.Canvas do begin // highlight pressed sections if Pressed then Font.Color := clRed else Font.Color := clBlue; TextOut(Rect.Left + Font.Size, Rect.Top + 2, 'Owner Drawn text'); end; end; ## HeaderSection, OnDrawSection, Sections, Canvas, TextOut example ---------- Trunc Example ---------- procedure TForm1.Button1Click(Sender: TObject); var S, T: string; begin Str(1.4:2:1, T); S := T + ' Truncs to ' + IntToStr(Trunc(1.4)) + #13#10; Str(1.5:2:1, T); S := S + T + ' Truncs to ' + IntToStr(Trunc(1.5)) + #13#10; Str(-1.4:2:1, T); S := S + T + ' Truncs to ' + IntToStr(Trunc(-1.4)) + #13#10; Str(-1.5:2:1, T); S := S + T + ' Truncs to ' + IntToStr(Trunc(-1.5)); MessageDlg(S, mtInformation, [mbOk], 0); end;
未归类 ---------- WrapText ---------- SysUtils type TSysCharSet = set of Char var S, R: string; begin S:= '123456_123456_123456'; R:= WrapText( S, #13#10, ['1', '4'], 4); MessageDlg( R, mtInformation, [mbOk], 0); end; ========== WideCharToStrVar(Source: PWideChar;var Dest: string ); ---------- System ----------
========== WideCharToString( Source: PWideChar ): string; ---------- System
var buffer: array [0..255] of char; FileToFind: string; begin GetWindowsDirectory(buffer, SizeOf(buffer)); FileToFind := FileSearch(Edit1.Text, GetCurrentDir + ';' + buffer); if FileToFind = ' then ShowMessage('Couldn't find ' + Edit1.Text + '.') else ShowMessage('Found ' + FileToFind + '.');
end; ## FileSearch, ShowMessage Example ---------- FindComponent 范例(1) type LogPal = record lpal : TLogPalette; dummy:Array[0..255] of TPaletteEntry; end;
procedure TForm1.SaveAsBmpClick(Sender: TObject); var Source: TComponent; SysPal : LogPal; tempCanvas: TCanvas; sourceRect, destRect: TRect; image2save: TImage; notUsed: HWND; begin Source := FindComponent(Edit1.Text); if (not Source is TControl) or ((not Source is TWinControl) and ((Source as TControl).Parent = nil)) then
begin Beep; ShowMessage(Edit1.Text + ' is not a valid control.'); Exit;
end;
tempCanvas := TCanvas.Create; try with Source as TControl do tempCanvas.Handle := GetDeviceContext(notUsed); image2save:=TImage.create(self); try with image2save do begin Height := (Source as TControl).Height; Width := (Source as TControl).Width; destRect := Rect(0,0,Width,Height); if Source is TWinControl then
sourceRect := destRect; else sourceRect := (Source as TControl).BoundsRect; Canvas.CopyRect(destRect,tempCanvas,sourceRect); SysPal.lPal.palVersion:=$300; SysPal.lPal.palNumEntries:=256; GetSystemPaletteEntries(tempCanvas.Handle,0,256,SysPal.lpal.PalpalEntry); Picture.Bitmap.Palette:= CreatePalette(Syspal.lpal); end; if SaveDialog1.Execute then
var i: Integer; const NamePrefix = 'MyEdit'; begin for i := 1 to 20 do begin TEdit.Create(Self).Name := NamePrefix + IntToStr(i); with TEdit(FindComponent(NamePrefix + IntToStr(i))) do begin Left := 10; Top := i * 20; Parent := self; end; end; end; ========== procedure TForm1.Button1Click(Sender: TObject); var A: Variant; begin A := VarArrayCreate([0, 4], varVariant); A[0] := 1; A[1] := 1234.5678; A[2] := 'Hello world'; A[3] := True; A[4] := VarArrayOf([1, 10, 100, 1000]); Edit1.Text :=(A[2]); { Hello world } Edit2.Text :=(A[4][2]); { 100 } end;
procedure TForm1.Button2Click(Sender: TObject); var s: string; begin s := 'Honest Abe Lincoln'; Delete(s,8,4); Canvas.TextOut(10, 130, s); { 'Honest Lincoln' } end;
procedure TForm1.Button3Click(Sender: TObject); var S: string; begin S := 'ABCDEF'; S := Copy(S, 2, 3); Edit1.Text :=s;{ 'BCD' } end;
procedure TForm1.Button4Click(Sender: TObject); var S: string; begin S := Concat('ABC', 'DEF'); Edit1.Text :=s; { 'ABCDE' } end;
procedure TForm1.Button5Click(Sender: TObject); var S: string; begin S := 'Honest Lincoln'; Insert('Abe ', S, 8); Edit1.Text :=s; { 'Honest Abe Lincoln' } end;
procedure TForm1.Button6Click(Sender: TObject); var S: string; begin S := 'The Black Knight'; Canvas.TextOut(10, 130, 'String Length = ' + IntToStr(Length(S)));{String Length = 16} Edit1.Text :=s;{The Black Knight} end;
procedure TForm1.Button7Click(Sender: TObject); var S: string; begin S := ' 123.5'; { Convert spaces to zeroes } while Pos(' ', S) > 0 do S[Pos(' ', S)] := '0'; Edit1.Text :=s; {000123.5} end;
WinAPI 控件与消息函数 ---------- AdjustWindowRect AdjustWindowRectEx 给定一种窗囗样式，计算获得目标客户区矩形所需的窗囗大小 ========== VB声明 Declare Function AdjustWindowRect Lib "user32" Alias "AdjustWindowRect" (lpRect As RECT, ByVal dwStyle As Long, ByVal bMenu As Long) As Long Declare Function AdjustWindowRectEx Lib "user32" Alias "AdjustWindowRectEx" (lpRect As RECT, ByVal dsStyle As Long, ByVal bMenu As Long, ByVal dwEsStyle As Long) As Long 说明 在给定一种窗囗样式的前提下，计算获得目标客户区矩形所需的窗囗大小 返回值 Long，如执行成功，则返回非零值；如失败，返回零值。会设置GetLastError
叁数表 叁数 类型及说明 lpRect RECT，最初包含要求的客户区。由函数设为目标窗囗矩形大小 dwStyle Long，窗囗样式 bMenu Long，如窗囗有菜单，则设为TRUE（非零） dwEsStyle Long，扩展窗囗样式（只适用於AdjustWindowRectEx） 注解 在调用本函数前，先用GetWindowLong取得一个窗体的样式。如菜单占用两行以上的空间，则函数不能正确计算大小。如程序使用了多行标题，则应使用GetSystemMetrics ========== AnyPopup 判断屏幕上是否存在任何弹出式窗囗 ---------- VB声明 Declare Function AnyPopup Lib "user32" Alias "AnyPopup" () As Long 说明 判断屏幕上是否存在任何弹出式窗囗 返回值 Long，如存在弹出式菜单，则返回TRUE（非零） 注解 对该函数来说，弹出式菜单包含所有可见的包容顶级窗囗，无论弹出式还是重叠窗囗 ========== ArrangeIconicWindows 排列一个父窗囗的最小化子窗囗 VB声明 Declare Function ArrangeIconicWindows Lib "user32" Alias "ArrangeIconicWindows" (ByVal hwnd As Long) As Long 说明 排列一个父窗囗的最小化子窗囗（在vb里使用：用於在桌面排列图标，用GetDesktopWindow 函数获得桌面窗囗的一个句柄） 返回值 Long，图标行的高度；如失败，则返回零。会设置GetLastError 叁数表 叁数 类型及说明 hwnd Long，父窗囗的句柄 注解
以下是几个关於菜单函数的类型定义 MENUITEMINFO 这个结构包含了菜单条目的信息 TPMPARAMS 这个结构用於TrackPopupMenuEx函数以支持额外的功能 ========== 绘图函数 -------- AbortPath 抛弃选入指定设备场景中的所有路径。也取消目前正在进行的任何路径的创建工作 ---------- VB声明 Declare Function AbortPath Lib "gdi32" Alias "AbortPath" (ByVal hdc As Long) As Long 说明 抛弃选入指定设备场景中的所有路径。也取消目前正在进行的任何路径的创建工作 返回值 Long，非零表示成功，零表示失败。会设置GetLastError 叁数 类型及说明 hdc Long，设备场景 ========== AngleArc 用一个连接弧画一条线 ---------- VB声明 Declare Function AngleArc Lib "gdi32" Alias "AngleArc" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal dwRadius As Long, ByVal eStartAngle As Double, ByVal eSweepAngle As Double) As Long 说明 用一个连接弧画一条线，叁考注解 返回值 Long，非零表示成功，零表示失败 叁数表 叁数 类型及说明 hdc Long，要在其中作图的设备场景 x,y Long，对弧进行描述的一个圆的中心点坐标
注意eStartAngle和eSweepAngle叁数是以度数为单位指定的，而且应该是单精度数（Single ）而不是双精度。相应的函数声明为：Declare Function AngleArc& Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal dwRadius As Long, ByVal eStartAngle As Single, ByVal eSweepAngle As Single)。
