Оригинальный DVD-ROM: eXeL@B DVD !
eXeL@B ВИДЕОКУРС !

ВИДЕОКУРС ВЗЛОМ
выпущен 2 августа!


УЗНАТЬ БОЛЬШЕ >>
Домой | Статьи | RAR-cтатьи | FAQ | Форум | Скачать | Видеокурс
Новичку | Ссылки | Программирование | Интервью | Архив | Связь

БОЛЬШОЙ FAQ ПО DELPHI



Кодирование файлов



 unit EncodStr;
 
 interface
 
 uses
   Classes;
 
 type
   TEncodedStream = class (TFileStream)
   private
     FKey: Char;
   public
     constructor Create(const FileName: string; Mode: Word);
     function Read(var Buffer; Count: Longint): Longint; override;
     function Write(const Buffer; Count: Longint): Longint; override;
     property Key: Char read FKey write FKey default 'A';
   end;
 
 implementation
 
 constructor TEncodedStream.Create(
   const FileName: string; Mode: Word);
 begin
   inherited Create (FileName, Mode);
   FKey := 'A';
 end;
 
 function TEncodedStream.Write(const Buffer;
    Count: Longint): Longint;
 var
   pBuf, pEnc: PChar;
   I, EncVal: Integer;
 begin
   // allocate memory for the encoded buffer
   GetMem (pEnc, Count);
   try
     // use the buffer as an array of characters
     pBuf := PChar (@Buffer);
     // for every character of the buffer
     for I := 0 to Count - 1 do
     begin
       // encode the value and store it
       EncVal := ( Ord (pBuf[I]) + Ord(Key) ) mod 256;
       pEnc [I] := Chr (EncVal);
     end;
     // write the encoded buffer to the file
     Result := inherited Write (pEnc^, Count);
   finally
     FreeMem (pEnc, Count);
   end;
 end;
 
 function TEncodedStream.Read(var Buffer; Count: Longint): Longint;
 var
   pBuf, pEnc: PChar;
   I, CountRead, EncVal: Integer;
 begin
   // allocate memory for the encoded buffer
   GetMem (pEnc, Count);
   try
     // read the encoded buffer from the file
     CountRead := inherited Read (pEnc^, Count);
     // use the output buffer as a string
     pBuf := PChar (@Buffer);
     // for every character actually read
     for I := 0 to CountRead - 1 do
     begin
       // decode the value and store it
       EncVal := ( Ord (pEnc[I]) - Ord(Key) ) mod 256;
       pBuf [I] := Chr (EncVal);
     end;
   finally
     FreeMem (pEnc, Count);
   end;
   // return the number of characters read
   Result := CountRead;
 end;
 
 
 
 end.


 unit EncForm;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
   StdCtrls, ExtCtrls;
 
 type
   TFormEncode = class(TForm)
     Memo1: TMemo;
     Memo2: TMemo;
     OpenDialog1: TOpenDialog;
     SaveDialog1: TSaveDialog;
     Panel1: TPanel;
     BtnLoadPlain: TButton;
     BtnSaveEncoded: TButton;
     BtnLoadEncoded: TButton;
     Splitter1: TSplitter;
     procedure BtnSaveEncodedClick(Sender: TObject);
     procedure BtnLoadEncodedClick(Sender: TObject);
     procedure BtnLoadPlainClick(Sender: TObject);
   private
     { Private declarations }
   public
     { Public declarations }
   end;
 
 var
   FormEncode: TFormEncode;
 
 implementation
 
 {$R *.DFM}
 
 uses
   EncodStr;
 
 procedure TFormEncode.BtnSaveEncodedClick(Sender: TObject);
 var
   EncStr: TEncodedStream;
 begin
   if SaveDialog1.Execute then
   begin
     EncStr := TEncodedStream.Create(
       SaveDialog1.Filename, fmCreate);
     try
       Memo1.Lines.SaveToStream (EncStr);
     finally
       EncStr.Free;
     end;
   end;
 end;
 
 procedure TFormEncode.BtnLoadEncodedClick(Sender: TObject);
 var
   EncStr: TEncodedStream;
 begin
   if OpenDialog1.Execute then
   begin
     EncStr := TEncodedStream.Create(
       OpenDialog1.FileName, fmOpenRead);
     try
       Memo2.Lines.LoadFromStream (EncStr);
     finally
       EncStr.Free;
     end;
   end;
 end;
 
 procedure TFormEncode.BtnLoadPlainClick(Sender: TObject);
 begin
   if OpenDialog1.Execute then
     Memo1.Lines.LoadFromFile (
       OpenDialog1.FileName);
 end;
 
 end.

Загрузить весь проект




Управление каталогами и файлами


 unit win95;
 {
 
 Копирование, перемещение и удаление файлов и каталогов наподобие
 Проводника (Explorer) в Windows 95.
 Дата  : 06/04/97
 Последнее обновление: 03/08/97
 
 Просьба сообщать о всех найденных ошибках и недочетах на мой
 адрес электронной почты.
 Приветствуются пожелания и предложения по улучшению функциональности!!!
 
 ОБНОВЛЕНИЯ:
 (18/04/97)
 Множество небольших поправок после множества ваших писем.
 Спасибо всем.
 
 (31/08/97)
 Две новых процедуры: Win95AddToRecent и
 Win95ClearRecentDocs.
 }
 interface
 uses Classes, ShellApi, ShlObj, Registry, Windows;
 type
 
   Str10 = string[10];
 
 const
 
   fpRootKey =
     '\Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders';
   fpDesktop: Str10 = 'DESKTOP';
   fpFavorites: Str10 = 'FAVORITES';
   fpFonts: Str10 = 'FONTS';
   fpPersonal: Str10 = 'PERSONAL';
   fpPrograms: Str10 = 'PROGRAMS';
   fpRecent: Str10 = 'RECENT';
   fpSendTo: Str10 = 'SENDTO';
   fpStartMenu: Str10 = 'START MENU';
   fpStartup: Str10 = 'STARTUP';
   fpTemplates: Str10 = 'TEMPLATES';
 
   {Пути к системным папкам}
 function GetFolderPath(const FolderName: Str10): string;
 
 {Функции для работы с файлами}
 procedure Win95AddToRecentDocs(const Filename: string);
 procedure Win95ClearRecentDocs;
 {Для манипулирования несколькими файлами разделите их имена символом "#0"}
 function Win95Copy(Owner: Integer; FromFile, ToFile: string; RenameOnCollision,
   Confirm: boolean): Boolean;
 function Win95Move(Owner: Integer; FromFile, ToFile: string; RenameOnCollision,
   Confirm: boolean): Boolean;
 {Если SendToRecycleBin = True, то файлы будут отправлены в Корзину (RecycleBin),
 
 в противном случае они будут стерты}
 function Win95Erase(Owner: Integer; WichFiles: string; SendToRecycleBin,
   Confirm: Boolean): Boolean;
 
 implementation
 
 function GetFolderPath(const FolderName: Str10): string;
 begin
 
   with TRegistry.Create do
   try
     RootKey := HKEY_CURRENT_USER;
     OpenKey(fpRootKey, False);
     Result := ReadString(FolderName);
   finally
     Free;
   end;
 end;
 
 procedure Win95AddToRecentDocs(const Filename: string);
 begin
 
   SHAddToRecentDocs(SHARD_PATH, @Filename[1]);
 end;
 
 procedure Win95ClearRecentDocs;
 begin
 
   SHAddToRecentDocs(SHARD_PATH, nil);
 end;
 
 function Win95Copy(Owner: Integer; FromFile, ToFile: string; RenameOnCollision,
   Confirm: boolean): Boolean;
 const
 
   Aborted: Boolean = False;
 var
 
   Struct: TSHFileOpStructA;
 begin
 
   while pos(';', FromFile) > 0 do
     FromFile[pos(';', FromFile)] := #0;
   while pos(';', ToFile) > 0 do
     ToFile[pos(';', ToFile)] := #0;
   FromFile := FromFile + #0#0;
   ToFile := ToFile + #0#0;
   with Struct do
   begin
     wnd := Owner;
     wFunc := FO_Copy;
     pFrom := PChar(FromFile);
     pTo := PChar(ToFile);
     fFlags := FOF_ALLOWUNDO or FOF_FILESONLY;
     if RenameOnCollision then
       fFLags := fFlags or FOF_RENAMEONCOLLISION;
     if not Confirm then
       fFLags := fFlags or FOF_NOCONFIRMATION;
     fAnyOperationsAborted := Aborted;
     hNameMappings := nil;
     lpszProgressTitle := nil;
   end;
   result := (SHFileOperationA(Struct) = 0) and (not Aborted);
 end;
 
 function Win95Move(Owner: Integer; FromFile, ToFile: string; RenameOnCollision,
   Confirm: boolean): Boolean;
 const
 
   Aborted: Boolean = False;
 var
 
   Struct: TSHFileOpStructA;
 begin
 
   while pos(';', FromFile) > 0 do
     FromFile[pos(';', FromFile)] := #0;
   while pos(';', ToFile) > 0 do
     ToFile[pos(';', ToFile)] := #0;
 
   FromFile := FromFile + #0#0;
   ToFile := ToFile + #0#0;
   with Struct do
   begin
     wnd := Owner;
     wFunc := FO_Move;
     pFrom := PChar(FromFile);
     pTo := PChar(ToFile);
     fFlags := FOF_ALLOWUNDO or FOF_FILESONLY;
     if RenameOnCollision then
       fFLags := fFlags or FOF_RENAMEONCOLLISION;
     if Confirm then
       fFLags := fFlags or FOF_NOCONFIRMATION;
     fAnyOperationsAborted := Aborted;
     hNameMappings := nil;
     lpszProgressTitle := nil;
   end;
   result := (SHFileOperationA(Struct) = 0) and (not Aborted);
 end;
 
 function Win95Erase(Owner: Integer; WichFiles: string; SendToRecycleBin,
   Confirm: Boolean): Boolean;
 const
 
   Aborted: Boolean = False;
 var
 
   Struct: TSHFileOpStructA;
 begin
 
   while pos(';', WichFiles) > 0 do
     WichFiles[pos(';', WichFiles)] := #0;
   WichFiles := WichFiles + #0#0;
   with Struct do
   begin
     wnd := Owner;
     wFunc := FO_Delete;
     pFrom := PChar(WichFiles);
     pTo := nil;
     if not Confirm then
       fFlags := FOF_NOCONFIRMATION;
     if SendToRecycleBin then
       fFLags := fFlags or FOF_ALLOWUNDO or FOF_FILESONLY
     else
       fFlags := fFlags or 0 or FOF_FILESONLY;
     fAnyOperationsAborted := Aborted;
     hNameMappings := nil;
     lpszProgressTitle := nil;
   end;
   result := (SHFileOperationA(Struct) = 0) and (not Aborted);
 end;
 
 end.
 




Как вывести список файлов с иконками

Удобнее всего воспользоваться компонентом ListView. Его используют многие программы, так как он позволяет очень просто создать удобный список.

Вначале создадим ImageList и с помощью функции WinAPI SHGetFileInfo заполним его иконками, связанными со всеми зарегистрированными расширениями. Затем, при выборе пользователем в DirectoryListBox каталога, найдем все файлы в этом каталоге и для каждого определим иконку при помощи той же функции SHGetFileInfo. И еще к каждому элементу списка добавляется размер файла. Если вывести список в виде таблицы (для этого нужно выбрать пункт Table в ComboBox), то справа от имени каждого файла окажется его размер.


 uses
   ShellAPI;
 
 procedure UpdateFiles;
 var
   sr: TSearchRec;
   li: TListItem;
   fi: TSHFileInfo;
   ext: string;
   IconIndex: word;
   ic: TIcon;
 begin
   Form1.ListView1.Items.BeginUpdate;
   Form1.ListView1.Items.Clear;
   if FindFirst(Form1.DirectoryListBox1.Directory + '\*.*', faAnyFile, sr) = 0 then
     repeat
       if sr.Attr and faDirectory <> 0 then
         continue;
       li := Form1.ListView1.Items.Add;
       li.Caption := sr.name;
       ext := LowerCase(ExtractFileExt(li.Caption));
       ShGetFileInfo(PChar('*' + ext), 0, fi, SizeOf(fi),
       SHGFI_SMALLICON or SHGFI_SYSICONINDEX or SHGFI_TYPENAME);
       li.ImageIndex := fi.iIcon;
       if sr.Size < 1024 then
         li.SubItems.Add(IntToStr(sr.Size) + ' byte')
       else
       if sr.Size < 1024 * 1024 then
         li.SubItems.Add(IntToStr(round(sr.Size / 1024)) + ' KByte')
       else
         li.SubItems.Add(IntToStr(round(sr.Size / (1024 * 1024))) + ' MByte');
       li.SubItems.Add(fi.szTypeName);
     until
       FindNext(sr) <> 0;
   FindClose(sr);
   Form1.ListView1.Items.EndUpdate;
 end;
 
 procedure TForm1.FormCreate(Sender: TObject);
 var
   fi: TSHFileInfo;
   lc: TListColumn;
 begin
   DriveComboBox1.DirList := DirectoryListBox1;
   with ListView1 do
   begin
     SmallImages := TImageList.CreateSize(16,16);
     SmallImages.Handle := ShGetFileInfo('*.*', 0, fi,
       SizeOf(fi), SHGFI_SMALLICON or SHGFI_ICON
       or SHGFI_SYSICONINDEX);
     LargeImages := TImageList.Create(nil);
     LargeImages.Handle := ShGetFileInfo('*.*', 0, fi,
       SizeOf(fi), SHGFI_LARGEICON or SHGFI_ICON
       or SHGFI_SYSICONINDEX);
     lc := Columns.Add;
     lc.Caption := 'Name';
     lc := Columns.Add;
     lc.Caption := 'Size';
     ComboBox1.Items.Add('Icons');
     ComboBox1.Items.Add('List');
     ComboBox1.Items.Add('Table');
     ComboBox1.Items.Add('SmallIcons');
     ComboBox1.ItemIndex := 0;
   end;
   UpdateFiles;
 end;
 
 procedure TForm1.DirectoryListBox1Change(Sender: TObject);
 begin
   UpdateFiles;
 end;
 
 procedure TForm1.ComboBox1Click(Sender: TObject);
 begin
   case ComboBox1.ItemIndex of
     0: ListView1.ViewStyle := vsIcon;
     1: ListView1.ViewStyle := vsList;
     2: ListView1.ViewStyle := vsReport;
     else
       ListView1.ViewStyle := vsSmallIcon;
   end;
 end;
 




Запись и чтение данных из файлов

Шеф дает секретарше две дискеты:
- Леночка, скопируйте вот эту дискету на эту, чистую.
Через пару минут она прибегает в слезах:
- Михаил Иваныч, чистую дискету ксерокс зажевал!


 {
 В следующем примере показано как можно осуществить чтение
 и запись данных в/из файла. Данный пример предполагается
 в первую очередь использовать тем, кто делает первые шаги
 в вопросах чтения/записи. Для получения дополнительной
 информации о каждом объекте, обратитесь к электронной справке.
 В коде присутствует минимальная обработка исключительных
 ситуаций, но она никоим образом не является законченным решением.
 
 Для оформления программы необходимо установить на форме
 компонент TMemo с заголовком Запись, и кнопку с заголовком
 Чтение. Запустите программу, поместите несколько строк в "memo",
 после чего нажмите на кнопку Запись. Очистите "memo", и нажмите Чтение.
 }
 
 procedure TForm1.BtnWriteClick(Sender: TObject);
 { автор: Michael Vincze
 }
 var
   FileStream: TFileStream;
   Writer: TWriter;
   I: Integer;
 begin
   FileStream :=
     TFileStream.Create('c:\delphi\projects\delta40\fileio\stream.txt',
     fmCreate or fmOpenWrite or fmShareDenyNone);
   Writer := TWriter.Create(FileStream, $FF);
   Writer.WriteListBegin;
   for I := 0 to Memo1.Lines.Count - 1 do
     Writer.WriteString(Memo1.Lines[I]);
   Writer.WriteListEnd;
   Writer.Destroy;
   FileStream.Destroy;
 end;
 
 procedure TForm1.BtnReadClick(Sender: TObject);
 { автор:  Michael Vincze
 }
 var
   FileStream: TFileStream;
   Reader: TReader;
 begin
   { пробуем открыть несуществующий файл
   }
   try
     FileStream :=
       TFileStream.Create('c:\delphi\projects\delta40\fileio\bogus.txt',
       fmOpenRead);
   except
     ; { Destroy не нужен, поскольку Create потерпела неудачу  }
   end;
 
   FileStream :=
     TFileStream.Create('c:\delphi\projects\delta40\fileio\stream.txt',
     fmOpenRead);
   Reader := TReader.Create(FileStream, $FF);
   Reader.ReadListBegin;
   Memo1.Lines.Clear;
   while not Reader.EndOfList do
     Memo1.Lines.Add(Reader.ReadString);
   Reader.ReadListEnd;
   Reader.Destroy;
   FileStream.Destroy;
 end;
 




Файловые переменные

Автор: Later, Ray Konopka (Raize Software Solutions)

Вы просто создаете файловую переменную, чей тип является 'File of ...', где ... - ваша структура записи. Пример:


 var
   F: File of TMyRec;
   R: TMyRec;
 begin
   { Заполнение записи R }
   AssignFile( F, 'somefile.dat' );
   Rewrite( F );
   Write( F, R );
   CloseFile( F );
 end;
 




Сбросить данные файла на диск

Имеется процедура Flush, которая работает с открытыми файлами:


 flush(f);
 

В руководстве четко не сказано, передает ли (сбрасывает) Flush данные непосредственно на диск. Если это не так, то данные сохраняются в других временных буферах. В качестве дополнительной меры безопасности, я "опускаюсь" для этого вызова в dos. Необходимость данного вызова спорна, но пусть он в нашем случае покажет эту возможность.

Ниже дан пример:


 Uses Sysutils;
 
 var
   F: text; { это ваш текстовый файл }
 
 Procedure TextFlush(F : Text);
 var
   fhandle: word;
 begin
   Flush(F);
   fhandle := ttextrec(F).Handle; { получаем дескриптор msdos }
   asm
     mov  ax, $6800
     mov  bx, handle
     call DOS3CALL
   end;
 end;
 

Если файл является "блочным" файлом, пропускаем шаг с командой flush, и используем tfilerec вместо ttextrec.

Переменная Filemode определяет режим открытия файла (По умолчанию режим эксклюзивный). К сожалению, это не срабатывает для текстовых файлов, поэтому вы должны, используя blockreads писать в буфер, и затем конвертировать части буфера в строку, если вы хотите работать с ним как с текстовым файлом.

Assign, или AssignFile, как вы теперь знаете, не может использоваться с файлом, который уже открыт (я проверял это, и это действительно так). В вашем случае рекомендую обратиться к вызову API OpenFile, ничего в этом страшного нет.

Если это текстовый файл, сбросьте сначала текстовый буфер на диск командой flush:


 flush(f);
 

Остальное относится ко всем файлам:

Сделайте файлу commit, используя dos-функцию commit, доступную начиная с DOS 5.


 asm
 mov  ax, $6800                { делаем commit файла }
 mov  bx, ttextrec(f).handle   { получаем дескриптор файла }
 call dos3call                 { это предпочтительный способ,  INT $21 также должно работать }
 end;
 

Согласно документации Microsoft, данный вызов также сбрасывает буфера SMARTDRIVE. MSDN10 так описывает алгоритм реализации этого на языке приложения:

Для сброса данных, сохраняемых в буфере SMARTDRV.EXE версии 4.0, вы можете воспользоваться одним из следующих способов:

  • Используйте функцию MS-DOS Commit File (которая записывает измененные данные буфера). Это прерывание 21h, функция 68h.
  • Используйте функцию MS-DOS Disk Reset (которая записывает измененные данные и чистит кэш). Это прерывание 21h, функция 0Dh.



TSharedStream — класс упрощающий работу с файлом подкачки

Открывает программер как-то холодильник после недельной попойки, глядит, а там нечто аж позеленело от плесени:
- ShareWare, trial version... - подумал программер.


 unit SharedStream;
 
 interface
 
 uses
  SysUtils, Windows, Classes, Consts;
 
 type
 
 { TSharedStream }
 
  TSharedStream = class(TStream) { Для совместимости с TStream }
  private
    FMemory  : Pointer;          { Указатель на данные }
    FSize    : Longint;          { Реальный размер записанных данных }
    FPageSize : Longint;         { Размер выделенной "страницы" под данные }
    FPosition : Longint;         { Текущая позиция "курсора" на "странице" }
  protected
  public
    constructor Create;
    destructor Destroy; override;
    function Read(var Buffer; Count: Longint): Longint; override;
    function Write(const Buffer; Count: Integer): Longint; override;
    function Seek(Offset: Longint; Origin: Word): Longint; override;
    procedure SetSize(NewSize: Longint); override;
    procedure LoadFromStream(Stream: TStream);
    procedure LoadFromFile(const FileName: string);
    procedure SaveToStream(Stream: TStream);
    procedure SaveToFile(const FileName: string);
  public
    property Memory: Pointer read FMemory;
  end;
 
 const
  SwapHandle = $FFFFFFFF; { Handle файла подкачки }
 
 implementation
 
 resourcestring
  CouldNotMapViewOfFile = 'Could not map view of file.';
 
 { TSharedStream }
 
 {
  * TSharedStream работает правильно только с файлом подкачки,
    с обычным файлом проще и надежнее работать TFileStream'ом.
 
  * Для тех кто знаком с File Mapping Functions'ами :
      Класс TSharedStream не может использоваться для синхронизации(разделения)
      данных среди различных процессов(программ/приложений). [пояснения в конструкторе]
 
  * Класс TSharedStream можно рассматривать как альтернативу
    временным файлам (т.е. как замену TFileStream).
    Преимущество :
      а. Данные никто не сможет просмотреть.
      б. Страница, зарезервированная под данные, автомотически освобождается
         после уничтожения создавшего ее TSharedStream'а.
 
  * Класс TSharedStream можно рассматривать как альтернативу
    TMemoryStream.
    Преимущество :
      а. Не надо опасаться нехватки памяти при большом объеме записываемых данных.
         [случай когда физически нехватает места на диске здесь не рассматривается].
 
  Известные проблемы:
    На данный момент таких не выявлено.
    Но есть одно НО. Я не знаю как поведет себя TSharedStream
    в результате нехватки места
      а. на диске
      б. в файле подкачки (т.е. в системе с ограниченным размером
                           файла подкачки).
 }
 
 constructor TSharedStream.Create;
 const
  Sz = 1024000;    { Первоначальный размер страницы }{ взят с потолка }
 var
  SHandle : THandle;
 begin
  FPosition := 0;  { Позиция "курсора" }
  FSize    := 0;  { Размер данных }
  FPageSize := Sz; { Выделенная область под данные }
  { Создаем дескриптор объекта отображения данных. //эта формулировка взята из книги
    Проще сказать - создаем страницу под данные.   //разрешите, я здесь и далее
                                                   //буду употреблять более протые
                                                   //информационные вставки.
    Все подробности по CreateFileMapping в Help'e. }
  SHandle := CreateFileMapping( SwapHandle, nil, PAGE_READWRITE, 0, Sz, nil );
  { Создаем "страницу"}
  { Handle файла подкачки }
  { Задаем размер "страницы"[Sz]. Не может быть = нулю}
  { Имя "страницы" должно быть нулевым[nil]}
  {    иначе Вам в последствии не удастся изменить размер "страницы".
      (Подробнее см. в TSharedStream.SetSize).
      * Для тех кто знаком с File Mapping Functions'ами :
          раз страница осталась неименованной, то Вам не удастся использовать
          ее для синхронизации(разделения) данных среди
          различных процессов(программ/приложений).
          [остальных недолжно волновать это отступление] }
  if SHandle = 0 then
     raise Exception.Create(CouldNotMapViewOfFile); { ошибка -
     неудалось создать объект отображения[т.е. "страница" не создана и указатель на нее = 0].
     Это может быть:
        Если Вы что-либо изменяли в конструкторе -
            a. Из-за ошибки в параметрах, передоваемых функции CreateFileMapping
            б. Если Sz <= 0
        Если Вы ничего не изменяли -
            а. То такое бывает случается после исключительных ситуаций в OS или
               некорректной работы с FileMapping'ом в Вашей или чужой программе.
               Помогает перезагрузка виндуса }
 
  FMemory := MapViewOfFile(SHandle, FILE_MAP_WRITE, 0, 0, Sz); { Получаем
             указатель на данные }
  if FMemory = nil then
     raise Exception.Create(CouldNotMapViewOfFile); { Виндус наверно
     может взбрыкнуться и вернуть nil, но я таких ситуаций не встречал.
     естественно если на предыдущих дейсвиях не возникало ошибок и если
     переданы корректные параметры для функции MapViewOfFile() }
 
  CloseHandle(SHandle);
 end;
 
 destructor TSharedStream.Destroy;
 begin
  UnmapViewOfFile(FMemory); { закрываем страницу.
  если у Вас не фиксированный размер файла подкачки, то через пару
  минут вы должны увидеть уменьшение его размера. }
  inherited Destroy;
 end;
 
 function TSharedStream.Read(var Buffer; Count: Longint): Longint;
 begin { Функция аналогичная TStream.Read().
        Все пояснения по работе с ней см. в help'e. }
  if Count > 0 then
  begin
    Result := FSize - FPosition;
    if Result > 0 then
    begin
      if Result > Count then Result := Count;
      Move((PChar(FMemory) + FPosition)^, Buffer, Result);
      Inc(FPosition, Result);
    end
  end else
    Result := 0
 end;
 
 function TSharedStream.Write(const Buffer; Count: Integer): Longint;
 var
  I : Integer;
 begin { Функция аналогичная TStream.Write().
        Все пояснения по работе с ней см. в help'e. }
  if Count > 0 then
  begin
    I := FPosition + Count;
    if FSize < I then Size := I;
    System.Move(Buffer, (PChar(FMemory) + FPosition)^, Count);
    FPosition := I;
    Result := Count;
  end else
    Result := 0
 end;
 
 function TSharedStream.Seek(Offset: Integer; Origin: Word): Longint;
 begin { Функция аналогичная TStream.Seek().
        Все пояснения по работе с ней см. в help'e. }
  case Origin of
    soFromBeginning : FPosition := Offset;
    soFromCurrent  : Inc(FPosition, Offset);
    soFromEnd      : FPosition := FSize - Offset;
  end;
  if FPosition > FSize then FPosition := FSize
  else if FPosition < 0 then FPosition := 0;
  Result := FPosition;
 end;
 
 procedure TSharedStream.SetSize(NewSize: Integer);
 const
  Sz = 1024000;
 var
  NewSz  : Integer;
  SHandle : THandle;
  SMemory : Pointer;
 begin { Функция аналогичная TStream.SetSize().
        Все пояснения по работе с ней см. в help'e. }
  inherited SetSize(NewSize);
 
  if NewSize > FPageSize then { Если размер необходимый для записи
  данных больше размера выделенного под "страницу", то мы должны
  увеличить размер "страницы", но... }
  begin { ...но FileMapping не поддерживает изменения размеров "страницы",
    что не очень удобно, поэтому приходится выкручиваться. }
    NewSz := NewSize + Sz; { задаем размер страницы +
                             1Meтр[чтобы уменьшить работу со страницами]. }
 
    { Создаем новую страницу }{ возможные ошибки создания страницы
      описаны в конструкторе TSharedStream. }
    SHandle := CreateFileMapping( SwapHandle, nil, PAGE_READWRITE, 0, NewSz, nil );
    if SHandle = 0 then
       raise Exception.Create(CouldNotMapViewOfFile);
 
    SMemory := MapViewOfFile(SHandle, FILE_MAP_WRITE, 0, 0, NewSz);
    if SMemory = nil then
       raise Exception.Create(CouldNotMapViewOfFile);
 
    CloseHandle(SHandle);
 
    Move(FMemory^, SMemory^, FSize); { Перемещаем данные
    из старой "страницы" в новую }
 
    UnmapViewOfFile(FMemory); { Закрываем старую "страницу" }
 
    FMemory := SMemory;
 
    FPageSize := NewSz; { Запоминаем размер "страницы" }
  end;
 
  FSize := NewSize;  { Запоминаем размер данных }
 
  if FPosition > FSize then FPosition := FSize;
 end;
 
 procedure TSharedStream.LoadFromFile(const FileName: string);
 var
  Stream: TFileStream;
 begin
  Stream := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
  try
    LoadFromStream(Stream)
  finally
    Stream.Free
  end
 end;
 
 procedure TSharedStream.LoadFromStream(Stream: TStream);
 var
  Count: Longint;
 begin
  Stream.Position := 0;
  Count := Stream.Size;
  SetSize(Count);
  if Count > 0 then Stream.Read(FMemory^, Count);
 end;
 
 procedure TSharedStream.SaveToFile(const FileName: string);
 var
  Stream: TFileStream;
 begin
  Stream := TFileStream.Create(FileName, fmCreate);
  try
    SaveToStream(Stream)
  finally
    Stream.Free
  end
 end;
 
 procedure TSharedStream.SaveToStream(Stream: TStream);
 begin
  Stream.Write(FMemory^, FSize);
 end;
 
 end.
 




Как вставить содержимое файла в текущую позицию курсора в компоненте TMemo

Муж в больнице после операции. Приехала навестить, а там обход. Врач спрашивает:
-Температура какая?
Он отвечает:
-Нормальная! 33,6...
Врач странно так посмотрела, говорит:
-Это нормальная?
Муж:
-Нет?
А я стою и думаю: Нормальная, не нормальная, а у меня больше и не бывает...


 var
   TheMStream: TMemoryStream;
   Zero: char;
 begin
   TheMStream := TMemoryStream.Create;
   TheMStream.LoadFromFile('C:.BAT');
   TheMStream.Seek(0, soFromEnd);
   //Null terminate the buffer!
   Zero := #0;
   TheMStream.write(Zero, 1);
   TheMStream.Seek(0, soFromBeginning);
   Memo1.SetSelTextBuf(TheMStream.Memory);
   TheMStream.Free;
 end;
 




Файл в корзину

MS Windows: Корзина должна быть чиста как совесть!

Не забудьте добавить ShellAPI в группу uses.

А это сама функция, которая выполняет всю работу:


 function RecycleFile(sFileName: string): Boolean;
 var
 FOS: TSHFileOpStruct;
 begin
    FillChar(FOS, SizeOf(FOS), 0);
    with FOS do
       begin
          wFunc := FO_DELETE; { так же можно использовать FO_COPY.
          pFrom := PChar(sFileName);
          pTo := { только для FO_COPY }
          fFlags := FOF_ALLOWUNDO; { Так как мы хотим послать файл в корзину }
       end;
    // Отправляем файл
    Result := (SHFileOperation(FOS) = 0);
 end;
 
 // Пример вызова функции:
 RecycleFile('E:\Test.exe' + #0);
 
 // либо, если изменить строку
 // pFrom:=PChar(sFileName+#0); ,
 // то можно вызывать проще:
 RecycleFile(Filename);
 




Послать файл от TServerSocket на TClientSocket

Мой адрес на дом и не улица, мой адрес тройной дабл ю.


 unit Unit1;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
   Dialogs, ScktComp, StdCtrls;
 
 type
   TForm1 = class(TForm)
     ClientSocket1: TClientSocket;
     ServerSocket1: TServerSocket;
     btnTestSockets: TButton;
     procedure ClientSocket1Read(Sender: TObject; Socket: TCustomWinSocket);
     procedure FormCreate(Sender: TObject);
     procedure FormDestroy(Sender: TObject);
     procedure ClientSocket1Disconnect(Sender: TObject;
       Socket: TCustomWinSocket);
     procedure ClientSocket1Connect(Sender: TObject;
       Socket: TCustomWinSocket);
     procedure ServerSocket1ClientConnect(Sender: TObject;
       Socket: TCustomWinSocket);
     procedure btnTestSocketsClick(Sender: TObject);
   private
     FStream: TFileStream;
     { Private-Deklarationen }
   public
     { Public-Deklarationen }
   end;
 
 var
   Form1: TForm1;
 
 implementation
 
 {$R *.dfm}
 
 procedure TForm1.ClientSocket1Read(Sender: TObject;
   Socket: TCustomWinSocket);
 var
   iLen: Integer;
   Bfr: Pointer;
 begin
   iLen := Socket.ReceiveLength;
   GetMem(Bfr, iLen);
   try
     Socket.ReceiveBuf(Bfr^, iLen);
     FStream.Write(Bfr^, iLen);
   finally
     FreeMem(Bfr);
   end;
 end;
 
 procedure TForm1.FormCreate(Sender: TObject);
 begin
   FStream := nil;
 end;
 
 procedure TForm1.FormDestroy(Sender: TObject);
 begin
   if Assigned(FStream) then
   begin
     FStream.Free;
     FStream := nil;
   end;
 end;
 
 procedure TForm1.ClientSocket1Disconnect(Sender: TObject;
   Socket: TCustomWinSocket);
 begin
   if Assigned(FStream) then
   begin
     FStream.Free;
     FStream := nil;
   end;
 end;
 
 procedure TForm1.ClientSocket1Connect(Sender: TObject;
   Socket: TCustomWinSocket);
 begin
   FStream := TFileStream.Create('c:\temp\test.stream.html', fmCreate or fmShareDenyWrite);
 end;
 
 procedure TForm1.ServerSocket1ClientConnect(Sender: TObject;
   Socket: TCustomWinSocket);
 begin
   Socket.SendStream(TFileStream.Create('c:\temp\test.html', fmOpenRead or fmShareDenyWrite));
 end;
 
 procedure TForm1.btnTestSocketsClick(Sender: TObject);
 begin
   ServerSocket1.Active := True;
   ClientSocket1.Active := True;
 end;
 
 end.
 




Описание типов файлов для Delphi

Формат .CAB-файлов

Это формат файлов, который Delphi предлагает теперь своим пользователям для размещения в Интернете. Cabinet-формат является эффективным средством для упаковки нескольких файлов. Cabinet-формат имеет две ключевых характеристики: в отдельном кабинете (.cab-файл) могут храниться несколько файлов, и сжатие данных выполняется в зависимости от типа файлов, что значительно увеличивает коэффициент сжатия. Создание Cabinet-файла зависит также от количества упаковываемых файлов и ожидаемого к ним типа доступа (последовательный, произвольный, одновременный ко всем файлам или доступ к нескольким файлам в одно и тоже время). Delphi не пользуется преимуществами сжатия файлов в зависимости от их типа.

Формат .LIC-файлов

В действительности, как такового, формата .lic-файла не существует. Обычно это такие же текстовые файлы, содержащие одну или две ключевых строки.

Формат .INF-файлов

Все inf-файлы состоят из секций и пунктов. Каждая именованная секция содержит соответствующие пункты. Все inf-файлы начинаются с заголовочной секции. После заголовка включенные секции могут располагаться в любом порядке. Каждый заголовок представляет собой строку с [Именем Заголовка]. Далее следуют пункты: ItemA = ItemDetail. Для получения дополнительной информации обратитесь к документу "Device Information File Reference".

Формат .dpr-файлов

.dpr-файл является центральным файлом delphi-проекта. Для программы он является первой точкой входа. dpr содержит ссылки на другие файлы проекта и связывает формы с соответствующими модулями. Данный файл нужно редактировать с предельной осторожностью, так как неумелые действия могут привести к тому, что вы не сможете загрузить ваш проект. Этот файл является критическим при загрузке и перемещении (копировании) проекта.

Формат .pas-файлов

Это стандартный текстовый файл, который можно редактировать в текстовом редакторе. Данный файл нужно редактировать с некоторой долей осторожности, поскольку это может закончиться потерей некоторых преимуществ двух других инструментов. К примеру, добавление кода для кнопки с декларацией типа никак не отразится на соответствующем .dfm-файле формы. Все pas-файлы являются критическими при пересборке проекта.

Формат .dfm-файлов

Данный файл содержит описание объектов, расположенных на форме. Содержимое файла можно увидеть в виде текста, вызвав правой кнопкой мыши контекстное меню и выбрав пункт "view as text", или же с помощью конвертора convert.exe (расположенного в каталоге bin), также позволяющего перевести файл в текстовый вид и обратно. Данный файл нужно редактировать очень осторожно, поскольку это может закончиться тем, что IDE не сможет загрузить форму. Этот файл является критическим при перемещении и пересборке проекта.

Формат .DOF-файлов

Данный текстовый файл содержит текущие установки для опций проекта, как например, настройки компилятора и компоновщика, каталоги, условные директивы и параметры командной строки. Данные установки могут быть изменены пользователем путем изменений настроек проекта.

Формат .DSK-файлов

Данный текстовый файл хранит информацию относительно состояния вашего проекта, как например, открытое окно и его координаты. Подобно .DOF-файлу, данный файл создается на основе текущей обстановки проекта.

Формат .DPK-файлов

Данный файл содержит исходный код пакета (аналогично .DPR-файлу стандартного проекта Delphi). Подобно файлу .DPR, .DPK-файл также является простым текстовым файлом, который можно редактировать (см. предупреждение выше) в стандартном редакторе. Одной из причин, по которой вы можете это сделать - использование компилятора командной строки.

Формат .DCP-файлов

Данный бинарный image-файл состоит фактически из реально скомпилированного пакета. Информация о символах и дополнительных заголовках, требуемых IDE, полностью содержится в .DCP-файле. Чтобы собрать (build) проект, IDE должен иметь доступ к этому файлу.

Формат .DPL-файла

В действительности это выполняемый runtime-пакет. Данный файл является Windows DLL с интегрированными Delphi-специфическими характеристиками. Данный файл необходим в случае развертывания приложения, использующего пакеты.

Формат .DCI-файла

Данный файл содержит как стандартные, так и определенные пользователем шаблоны кода, используемых в IDE. Файл может редактироваться стандартным текстовым редактором, или в самой IDE. Как и любой текстовый файл данных, используемый Delphi, редактировать его самостоятельно не рекомендуется.

Формат .DCT-файла

Это "частный" бинарный файл, содержащий информацию об определенных пользователями шаблонах компонентов. Данный файл не может быть отредактирован никакими способами через IDE. Поскольку данный файл является "личным" файлом IDE, то совместимость с последующими версиями Delphi не гарантируется.

Формат .TLB-файла

.TLB-файл является "частным" двоичным файлом библиотеки типов. Обеспечивает информацией для идентификации типов объектов и интерфейсов, доступных в ActiveX сервере. Подобно модулю или заголовочному файлу, .TLB служит в качестве хранилища для необходимой символьной информации приложения. Поскольку данный файл является "личным", то совместимость с последующими версиями Delphi не гарантируется.

Формат .DRO-файла

Данный текстовый файл содержит информацию об объектном хранилище. Каждый пункт данного файла содержит специфическую информацию о каждом доступном элементе в хранилище объектов. Хотя этот файл и является простым текстовым файлом, мы настоятельно не рекомендуем править его вручную. Хранилище может редактироваться только с помощью меню Tools|Repository в самом IDE.

Формат .RES-файла

Это стандартный двоичный windows-формата файл ресурсов, включающий в себя информацию о приложении. По умолчанию, Delphi создает новый .RES-файл при каждой компиляции проекта в исполняемое приложение.

Формат .DB-файла

Файлы с таким расширением - стандартные файлы Paradox.

Формат .DBF-файла

Файлы с таким расширением - стандартные dBASE-файлы.

Фомат .GDB-файла

Файлы с таким расширением - стандартные Interbase-файлы.

Формат .DMT-файла

Этот "частный" бинарный файл содержит встроенные и определенные пользователем шаблоны меню. Данный файл не может быть отредактирован никакими способами через IDE. Поскольку данный файл является "личным", то совместимость с последующими версиями Delphi не гарантируется.

Формат .DBI-файла

Данный текстовый файл содержит информацию, необходимую для инициализации Database Explorer. Данный файл не может быть отредактирован никакими способами через Database Explorer.

Формат .DEM-файла

Данный текстовый файл содержит некоторые стандартные, привязанные к стране, форматы компонента TMaskEdit. Как и любой текстовый файл данных, используемый Delphi, редактировать его самостоятельно не рекомендуется.

Формат .OCX-файла

.OCX-файл является специализированной DLL, которая содержит все или несколько функций, связанных с элементом управления ActiveX. Файл OCX задумывался как "обертка", которая содержала бы сам объект, и средства для связи с другими объектами и серверами.




Получаем информацию о версии файла


 uses ShellApi;
 
 type
   TFileVersionInfo = record
     FileType,
     CompanyName,
     FileDescription,
     FileVersion,
     InternalName,
     LegalCopyRight,
     LegalTradeMarks,
     OriginalFileName,
     ProductName,
     ProductVersion,
     Comments,
     SpecialBuildStr,
     PrivateBuildStr,
     FileFunction : string;
     DebugBuild,
     PreRelease,
     SpecialBuild,
     PrivateBuild,
     Patched,
     InfoInferred : Boolean;
   end;
 
 function FileVersionInfo(const sAppNamePath: TFileName): TFileVersionInfo;
 var
   rSHFI: TSHFileInfo;
   iRet: Integer;
   VerSize: Integer;
   VerBuf: PChar;
   VerBufValue: Pointer;
   VerHandle: Cardinal;
   VerBufLen: Cardinal;
   VerKey: string;
   FixedFileInfo: PVSFixedFileInfo;
 
   // dwFileType, dwFileSubtype 
   function GetFileSubType(FixedFileInfo: PVSFixedFileInfo) : string;
   begin
     case FixedFileInfo.dwFileType of
 
       VFT_UNKNOWN: Result := 'Unknown';
       VFT_APP: Result := 'Application';
       VFT_DLL: Result := 'DLL';
       VFT_STATIC_LIB: Result := 'Static-link Library';
 
       VFT_DRV:
         case
           FixedFileInfo.dwFileSubtype of
           VFT2_UNKNOWN: Result := 'Unknown Driver';
           VFT2_DRV_COMM: Result := 'Communications Driver';
           VFT2_DRV_PRINTER: Result := 'Printer Driver';
           VFT2_DRV_KEYBOARD: Result := 'Keyboard Driver';
           VFT2_DRV_LANGUAGE: Result := 'Language Driver';
           VFT2_DRV_DISPLAY: Result := 'Display Driver';
           VFT2_DRV_MOUSE: Result := 'Mouse Driver';
           VFT2_DRV_NETWORK: Result := 'Network Driver';
           VFT2_DRV_SYSTEM: Result := 'System Driver';
           VFT2_DRV_INSTALLABLE: Result := 'InstallableDriver';
           VFT2_DRV_SOUND: Result := 'Sound Driver';
         end;
       VFT_FONT:
          case FixedFileInfo.dwFileSubtype of
           VFT2_UNKNOWN: Result := 'Unknown Font';
           VFT2_FONT_RASTER: Result := 'Raster Font';
           VFT2_FONT_VECTOR: Result := 'Vector Font';
           VFT2_FONT_TRUETYPE: Result :='Truetype Font';
           else;
         end;
       VFT_VXD: Result :='Virtual Defice Identifier = ' +
           IntToHex(FixedFileInfo.dwFileSubtype, 8);
     end;
   end;
 
 
   function HasdwFileFlags(FixedFileInfo: PVSFixedFileInfo;
   Flag : Word) : Boolean;
   begin
     Result := (FixedFileInfo.dwFileFlagsMask and
               FixedFileInfo.dwFileFlags and
               Flag) = Flag;
   end;
 
   function GetFixedFileInfo: PVSFixedFileInfo;
   begin
     if not VerQueryValue(VerBuf, '', Pointer(Result), VerBufLen) then
       Result := nil
   end;
 
   function GetInfo(const aKey: string): string;
   begin
     Result := '';
     VerKey := Format('\StringFileInfo\%.4x%.4x\%s',
               [LoWord(Integer(VerBufValue^)),
                HiWord(Integer(VerBufValue^)), aKey]);
     if VerQueryValue(VerBuf, PChar(VerKey),VerBufValue,VerBufLen) then
       Result := StrPas(VerBufValue);
   end;
 
   function QueryValue(const aValue: string): string;
   begin
     Result := '';
     // obtain version information about the specified file 
     if GetFileVersionInfo(PChar(sAppNamePath), VerHandle,
     VerSize, VerBuf) and
        // return selected version information 
        VerQueryValue(VerBuf, '\VarFileInfo\Translation',
        VerBufValue, VerBufLen) then
          Result := GetInfo(aValue);
   end;
 
 
 begin
   // Initialize the Result 
   with Result do
   begin
     FileType := '';
     CompanyName := '';
     FileDescription := '';
     FileVersion := '';
     InternalName := '';
     LegalCopyRight := '';
     LegalTradeMarks := '';
     OriginalFileName := '';
     ProductName := '';
     ProductVersion := '';
     Comments := '';
     SpecialBuildStr:= '';
     PrivateBuildStr := '';
     FileFunction := '';
     DebugBuild := False;
     Patched := False;
     PreRelease:= False;
     SpecialBuild:= False;
     PrivateBuild:= False;
     InfoInferred := False;
   end;
 
   // Get the file type 
   if SHGetFileInfo(PChar(sAppNamePath), 0, rSHFI, SizeOf(rSHFI),
     SHGFI_TYPENAME) <> 0 then
   begin
     Result.FileType := rSHFI.szTypeName;
   end;
 
   iRet := SHGetFileInfo(PChar(sAppNamePath), 0, rSHFI,
   SizeOf(rSHFI), SHGFI_EXETYPE);
   if iRet <> 0 then
   begin
     // determine whether the OS can obtain version information 
     VerSize := GetFileVersionInfoSize(PChar(sAppNamePath), VerHandle);
     if VerSize > 0 then
     begin
       VerBuf := AllocMem(VerSize);
       try
         with Result do
         begin
           CompanyName      := QueryValue('CompanyName');
           FileDescription  := QueryValue('FileDescription');
           FileVersion      := QueryValue('FileVersion');
           InternalName     := QueryValue('InternalName');
           LegalCopyRight   := QueryValue('LegalCopyRight');
           LegalTradeMarks  := QueryValue('LegalTradeMarks');
           OriginalFileName := QueryValue('OriginalFileName');
           ProductName      := QueryValue('ProductName');
           ProductVersion   := QueryValue('ProductVersion');
           Comments         := QueryValue('Comments');
           SpecialBuildStr  := QueryValue('SpecialBuild');
           PrivateBuildStr  := QueryValue('PrivateBuild');
           // Fill the  VS_FIXEDFILEINFO structure 
           FixedFileInfo    := GetFixedFileInfo;
           DebugBuild       := HasdwFileFlags(FixedFileInfo,VS_FF_DEBUG);
           PreRelease       := HasdwFileFlags(FixedFileInfo,VS_FF_PRERELEASE);
           PrivateBuild     := HasdwFileFlags(FixedFileInfo,VS_FF_PRIVATEBUILD);
           SpecialBuild     := HasdwFileFlags(FixedFileInfo,VS_FF_SPECIALBUILD);
           Patched          := HasdwFileFlags(FixedFileInfo,VS_FF_PATCHED);
           InfoInferred     := HasdwFileFlags(FixedFileInfo,VS_FF_INFOINFERRED);
           FileFunction     := GetFileSubType(FixedFileInfo);
         end;
       finally
         FreeMem(VerBuf, VerSize);
       end
     end;
   end
 end;
 
 // Test it: 
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
   FvI: TFileVersionInfo;
 const
   Tabulator: array[0..0] of Integer = (70);
   BoolValues: array[Boolean] of string = ('No', 'Yes');
 begin
   FvI := FileVersionInfo('C:\FileName.exe');
   ListBox1.TabWidth := 1;
   SendMessage(ListBox1.Handle, LB_SETTABSTOPS, 1, Longint(@Tabulator));
   with FvI, ListBox1.Items do
   begin
     Add('FileType:'#9 + FileType);
     Add('CompanyName:'#9 + CompanyName);
     Add('CompanyName:'#9 + FileDescription);
     Add('FileVersion:'#9 + FileVersion);
     Add('InternalName:'#9 + InternalName);
     Add('LegalCopyRight:'#9 + LegalCopyRight);
     Add('LegalTradeMarks:'#9 + LegalTradeMarks);
     Add('OriginalFileName:'#9 + OriginalFileName);
     Add('ProductName:'#9 + ProductName);
     Add('ProductVersion:'#9 + ProductVersion);
     Add('SpecialBuildStr:'#9 + SpecialBuildStr);
     Add('PrivateBuildStr:'#9 + PrivateBuildStr);
     Add('FileFunction:'#9 + FileFunction);
     Add('DebugBuild:'#9 + BoolValues[DebugBuild]);
     Add('PreRelease:'#9 + BoolValues[PreRelease]);
     Add('PrivateBuild:'#9 + BoolValues[PrivateBuild]);
     Add('SpecialBuild:'#9 + BoolValues[SpecialBuild]);
   end;
 end;
 




Файл с множеством записей

Обычно, я использую файл с заголовком, который я затем загружаю в память, и использую его для поиска необходимой мне записи.


 type
   TSaveHeader = record
     scene: Integer;
     hotspots: LongInt;
     talk: LongInt;
     hype: LongInt;
   end;
 
 var
   SaveHeader: TSaveHeader;
 
 procedure OpenSaveFile(fname: string);
 var
   f: file;
   i: Integer;
 begin
   AssignFile(f, fname);
   Reset(f, 1);
   BlockRead(f, SaveHeader, Sizeof(TSaveHeader));
   { получаем один набор записи }
   Seek(f, SaveHeader.hotspots);
   for i := 1 to 50 do
     BlockRead(f, somevar, sizeof_hotspotrec);
   { и так далее }
   CloseFile(f);
 end;
 
 { предположим, что файл открыт }
 
 procedure GetHotspotRec(index: LongInt; var hotspotrec: THotspot);
 var
   offset: LongInt;
 begin
   offset := SaveHeader.hotspots + index * Sizeof(THotSpot);
   Seek(f, offset);
   BlockRead(f, hotspotrec, Sizeof(THotspot));
 end;
 




Заполнения массива случаными неповторяющимися значениями

Автор: Дедок Василий

Огромное Вам спасибо за сбор и систематизацию советов по Delphi. Предлагаю Вам интересное решение заполнения массива случаными неповторяющимися значениями. Думаю этот алгоритм небесполезен.


 type
   arr = array[1..255] of integer;
 
 procedure FillArray(var A: arr; n: integer);
 var
   i: integer;
   s: string;
   q: byte;
 begin
   randomize;
   s := '';
   for i := 1 to n do
   begin
     q := random(i);
     insert(chr(i), s, q);
   end;
   for i := 1 to n do
   begin
     A[i] := ord(s[i]);
   end;
 end;
 




Заполнения массива случаными неповторяющимися значениями 2

Автор: Иваненко Фёдор Григорьевич

Приведу стандартную процедуру, работает в шесть раз быстрее, не имеет ограничений, да и кода поменьше :)


 procedure FillArray(var A: array of Integer);
 var
   I, S, R: Integer;
 begin
   for I := 0 to High(A) do
     A[I] := I;
   for i := High(A) downto 0 do
   begin
     R := Random(I);
     S := A[R];
     A[R] := A[I];
     A[I] := S;
   end;
 end;
 




Заполнение фона формы рисунком


Интуитивно понятный интерфейс - это такой интерфейс, для работы с которым нужна недюжинная интуиция.


 unit bmpformu;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls,
   Forms, Dialogs, StdCtrls;
 
 type
   TBmpForm = class(TForm)
     Button1: TButton;
     procedure FormDestroy(Sender: TObject);
     procedure FormPaint(Sender: TObject);
     procedure Button1Click(Sender: TObject);
     procedure FormCreate(Sender: TObject);
   private
     Bitmap: TBitmap;
     procedure ScrambleBitmap;
     procedure WMEraseBkgnd(var m: TWMEraseBkgnd); message WM_ERASEBKGND;
 end;
 
 var
   BmpForm: TBmpForm;
 
 implementation
 {$R *.DFM}
 
 procedure TBmpForm.FormCreate(Sender: TObject);
 begin
   Bitmap := TBitmap.Create;
   Bitmap.LoadFromFile('bor6.bmp');
 end;
 
 procedure TBmpForm.FormDestroy(Sender: TObject);
 begin
   Bitmap.Free;
 end;
 
 // since we're going to be painting the whole form, handling this
 // message will suppress the uneccessary repainting of the background
 // which can result in flicker.
 procedure TBmpform.WMEraseBkgnd(var m : TWMEraseBkgnd);
 begin
   m.Result := LRESULT(False);
 end;
 
 procedure TBmpForm.FormPaint(Sender: TObject);
 var
   x, y: Integer;
 begin
   y := 0;
   while y < Height do
   begin
     x := 0;
     while x < Width do
     begin
       Canvas.Draw(x, y, Bitmap);
       x := x + Bitmap.Width;
     end;
     y := y + Bitmap.Height;
   end;
 end;
 
 procedure TBmpForm.Button1Click(Sender: TObject);
 begin
   ScrambleBitmap; Invalidate;
 end;
 
 // scrambling the bitmap is easy when it's has 256 colors:
 // we just need to change each of the color in the palette
 // to some other value.
 procedure TBmpForm.ScrambleBitmap;
 var
   pal: PLogPalette;
   hpal: HPALETTE;
   i: Integer;
 begin
   pal := nil;
   try
     GetMem(pal, sizeof(TLogPalette) + sizeof(TPaletteEntry) * 255);
     pal.palVersion := $300;
     pal.palNumEntries := 256;
     for i := 0 to 255 do
     begin
       pal.palPalEntry[i].peRed := Random(255);
       pal.palPalEntry[i].peGreen := Random(255);
       pal.palPalEntry[i].peBlue := Random(255);
     end;
     hpal := CreatePalette(pal^);
     if hpal <> 0 then
       Bitmap.Palette := hpal;
   finally
     FreeMem(pal);
   end;
 end;
 
 end.
 




Заполнение формы изображением

Автор: Dmitry Morsin


 form1.brush.bitmap:=image1.picture.bitmap;
 




Заполнение строки символами до определённой длины

Решением является создание функции, функционально похожей на функцию Clipper:


 PadL(string, width, character)
 


 function TfrmFunc.PadL(cVal: string; nWide: integer; cChr: char): string;
 var
   i1, nStart: integer;
 begin
   if length(cVal) < nWide then
   begin
     nStart:=length(cVal);
     for i1:=nStart to nWide-1 do
       cVal:=cChar+cVal;
   end;
   PadL:=cVal;
 end;
 

Затем это может вызываться c любой строкой, которой вы хотите задать определенную длину. Пользуйтесь функцией также, как вы привыкли пользоваться прежней - PadL(A,length(B),'0'); Она имеет большую гибкость - возможно заполнение любым символом до необходимой длины (удобно для задания текстовых счетчиков с фиксированным количеством символов -- PadL(A,6,'0').




Заполнение TDBComboBox


 procedure TForm1.FormCreate(Sender: TObject);
 begin
   with table2 do
   begin
     open;
     while not EOF do
     begin
       DBlistbox1.items.add(FieldByName('name').AsString);
       next;
     end;
   end;
 end;
 




Фильтрованный поиск в строке

Автор: David Stidolph

Есть множество задач, где необходимо использование так называемой "дикой карты", то есть поиск в строке по фильтру, когда в качестве поиска используется подстрока с символом "*" (звездочка). Например, если необходимо выяснить наличие подстроки 'St' с какими-либо символами перед ней, то в качестве параметра для поиска задается подстрока вида '*St'. Звездочка может присутствовать как в начале/конце подстроки, так и по обеим ее сторонам. Также при составлении фильтра вместо любого одиночного символа возможна подстановка знака вопроса.

Пока функция может только сообщать о наличии необходимых вложений, но было бы интересно получить ваши примеры, которые могли бы и возвращать искомую подстроку.


 {
 Данная функция осуществляет сравнение двух строк. Первая строка
 может быть любой, но она не должна содержать символов соответствия (* и ?).
 Строка поиска (искомый образ) может содержать абсолютно любые символы.
 Для примера: MatchStrings('David Stidolph','*St*') возвратит True.
 
 Автор оригинального C-кода Sean Stanley
 Автор портации на Delphi David Stidolph
 }
 
 function MatchStrings(source, pattern: string): Boolean;
 var
   pSource: array[0..255] of Char;
   pPattern: array[0..255] of Char;
 
   function MatchPattern(element, pattern: PChar): Boolean;
 
     function IsPatternWild(pattern: PChar): Boolean;
     var
       t: Integer;
     begin
       Result := StrScan(pattern, '*') <> nil;
       if not Result then
         Result := StrScan(pattern, '?') <> nil;
     end;
 
   begin
     if 0 = StrComp(pattern, '*') then
       Result := True
     else if (element^ = Chr(0)) and (pattern^ <> Chr(0)) then
       Result := False
     else if element^ = Chr(0) then
       Result := True
     else
     begin
       case pattern^ of
         '*': if MatchPattern(element, @pattern[1]) then
             Result := True
           else
             Result := MatchPattern(@element[1], pattern);
         '?': Result := MatchPattern(@element[1], @pattern[1]);
       else
         if element^ = pattern^ then
           Result := MatchPattern(@element[1], @pattern[1])
         else
           Result := False;
       end;
     end;
   end;
 
 begin
   StrPCopy(pSource, source);
   StrPCopy(pPattern, pattern);
   Result := MatchPattern(pSource, pPattern);
 end;
 




Как добиться верной работы фильтра на запросах и на неиндексированных таблицах

Автор: Nomadic

(Т.е. при работе программы наблюдалась следующая картина: в результате очередной фильтрации оставалось видно 4 записи из восьми. Добавляем букву к фильтру, остается, допустим, две. Убираем букву, которую только что добавили, в гриде все равно видно только две записи)

Эта проблема была в Delphi 3.0 только на TQuery, а в Delphi 3.01 появилась и в TTable. Лечится так (простой пример):


 procedure TMainForm.Edit1Change(Sender: TObject);
 begin
   if length(Edit1.Text) > 0 then
   begin
     Table1.Filtered := TRUE;
     UpdateFilter(Table1);
   end
   else
     Table1.Filtered := FALSE;
 end;
 
 procedure TMainForm.UpdateFilter(DataSet: TDataSet);
 var
   FR: TFilterRecordEvent;
 begin
   with DataSet do
   begin
     FR := OnFilterRecord;
     if Assigned(FR) and Active then
     begin
       DisableControls;
       try
         OnFilterRecord := nil;
         OnFilterRecord := FR;
       finally
         EnableControls;
       end;
     end;
   end;
 end;
 




Функция наполнения строки


 function Spcs(num : byte) : string;
 var
   tmp : string;
 begin
   fillchar(tmp, num+1, ' ');  {инициализация всей строки пробелами}
   tmp[0] := chr(num);         {устанавливаем длину строки с пробелами}
   result := tmp;
 end;
 

Теперь достаточно написать


 Edit1.Text := SurName + spcs(10) + FirstName
 




FindKey для нескольких полей


 with Table1 do
 begin
 SetKey;
 FieldByName('State').AsString := 'CA';
 FieldByName('City').AsString := 'Scotts Valley';
 GotoKey;
 end;
 

Вы не можете использовать Findkey с файлами DBase более чем для одного поля.


 oEmetb.indexName:='PrimaryKey';
 if oEmeTb.findkey([prCLient,prDiv,prEme])then
 

где findkey передаются параметры для Primary Keyfields.

Я обращаю ваше внимание на то, что имя индекса (Index) чувствительно к регистру, так что будьте внимательны.

Вы можете также воспользоваться oEmeTb.indexfieldnames, но убедитесь в том, что ваш список ключевых полей в точности соответствуют ключевым полям, которые вы ищете.


 oEmetb.indexfieldNames:='EmeClient;EmeDiv;EmeNo';
 if oEmeTb.findkey([123,'A',96])then
 




Как найти все компьютеры в рабочей группе

Я пришел к тебе с дискетой - рассказать, что сеть упала.


 var
   Computer: array [1..500] of string[25];
   ComputerCount: Integer;
 
 procedure FindAllComputers(Workgroup: string);
 var
   EnumHandle: THandle;
   WorkgroupRS: TNetResource;
   Buf: array [1..500] of TNetResource;
   BufSize: Integer;
   Entries: Integer;
   Result: Integer;
 begin
   ComputerCount := 0;
   Workgroup := Workgroup + #0;
   FillChar(WorkgroupRS, SizeOf(WorkgroupRS) , 0);
   with WorkgroupRS do
   begin
     dwScope := 2;
     dwType := 3;
     dwDisplayType := 1;
     dwUsage := 2;
     lpRemoteName := @Workgroup[1];
   end;
 
   WNetOpenEnum(RESOURCE_GLOBALNET, RESOURCETYPE_ANY, 0, @WorkgroupRS, EnumHandle);
 
   repeat
     Entries := 1;
     BufSize := SizeOf(Buf);
 
     Result := WNetEnumResource(EnumHandle, Entries, @Buf, BufSize);
     if (Result = NO_ERROR) and (Entries = 1) then
     begin
       Inc( ComputerCount );
       Computer[ ComputerCount ] := StrPas(Buf[1].lpRemoteName);
     end;
   until
     (Entries <> 1) or (Result <> NO_ERROR);
 
   WNetCloseEnum( EnumHandle );
 end;
 




Найти и подсветить текст в WEBBrowser

Недавно ученые создали холодильник с возможностью доступа в Интернет для заказа продуктов, но проклятая железяка лазает исключительно по порносайтам и заказывает только огурцы и бананы.


 {....}
 
   private
     procedure SearchAndHighlightText(aText: string);
 
 {....}
 
 procedure TForm1.SearchAndHighlightText(aText: string);
 var
   i: Integer;
 begin
   for i := 0 to WebBrowser1.OleObject.Document.All.Length - 1 do
   begin
     if Pos(aText, WebBrowser1.OleObject.Document.All.Item(i).InnerText) <> 0 then
     begin
       WebBrowser1.OleObject.Document.All.Item(i).Style.Color := '#FFFF00';
       WebBrowser1.OleObject.Document.All.Item(i).ScrollIntoView(True);
     end;
   end;
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   SearchAndHighlightText('some text...');
 end;
 




Поиск существующей записи перед тем, как она будет вставлена

Если вы находитесь в режиме редактирования (Edit) или вставки (Insert), то при изменении режима вы автоматически делаете постинг записи. И, естественно, при наличие дубликата (неуникальности) записи, вы получите ошибку. Способ обойти это - использовать другой компонент TTable, связанный с той же таблицей, и осуществляющий по ней поиск. Этот путь самый простой и эффективный.

Воспользуйтесь двумя компонентами TTable (оба должны указывать на одну и ту же таблицу). Используйте один для поиска, а второй для редактирования.

Ваша "ключевая" таблица BDE будет автоматически генерировать исключения, если пользователь будет пытаться послать созданный им дублирующий ключ. Для установки таблицы используйте Database Desktop.

Создайте на основе поля первичный индекс (Primary Index). Затем создайте какой-то обработчик DB-исключения для нашего "нарушения уникальности".

Моя технология заключается в следующем: в отдельной форме я предлагаю пользователям ввести часть записи, которая должна быть уникальна (обычно одно поле). Затем для проверки существования я делал FindKey. Если он находился, через MessageDlg я информировал пользователя, и возвращал его на форму редактирования, не создавая новой записи. Помните, что если FindKey ничего не находит, dbCursor никуда не перемещается, и закладка не нужна. Если запись найдена, она немедленно будет отображена на форме редактирования для того, чтобы пользователь смог увидеть ее содержимое. В противном случае происходит следующее:


 Table.Append;
 Table.FieldByName('KeyField').AsString := UserEntry;
 { ... позволяем пользователю редактировать все остальные поля записи ... }
 { в это время кнопка Cancel должна быть активной для того, чтобы
 дать возможность пользователю отменить ввод новой записи. }
 

В моей форме редактирования поле с уникальном ключем выключается (disabled) и показывается с другим цветом. Целостность соблюдена :-).




Найти все линки в WEBBrowser

Депрессия - это когда включаешь интернет и не знаешь куда пойти.


 procedure TForm1.Button1Click(Sender: TObject);
 var
   i: Integer;
 begin
   for i := 0 to Webbrowser1.OleObject.Document.links.Length - 1 do
     Listbox1.Items.Add(Webbrowser1.OleObject.Document.Links.Item(i));
 end;
 




Поиск на винчестере

Я ищу метод или компонент, производящий поиск каких-либо файлов на винчестере, например, (*.exe)...


 unit Audit1;
 interface
 
 uses windos;
 
 var
   dest: string;
 
 procedure dorecurse(dir: string);
 
 implementation
 {$R *.DFM}
 
 procedure Process(dir: string; Searchrec: tsearchrec);
 begin
   showmessage(Searchrec.name);
   case Searchrec.attr of
     $10:
       if (searchrec.name <> '.') and (searchrec.name <> '..') then
       begin
         dorecurse(dir + '\' + searchrec.name);
         writeln(dir);
       end;
   end;
 end;
 
 procedure Dorecurse(dir: string);
 var
   Searchrec: Tsearchrec;
   pc: array[0..79] of Char;
 begin
   StrPCopy(pc, dir + '\*.*');
   FindFirst(pc, FaAnyfile, SearchRec);
   Process(dir, SearchRec);
   while FindNext(SearchRec) <> -18 do
   begin
     Process(dir, SearchRec);
   end;
 end;
 
 procedure startsearch;
 begin
   dorecurse(paramstr(1));
 end;
 
 begin
   startsearch;
 end.
 




Определение окончания работы другого приложения

WinExec сразу после запуска приложения возвращает его дескриптор. Для определения завершения программы вы должны вызывать функцию GetModuleUsage(InstanceID), где InstanceID - дескриптор запущенного функцией WinExec приложения. Если возвращаемый результат содержит ноль, приложение завершило свою работу. Сделайте проверку в таймерном цикле и задача решена.




Каким образом, программным путем, можно узнать о завершении запущенной программы

Тяжелое детство. Все игрушки сплошной софт.

16-битная версия:


 uses Wintypes, WinProcs, Toolhelp, Classes, Forms;
 
 function WinExecAndWait(Path: string; Visibility: word): word;
 var
   InstanceID: THandle;
   PathLen: integer;
 begin
   { Преобразуем строку в тип PChar }
 
   PathLen := Length(Path);
   Move(Path[1], Path[0], PathLen);
   Path[PathLen] := #00;
   { Пытаемся запустить приложение }
 
   InstanceID := WinExec(@Path, Visibility);
   if InstanceID < 32 then { значение меньше 32 указывает на ошибку приложения }
     WinExecAndWait := InstanceID
 
   else
   begin
     repeat
       Application.ProcessMessages;
     until Application.Terminated or (GetModuleUsage(InstanceID) = 0);
     WinExecAndWait := 32;
   end;
 end;
 

32-битная версия:


 function WinExecAndWait32(FileName: string; Visibility: integer): integer;
 var
   zAppName: array[0..512] of char;
   zCurDir: array[0..255] of char;
   WorkDir: string;
   StartupInfo: TStartupInfo;
   ProcessInfo: TProcessInformation;
 begin
   StrPCopy(zAppName, FileName);
   GetDir(0, WorkDir);
   StrPCopy(zCurDir, WorkDir);
   FillChar(StartupInfo, Sizeof(StartupInfo), #0);
   StartupInfo.cb := Sizeof(StartupInfo);
 
   StartupInfo.dwFlags := STARTF_USESHOWWINDOW;
   StartupInfo.wShowWindow := Visibility;
   if not CreateProcess(nil,
     zAppName, { указатель командной строки }
     nil, { указатель на процесс атрибутов безопасности }
     nil, { указатель на поток атрибутов безопасности }
     false, { флаг родительского обработчика }
     CREATE_NEW_CONSOLE or { флаг создания }
     NORMAL_PRIORITY_CLASS,
     nil, { указатель на новую среду процесса }
     nil, { указатель на имя текущей директории }
     StartupInfo, { указатель на STARTUPINFO }
     ProcessInfo) then
     Result := -1 { указатель на PROCESS_INF }
 
   else
   begin
     WaitforSingleObject(ProcessInfo.hProcess, INFINITE);
     GetExitCodeProcess(ProcessInfo.hProcess, Result);
   end;
 end;
 

Дополнение

Письмо от читателя:

Очень помог совет из API\Разное: "Каким образом, программным путем, можно узнать о завершении запущенной программы?". Однако хочется внести резонное исправление: вместо


 WaitforSingleObject(ProcessInfo.hProcess,INFINITE);
 

лучше написать:


 while WaitforSingleObject(ProcessInfo.hProcess,200)=WAIT_TIMEOUT do
   Repaint;
 

Смысл замены прост: в первом варианте главное окно ждёт завершения вызванного сообщения, не обрабатывая при этом никаких событий. Вследствие этого главное окно даже не перерисовывается, что выглядит очень некрасиво. Второй вариант исправляет этот недостаток.

Автор: Pavel Trubachёv




Видеть подсказки все время, пока поле редактирования имеет фокус

Автор: Ed Jordan

На TabbedNotebook у меня есть множество компонентов TEdit. Я изменяю цвет компонентов TEdit на желтый и назначаю свойству Hint компонента строчку предупреждения, если поле редактирования содержит неверные данные.

Поведение окна со всплывающей подсказкой (hintwindow) позволяет делать его видимым только тогда, когда курсор мыши находится в области элемента управления. Но мой заказчик хочет видеть подсказки все время, пока поле редактирования имеет фокус.

Я не знаю как изменить поведение всплывающей подсказки, заданное по умолчанию. Я знаю что это возможно, но кто мне подскажет как?

Ниже приведен модуль, содержащий новый тип hintwindow, TFocusHintWindow. Когда вы "просите" TFocusHintWindow появиться, он появляется ниже элемента управления, имеющего фокус. Для показа и скрытия достаточно следующих команд:


 FocusHintWindow.Showing := True;
 FocusHintWindow.Showing := False;
 

Пример того, как это можно использовать, содержится в комментариях к модулю. Это просто.


 unit FHintWin;
 
 { -----------------------------------------------------------
 
 TFocusHintWindow --
 
 Вот пример того, как можно использовать TFocusHintWindow.
 Данный пример выводит всплывающую подсказку ниже любого
 TEdit, имеющего фокус. В противном случае выводится
 стандартная подсказка Windows.
 
 unit Unit1;
 interface
 uses
 SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics,
 Controls, Forms, Dialogs, StdCtrls, FHintWin;
 
 type
 TForm1 = class(TForm)
 procedure FormCreate(Sender: TObject);
 private
 FocusHintWindow: TFocusHintWindow;
 procedure AppIdle( Sender: TObject; var Done: Boolean );
 procedure AppShowHint( var HintStr: string;
 var CanShow: Boolean; var HintInfo: THintInfo );
 end;
 
 implementation
 
 procedure TForm1.FormCreate( Sender: TObject );
 begin
 Application.OnIdle := AppIdle;
 Application.OnShowHint := AppShowHint;
 FocusHintWindow := TFocusHintWindow.Create( Self );
 end;
 
 procedure TForm1.AppIdle(Sender: TObject; var Done: Boolean);
 begin
 FocusHintWindow.Showing := Screen.ActiveControl is TEdit;
 end;
 
 procedure TForm1.AppShowHint( var HintStr: string;
 var CanShow: Boolean; var HintInfo: THintInfo );
 begin
 CanShow := not FocusHintWindow.Showing;
 end;
 
 end.
 ----------------------------------------------------------- }
 
 interface
 
 uses SysUtils, WinTypes, WinProcs, Classes, Controls, Forms;
 
 type
   TFocusHintWindow = class(THintWindow)
   private
     FShowing: Boolean;
     HintControl: TControl;
   protected
     procedure SetShowing(Value: Boolean);
     function CalcHintRect(Hint: string): TRect;
     procedure Appear;
     procedure Disappear;
   public
     property Showing: Boolean read FShowing write SetShowing;
   end;
 
 implementation
 
 function TFocusHintWindow.CalcHintRect(Hint: string): TRect;
 var
   Buffer: array[Byte] of Char;
 begin
   Result := Bounds(0, 0, Screen.Width, 0);
   DrawText(Canvas.Handle, StrPCopy(Buffer, Hint), -1, Result,
     DT_CALCRECT or DT_LEFT or DT_WORDBREAK or DT_NOPREFIX);
 
   with HintControl, ClientOrigin do
     OffsetRect(Result, X, Y + Height + 6);
   Inc(Result.Right, 6);
   Inc(Result.Bottom, 2);
 end;
 
 procedure TFocusHintWindow.Appear;
 var
   Hint: string;
   HintRect: TRect;
 begin
   if (Screen.ActiveControl = HintControl) then
     Exit;
 
   HintControl := Screen.ActiveControl;
   Hint := GetShortHint(HintControl.Hint);
   HintRect := CalcHintRect(Hint);
   ActivateHint(HintRect, Hint);
   FShowing := True;
 end;
 
 procedure TFocusHintWindow.Disappear;
 begin
   HintControl := nil;
   ShowWindow(Handle, SW_HIDE);
   FShowing := False;
 end;
 
 procedure TFocusHintWindow.SetShowing(Value: Boolean);
 begin
   if Value then
     Appear
   else
     Disappear;
 end;
 
 end.
 




Как определить работает ли уже данное приложение или это его первая копия

Сидит программист в столовой, обедает, суп ест. В очках такой, задумчивый, программу думает. Народу никого, все уже поели, ушли. Подходит к нему официантка и заигрывает:
- Если Вы хотите хорошо провести время, то меня зовут Маша!
Программист медленно возвращается на землю и смотрит на официантку отрешенным взглядом и на автопилоте спрашивает:
- А если не хочу, то как Вас зовут?!

Каждый экземпляр программы имеет ссылку на свою предыдущую копию - hPrevInst: hWnd. Ее можно проверить перед созданием приложения и при необходимости отреагировать соответствующим образом. Если запущена только одна копия, то эта ссылка равна нулю. Только для Delphi 1. Пример использования hPrevInst:


 procedure TForm1.FormCreate(Sender: TObject);
 begin
   // Проверяем есть ли указатель на предыдущую копию приложения
   if hPrevInst <> 0 then begin
     // Если есть, то выдаем сообщение и выходим
     MessageDlg('Программа уже запущена!', mtError, [mbOk], 0);
     Application.Terminate;
   end;
   // Иначе - ничего не делаем (не мешаем созданию формы)
 end;
 

Другой способ - по списку загруженных приложений


 procedure TForm1.FormCreate(Sender: TObject);
 var
   Wnd : hWnd;
   buff : array[0.. 127] of Char;
 begin
   //Получили указатель на первое окно
   Wnd := GetWindow(Handle, gw_HWndFirst);
   // Поиск
   while Wnd <> 0 do begin
     // Это окно предыдущей копии ?
     if (Wnd <> Application.Handle) and (GetWindow(Wnd, gw_Owner) = 0) then
     begin
       GetWindowText (Wnd, buff, sizeof (buff ));
       if StrPas (buff) = Application.Title then
       begin
         MessageDlg('Приложение уже загружено', mtWarning, [mbOk], 0);
         Halt;
       end;
     end;
     Wnd := GetWindow (Wnd, gw_hWndNext);
   end;
 end;
 

Данный пример не всегда применим - часто заголовок приложения меняется при каждом старте, поэтому рассмотрим более надежный способ - через FileMapping

Дело в том, что можно в памяти создавать временные файлы. При перезагрузке они теряются, а так существуют. Кстати, этот метод можно использовать и для обмена информацией между вашими приложениями. Пример с использованием FileMapping:


 program Project1;
 uses
   Windows, // Обязательно
   Forms,
   Unit1 in 'Unit1.pas' {Form1};
 
 {$R *.RES}
 const
   MemFileSize = 1024;
   MemFileName = 'one_inst_demo_memfile';
 var
   MemHnd : HWND;
 begin
   // Попытаемся создать файл в памяти
   MemHnd := CreateFileMapping(HWND($FFFFFFFF),
     nil, PAGE_READWRITE, 0, MemFileSize, MemFileName);
   // Если файл не существовал запускаем приложение
   if GetLastError<>ERROR_ALREADY_EXISTS then
   begin
     Application.Initialize;
     Application.CreateForm(TForm1, Form1);
     Application.Run;
   end;
   CloseHandle(MemHnd);
 end.
 

Часто при работе у пользователя может быть открыто 5-20 окон и сообщение о том, что программа уже запущено приводит к тому, что он вынужден полчаса искать ранее запущенную копию. Выход из положения - найдя копию программы активировать ее, для чего в последнем примере перед HALT необходимо добавить строку : SetForegroundWindow(Wnd);

Пример:


 program Project0;
 uses
   Windows, // !!!
   Forms,
   Unit0 in 'Unit0.pas' {Form1};
 
 var
   Handle1 : LongInt;
   Handle2 : LongInt;
 
 {$R *.RES}
 
 begin
   Application.Initialize;
   Handle1 := FindWindow('TForm1',nil);
   if handle1 = 0 then
   begin
     Application.CreateForm(TForm1, Form1);
     Application.Run;
   end
   else
   begin
     Handle2 := GetWindow(Handle1,GW_OWNER);
     //Чтоб заметили :)
     ShowWindow(Handle2,SW_HIDE); ShowWindow(Handle2,SW_RESTORE);
     SetForegroundWindow(Handle1); // Активизируем
   end;
 end.
 

Блокировка запуска второй копии при помощи Mutex На мой взгляд, это один из самых простых и надежных способов.


 procedure TForm1.FormCreate(Sender: TObject);
 var
   hMutex : THandle;
 begin
   hMutex := CreateMutex(0, true , 'My application name');
   if GetLastError = ERROR_ALREADY_EXISTS then
   begin
     CloseHandle(hMutex);
     Application.Terminate;
   end;
 end;
 

В данном примере при старте приложения создается мьютекс с некоторым уникальным именем (у каждого приложения оно должно бять свое !!). Если хоть одна копия приложения запущена, то в системе уже будет мьютекс с таким именем и возникнет ошибка ERROR_ALREADY_EXISTS. В противном случае мьютекс создается и существует, пока работает данная копия приложения Задать вопрос




Показать вторую форму, а заголовок первой оставить активным


 procedure TForm2.FormActivate(Sender: TObject);
 begin
   SendMessage(Application.MainForm.Handle, WM_NCACTIVATE, Boolean(True), 0);
 end;
 




Перевод в верхний регистр первого вводимого символа

Сокращенное название Международной Ассоциации Старых Дев - "Интер-НЕТ!"


 procedure TForm1.DBEdit1KeyPress(Sender: TObject; var Key: Char);
 begin
   if (DBEdit1.SelStart = 0) then
     Key := upCase(Key);
 end;
 

Или для Edit:


 procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char);
 begin
   with Sender as TEdit do
     if (Text = '') or (Text[SelStart] = ' ')
       or (SelLength = Length(Text)) then
         if Key in ['a'..'z'] then
           Key := UpCase(Key);
 end;
 




Как зафиксировать один или несколько столбцов в TDBGrid



Отоpвался дyмеp от компа, вышел на yлицy, а пpямо на него камаз пpет.
- А, фигня, я ж записался!


 procedure TForm1.FormCreate(Sender: TObject);
 begin
   TDrawGrid(DBGrid1).FixedCols := 2;
 end;
 




Как зафиксировать один или несколько столбцов в TDBGrid 2

Автор: Nomadic

Звонит программер своей девушке в дверь, а она не открывает.
- Неустранимая ошибка по адресу Lenin st. 10/5/44 второй этаж, - подумал программер.

Это маленькая вставка в Ваш наследник от TCustomDBGrid, которая решает данную задачу.


 // DBGRIDEX.PAS
 // ----------------------------------------------------------------------------
 
 destructor TDbGridEx.Destroy;
 begin
 
   _HideColumnsValues.Free;
   _HideColumns.Free;
 
   inherited Destroy;
 end;
 
 // ----------------------------------------------------------------------------
 
 constructor TDbGridEx.Create(Component: TComponent);
 begin
 
   inherited Create(Component);
 
   FFreezeCols := ?;
 
   _HideColumnsValues := TList.Create;
   _HideColumns := TList.Create;
 end;
 
 // ----------------------------------------------------------------------------
 
 procedure TDbGridEx.KeyDown(var Key: Word; Shift: TShiftState);
 begin
 
   if (Key = VK_LEFT) then
     ColBeforeEnter(-1);
   if (Key = VK_RIGHT) then
     ColBeforeEnter(1);
 
   inherited;
 end;
 
 // ----------------------------------------------------------------------------
 
 procedure TDbGridEx.SetFreezeColor(AColor: TColor);
 begin
 
   InvalidateRow(0);
 end;
 
 // ----------------------------------------------------------------------------
 
 procedure TDbGridEx.SetFreezeCols(AFreezeCols: Integer);
 begin
 
   FFreezeCols := AFreezeCols;
   InvalidateRow(0);
 end;
 
 // ----------------------------------------------------------------------------
 
 procedure TDbGridEx.ColEnter;
 begin
 
   ColBeforeEnter(0);
 
   if Assigned(OnColEnter) then
     OnColEnter(Self);
 end;
 
 // ----------------------------------------------------------------------------
 
 procedure TDbGridEx.ColBeforeEnter(ADelta: Integer);
 var
 
   nIndex: Integer;
 
   function ReadWidth: Integer;
   var
 
     i: Integer;
 
   begin
 
     i := _HideColumns.IndexOf(Columns[nIndex]);
 
     if i = -1 then
       result := 120
     else
       result := Integer(_HideColumnsValues[i]);
   end;
 
   procedure SaveWidth;
   var
 
     i: Integer;
 
   begin
 
     i := _HideColumns.IndexOf(Columns[nIndex]);
     if i <> -1 then
     begin
       _HideColumnsValues[i] := Pointer(Columns[nIndex].Width);
     end
     else
     begin
       _HideColumns.Add(Columns[nIndex]);
       _HideColumnsValues.Add(Pointer(Columns[nIndex].Width));
     end;
   end;
 
 begin
 
   for nIndex := 0 to Columns.Count - 1 do
   begin
     if (Columns[nIndex].Width = 0) then
     begin
       if (nIndex + 1 <= FreezeCols) or (nIndex >= SelectedIndex + ADelta) then
         Columns[nIndex].Width := ReadWidth;
     end
     else
     begin
       SaveWidth;
       if (nIndex + 1 > FreezeCols) and
         (nIndex < SelectedIndex + ADelta) and
         (nIndex + 1 < Columns.Count) and
         (FreezeCols > 0) then
         Columns[nIndex].Width := 0;
     end;
   end;
 end;
 




Как сделать WebBrowser плоским вместо 3D

Автор: Donovan J. Edye

Приходит 3d художник на собеседование в компанию по созданию компьютерных игр Шеф - за неделю нарисуйте какого нибудь монстра для нашей игры... Чисто на пробу, посмотреть на что вы способны.
- Не могли бы вы повернуться, чтобы я увидел вас со всех сторон, пожалуйста?

Следующий пример устанавливает borderStyle:


 procedure TForm1.WBDocumentComplete(Sender: TObject;
 const pDisp: IDispatch; var URL: OleVariant);
 var
   Doc : IHTMLDocument2;
   Element : IHTMLElement;
 begin
   Doc := IHTMLDocument2(TWebBrowser(Sender).Document);
   if Doc = nil then
     Exit;
   Element := Doc.body;
   if Element = nil then
     Exit;
   case Make_Flat of
     TRUE : Element.style.borderStyle := 'none';
     FALSE : Element.style.borderStyle := '';
   end;
 end;
 




Плавающая палитра

На самоме деле для создания плавающей (floating) палитры вы можете использовать вышу форму. Хитрость заключается в том, чтобы убедиться, что окно палитры всегда появляется на "переднем плане" основного окна, а не сверху всех других окон. Этот эффект может быть достигнут перекрытием метода CreateParams вашей формы. Для примера,


 procedure TForm2.CreateParams( var Params: TCreateParams );
 begin
   inherited CreateParams( Params );
   with Params do
   begin
     Style := Style or ws_Overlapped;
     WndParent := Form1.Handle;
   end;
 end;
 




Сделать плавающую панель

Так называемая "плавающая панель" используется обычно для панелей инструментов.

Текст в модуле с основной формой:


 procedure TForm1.FormShow(Sender: TObject);
 begin
   Form2.Show;
 end;
 

Текст в модуле с "плавающей" панелью:


 private
   procedure CreateParams(var Params: TCreateParams); override;
   ...
   procedure TForm2.CreateParams(var Params: TCreateParams);
 
 begin
   inherited;
   with Params do
   begin
     Style := Style or WS_OVERLAPPED;
     WndParent := Form1.Handle;
   end;
 end;
 




Плавающие панельки

Кто-нибудь пробовал создать форму, подобную "отстегивающимся" панелькам (FreeDoc)? Я попробовал и вот что получилось...

Код требует использования некоторых функций WinAPI. Описание всех WinAPI функций доступны при нажатии F1 (электронная справка)...

Ну а теперь попробуем это создать (весь код занимает около 100 строчек)...

Ход работы:

Стартуйте новый проект, задайте свойству borderstyle формы значение bsNone, добавьте панель, установите у нее свойство borderstyle равным значению bsSingle, добавьте другую панель с любым заголовком, добавьте кнопку с подсказкой 'переключатель панели заголовка', вырежьте из данного совера код и вставьте его в модуль, создайте обработчики трех событий панелей (MouseDown, MouseMove, MouseUp) и один обработчик кнопки (Click). Надеюсь, что ничего не забыл... ;-) Быстрее сделать это в Delphi, чем написать здесь... ;-)


 unit Unit1;
 
 interface
 
 uses
   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
   Forms, Dialogs, ExtCtrls, StdCtrls;
 
 type
   TForm1 = class(TForm)
     Panel1: TPanel;
     Panel2: TPanel;
     Button1: TButton;
     procedure Panel1MouseDown(Sender: TObject; Button: TMouseButton;
       Shift: TShiftState; X, Y: Integer);
     procedure Panel1MouseMove(Sender: TObject; Shift: TShiftState; X,
       Y: Integer);
     procedure Panel1MouseUp(Sender: TObject; Button: TMouseButton;
       Shift: TShiftState; X, Y: Integer);
     procedure Button1Click(Sender: TObject);
   private
     { Private declarations }
     OldX,
       OldY,
       OldLeft,
       OldTop: Integer;
     ScreenDC: HDC;
     MoveRect: TRect;
     Moving: Boolean;
   public
     { Public declarations }
   end;
 
 var
 
   Form1: TForm1;
 
 implementation
 
 {$R *.DFM}
 
 procedure TForm1.Panel1MouseDown(Sender: TObject; Button: TMouseButton;
 
   Shift: TShiftState; X, Y: Integer);
 begin
 
   if Button = mbLeft then
   begin
     SetCapture(Panel1.Handle);
     ScreenDC := GetDC(0);
     OldX := X;
     OldY := Y;
     OldLeft := X;
     OldTop := Y;
     MoveRect := BoundsRect;
     DrawFocusRect(ScreenDC, MoveRect);
     Moving := True;
   end;
 end;
 
 procedure TForm1.Panel1MouseMove(Sender: TObject; Shift: TShiftState; X,
 
   Y: Integer);
 begin
 
   if Moving then
   begin
     DrawFocusRect(ScreenDC, MoveRect);
     OldX := X;
     OldY := Y;
     MoveRect := Rect(Left + OldX - OldLeft, Top + OldY - OldTop,
       Left + Width + OldX - OldLeft, Top + Height + OldY - OldTop);
     DrawFocusRect(ScreenDC, MoveRect);
   end;
 end;
 
 procedure TForm1.Panel1MouseUp(Sender: TObject; Button: TMouseButton;
 
   Shift: TShiftState; X, Y: Integer);
 begin
 
   if Button = mbLeft then
   begin
     ReleaseCapture;
     DrawFocusRect(ScreenDC, MoveRect);
     Left := Left + X - OldLeft;
     Top := Top + Y - OldTop;
     ReleaseDC(0, ScreenDC);
     Moving := False;
   end;
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
 
   TitleHeight,
     BorderWidth,
     BorderHeight: Integer;
 begin
 
   TitleHeight := GetSystemMetrics(SM_CYCAPTION);
   BorderWidth := GetSystemMetrics(SM_CXBORDER) + GetSystemMetrics(SM_CXFRAME) -
     1;
   BorderHeight := GetSystemMetrics(SM_CYBORDER) + GetSystemMetrics(SM_CYFRAME) -
     2;
   if BorderStyle = bsNone then
   begin
     BorderStyle := bsSizeable;
     Top := Top - TitleHeight - BorderHeight;
     Height := Height + TitleHeight + 2 * BorderHeight;
     Left := Left - BorderWidth;
     Width := Width + 2 * BorderWidth;
   end
   else
   begin
     BorderStyle := bsNone;
     Top := Top + TitleHeight + BorderHeight;
     Height := Height - TitleHeight - 2 * BorderHeight;
     Left := Left + BorderWidth;
     Width := Width - 2 * BorderWidth;
   end;
 end;
 
 end.
 

Коментарии

У меня есть один коментарий отностительно вышеприведенного кода: данная реализация сложней, чем она должна была быть. Все, что вы должны сделать - это обработать системное сообщение wm_NCHitTest. Я приведу здесь код, который я создал для Borland Tech Info, и который выполняет ту же функцию:


 unit Dragmain;
 
 interface
 
 uses
   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
   Forms, Dialogs, StdCtrls;
 
 type
   TForm1 = class(TForm)
     Button1: TButton;
     procedure Button1Click(Sender: TObject);
   private
     procedure WMNCHitTest(var M: TWMNCHitTest); message wm_NCHitTest;
   end;
 
 var
 
   Form1: TForm1;
 
 implementation
 
 {$R *.DFM}
 
 procedure TForm1.WMNCHitTest(var M: TWMNCHitTest);
 begin
 
   inherited; { вызвали наследованный дескриптор сообщения, }
   if M.Result = htClient then { кликнув в области окна?                     }
     M.Result := htCaption; { если так, то мы заставили Windows думать,   }
   { что это область заголовка.                  }
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   Close;
 end;
 
 end.
 




Функция представления чисел с плавающей точкой и нужным числом разрядов

Автор: Alexandr Kordyum

Функция представления чисел с плавающей точкой и нужным числом разрядов. Пример: Conv(2.005,2) возвращает 2.01; Conv(2.5,0) возвращает 3


 function Conv(cs: double; numb: integer): double;
 var
   db, db1, db2: double;
   i: int64;
   ii, ink, i1: integer;
   st: string;
 begin
   db:=cs-int(cs);
   ink:=1;
   for ii:=1 to numb do
     ink:=ink*10;
   db1:=db*ink;
   db2:=cs*ink*100;
   i:=trunc(int(db2)/100);
   i1:=trunc(db2-i*100);
   if i1>49 then
     inc(i);
   result:=i/ink;
 end;
 




Как заставить мигать кнопку программы на панели задач



 procedure TForm1.Timer1Timer(Sender: TObject);
 begin
   FlashWindow(Application.Handle, True);
 end;
 




Вылет окна


Лена: А у нас вчера под окнами HЛО висело... Хакер(злобно, не отрываясь от компьютера): -Кто ж его под "окнами" ставит, надо было под LINUX, тагда б не зависло...

Если Вы хотите ввести в изумление пользователя с первых минут его использования Вашего приложения, тогда самый верный способ - заставить окно “вылететь”, а не появиться обычным способом! Сделать это довольно легко, надо только описать два события: OnShow (на появление формы) и OnClose (на закрытие формы)Выглядеть это будет так:


 procedure TForm1.FormShow(Sender: TObject);
 var
   RectSmall, RectNormal: TRect;
 begin
   RectSmall := Rect(0, 0, 0, 0);
   RectNormal := Form1.BoundsRect;
   DrawAnimatedRects(GetDesktopWindow, IDANI_CAPTION, RectSmall, RectNormal);
 end;
 
 procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
 var
   RectSmall, RectNormal: TRect;
 begin
   RectSmall := Rect(0, 0, 0, 0);
   RectNormal := Form1.BoundsRect;
   DrawAnimatedRects(GetDesktopWindow, IDANI_CAPTION, RectNormal, RectSmall);
 end;
 

Мы объявляем две переменные класса TRect (От англ. Rectangle - прямоугольник ). Называем их, например RectSmall и RectNormal. Для RectSmall мы задаём нули: (0,0,0,0), тем самым указав начало координат, т.е. левый верхний угол экрана. В RectNormal помещаем рамку формы с помощью функции BoundsRect. Функция DrawAnimatedRects создаёт перетекание начальной рамки в конечную. В событии OnShow мы из маленькой рамки делаем большую – окно вылетает, а в событии OnClose большая рамка перетекает в маленькую – окно улетает!




Управление настройками шрифта


 {
 Данный код изменяет стиль шрифта поля редактирования,
 если оно выбрано. Может быть адаприрован для управления
 шрифтами в других объектах.
 
 Расположите на форме Edit(Edit1) и ListBox(ListBox1).
 Добавьте следующие элементы (Items) к ListBox:
 fsBold
 fsItalic
 fsUnderLine
 fsStrikeOut
 }
 
 procedure TForm1.ListBox1Click(Sender: TObject);
 var
   X: Integer;
 type
   TLookUpRec = record
     Name: string;
     Data: TFontStyle;
   end;
 const
   LookUpTable: array[1..4] of TLookUpRec =
   ((Name: 'fsBold'; Data: fsBold),
     (Name: 'fsItalic'; Data: fsItalic),
     (Name: 'fsUnderline'; Data: fsUnderline),
     (Name: 'fsStrikeOut'; Data: fsStrikeOut));
 begin
   X := ListBox1.ItemIndex;
   Edit1.Text := ListBox1.Items[X];
   Edit1.Font.Style := [LookUpTable[ListBox1.ItemIndex + 1].Data];
 end;
 




Сохранение параметров шрифта в INI-файле

Мое решение: (для сохранения всей иннформации об отдельном шрифте)


 function FontToStr(font: TFont): string;
   procedure yes(var str: string);
   begin
 
     str := str + 'y';
   end;
   procedure no(var str: string);
   begin
 
     str := str + 'n';
   end;
 begin
 
   {кодируем все атрибуты TFont в строку}
   Result := '';
   Result := Result + IntToStr(font.Color) + '|';
   Result := Result + IntToStr(font.Height) + '|';
   Result := Result + font.Name + '|';
   Result := Result + IntToStr(Ord(font.Pitch)) + '|';
   Result := Result + IntToStr(font.PixelsPerInch) + '|';
   Result := Result + IntToStr(font.size) + '|';
   if fsBold in font.style then
     yes(Result)
   else
     no(Result);
   if fsItalic in font.style then
     yes(Result)
   else
     no(Result);
   if fsUnderline in font.style then
     yes(Result)
   else
     no(Result);
   if fsStrikeout in font.style then
     yes(Result)
   else
     no(Result);
 end;
 
 procedure StrToFont(str: string; font: TFont);
 begin
 
   if str = '' then
     Exit;
   font.Color := StrToInt(tok('|', str));
   font.Height := StrToInt(tok('|', str));
   font.Name := tok('|', str);
   font.Pitch := TFontPitch(StrToInt(tok('|', str)));
   font.PixelsPerInch := StrToInt(tok('|', str));
   font.Size := StrToInt(tok('|', str));
   font.Style := [];
   if str[0] = 'y' then
     font.Style := font.Style + [fsBold];
   if str[1] = 'y' then
     font.Style := font.Style + [fsItalic];
   if str[2] = 'y' then
     font.Style := font.Style + [fsUnderline];
   if str[3] = 'y' then
     font.Style := font.Style + [fsStrikeout];
 end;
 
 function tok(sep: string; var s: string): string;
 
   function isoneof(c, s: string): Boolean;
   var
     iTmp: integer;
   begin
     Result := False;
     for iTmp := 1 to Length(s) do
     begin
       if c = Copy(s, iTmp, 1) then
       begin
         Result := True;
         Exit;
       end;
     end;
   end;
 var
 
   c, t: string;
 begin
 
   if s = '' then
   begin
     Result := s;
     Exit;
   end;
   c := Copy(s, 1, 1);
   while isoneof(c, sep) do
   begin
     s := Copy(s, 2, Length(s) - 1);
     c := Copy(s, 1, 1);
   end;
   t := '';
   while (not isoneof(c, sep)) and (s <> '') do
   begin
     t := t + c;
     s := Copy(s, 2, length(s) - 1);
     c := Copy(s, 1, 1);
   end;
   Result := t;
 end;
 

Если вы серьезно нуждаетесь в подобной технологии для сохранения свойств объектов, то я бы посоветовал вам создать наследника класса TIniFile, выполняющего подобные операции.




Включение шрифта как ресурс в EXE

Идет как-то Товарищ Комманд Ком по диску, смотрит по сторонам и удивляется: ветки у деревьев поломаны, файлы дефрагментированы, что не разберешь где какой, Командир Нортон в архив запихнут!!! Ну, пожалел его Комманд Ком, вытащил из архива и спрашивает:
- Кто ж это тебя так, бедненького?!!
А командир Нортон ему и отвечает:
- Какой ты, Товарищ Комманд Ком, добрый и заботливый... когда трезвый!!!

Включение шрифта в ваш EXE:

  • Используйте ваш любимый текстовый редактор, создайте *.rc файл, описывающий шрифт:

  •  MY_FONT ANYOL1 "Bauhs93.ttf"
     

    Первые два параметра могут быть любыми. Они будут использоваться в программе позже.

  • Затем для создания *.res файла используйте компилятор командной строки BRCC32.EXE, поставляемый с Delphi. Если ваш файл на этапе 1 был назван MyFont.rc, командная строка в сеансе DOS должна выглядеть так:

  •  BRCC32 MyFont
     

    Программа добавит в компилируемый файл созданный ресурс .rc и создаст файл с тем же именем, за исключением расширения, которое будет .res: MyFont.res

  • В вашей программе добавьте директиву компилятора, чтобы включить вновь созданный файл:

  •  {$R MyFont.res}
     

    Правильным будет разместить его в секции реализации после строчки {$R *.DFM}.

  • Добавьте процедуру создания файла из ресурса, делающим шрифт доступным для использования. Пример:

  •  procedure TForm1.FormCreate(Sender: TObject);
     var
     Res : TResourceStream;
     begin
     Res := TResourceStream.Create(hInstance, 'MY_FONT', Pchar('ANYOL1'));
     Res.SavetoFile('Bauhs93.ttf');
     Res.Free;
     AddFontResource(PChar('Bauhs93.ttf'));
     SendMessage(HWND_BROADCAST,WM_FONTCHANGE,0,0);
     end;
     

  • Теперь вы можете использовать данный шрифт в своем приложении:

  •  procedure TForm1.Button1Click(Sender: TObject);
     begin
     Button1.Font.Name := 'Bauhaus 93';
     end;
     

Предостережения:

Приведенный пример не предусматривает никакой проверки и защиты от возможных ошибок.

Обратите внимание - имя файла НЕ такое же, как имя шрифта. Это допускает, что вы знаете имя шрифта и имя его ttf-файла. Вы можете определить это, дважды щелкнув на файле в окне Проводника.

Я рекомендую устанавливать файл шрифта в папку C:\WINDOWS\FONTS. Его легче отыскать потом именно там.

Ваш вновь установленный шрифт может быть удален программным путем, естественно, в случае, когда он никем не используется:


 procedure TForm1.FormDestroy(Sender: TObject);
 begin
 RemoveFontResource(PChar("Bauhs93.ttf"))
 SendMessage(HWND_BROADCAST,WM_FONTCHANGE,0,0);
 end;
 

Для получения дополнительной справки по функциям AddFontResource и RemoveFontResource загляните в электронную справку по Win32.




Свойства шрифта Style и Color в виде строки

Автор: Dennis Passmore

Как мне получить значение Font.Style и Font.Color в виде строки, я хотел бы присвоить его заголовку компонента Label, но style и color не являются строковыми величинами.

Есть масса способов это сделать, но я использую следующий способ:


 const
   fsTextName: array[TFontStyle] of string[11] = ('fsBold', 'fsItalic', 'fsUnderline', 'fsStrikeOut');
   fpTextName: array[TFontPitch] of string[10] = ('fpDefault','fpVariable','fpFixed');
 

Позже, в коде, я так использую эти имена:


 var
   TFPitch: TFontPitch;
   TFStyle: TFontStyle;
   FString: String;
 ...
 
 FString := '';
 for TFStyle := fsBold to fsStrikeOut do
   if TFStyle in Canvas.Font.Style then
     Fstring := Fstring+fsTextName[TFStyle]+',';
 if FString<>'' then
   dec(FString[0]); { убираем лишний разделитель ',' }
 something := FString;
 
 FString := fpTextName[Canvas.Font.Pitch];
 something := FString;
 

Примерно также нужно поступить и с именованными цветами типа TColor.




Сохраняем и загружаем TFont и INI файлах


 uses
   Inifiles;
 
 procedure SaveFont(FName: string; Section: string; smFont: TFont);
 var
   FStream: TIniFile;
 begin
   FStream := TIniFile.Create(FName);
   try
     FStream.WriteString(Section, 'Name', smFont.Name);
     FStream.WriteInteger(Section, 'CharSet', smFont.CharSet);
     FStream.WriteInteger(Section, 'Color', smFont.Color);
     FStream.WriteInteger(Section, 'Size', smFont.Size);
     FStream.WriteInteger(Section, 'Style', Byte(smFont.Style));
   finally
     FStream.Free;
   end;
 end;
 
 procedure LoadFont(FName: string; Section: string; smFont: TFont);
 var
   FStream: TIniFile;
 begin
   FStream := TIniFile.Create(Fname);
   try
     smFont.Name    := FStream.ReadString(Section, 'Name', smFont.Name);
     smFont.CharSet := TFontCharSet(FStream.ReadInteger(Section, 'CharSet', smFont.CharSet));
     smFont.Color   := TColor(FStream.ReadInteger(Section, 'Color', smFont.Color));
     smFont.Size    := FStream.ReadInteger(Section, 'Size', smFont.Size);
     smFont.Style   := TFontStyles(Byte(FStream.ReadInteger(Section, 'Style', Byte(smFont.Style))));
   finally
     FStream.Free;
   end;
 end;
 
 //Example: 
 //Beispiel: 
 
 //Save Font 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   SaveFont('font.ini', 'label', label1.Font);
 end;
 
 procedure TForm1.Label1DblClick(Sender: TObject);
 begin
   if FontDialog1.Execute then
     label1.Font := FontDialog1.Font
 end;
 
 //Load Font 
 procedure TForm1.Button2Click(Sender: TObject);
 begin
   LoadFont('font.ini', 'label', label1.Font);
 end;
 




Временно запретить форме перерисовываться

Автор: Danny Thorpe (Borlandeer)

Danny Thorpe (Borlandeer) посоветовал мне способ избежать использования LockWindowUpdate и, соответственно, избежать излишнего мерцания экрана. Во многих случаях более эффективным способом будет посылка сообщения WM_SETREDRAW, позволяющая блокировать/разблокировать форму, не затрагивая при этом остальные окна.

Так, чтобы временно запретить форме перерисовываться, необходим следующий код:


 Perform(WM_SETREDRAW, 0, 0);
 

... и, чтобы возвратиться к нормальному состоянию:


 Perform(WM_SETREDRAW, 1, 0);
 Refresh;
 




Временно запретить форме перерисовываться 2


 LockWindowUpdate(Memo1.Handle); 
 ...
 ...
 LockWindowUpdate(0);
 




<< ВЕРНУТЬСЯ В ОГЛАВЛЕНИЕ



Материалы находятся на сайте https://exelab.ru/pro/



Оригинальный DVD-ROM: eXeL@B DVD !


Вы находитесь на EXELAB.rU
Проект ReactOS