Çeşitli kod ipuçları

[ikutluay]

örnek

http://www.swissdelphicenter.ch/screenshots/Tip1390.png

Kod: Tümünü seç

*********************************************************

 Mit Hilfe des folgendes Codes lassen sich leicht beliebige
 Hints erstellen. Dazu muss nur dir Prozedur "Paint" den
 Wünschen entsprechend angepasst werden.

 With the following Code you can simply create custom hints.
 You just have to change the procedur "Paint".

 *********************************************************}

type
  TGraphicHintWindow = class(THintWindow)
    constructor Create(AOwner: TComponent); override;
  private
    FActivating: Boolean;
  public
    procedure ActivateHint(Rect: TRect; const AHint: string); override;
  protected
    procedure Paint; override;
  published
    property Caption;
  end;

  {...}

constructor TGraphicHintWindow.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);

  {
   Hier können beliebige Schrift Eigenschaften gesetzt
   werden.

   Here you can set custom Font Properties:
   }

  with Canvas.Font do
  begin
    Name := 'Arial';
    Style := Style + [fsBold];
    Color := clBlack;
  end;
end;

procedure TGraphicHintWindow.Paint;
var
  R: TRect;
  bmp: TBitmap;
begin
  R := ClientRect;
  Inc(R.Left, 2);
  Inc(R.Top, 2);

  {*******************************************************
   Der folgende Code ist ein Beispiel wie man die Paint
   Prozedur nutzen kann um einen benutzerdefinierten Hint
   zu erzeugen.

   The folowing Code ist an example how to create a custom
   Hint Object. :
   }

  bmp := TBitmap.Create;
  bmp.LoadfromFile('D:\hint.bmp');

  with Canvas do
  begin
    Brush.Style := bsSolid;
    Brush.Color := clsilver;
    Pen.Color   := clgray;
    Rectangle(0, 0, 18, R.Bottom + 1);
    Draw(2,(R.Bottom div 2) - (bmp.Height div 2), bmp);
  end;

  bmp.Free;
  //Beliebige HintFarbe
  //custom Hint Color
  Color := clWhite;

  Canvas.Brush.Style := bsClear;
  Canvas.TextOut(20, (R.Bottom div 2) - (Canvas.Textheight(Caption) div 2), Caption);
  {********************************************************}
end;

procedure TGraphicHintWindow.ActivateHint(Rect: TRect; const AHint: string);
begin
  FActivating := True;
  try
    Caption := AHint;
    //Höhe des Hints setzen setzen
    //Set the "Height" Property of the Hint
    Inc(Rect.Bottom, 14);
    //Breite des Hints setzen
    //Set the "Width" Property of the Hint
    Rect.Right := Rect.Right + 20;
    UpdateBoundsRect(Rect);
    if Rect.Top + Height > Screen.DesktopHeight then
      Rect.Top := Screen.DesktopHeight - Height;
    if Rect.Left + Width > Screen.DesktopWidth then
      Rect.Left := Screen.DesktopWidth - Width;
    if Rect.Left < Screen.DesktopLeft then Rect.Left := Screen.DesktopLeft;
    if Rect.Bottom < Screen.DesktopTop then Rect.Bottom := Screen.DesktopTop;
    SetWindowPos(Handle, HWND_TOPMOST, Rect.Left, Rect.Top, Width, Height,
      SWP_SHOWWINDOW or SWP_NOACTIVATE);
    Invalidate;
  finally
    FActivating := False;
  end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  HintWindowClass := TGraphicHintWindow;
  Application.ShowHint := False;
  Application.ShowHint := True;
end;

[ikutluay]

Kod: Tümünü seç

{
  This code might be useful for nonVCL applications or to read Listbox
  items from another application.
}

{
  Die folgenden Funktionen können z.B für nonVCL Projekte verwendet werden
  oder auch zum Auslesen von Listboxen aus anderen Applikationen.
}


// Retrieve the number of items in a ListBox
// Anzahl Einträge einer ListBox ermitteln

function LB_GetItemCount(hListBox: THandle): Integer;
begin
  Result := SendMessage(hListBox, LB_GETCOUNT, 0, 0);
end;

// Delete a string in a ListBox
// Einen String in einer ListBox löschen

procedure LB_DeleteItem(hListBox: THandle; Index: Integer);
begin
  SendMessage(hListBox, LB_DELETESTRING, Index, 0);
end;

// Retrieve the selected item from a ListBox
// Gibt den Text des markiertes Items einer ListBox zurück

function LB_GetSelectedItem(hListBox: THandle): string;
var
  Index, len: Integer;
  s: string;
  buffer: PChar;
begin
  Index := SendMessage(hListBox, LB_GETCURSEL, 0, 0);
  len := SendMessage(hListBox, LB_GETTEXTLEN, wParam(Index), 0);
  GetMem(buffer, len + 1);
  SendMessage(hListBox, LB_GETTEXT, wParam(Index), lParam(buffer));
  SetString(s, buffer, len);
  FreeMem(buffer);
  Result := IntToStr(Index) + ' : ' + s;
end;

// Example, Beispiel:

procedure TForm1.Button1Click(Sender: TObject);
var
  hListBox: THandle;
begin
  hListBox := {...}; // listbox handle
  ListBox1.Items.Text := LB_GetSelectedItem(hListBox);
end;

// Retrieve a string from a ListBox
// Gibt den Text eines bestimmten Items einer ListBox zurück

function LB_GetListBoxItem(hWnd: Hwnd; LbItem: Integer): string;
var
  l: Integer;
  buffer: PChar;
begin
  l := SendMessage(hWnd, LB_GETTEXTLEN, LbItem, 0);
  GetMem(buffer, l + 1);
  SendMessage(hWnd, LB_GETTEXT, LbItem, Integer(buffer));
  Result := StrPas(buffer);
  FreeMem(buffer);
end;

// Example, Beispiel:

procedure TForm1.Button2Click(Sender: TObject);
var
  hListBox: THandle;
begin
  hListBox := {...}; // listbox handle
  ListBox1.Items.Text := LB_GetListBoxItem(hListBox, 2);
end;

// Gibt den gesamten Text einer ListBox zurück
// Retrieve all listbox items

function LB_GetAllItems(hWnd: Hwnd; sl: TStrings): string;
var
  RetBuffer: string;
  i, x, y: Integer;
begin
  x := SendMessage(hWnd, LB_GETCOUNT, 0, 0);
  for i := 0 to x - 1 do
  begin
    y := SendMessage(hWnd, LB_GETTEXTLEN, i, 0);
    SetLength(RetBuffer, y);
    SendMessage(hWnd, LB_GETTEXT, i, lParam(PChar(RetBuffer)));
    sl.Add(RetBuffer);
  end;
end;

// Example, Beispiel:

procedure TForm1.Button3Click(Sender: TObject);
var
  sl: TStringList;
  ListBox_Handle: THandle;
begin
  hListBox := {...}; // listbox handle
  sl := TStringList.Create;
  try
    LB_GetAllItems(ListBox_Handle, sl);
  finally
    ListBox1.Items.Text := sl.Text;
    sl.Free;
  end;
end;

[ikutluay]

Kod: Tümünü seç

function IsOnLocalDrive(aFileName: string): Boolean;
var
  aDrive: string;
begin
  aDrive := ExtractFileDrive(aFileName);
  if (GetDriveType(PChar(aDrive)) = DRIVE_REMOVABLE) or
     (GetDriveType(PChar(aDrive)) = DRIVE_FIXED) then
    Result := True
  else
    Result := False;
end;


// Example, Beispiel:
procedure TForm1.Button1Click(Sender: TObject);
begin
  if OpenDialog1.Execute then
    if IsOnLocalDrive(OpenDialog1.FileName) then
      ShowMessage(OpenDialog1.FileName + ' is on a local drive.');
end;

 

[ikutluay]

Kod: Tümünü seç

Generally, EXE files created with Delphi are larger than EXE files
created with another programming language. The reason is the VCL.
(Sure, VCL has many advantages...)

There are several ways to reduce a EXE's size:

01) Use a EXE-Packer (UPX, ASPack,...)
02) Use KOL.
03) Write your application without VCL
04) Use the ACL (API Controls Library)
05) Use StripReloc.
06) Deactivate remote debugging information and TD32.
07) You might want to put code in a dll.
08) Don't put the same images several times on a form. Load them at runtime.
09) Use compressed images (JPG and not BMP)
10) Store less properties in DFM files
(See Link below "How To Make Your EXE's Lighter")

11) Use the TStringList replacement by ~LOM~
Use the Minireg - TRegistry replacement by Ben Hochstrasser


{*****************************************}


Mit Delphi erstellte Exe-Dateien sind im allgemeinen einiges grösser als solche,
welche mit anderen Programmiersprachen erzeugt wurden.
Der Grund dafür ist die VCL.
(Klar, Die VCL hat viele Vorteile...)

Es gibt verschiedene Möglichkeiten, um die Exe-Grösse zu reduzieren.

01) Einen EXE-Packer verwenden (UPX, ASPack, ....)
02) KOL verwenden.
03) Die Anwendung ohne VCL schreiben (nur mit API, nonVCL)
04) Die ACL (API Controls Library) verwenden.
05) StripReloc verwenden.
06) Debug Informationen und TD32 ausschalten.
07) Code in eine Dll auslagern.
08) Wenn Bilder mehrmals verwendet werden,
dann nur einmal einbinden und die anderen zur Laufzeit laden.
09) Bilder komprimieren (nicht bmp sondern z.B das jpg Format verwenden)
10) Weniger Properties in den DFM Dateien speichern
(Siehe Link unten ("How To Make Your EXE's Lighter")
11) Verwende den TStringList Ersatz von ~LOM~
Verwende die Minireg - TRegistry Ersatz von Ben Hochstrasser

{*****************************************}

// Further descriptions and links:
// Beschreibungen in Englisch und Links:

{****************************************************************}

01)
UPX is a free, portable, extendable, high-performance executable
packer for several different executable formats. It achieves an excellent
compression ratio and offers very fast decompression.
Your executables suffer no memory overhead or other drawbacks.

http://upx.sourceforge.net/

ASPack is an advanced Win32 executable file compressor, capable of reducing the file size of
32-bit Windows programs by as much as 70%. (ASPack's compression ratio improves upon the
industry-standard zip file format by as much as 10-20%.) ASPack makes Windows 95/98/NT
programs and libraries smaller, and decrease load times across networks, and download
times from the internet; it also protects programs against reverse engineering
by non-professional hackers.
Programs compressed with ASPack are self-contained and run exactly as before,
with no runtime performance penalties.

http://www.aspack.com/aspack.htm

{****************************************************************}

02)
KOL - Key Objects Library is a set of objects to develop power
(but small) 32 bit Windows GUI applications using Delphi but without VCL.
It is distributed free of charge, with source code.

http://bonanzas.rinet.ru/

{****************************************************************}

03)
nonVCL
Delphi lets you have it both ways. If you want tiny EXE's, then don't use
the VCL. Its entirely possible to use all the rich features of Delphi IDE
using 100% WinAPI calls, standard resources, etc.

http://nonvcl.luckie-online.de
http://www.erm.tu-cottbus.de/delphi/stuff/Tutorials/nonVCL/index.html
http://www.angelfire.com/hi5/delphizeus/
http://www.tutorials.delphi-source.de/nonvcl/


{****************************************************************}

04)

ACL (API Controls Library)
To write the program on pure API certainly it is possible, but I have deci-
ded to reach both goals - both to make that program and to receive the tool,
through which it would be possible in further to build similar programs, almost,
as on Delphi with VCL. So the idea to create my own TWinControl and all standard
Windows controls classes, derived from it has appeared.

http://www.apress.ru/pages/bokovikov/delphi/index.html/

{****************************************************************}

05)
StripReloc is a free (GPL license) command line utility that removes the relocation
(".reloc") section from Win32 PE EXE files, reducing their size.
Most compilers/linkers (including Delphi) put a relocation section in EXE files,
but this is actually not necessary since EXEs never get relocated.
Hence, a relocation section only wastes space.

Why not use an EXE compressor?
http://www.jrsoftware.org/striprlc.php

{****************************************************************}

06)
Deactivating the Debug Information

Exclude any debug information for the final build
(project-Options Compiler - Debugging and project-Options
Linker EXE and DLL options)
Dependeing on the amount of Debug information,
Debugging can take up until half of the size.

The options that are going to singificantly reduce your file size are
"Include TD32 debug info" and "Build with runtime packages". If you are
shipping commercial applications, you usually don't need the debug info
linked with your project.

{****************************************************************}

08/09)
About Images

The forms in your project have any bitmaps on them, then these are
compiled into the EXE. If you use the same bitmap multiple times, don't
assign them at design-time in the IDE as it will be included in the EXE
multiple times, assign them in code instead.
This can help reduce the size of the EXE, especially if you use large
bitmaps.

Use JPEG-files instead of BMP-files. This also reduces the EXE size.

{****************************************************************}

10)
How To Make Your EXE's Lighter:
http://www.undu.com/DN970301/00000064.htm

{****************************************************************}

11)
TStringList replacement by ~LOM~
Minireg - TRegistry replacement

 

[ikutluay]

Kod: Tümünü seç

uses
  ShellAPI;

function MrsGetFileType(const strFilename: string): string;
var
  FileInfo: TSHFileInfo;
begin
  FillChar(FileInfo, SizeOf(FileInfo), #0);
  SHGetFileInfo(PChar(strFilename), 0, FileInfo, SizeOf(FileInfo), SHGFI_TYPENAME);
  Result := FileInfo.szTypeName;
end;


// Beispiel:
// Example:
procedure TForm1.Button1Click(Sender: TObject);
begin
  ShowMessage('File type is: ' + MrsGetFileType('c:\autoexec.bat'));
end;

[ikutluay]

Kod: Tümünü seç

procedure GetSubDirs(const sRootDir: string; slt: TStrings);
var
  srSearch: TSearchRec;
  sSearchPath: string;
  sltSub: TStrings;
  i: Integer;
begin
  sltSub := TStringList.Create;
  slt.BeginUpdate;
  try
    sSearchPath := AddDirSeparator(sRootDir);
    if FindFirst(sSearchPath + '*', faDirectory, srSearch) = 0 then
      repeat
        if ((srSearch.Attr and faDirectory) = faDirectory) and
          (srSearch.Name <> '.') and
          (srSearch.Name <> '..') then
        begin
          slt.Add(sSearchPath + srSearch.Name);
          sltSub.Add(sSearchPath + srSearch.Name);
        end;
      until (FindNext(srSearch) <> 0);

    FindClose(srSearch);

    for i := 0 to sltSub.Count - 1 do
      GetSubDirs(sltSub.Strings[i], slt);
  finally
    slt.EndUpdate;
    FreeAndNil(sltSub);
  end;
end;

[ikutluay]

Kod: Tümünü seç

// Split file / File splitten

{
  Parameters:

  FileToSplit: Specify a file to split.
  SizeofFiles: Specify the size of the files you want to split to (in bytes)
  Progressbar: Specify a TProgressBar to show the splitting progress

  Result:
  SplitFile() will create files  FileName.001, FileName.002, FileName.003 and so on
  that are SizeofFiles bytes in size.
 }

function SplitFile(FileName : TFileName; SizeofFiles : Integer; ProgressBar : TProgressBar) : Boolean;
var
  i : Word;
  fs, sStream: TFileStream;
  SplitFileName: String;
begin
  ProgressBar.Position := 0;
  fs := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
  try
    for i := 1 to Trunc(fs.Size / SizeofFiles) + 1 do
    begin
      SplitFileName := ChangeFileExt(FileName, '.'+ FormatFloat('000', i));
      sStream := TFileStream.Create(SplitFileName, fmCreate or fmShareExclusive);
      try
        if fs.Size - fs.Position < SizeofFiles then
          SizeofFiles := fs.Size - fs.Position;
        sStream.CopyFrom(fs, SizeofFiles);
        ProgressBar.Position := Round((fs.Position / fs.Size) * 100);
      finally
        sStream.Free;
      end;
    end;
  finally
    fs.Free;
  end;

end;

// Combine files / Dateien zusammenführen

{
  Parameters:

  FileName: Specify the first piece of the splitted files
  CombinedFileName: Specify the combined file name. (the output file)

  Result:
  CombineFiles() will create one large file from the pieces
 }

function CombineFiles(FileName, CombinedFileName : TFileName) : Boolean;
var
  i: integer;
  fs, sStream: TFileStream;
  filenameOrg: String;
begin
  i := 1;
  fs := TFileStream.Create(CombinedFileName, fmCreate or fmShareExclusive);
  try
    while FileExists(FileName) do
    begin
      sStream := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
      try
        fs.CopyFrom(sStream, 0);
      finally
        sStream.Free;
      end;
      Inc(i);
      FileName := ChangeFileExt(FileName, '.'+ FormatFloat('000', i));
    end;
  finally
    fs.Free;
  end;
end;

// Examples:

procedure TForm1.Button1Click(Sender: TObject);
begin
  SplitFile('C:\temp\FileToSplit.chm',1000000, ProgressBar1);
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  CombineFiles('C:\temp\FileToSplit.001','H:\temp\FileToSplit.chm');
end;

[ikutluay]

Kod: Tümünü seç

Kod: Tümünü seç

{
  Byte 1-3 = ID 'TAG'
  Byte 4-33 = Titel / Title
  Byte 34-63 = Artist
  Byte 64-93 = Album
  Byte 94-97 = Jahr / Year
  Byte 98-127 = Kommentar / Comment
  Byte 128 = Genre
}


type
  TID3Tag = record
    ID: string[3];
    Titel: string[30];
    Artist: string[30];
    Album: string[30];
    Year: string[4];
    Comment: string[30];
    Genre: Byte;
  end;

const
 Genres : array[0..146] of string =
    ('Blues','Classic Rock','Country','Dance','Disco','Funk','Grunge',
    'Hip- Hop','Jazz','Metal','New Age','Oldies','Other','Pop','R&B',
    'Rap','Reggae','Rock','Techno','Industrial','Alternative','Ska',
    'Death Metal','Pranks','Soundtrack','Euro-Techno','Ambient',
    'Trip-Hop','Vocal','Jazz+Funk','Fusion','Trance','Classical',
    'Instrumental','Acid','House','Game','Sound Clip','Gospel','Noise',
    'Alternative Rock','Bass','Punk','Space','Meditative','Instrumental Pop',
    'Instrumental Rock','Ethnic','Gothic','Darkwave','Techno-Industrial','Electronic',
    'Pop-Folk','Eurodance','Dream','Southern Rock','Comedy','Cult','Gangsta',
    'Top 40','Christian Rap','Pop/Funk','Jungle','Native US','Cabaret','New Wave',
    'Psychadelic','Rave','Showtunes','Trailer','Lo-Fi','Tribal','Acid Punk',
    'Acid Jazz','Polka','Retro','Musical','Rock & Roll','Hard Rock','Folk',
    'Folk-Rock','National Folk','Swing','Fast Fusion','Bebob','Latin','Revival',
    'Celtic','Bluegrass','Avantgarde','Gothic Rock','Progressive Rock',
    'Psychedelic Rock','Symphonic Rock','Slow Rock','Big Band','Chorus',
    'Easy Listening','Acoustic','Humour','Speech','Chanson','Opera',
    'Chamber Music','Sonata','Symphony','Booty Bass','Primus','Porn Groove',
    'Satire','Slow Jam','Club','Tango','Samba','Folklore','Ballad',
    'Power Ballad','Rhytmic Soul','Freestyle','Duet','Punk Rock','Drum Solo',
    'Acapella','Euro-House','Dance Hall','Goa','Drum & Bass','Club-House',
    'Hardcore','Terror','Indie','BritPop','Negerpunk','Polsk Punk','Beat',
    'Christian Gangsta','Heavy Metal','Black Metal','Crossover','Contemporary C',
    'Christian Rock','Merengue','Salsa','Thrash Metal','Anime','JPop','SynthPop');


var
  Form1: TForm1;

implementation

{$R *.dfm}

function readID3Tag(FileName: string): TID3Tag;
var
  FS: TFileStream;
  Buffer: array [1..128] of Char;
begin
  FS := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
  try
    FS.Seek(-128, soFromEnd);
    FS.Read(Buffer, 128);
    with Result do
    begin
      ID := Copy(Buffer, 1, 3);
      Titel := Copy(Buffer, 4, 30);
      Artist := Copy(Buffer, 34, 30);
      Album := Copy(Buffer, 64, 30);
      Year := Copy(Buffer, 94, 4);
      Comment := Copy(Buffer, 98, 30);
      Genre := Ord(Buffer[128]);
    end;
  finally
    FS.Free;
  end;
end;

procedure TfrmMain.Button1Click(Sender: TObject);
begin
  if OpenDialog1.Execute then
  begin
    with readID3Tag(OpenDialog1.FileName) do
    begin
      LlbID.Caption := 'ID: ' + ID;
      LlbTitel.Caption := 'Titel: ' + Titel;
      LlbArtist.Caption := 'Artist: ' + Artist;
      LlbAlbum.Caption := 'Album: ' + Album;
      LlbYear.Caption := 'Year: ' + Year;
      LlbComment.Caption := 'Comment: ' + Comment;
      if (Genre >= 0) and (Genre <=146) then
       LlbGenre.Caption := 'Genre: ' + Genres[Genre]
      else
       LlbGenre.Caption := 'N/A';
    end;
  end;
end;

[ikutluay]

Kod: Tümünü seç

{
  To set a file's compression state, use the DeviceIoControl function with the
  FSCTL_SET_COMPRESSION operation.

  Call the following function with the name of the file to compress and
  boolean parameter 'forceCompress'. If that one is true, file will be compressed.
  If it is false, the file will be compressed only if its parent folder is
  compressed (reason for that parameter: if you MoveFile uncompressed file from
  uncompressed folder to compressed folder, file will not become automatically
  compressed - at least under some NT 4 service packs).

  Ein "compressed" Attribut kann man nicht mit der FileSetAttr Funktion setzen
  sondern muss DeviceIoControl Funktion mit dem flag FSCTL_SET_COMPRESSION verwenden:
}


const
  COMPRESSION_FORMAT_NONE = 0
  COMPRESSION_FORMAT_LZNT1 = 2
  COMPRESSION_FORMAT_DEFAULT = 1;
  FILE_DEVICE_FILE_SYSTEM = 9;
  METHOD_BUFFERED = 0;
  FILE_READ_DATA = 1;
  FILE_WRITE_DATA = 2;
  FSCTL_SET_COMPRESSION = (FILE_DEVICE_FILE_SYSTEM shl 16) or
    ((FILE_READ_DATA or FILE_WRITE_DATA) shl 14) or (16 shl 2) or METHOD_BUFFERED;

function SetCompressedAttribut(FileName: PChar; forceCompress: Boolean): Boolean;
var
  hnd: Integer;
  Comp: SHORT;
  res: DWORD;
begin
  if forceCompress or ((GetFileAttributes(PChar(ExtractFilePath(FileName))) and
    FILE_ATTRIBUTE_COMPRESSED) <> 0) then
  begin
    Result := False;
    if (GetFileAttributes(FileName) and FILE_ATTRIBUTE_COMPRESSED) = 0 then
    begin
      hnd := CreateFile(FileName, GENERIC_READ + GENERIC_WRITE, 0, nil, OPEN_EXISTING, 0, 0);
      try
        Comp := COMPRESSION_FORMAT_DEFAULT;
        if not DeviceIoControl(hnd, FSCTL_SET_COMPRESSION, @Comp,
          SizeOf(SHORT), nil, 0, res, nil) then Exit;
      finally
        CloseHandle(hnd);
      end;
    end;
    Result := True;
  end
  else
    Result := True;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  if OpenDialog1.Execute then
  begin
    SetCompressedAttribut(PChar(OpenDialog1.FileName), True);
  end;
end;

[ikutluay]

Kod: Tümünü seç

{
 You need a TProgressBar on your form for this tip.
 Für diesen Tip wird eine TProgressBar benötigt.
}


procedure TForm1.CopyFileWithProgressBar1(Source, Destination: string);
var
  FromF, ToF: file of byte;
  Buffer: array[0..4096] of char;
  NumRead: integer;
  FileLength: longint;
begin
  AssignFile(FromF, Source);
  reset(FromF);
  AssignFile(ToF, Destination);
  rewrite(ToF);
  FileLength := FileSize(FromF);
  with Progressbar1 do
  begin
    Min := 0;
    Max := FileLength;
    while FileLength > 0 do
    begin
      BlockRead(FromF, Buffer[0], SizeOf(Buffer), NumRead);
      FileLength := FileLength - NumRead;
      BlockWrite(ToF, Buffer[0], NumRead);
      Position := Position + NumRead;
    end;
    CloseFile(FromF);
    CloseFile(ToF);
  end;
end;


procedure TForm1.Button1Click(Sender: TObject);
begin
  CopyFileWithProgressBar1('c:\Windows\Welcome.exe', 'c:\temp\Welcome.exe');
end;

{ 2. }

{***************************************}

// To show the estimated time to copy a file:

procedure TForm1.CopyFileWithProgressBar1(Source, Destination: string);
var
  FromF, ToF: file of byte;
  Buffer: array[0..4096] of char;
  NumRead: integer;
  FileLength: longint;
  t1, t2: DWORD;
  maxi: integer;
begin
  AssignFile(FromF, Source);
  reset(FromF);
  AssignFile(ToF, Destination);
  rewrite(ToF);
  FileLength := FileSize(FromF);
  with Progressbar1 do
  begin
    Min  := 0;
    Max  := FileLength;
    t1   := TimeGetTime;
    maxi := Max div 4096;
    while FileLength > 0 do
    begin
      BlockRead(FromF, Buffer[0], SizeOf(Buffer), NumRead);
      FileLength := FileLength - NumRead;
      BlockWrite(ToF, Buffer[0], NumRead);
      t2  := TimeGetTime;
      Min := Min + 1;
      // Show the time in Label1
      label1.Caption := FormatFloat('0.00', ((t2 - t1) / min * maxi - t2 + t1) / 100);
      Application.ProcessMessages;
      Position := Position + NumRead;
    end;
    CloseFile(FromF);
    CloseFile(ToF);
  end;
end;

{ 3. }
{***************************************}
// To show the estimated time to copy a file, using a callback function:

type
  TCallBack = procedure(Position, Size: Longint); { export; }

procedure FastFileCopy(const InFileName, OutFileName: string;
  CallBack: TCallBack);


implementation

procedure FastFileCopyCallBack(Position, Size: Longint);
begin
  Form1.ProgressBar1.Max := Size;
  Form1.ProgressBar1.Position := Position;
end;

procedure FastFileCopy(const InFileName, OutFileName: string;
  CallBack: TCallBack);
const
  BufSize = 3 * 4 * 4096; { 48Kbytes gives me the best results }
type
  PBuffer = ^TBuffer;
  TBuffer = array[1..BufSize] of Byte;
var
  Size: DWORD;
  Buffer: PBuffer;
  infile, outfile: file;
  SizeDone, SizeFile: LongInt;
begin
  if (InFileName <> OutFileName) then
  begin
    buffer := nil;
    Assign(infile, InFileName);
    Reset(infile, 1);
    try
      SizeFile := FileSize(infile);
      Assign(outfile, OutFileName);
      Rewrite(outfile, 1);
      try
        SizeDone := 0;
        New(Buffer);
        repeat
          BlockRead(infile, Buffer^, BufSize, Size);
          Inc(SizeDone, Size);
          CallBack(SizeDone, SizeFile);
          BlockWrite(outfile, Buffer^, Size)
        until Size < BufSize;
        FileSetDate(TFileRec(outfile).Handle,
        FileGetDate(TFileRec(infile).Handle));
      finally
        if Buffer <> nil then
          Dispose(Buffer);
        CloseFile(outfile)
      end;
    finally
      CloseFile(infile);
    end;
  end
  else
    raise EInOutError.Create('File cannot be copied onto itself')
end; {FastFileCopy}




procedure TForm1.Button1Click(Sender: TObject);
begin
  FastFileCopy('c:\daten.txt', 'c:\test\daten2.txt', @FastFileCopyCallBack);
end;

{ 4. }
{***************************************}


function CopyFileWithProgressBar2(TotalFileSize,
  TotalBytesTransferred,
  StreamSize,
  StreamBytesTransferred: LARGE_INTEGER;
  dwStreamNumber,
  dwCallbackReason: DWORD;
  hSourceFile,
  hDestinationFile: THandle;
  lpData: Pointer): DWORD; stdcall;
begin
  // just set size at the beginning
  if dwCallbackReason = CALLBACK_STREAM_SWITCH then
    TProgressBar(lpData).Max := TotalFileSize.QuadPart;

  TProgressBar(lpData).Position := TotalBytesTransferred.QuadPart;
  Application.ProcessMessages;
  Result := PROGRESS_CONTINUE;
end;

function TForm1.CopyWithProgress(sSource, sDest: string): Boolean;
begin
  // set this FCancelled to true, if you want to cancel the copy operation
  FCancelled := False;
  Result     := CopyFileEx(PChar(sSource), PChar(sDest), @CopyFileWithProgressBar2,
    ProgressBar1, @FCancelled, 0);
end;

end;

{***************************************}

 

[ikutluay]

Kod: Tümünü seç

function GetEXEType(FileName: string): string;
var
  BinaryType: DWORD;
begin
  if GetBinaryType(PChar(FileName), Binarytype) then
    case BinaryType of
      SCS_32BIT_BINARY: Result := 'Win32 executable';
      SCS_DOS_BINARY: Result   := 'DOS executable';
      SCS_WOW_BINARY: Result   := 'Win16 executable';
      SCS_PIF_BINARY: Result   := 'PIF file';
      SCS_POSIX_BINARY: Result := 'POSIX executable';
      SCS_OS216_BINARY: Result := 'OS/2 16 bit executable'
        else
          Result := 'unknown executable'
    end
  else
    Result := 'File is not an executable';
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  label1.Caption := GetEXEType('c:\windows\notepad.exe');
end;


{
 Windows NT/2000: Requires Windows NT 3.5 or later.
 Windows 95/98: Unsupported.
}


{********************************************************************}

{2.}

type
  TExeType = (etUnknown, etDOS, etWinNE {16-bit}, etWinPE {32-bit});

function GetExeType(const FileName: string): TExeType;
{ func to return the type of executable or dll (DOS, 16-bit, 32-bit). }
(**************************************************************
Usage:
  with OpenDialog1 do
    if Execute then
      begin
        Label1.Caption := FileName;
        Label2.Caption := ExeStrings[GetExetype(FileName)];
      end;

  - or -

  case GetExeType(OpenDialog1.FileName) of
    etUnknown: Label3.Caption := 'Unknown file type';
    etDOS    : Label3.Caption := 'DOS executable';
    etWinNE  : {16-bit} Label3.Caption := 'Windows 16-bit executable';
    etWinPE  : {32-bit} Label3.Caption := 'Windows 32-bit executable';
  end;
***************************************************************)
var
  Signature,
  WinHdrOffset: Word;
  fexe: TFileStream;
begin
  Result := etUnknown;
  try
    fexe := TFileStream.Create(FileName, fmOpenRead or fmShareDenyNone);
    try
      fexe.ReadBuffer(Signature, SizeOf(Signature));
      if Signature = $5A4D { 'MZ' } then
        begin
          Result := etDOS;
          fexe.Seek($18, soFromBeginning);
          fexe.ReadBuffer(WinHdrOffset, SizeOf(WinHdrOffset));
          if WinHdrOffset >= $40 then
            begin
              fexe.Seek($3C, soFromBeginning);
              fexe.ReadBuffer(WinHdrOffset, SizeOf(WinHdrOffset));
              fexe.Seek(WinHdrOffset, soFrombeginning);
              fexe.ReadBuffer(Signature, SizeOf(Signature));
              if Signature = $454E { 'NE' } then
                Result := etWinNE
              else
                if Signature = $4550 { 'PE' } then
                  Result := etWinPE;
            end;
        end;
    finally
      fexe.Free;
    end;
  except
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  if OpenDialog1.Execute then
    case GetExeType(OpenDialog1.FileName) of
      etUnknown: Label_ExeType.Caption := 'Unknown file type';
      etDOS    : Label_ExeType.Caption := 'DOS executable';
      etWinNE  : Label_ExeType.Caption := 'Windows 16-bit executable';
      etWinPE  : Label_ExeType.Caption := 'Windows 32-bit executable';
    end;
end;

[ikutluay]

Kod: Tümünü seç

uses Commctrl;

{....}

const
  TTS_BALLOON    = $40;
  TTM_SETTITLE = (WM_USER + 32);

var
  hTooltip: Cardinal;
  ti: TToolInfo;
  buffer : array[0..255] of char;
  
{....}



procedure CreateToolTips(hWnd: Cardinal);
begin
  hToolTip := CreateWindowEx(0, 'Tooltips_Class32', nil, TTS_ALWAYSTIP or TTS_BALLOON,
    Integer(CW_USEDEFAULT), Integer(CW_USEDEFAULT), Integer(CW_USEDEFAULT),
    Integer(CW_USEDEFAULT), hWnd, 0, hInstance, nil);
  if hToolTip <> 0 then
  begin
    SetWindowPos(hToolTip, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE or
      SWP_NOSIZE or SWP_NOACTIVATE);
    ti.cbSize := SizeOf(TToolInfo);
    ti.uFlags := TTF_SUBCLASS;
    ti.hInst  := hInstance;
  end;
end;

procedure AddToolTip(hwnd: DWORD; lpti: PToolInfo; IconType: Integer;
  Text, Title: PChar);
var
  Item: THandle;
  Rect: TRect;
begin
  Item := hWnd;
  if (Item <> 0) and (GetClientRect(Item, Rect)) then
  begin
    lpti.hwnd := Item;
    lpti.Rect := Rect;
    lpti.lpszText := Text;
    SendMessage(hToolTip, TTM_ADDTOOL, 0, Integer(lpti));
    FillChar(buffer, SizeOf(buffer), #0);
    lstrcpy(buffer, Title);
    if (IconType > 3) or (IconType < 0) then IconType := 0;
    SendMessage(hToolTip, TTM_SETTITLE, IconType, Integer(@buffer));
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  CreateToolTips(Form1.Handle);
  AddToolTip(Memo1.Handle, @ti, 1, 'Tooltip text', 'Title');
end;

{
IconType can be:

 0 - No icon
 1 - Information
 2 - Warning
 3 - Error
}

[ikutluay]

Kod: Tümünü seç

{
For People (as I am) who can't manage with all of this function names and
forget some "jewels".
You should sometimes "rename" such procedures if it helps you to remember.
}

{
Die Unit Sysutils verbirgt einige Funktionen, die oft in Vergessenheit
geraten.
Kapselt die Funktion aus "Sysutils" in einer Funktion mit einem
"ansprechenden" Namen.
}


{ IncludeTrailingBackslash }

// Adds '\' to the end of a string if it is not already there.
// Die Funktion gibt einen Pfadnamen mit dem abschließenden Zeichen '\' zurück.

function CheckPfadEnd(const P: string): string;
begin
Result := IncludeTrailingBackslash(P);
end;


{ ExcludeTrailingBackslash }

// Removes one '\' from the end of a string if it is there.
// Die Funktion gibt einen Pfadnamen ohne das abschließende Zeichen \ zurück.


MyDir := ExcludeTrailingBackslash('c:\Windows\');
// ---> MyDir = c:\Windows

[ikutluay]

Kod: Tümünü seç

procedure FileReplaceString(const FileName, searchstring, replacestring: string);
var
  fs: TFileStream;
  S: string;
begin
  fs := TFileStream.Create(FileName, fmOpenread or fmShareDenyNone);
  try
    SetLength(S, fs.Size);
    fs.ReadBuffer(S[1], fs.Size);
  finally
    fs.Free;
  end;
  S  := StringReplace(S, SearchString, replaceString, [rfReplaceAll, rfIgnoreCase]);
  fs := TFileStream.Create(FileName, fmCreate);
  try
    fs.WriteBuffer(S[1], Length(S));
  finally
    fs.Free;
  end;
end;

[ikutluay]

Kod: Tümünü seç

...Copy Files to the Windows clipboard?
Autor: Thomas Stutz
[ Print tip ]	 	 

Tip Rating (15): 	 
     


uses
  ShlObj, ClipBrd;

procedure CopyFilesToClipboard(FileList: string);
var
  DropFiles: PDropFiles;
  hGlobal: THandle;
  iLen: Integer;
begin
  iLen := Length(FileList) + 2;
  FileList := FileList + #0#0;
  hGlobal := GlobalAlloc(GMEM_SHARE or GMEM_MOVEABLE or GMEM_ZEROINIT,
    SizeOf(TDropFiles) + iLen);
  if (hGlobal = 0) then raise Exception.Create('Could not allocate memory.');
  begin
    DropFiles := GlobalLock(hGlobal);
    DropFiles^.pFiles := SizeOf(TDropFiles);
    Move(FileList[1], (PChar(DropFiles) + SizeOf(TDropFiles))^, iLen);
    GlobalUnlock(hGlobal);
    Clipboard.SetAsHandle(CF_HDROP, hGlobal);
  end;
end;

// Example, Beispiel:

procedure TForm1.Button1Click(Sender: TObject);
begin
  CopyFilesToClipboard('C:\Bootlog.Txt'#0'C:\AutoExec.Bat');
end;

{
  Separate the files with a #0.
  Dateien mit einem #0 trennen.
}