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

ВИДЕОКУРС
выпущен 4 ноября!


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

БОЛЬШОЙ FAQ ПО DELPHI



Как сохранить исходник HTML из TWebBrowser.Document на диск


Серьезная организация возьмет на высокооплачиваемую должность опытного хакера. Резюме просим размещать на главной странице сайта www.microsoft.com.

TWebBrowser.Document включает в себя IPersistStreamInit который содержит метод Save(). Всё, что нам нужно знать, это как использовать данный метод с объектом, который включён в IStream. Для этого мы просто воспользуемся TStreamAdapter.

Обратите внимание, что интерфейсы IPersistStreamInit и IStream объявлены внутри ActiveX unit.

Итак, вот так это выглядит.


 procedure TForm1.SaveHTMLSourceToFile(const FileName: string;
 WB: TWebBrowser);
 var
   PersistStream: IPersistStreamInit;
   FileStream: TFileStream;
   Stream: IStream;
   SaveResult: HRESULT;
 begin
   PersistStream := WB.Document as IPersistStreamInit;
   FileStream := TFileStream.Create(FileName, fmCreate);
   try
     Stream := TStreamAdapter.Create(FileStream, soReference) as IStream;
     SaveResult := PersistStream.Save(Stream, True);
     if FAILED(SaveResult) then
       MessageBox(Handle, 'Fail to save HTML source', 'Error', 0);
   finally
     { В ответ на уничтожение объекта TFileStream, передаём
     soReference в конструктор TStreamAdapter. }
     FileStream.Free;
   end;
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   if SaveDialog1.Execute then
     SaveHTMLSourceToFile(SaveDialog1.FileName, WebBrowser1);
 end;
 

А как сохранить вместе с исходником все файлы (.CSS, JPG, GIF и т.д...) ?


 try
   WebBrowser1.ExecWB(4, 0);
 except
   on E: Exception do
     msError := true;
 end;
 




Сохранить документ Word как RTF


 uses
   ComObj;
 
 function ConvertDoc2Rtf(var FileName: string) : Boolean;
 var
   oWord: OleVariant;
   oDoc: OleVariant;
 begin
   Result := False;
   try
     oWord := GetActiveOleObject('Word.Application');
   except
     oWord := CreateOleObject('Word.Application');
   end;
   oWord.Documents.Open(FileName);
   oDoc  := oWord.ActiveDocument;
   FileName := ChangeFileExt(FileName, '.rtf');
   oDoc.SaveAs(FileName);
   oWord.ActiveDocument.Close(wdDoNotSaveChanges, EmptyParam, EmptyParam);
   oWord.Quit(EmptyParam, EmptyParam, EmptyParam);
   oDoc := VarNull;
   oWord := VarNull;
   Result := True;
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 const
   FileName = 'c:\Document.doc';
 begin
   if ConvertDoc2Rtf(FileName) then
   begin
     ShowMessage('Word document has been converted to .rtf');
     RichEdit1.Lines.LoadFromFile(FileName);
   end;
 end;
 




Из ресурсов поочередно загружать глифы для кнопок SpeedButton

Автор: Dennis Passmore

Могу ли я из ресурсов поочередно загружать глифы для кнопок speedbutton и, если да, то как это сделать?

Например, если в вашем проекте используется TDBGrid, то иконки кнопок компонента DBNavigator могут линковаться вашей программой, и их можно загрузить для использования в ваших speedbutton следующим образом:


 SpeedButton.Caption := '';
 SpeedButton1.Glyph.LoadFromResourcename(HInstance,'DBN_REFRESH');
 SpeedButton1.NumGlyphs := 2;
 

Другие зарезервированные имена:
DBN_PRIOR, DBN_DELETE, DBN_CANCEL, DBN_EDIT, DBN_FIRST, DBN_INSERT, DBN_LAST, DBN_NEXT, DBN_POST

Все имена должны использовать верхний регистр.




Масштабирование окна

Автор: Andrey Kozlov


 implementation
 
 const
   ScreenWidth: Integer = 800; {Я разрабатывал свою форму в режиме 800x600.}
   ScreenHeight: Integer = 600;
 
 {$R *.DFM}
 
 procedure TForm1.FormCreate(Sender: TObject);
 var
   x, y: LongInt; {Тип Integer не достаточно большой для наших значений.}
 begin
   form1.scaled := true;
   x := getSystemMetrics(SM_CXSCREEN);
   y := getSystemMetrics(SM_CYSCREEN);
   if (x <> ScreenHeight) or (y <> ScreenWidth) then
   begin
     form1.height := form1.height * x div ScreenWidth;
     form1.width := form1.width * y div ScreenHeight;
   end;
   if x <> ScreenWidth then
     scaleBy(x, ScreenWidth);
 end;
 

Дополнение

Файл DELSEQ07.FAQ содержит код примера отображения форм в различных разрешениях. К сожалению, он не учитывал ширину границы окна. Я публикую изменение, масштабирующее компоненты вне зависимости от разрешения экрана и ширины границ окон. Включите нижеследующий модуль в секцию uses каждого модуля и вызывайте ScaleForm в обработчике формы OnCreate, передавая в качестве параметра имя формы. Я надеюсь что помог тем, кто столкнулся с данной проблемой.


 unit scale;
 
 interface
 
 uses
   Forms, WinTypes, WinProcs, SysUtils;
 
 procedure ScaleForm(Sender: TObject);
 
 implementation
 
 procedure ScaleForm(Sender: TObject);
 
 const
 
   {измените это так, чтобы это соответствовало
   режиму разрешения во время разработки}
   DesignScrY: LongInt = 480;
   DesignScrX: LongInt = 640;
   DesignBorder: LongInt = 4; {значение в Панели Управления + 1}
 
 var
 
   SystemScrY: LongInt;
   SystemScrX: LongInt;
   SystemBorder: LongInt;
   OldHeight: LongInt;
   OldWidth: LongInt;
 
 begin
 
   SystemScrY := GetSystemMetrics(SM_CYSCREEN);
   SystemScrX := GetSystemMetrics(SM_CXSCREEN);
   SystemBorder := GetSystemMetrics(SM_CYFRAME);
   with Sender as TForm do
   begin
     Scaled := True;
     AutoScroll := False;
     Top := Top * SystemScrX div DesignScrX;
     Left := Left * SystemScrX div DesignScrX;
     OldHeight := Height + (DesignBorder - SystemBorder) * 2;
     OldWidth := Width + (DesignBorder - SystemBorder) * 2;
     ScaleBy((OldWidth * SystemScrX div DesignScrX - SystemBorder * 2),
       (OldWidth - DesignBorder * 2));
     {
     Для форм не имеющих границ измените предшествующие
     три строки следующим способом:
 
     OldHeight := Height;
     OldWidth  := Width;
     ScaleBy(SystemScrX, DesignScrX);
     }
 
     Height := OldHeight * SystemScrY div DesignScrY;
     Width := OldWidth * SystemScrX div DesignScrX;
   end;
 end;
 
 begin
 end.
 




Масштабирование окна 2

Вывод формы с различными разрешениями экрана.

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


 implementation
 
 const
   ScreenWidth: LongInt = 800; {Я разрабатывал мою форму в режиме 800x600.}
   ScreenHeight: LongInt = 600;
 
 {$R *.DFM}
 
 procedure TForm1.FormCreate(Sender: TObject);
 begin
   scaled := true;
   if (screen.width <> ScreenWidth) then
   begin
     height := longint(height) * longint(screen.height) div ScreenHeight;
     width := longint(width) * longint(screen.width) div ScreenWidth;
     scaleBy(screen.width, ScreenWidth);
   end;
 end;
 

Затем, вероятно, вы захотите иметь нечто, проверяющее размер шрифтов, OK. Прежде, чем вы измените размер шрифта, вам необходимо убедиться, что объект имеет свойство font. Это может быть сделано следующим образом:


 uses typinfo;
 
 var
   i: integer;
 begin
   for i := componentCount - 1 downtto 0 do
     with components[i] do
     begin
       if GetPropInfo(ClassInfo, 'font') <> nil  then
         font.size := (NewFormWidth DIV OldFormWidth) * font.size;
     end;
 end;
 

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

  • Заранее, в самом начале этапа разработки, решите для себя - собираетесь ли вы разрешать масштабировать форму или нет. Преимущество запрета масштабирования в том, что вам ничего не нужно менять во время выполнения приложения. Недостаток запрета масштабирования - во время выполнения приложения никаких изменений не происходит (ваша форма может быть слишком малой или слишком большой для работы в некоторых режимах при отсутствии масштабирования).
  • Если вы НЕ собираетесь масштабировать форму, установите свойство Scaled в False.
  • В противном случае, установите свойство формы Scaled в True.
  • Установите AutoScroll в False. AutoScroll = True означает 'не изменять размер окна формы во время выполнения приложения', что приводит к "плохому виду" формы, если ее содержимое меняет размер.
  • Установите шрифты формы в масштабируемые TrueType-шрифты типа Arial. MS San Serif также подойдет в качестве альтернативы, только помните, это не TrueType, а bitmapped-шрифт. Только Arial может правильно изменять свою высоту с дискретностью 1 пиксел. Примечание: Если используемый шрифт не установлен на машине пользователя, Windows выбирает альтернативный шрифт из данной линейки (семьи) шрифтов. Размеры нового шрифта могут отличаться от размеров оригинального шрифта, что также может вызвать проблемы.
  • Установите свойство формы Position во что-нибудь другое, чем poDesigned. poDesigned всегда показывает форму в первозданном виде, и, если форма разрабатывалась в разрешении 1280x1024, то вы можете себе представить, что будет при разрешении 640x480?
  • Не "слепляйте" на форме элементы управления, оставляйте между ними, по крайней мере, 4 пикселя, в противном случае, при изменении месторасположения границы на 1 пиксель (это происходит при масштабировании), элементы управления наедут друг на друга.
  • Для однострочных компонентов Label, у которых свойство Aligned равно alLeft или alRight, установите AutoSize в True. В противном случае, установите AutoSize в False.
  • Убедитесь в том, что компоненты Label имеют достаточный запас по ширине (требуется, примерно, 25%) от длины текущего текста. (При переводе вашего приложения на другие языки вам необходимо примерно 30%-ный запас от текущей ширины текста). Если AutoSize - False, убедитесь, что ширины компонента Label достаточно для размещения реального текста. Если AutoSize - True, убедитесь, что на компоненту Label достаточно места (например, на форме) для размещения всего текста плюс небольшой запас для его роста при смене шрифтов.
  • В случае многострочного текста и компонентов Label с переносом слов, убедитесь, что в нижней части у вас имеется, по крайней мере, еще одна строчка. Она необходима вам для того, чтобы не допустить переполнения строки, если размер шрифта увеличивается при масштабировании. Не думайте, что, если вы используете большие шрифты и переполнения не возникает, то эта проблема снята - кто-нибудь может использовать шрифты с еще большим размером, чем у вас!
  • Будьте осторожными при открытии проекта в IDE с другим разрешением. Свойство формы PixelsPerInch будет изменено как только вы откроете форму, и сохранено в DFM-файле при сохранении проекта. Лучше всего запускать приложение отдельно от IDE, а редактировать его при одном разрешении. Редактируя формы при различных разрешениях и размерах шрифтов, вы инициируете проблему "дрейфа" компонентов по форме и изменения их размера.
  • Говоря о дрейфе компонент, не следует многократно масштабировать форму, как во время разработки, так и во время выполнения приложения. Каждое изменение размеров сопровождается ошибками округления, которые достаточно быстро накапливаются с тех пор, как координаты стали строго целочисленными. Поскольку при калькулировании новых размеров дробная часть отбрасывается, вновь пересчитанные размеры оказываются меньше, а координаты элементов управления северо-западнее. Если вы решили разрешить пользователю изменять масштабы форм, начинайте масштабирование с последней загруженной/созданной формы, этим вы уменьшите накапливаемые при масштабировании ошибки.
  • Старайтесь не изменять значение свойства формы PixelsPerInch.
  • В общих словах, нет необходимости разрабатывать формы для всех возможных режимов, перед окончательным релизом вашего приложения вы должны оценить поведение формы в пограничных режимах - 640x480 с маленькими и большими шрифтами, и при высоком разрешении и, также, с маленькими и большими шрифтами. Это должно быть частью ваших регулярных проверок на предмет системной совместимости, для ведения так называемой тестирующей контрольной таблицы.
  • Обратите пристальное внимание на "однострочные компоненты TMemo" - типа TDBLookupCombo. Системные многострочные редакторы всегда выводят только целые строки текста - если ширина элемента управления слишком мала для своего шрифта, то TMemo вообще ничего не показывает (TEdit показывает обрезанный текст). Размер таких компонентов лучше сделать на несколько пикселей больше, чем на несколько пикселей меньше, тем самым можно определеть наличие в компоненте оставшейся части текста.
  • Обратите внимание на то, что масштабирование во время проектирования и во время выполнения программы отличается коэффициентом и зависит от высоты шрифта, а не от экранного разрешения в пикселях. Помните также, что "начало" компонент будет изменяться в зависимости от масштаба формы, и для их "броуновского" движения также необходимо небольшое пространство.



Масштабирование размера формы и размера шрифтов

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

Попробуй следующий код. Он масштабирует как размер формы, так и размер шрифтов. Вызывай его в Form.FormCreate. Надеюсь это поможет.


 unit geScale;
 
 interface
 uses Forms, Controls;
 
 procedure geAutoScale(MForm: TForm);
 
 implementation
 type
   TFooClass = class(TControl); { необходимо выяснить защищенность }
 
   { свойства Font }
 
 procedure geAutoScale(MForm: TForm);
 const
 
   cScreenWidth: integer = 800;
   cScreenHeight: integer = 600;
   cPixelsPerInch: integer = 96;
   cFontHeight: integer = -11; {В режиме проектирование значение из Font.Height}
 
 var
 
   i: integer;
 
 begin
 
   {
   ВАЖНО!! : Установите в Инспекторе Объектов свойство Scaled TForm в FALSE.
 
   Следующая программа масштабирует форму так, чтобы она выглядела одинаково
   внезависимости от размера экрана и пикселей на дюйм. Расположенный ниже
   участок кода проверяет, отличается ли размер экрана во время выполнения
   от размера во время проектирования. Если да, Scaled устанавливается в True
   и компоненты снова масштабируются так, чтобы они выводились в той же
   позиции экрана, что и во время проектирования.
   }
   if (Screen.width &; lt > cScreenWidth) or (Screen.PixelsPerInch <>
     cPixelsPerInch) then
   begin
     MForm.scaled := TRUE;
     MForm.height := MForm.height * screen.Height div cScreenHeight;
     MForm.width := MForm.width * screen.width div cScreenWidth;
     MForm.ScaleBy(screen.width, cScreenWidth);
 
   end;
 
   {
   Этот код проверяет, отличается ли размер шрифта во времы выполнения от
   размера во время проектирования. Если во время выполнения pixelsperinch
   формы отличается от pixelsperinch во время проектирования, шрифты снова
   масштабируются так, чтобы форма не отличалась от той, которая была во
   время разработки. Масштабирование производится исходя из коэффициента,
   получаемого путем деления значения font.height во время проектирования
   на font.height во время выполнения. Font.size в этом случае работать не
   будет, так как это может дать результат больший, чем текущие размеры
   компонентов, при этом текст может оказаться за границами области компонента.
   Например, форма создана при размерах экрана 800x600 с установленными
   маленькими шрифтами, имеющими размер font.size = 8. Когда вы запускаете
   в системе с 800x600 и большими шрифтами, font.size также будет равен 8,
   но текст будет бОльшим чем при работе в системе с маленькими шрифтами.
   Данное масштабирование позволяет иметь один и тот же размер шрифтов
   при различных установках системы.
   }
 
   if (Screen.PixelsPerInch <> cPixelsPerInch) then
   begin
 
     for i := MForm.ControlCount - 1 downto 0 do
       TFooClass(MForm.Controls[i]).Font.Height :=
         (MForm.Font.Height div cFontHeight) *
         TFooClass(MForm.Controls[i]).Font.Height;
 
   end;
 
 end;
 
 end.
 




Сканирование версии структуры базы данных

Спасибо за идеи, высказанные в группах новостей и присланные по электронной почте. Я думаю, что нашел лучшее решение.

Очевидно, BDE содержит номер версии структуры, по крайней мере для файлов Paradox. (Я не могу поручиться за dBase и другие форматы.) Всякий раз при изменении структуры (например, в Database Desktop) BDE увеличивает номер версии. Следующий модуль содержит функцию, которая возвращает версию структуры базы данных:


 (*****************************************************************************
 * DbUtils.pas
 *
 * Утилита для работы с базами данных
 *
 * Создана 09/20/96
 *****************************************************************************)
 
 unit Dbutils;
 
 (****************************************************************************)
 (****************************************************************************)
 
 interface
 
 (****************************************************************************)
 (****************************************************************************)
 
 uses DbTables;
 
 function DbGetVersion(table: TTable): LongInt;
 
 (****************************************************************************)
 (****************************************************************************)
 
 implementation
 
 (****************************************************************************)
 (****************************************************************************)
 
 uses
   Db, DbiProcs, DbiTypes, {DbiErrs,}
   SysUtils;
 
 {---------------------------------------------------------------------------}
 (*
 * Цель:                    определение номера версии структуры таблицы
 * Параметры:               table (I) - интересующая нас таблица
 * Возвращаемая величина:   номер версии
 * Исключительная ситуация: EDatabaseError
 *)
 
 function DbGetVersion(table: TTable): LongInt;
 var
   hCursor: hDBICur;
   tableDesc: TBLFullDesc;
   cName: array[0..255] of Char;
 begin
   { копируем имя таблицы в строку 'с' }
   StrPCopy(cName, table.TableName);
 
   { просим BDE создать запись, содержащую информацию об определенной таблице }
   Check(DbiOpenTableList(table.DBHandle, True, False, cName, hCursor));
 
   { получаем запись, содержащую информацию о структуре }
   Check(DbiGetNextRecord(hCursor, dbiNOLOCK, @tableDesc, nil));
 
   { возвращаем поле записи, содержащее номер версии структуры нашей таблицы }
   Result := tableDesc.tblExt.iRestrVersion;
 
   Check(DbiCloseCursor(hCursor));
 end;
 
 end.
 




Сканируем файл в поисках текста


 function ScanFile(const FileName: string;
   const forString: string;
   caseSensitive: Boolean): Longint;
   { returns position of string in file or -1, if not found }
 const
   BufferSize = $8001;  { 32K+1 bytes }
 var
   pBuf, pEnd, pScan, pPos: PChar;
   filesize: LongInt;
   bytesRemaining: LongInt;
   bytesToRead: Word;
   F: file;
   SearchFor: PChar;
   oldMode: Word;
 begin
   Result := -1;  { assume failure }
   if (Length(forString) = 0) or (Length(FileName) = 0) then Exit;
   SearchFor := nil;
   pBuf      := nil;
 
   { open file as binary, 1 byte recordsize }
   AssignFile(F, FileName);
   oldMode  := FileMode;
   FileMode := 0;    { read-only access }
   Reset(F, 1);
   FileMode := oldMode;
   try { allocate memory for buffer and pchar search string }
     SearchFor := StrAlloc(Length(forString) + 1);
     StrPCopy(SearchFor, forString);
     if not caseSensitive then  { convert to upper case }
       AnsiUpper(SearchFor);
     GetMem(pBuf, BufferSize);
     filesize       := System.Filesize(F);
     bytesRemaining := filesize;
     pPos           := nil;
     while bytesRemaining > 0 do
     begin
       { calc how many bytes to read this round }
       if bytesRemaining >= BufferSize then
         bytesToRead := Pred(BufferSize)
       else
         bytesToRead := bytesRemaining;
 
       { read a buffer full and zero-terminate the buffer }
       BlockRead(F, pBuf^, bytesToRead, bytesToRead);
       pEnd  := @pBuf[bytesToRead];
       pEnd^ := #0;
        { scan the buffer. Problem: buffer may contain #0 chars! So we
          treat it as a concatenation of zero-terminated strings. }
       pScan := pBuf;
       while pScan < pEnd do
       begin
         if not caseSensitive then { convert to upper case }
           AnsiUpper(pScan);
         pPos := StrPos(pScan, SearchFor);  { search for substring }
         if pPos <> nil then
         begin { Found it! }
           Result := FileSize - bytesRemaining +
             Longint(pPos) - Longint(pBuf);
           Break;
         end;
         pScan := StrEnd(pScan);
         Inc(pScan);
       end;
       if pPos <> nil then Break;
       bytesRemaining := bytesRemaining - bytesToRead;
       if bytesRemaining > 0 then
       begin
        { no luck in this buffers load. We need to handle the case of
          the search string spanning two chunks of file now. We simply
          go back a bit in the file and read from there, thus inspecting
          some characters twice
        }
         Seek(F, FilePos(F) - Length(forString));
         bytesRemaining := bytesRemaining + Length(forString);
       end;
     end; { While }
   finally
     CloseFile(F);
     if SearchFor <> nil then StrDispose(SearchFor);
     if pBuf <> nil then FreeMem(pBuf, BufferSize);
   end;
 end; { ScanFile }
 




ScreenMate

Новая игра. Казахский DOOM!
Никаких тебе лабиринтов! Голая степь!

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

p.s К сожалению вам надо позаботиться о кадрах анимации этого персонажа самим т.к рисунки я послать немогу...


 {*******************************************************}
                                                       { }
                            { Delphi VCL Extensions (RX) }
                                                       { }
                     { Copyright (c) 1995, 1996 AO ROSNO }
                  { Copyright (c) 1997, 1998 Master-Bank }
                                                       { }
 {*******************************************************}
 
 unit Animate;
 
 interface
 
 {$I RX.INC}
 
 uses Messages, {$IFDEF WIN32}Windows, {$ELSE}WinTypes, WinProcs,
 {$ENDIF}
   SysUtils, Classes, Graphics, Controls, Forms, StdCtrls, Menus,
   ExtCtrls;
 
 type
   TGlyphOrientation = (goHorizontal, goVertical);
 
   { TRxImageControl }
 
   TRxImageControl = class(TGraphicControl)
   private
     FDrawing: Boolean;
   protected
     FGraphic: TGraphic;
     function DoPaletteChange: Boolean;
     procedure DoPaintImage; virtual; abstract;
     procedure PaintDesignRect;
     procedure PaintImage;
     procedure PictureChanged;
   public
     constructor Create(AOwner: TComponent); override;
   end;
 
   { TAnimatedImage }
 
   TAnimatedImage = class(TRxImageControl)
   private
     { Private declarations }
     FActive: Boolean;
     FAutoSize: Boolean;
     FGlyph: TBitmap;
     FImageWidth: Integer;
     FImageHeight: Integer;
     FInactiveGlyph: Integer;
     FOrientation: TGlyphOrientation;
     FTimer: TTimer;
     FNumGlyphs: Integer;
     FGlyphNum: Integer;
     FStretch: Boolean;
     FTransparentColor: TColor;
     FOpaque: Boolean;
     FTimerRepaint: Boolean;
     FOnFrameChanged: TNotifyEvent;
     FOnStart: TNotifyEvent;
     FOnStop: TNotifyEvent;
     procedure DefineBitmapSize;
     procedure ResetImageBounds;
     procedure AdjustBounds;
     function GetInterval: Cardinal;
     procedure SetAutoSize(Value: Boolean);
     procedure SetInterval(Value: Cardinal);
     procedure SetActive(Value: Boolean);
     procedure SetOrientation(Value: TGlyphOrientation);
     procedure SetGlyph(Value: TBitmap);
     procedure SetGlyphNum(Value: Integer);
     procedure SetInactiveGlyph(Value: Integer);
     procedure SetNumGlyphs(Value: Integer);
     procedure SetStretch(Value: Boolean);
     procedure SetTransparentColor(Value: TColor);
     procedure SetOpaque(Value: Boolean);
     procedure ImageChanged(Sender: TObject);
     procedure UpdateInactive;
     procedure TimerExpired(Sender: TObject);
     function TransparentStored: Boolean;
     procedure WMSize(var Message: TWMSize); message WM_SIZE;
   protected
     { Protected declarations }
     function GetPalette: HPALETTE; override;
     procedure Loaded; override;
     procedure Paint; override;
     procedure DoPaintImage; override;
     procedure FrameChanged; dynamic;
     procedure Start; dynamic;
     procedure Stop; dynamic;
   public
     { Public declarations }
     constructor Create(AOwner: TComponent); override;
     destructor Destroy; override;
     procedure DoPaintImageOn(Mycanvas: Tcanvas; x, y: integer);
       virtual;
   published
     { Published declarations }
     property Active: Boolean read FActive write SetActive default
       False;
     property Align;
     property AutoSize: Boolean read FAutoSize write SetAutoSize
       default True;
     property Orientation: TGlyphOrientation read FOrientation write
       SetOrientation
       default goHorizontal;
     property Glyph: TBitmap read FGlyph write SetGlyph;
     property GlyphNum: Integer read FGlyphNum write SetGlyphNum
       default 0;
     property Interval: Cardinal read GetInterval write SetInterval
       default 100;
     property NumGlyphs: Integer read FNumGlyphs write SetNumGlyphs
       default 1;
     property InactiveGlyph: Integer read FInactiveGlyph write
       SetInactiveGlyph default -1;
     property TransparentColor: TColor read FTransparentColor write
       SetTransparentColor
       stored TransparentStored;
     property Opaque: Boolean read FOpaque write SetOpaque default
       False;
     property Color;
     property Cursor;
     property DragCursor;
     property DragMode;
     property ParentColor default True;
     property ParentShowHint;
     property PopupMenu;
     property ShowHint;
     property Stretch: Boolean read FStretch write SetStretch default
       True;
     property Visible;
     property OnClick;
     property OnDblClick;
     property OnMouseMove;
     property OnMouseDown;
     property OnMouseUp;
     property OnDragOver;
     property OnDragDrop;
     property OnEndDrag;
 {$IFDEF WIN32}
     property OnStartDrag;
 {$ENDIF}
     property OnFrameChanged: TNotifyEvent read FOnFrameChanged write
       FOnFrameChanged;
     property OnStart: TNotifyEvent read FOnStart write FOnStart;
     property OnStop: TNotifyEvent read FOnStop write FOnStop;
   end;
 
 implementation
 
 uses RxConst, VCLUtils;
 
 { TRxImageControl }
 
 constructor TRxImageControl.Create(AOwner: TComponent);
 begin
   inherited Create(AOwner);
   ControlStyle := [csClickEvents, csCaptureMouse, csOpaque,
 {$IFDEF WIN32}csReplicatable, {$ENDIF}csDoubleClicks];
   Height := 105;
   Width := 105;
   ParentColor := True;
 end;
 
 procedure TRxImageControl.PaintImage;
 var
   Save: Boolean;
 begin
   Save := FDrawing;
   FDrawing := True;
   try
     DoPaintImage;
   finally
     FDrawing := Save;
   end;
 end;
 
 procedure TRxImageControl.PaintDesignRect;
 begin
   if csDesigning in ComponentState then
     with Canvas do
     begin
       Pen.Style := psDash;
       Brush.Style := bsClear;
       Rectangle(0, 0, Width, Height);
     end;
 end;
 
 function TRxImageControl.DoPaletteChange: Boolean;
 var
   ParentForm: TCustomForm;
   Tmp: TGraphic;
 begin
   Result := False;
   Tmp := FGraphic;
   if Visible and (not (csLoading in ComponentState)) and (Tmp <>
     nil)
 {$IFDEF RX_D3} and (Tmp.PaletteModified){$ENDIF} then
   begin
     if (GetPalette <> 0) then
     begin
       ParentForm := GetParentForm(Self);
       if Assigned(ParentForm) and ParentForm.Active and
         Parentform.HandleAllocated then
       begin
         if FDrawing then
           ParentForm.Perform(WM_QUERYNEWPALETTE, 0, 0)
         else
           PostMessage(ParentForm.Handle, WM_QUERYNEWPALETTE, 0, 0);
         Result := True;
 {$IFDEF RX_D3}
         Tmp.PaletteModified := False;
 {$ENDIF}
       end;
     end
 {$IFDEF RX_D3}
     else
     begin
       Tmp.PaletteModified := False;
     end;
 {$ENDIF}
   end;
 end;
 
 procedure TRxImageControl.PictureChanged;
 begin
   if (FGraphic <> nil) then
     if DoPaletteChange and FDrawing then
       Update;
   if not FDrawing then
     Invalidate;
 end;
 
 { TAnimatedImage }
 
 constructor TAnimatedImage.Create(AOwner: TComponent);
 begin
   inherited Create(AOwner);
   FTimer := TTimer.Create(Self);
   Interval := 100;
   FGlyph := TBitmap.Create;
   FGraphic := FGlyph;
   FGlyph.OnChange := ImageChanged;
   FGlyphNum := 0;
   FNumGlyphs := 1;
   FInactiveGlyph := -1;
   FTransparentColor := clNone;
   FOrientation := goHorizontal;
   FAutoSize := True;
   FStretch := True;
   Width := 32;
   Height := 32;
 end;
 
 destructor TAnimatedImage.Destroy;
 begin
   FOnFrameChanged := nil;
   FOnStart := nil;
   FOnStop := nil;
   FGlyph.OnChange := nil;
   Active := False;
   FGlyph.Free;
   inherited Destroy;
 end;
 
 procedure TAnimatedImage.Loaded;
 begin
   inherited Loaded;
   ResetImageBounds;
   UpdateInactive;
 end;
 
 function TAnimatedImage.GetPalette: HPALETTE;
 begin
   Result := 0;
   if not FGlyph.Empty then
     Result := FGlyph.Palette;
 end;
 
 procedure TAnimatedImage.ImageChanged(Sender: TObject);
 begin
   FTransparentColor := FGlyph.TransparentColor and not PaletteMask;
   DefineBitmapSize;
   AdjustBounds;
   PictureChanged;
 end;
 
 procedure TAnimatedImage.UpdateInactive;
 begin
   if (not Active) and (FInactiveGlyph >= 0) and
     (FInactiveGlyph < FNumGlyphs) and (FGlyphNum <> FInactiveGlyph) then
   begin
     FGlyphNum := FInactiveGlyph;
   end;
 end;
 
 function TAnimatedImage.TransparentStored: Boolean;
 begin
   Result := (FGlyph.Empty and (FTransparentColor <> clNone)) or
     ((FGlyph.TransparentColor and not PaletteMask) <>
     FTransparentColor);
 end;
 
 procedure TAnimatedImage.SetOpaque(Value: Boolean);
 begin
   if Value <> FOpaque then
   begin
     FOpaque := Value;
     PictureChanged;
   end;
 end;
 
 procedure TAnimatedImage.SetTransparentColor(Value: TColor);
 begin
   if Value <> TransparentColor then
   begin
     FTransparentColor := Value;
     PictureChanged;
   end;
 end;
 
 procedure TAnimatedImage.SetOrientation(Value: TGlyphOrientation);
 begin
   if FOrientation <> Value then
   begin
     FOrientation := Value;
     DefineBitmapSize;
     AdjustBounds;
     Invalidate;
   end;
 end;
 
 procedure TAnimatedImage.SetGlyph(Value: TBitmap);
 begin
   FGlyph.Assign(Value);
 end;
 
 procedure TAnimatedImage.SetStretch(Value: Boolean);
 begin
   if Value <> FStretch then
   begin
     FStretch := Value;
     PictureChanged;
     if Active then
       Repaint;
   end;
 end;
 
 procedure TAnimatedImage.SetGlyphNum(Value: Integer);
 begin
   if Value <> FGlyphNum then
   begin
     if (Value < FNumGlyphs) and (Value >= 0) then
     begin
       FGlyphNum := Value;
       UpdateInactive;
       FrameChanged;
       PictureChanged;
     end;
   end;
 end;
 
 procedure TAnimatedImage.SetInactiveGlyph(Value: Integer);
 begin
   if Value < 0 then
     Value := -1;
   if Value <> FInactiveGlyph then
   begin
     if (Value < FNumGlyphs) or (csLoading in ComponentState) then
     begin
       FInactiveGlyph := Value;
       UpdateInactive;
       FrameChanged;
       PictureChanged;
     end;
   end;
 end;
 
 procedure TAnimatedImage.SetNumGlyphs(Value: Integer);
 begin
   FNumGlyphs := Value;
   if FInactiveGlyph >= FNumGlyphs then
   begin
     FInactiveGlyph := -1;
     FGlyphNum := 0;
   end
   else
     UpdateInactive;
   FrameChanged;
   ResetImageBounds;
   AdjustBounds;
   PictureChanged;
 end;
 
 procedure TAnimatedImage.DefineBitmapSize;
 begin
   FNumGlyphs := 1;
   FGlyphNum := 0;
   FImageWidth := 0;
   FImageHeight := 0;
   if (FOrientation = goHorizontal) and (FGlyph.Height > 0) and
     (FGlyph.Width mod FGlyph.Height = 0) then
     FNumGlyphs := FGlyph.Width div FGlyph.Height
   else if (FOrientation = goVertical) and (FGlyph.Width > 0) and
     (FGlyph.Height mod FGlyph.Width = 0) then
     FNumGlyphs := FGlyph.Height div FGlyph.Width;
   ResetImageBounds;
 end;
 
 procedure TAnimatedImage.ResetImageBounds;
 begin
   if FNumGlyphs < 1 then
     FNumGlyphs := 1;
   if FOrientation = goHorizontal then
   begin
     FImageHeight := FGlyph.Height;
     FImageWidth := FGlyph.Width div FNumGlyphs;
   end
   else {if Orientation = goVertical then}
   begin
     FImageWidth := FGlyph.Width;
     FImageHeight := FGlyph.Height div FNumGlyphs;
   end;
 end;
 
 procedure TAnimatedImage.AdjustBounds;
 begin
   if not (csReading in ComponentState) then
   begin
     if FAutoSize and (FImageWidth > 0) and (FImageHeight > 0) then
       SetBounds(Left, Top, FImageWidth, FImageHeight);
   end;
 end;
 
 type
   TParentControl = class(TWinControl);
 




Как скопировать экран (или его часть) в TBitmap

Например, с помощью WinAPI так -


 var
   bmp: TBitmap;
   DC: HDC;
 begin
   bmp:=TBitmap.Create;
   bmp.Height:=Screen.Height;
   bmp.Width:=Screen.Width;
   DC:=GetDC(0);  //Дескpиптоp экpана
   bitblt(bmp.Canvas.Handle, 0, 0, Screen.Width, Screen.Height,
     DC, 0, 0, SRCCOPY);
   bmp.SaveToFile('Screen.bmp');
   ReleaseDC(0, DC);
 end;
 

Или с помощью обертки TCanvas -

Объект Screen[.width,height] - размеры


 Var
   Desktop: TCanvas ;
   BitMap: TBitMap;
 begin
   DesktopCanvas:=TCanvas.Create;
   DesktopCanvas.Handle:=GetDC(Hwnd_Desktop);
   BitMap := TBitMap.Create;
   BitMap.Width := Screen.Width;
   BitMap.Height:=Screen.Height;
   Bitmap.Canvas.CopyRect(Bitmap.Canvas.ClipRect,
   DesktopCanvas, DesktopCanvas.ClipRect);
   ........
 end;
 




Как сохранить содержимое экрана в файл

10 стадий утреннего похмелья для программиста (заметки монитора).
1. Созерцательная. Смотрит в монитор чистыми прозрачными глазами, ничего не предпринимает, никуда не нажимает, изредка в изумлении произносит, глядя в экран: "Вот это да, кто бы мог подумать!" Компьютер выключен из розетки.
2. Деятельная. С подозрением и прищуром смотрит на клавиатуру, раскачиваясь всем телом, потом резким движением выбрасывает руку, пытаясь нажать на искомую кнопку. В случае удачного попадания кричит "Е-ху!!!", в случае неудачного попадания сносит монитор к едрене фене, при этом добродушно ворчит "ну вот третий раз за сегодня"
3. Угрюмая. Понуро сидит перед компьтером, пытаясь не совершать резких движений. Набирает текст на клавиатуре языком головы и двумя руками держится за мышку, чтобы не опрокинуться с кресла... Как оказалось, напрасно.
4. Автомобильная. Пытается завести компьютер автомобильными ключами, присобачить магнитолу на панель компьютера, и включить дворники, потому что "ни хр@на не видно, а ехать надо".
5. Развлекательная. Играет в Quake, причем из всех видов оружия предпочитает собственные руки и дерется с монитором, угрожает компьютеру вернуться завтра с друзьями-каратистами, и отп*здить его так, что "мама" не распознает.
6. Террористическая. После очередной попытки разлепить глаза, в ужасе кричит, что компьютер заминирован, потому что в правом нижнем углу тикают часы, и ныряет под стол.
7. Государственная. На предложение "Введите свой пароль" орет в компьютер: "Ах сука, ты меня, что ли не узнаешь?", показывает монитору язык, неприличные жесты и удостоверение помощника депутата Государственной Думы.
8. Оптимистическая. Весел, игрив, обращается с компьютером на равных. Прочитав страничку BK.list.ru, также вспоминает пару забавных историй и рассказывает их монитору. Потом они вместе пьют пиво, компьютер отхлебывает дисководом.
9. Униксовая. ...выключает компьютер, две минуты пьет пиво, снова включает, дожидается заставки и в тоске произносит "Опять винды, ненавижу Гейтса", выключает компьютер, две минуты пьет пиво, снова включает...
10. Успокоительная. Долго по слогам читает с экрана "Теперь питание компьютера можно отключить", после чего, мягко улыбаясь, говорит "Спасибо" и засыпает на клавиатуре.


 procedure TForm1.Button1Click(Sender: TObject);
 var
   DC: HDC;
   Canva: TCanvas;
   B: TBitmap;
 begin
   Canva := TCanvas.Create;
   B := TBitmap.Create;
   DC := GetDC(0);
   try
     Canva.Handle := DC;
     with Screen do
     begin
       B.Width := Width;
       B.Height := Height;
       B.Canvas.CopyRect(Rect(0, 0, Width, Height),
       Canva, Rect(0, 0, Width, Height));
       B.SaveToFile('c:\Мои документы\screentofile.bmp');
     end
   finally
     ReleaseDC(0, DC);
     B.Free;
     Canva.Free
   end
 end;
 




Прокрутка Memo


 Var
   ScrollMessage:TWMVScroll;
 begin
   ScrollMessage.Msg:=WM_VScroll;
   for i := Memo1.Lines.Count DownTo 0 do
   begin
     ScrollMessage.ScrollCode:=sb_LineUp;
     ScrollMessage.Pos:=0;
     Memo1.Dispatch(ScrollMessage);
   end;
 end;
 




Как прокрутить TRichEdit в конец

Существует множество способов, включая и:


 with MainFrm.RichEdit1 do
 begin
   perform (WM_VSCROLL, SB_BOTTOM, 0);
   perform (WM_VSCROLL, SB_PAGEUP, 0);
 end;
 

Вышеприведённый пример работает отлично в 9x и NT4, но не работает в Windows 2000. Поэетому предлагаю воспользоваться следующим примером:


 with MainFrm.RichEdit1 do
 begin
   SelStart := Length(Text);
   Perform(EM_SCROLLCARET, 0, 0);
 end;
 

или


 SendMessage(RichEdit1.Handle, EM_SCROLL, SB_LINEDOWN, 0);
 




Прокрутка таблицы - хитрость PeekMessage

На днях я решил поиграть с API-функцией PeekMessage(). Функция работает, но ловить ее нужно следующим образом.

Я прокручиваю таблицу, связанную с набором данных. "Поиск" в наборе данных замедляет процесс скролирования (условимся называть "поиском" синхронное перемещение табличного курсора в процессе скроллирования, при котором текущей записью становится запись, ближайшая к нажимаемой кнопке полосы прокрутки). Возникла задача: необходимо отменить "поиск" (процесс слежения) и переместить указатель на необходимую запись только в случае остановки пользователем процесса скроллирования, другими словами - пока пользователь осуществляет скроллирование, "поиск" необходимо отменить. Итак, ко мне в голову пришла мысль, что с помощью PeekMessage() можно выловить определенное сообщение и тем самым отменить поиск во время прокрутки. Звучит просто, но на самом деле все оказалось наоборот.

Я установил фильтр поиска сообщений на WM_MOUSEFIRST/LAST. Ситуация: пользователь непрерывно прокручивает DBGrid вниз, т.е. держит нажатой нижнюю кнопку скроллирования. В результате PeekMessage() возвращает False - нас это не устраивает, это не то, что мы хотим. Положительный результат можно получить только в случае сверхскоростных манипуляций мышью.

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

Было бы хорошо, если бы дескриптор DBGrid получал событие OnMouseUp() во время его скроллирования. Обидно, но OnMouseUp() работает только с DBGrid, а не с полосами прокрутки. OnMouseUp() с TForm при KeyPreview:=true не работает, я проверял.

После пришла идея опросить состояние кнопок мыши с помощью функции GetKeyState(). Пока кнопка нажата (DOWN), "поиск" запрещен, и наоборот. UP (кнопка отжата) свидетельствует об окончании процесса скроллирования. Данный способ работы с окном во время манипуляций с его полосой прокрутки заработал без проблем. Теперь все в порядке: поиска во время прокрутки не происходит и табличный курсор также никуда не перемещается.

Рассмотренная тема имеет отношение к полосам прокрутки, а события OnKeyUp() и OnMouseUp() могут применяться где-нибудь еще.




Как в Memo прокрутить текст

Все, конечно же, в курсе, что Аська (ICQ-98, например) при получении сообщения говорит второй любимый американский звук "О-а!" (первый лю- бимый - "Упс!"). Так вот, как-то одна моя знакомая девушка, увидев что- то то ли в окне, то ли по телевизору, произнесла это самое "О-а!". На что я воскликнул: "Ну ты прям как Аська". После чего минут десять объяснял, что я не имел ввиду никакие "какаськи". :))

В поле ввода вводите на какую строку нужно сойти, и по нажатию на кнопку эта строка будет попадать о зону видимости:


 procedure TForm1.Button1Click(Sender: TObject);
 var
   line: integer;
 begin
   line := StrToIntDef(Edit1.Text,1);
   Memo1.SelStart := Memo1.Perform(EM_LINEINDEX, line, 0);
   Memo1.Perform(EM_SCROLLCARET, 0, 0);
 end;
 




Прокручивать TWebBrowser своими кнопками


 // Scroll up 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   WebBrowser1.OleObject.Document.ParentWindow.ScrollBy(0, -100);
 end;
 
 // Scroll left 
 procedure TForm1.Button3Click(Sender: TObject);
 begin
   WebBrowser1.OleObject.Document.ParentWindow.ScrollBy(-100, 0);
 end;
 
 // Scroll down 
 procedure TForm1.Button2Click(Sender: TObject);
 begin
   WebBrowser1.OleObject.Document.ParentWindow.ScrollBy(0, +100);
 end;
 
 // Scroll right 
 procedure TForm1.Button4Click(Sender: TObject);
 begin
   WebBrowser1.OleObject.Document.ParentWindow.ScrollBy(+100, 0);
 end;
 




Читаем CSV текстовый файл в StringGrid


 procedure ReadTabFile(FN: TFileName; FieldSeparator:
 Char; SG: TStringGrid);
 var
   i: Integer;
   S: string;
   T: string;
   Colonne, ligne: Integer;
   Les_Strings: TStringList;
   CountCols: Integer;
   CountLines: Integer;
   TabPos: Integer;
   StartPos: Integer;
   InitialCol: Integer;
 begin
   Les_Strings := TStringList.Create;
   try
     // Load the file, Datei laden 
     Les_Strings.LoadFromFile(FN);
 
     // Get the number of rows, Anzahl der Zeilen ermitteln 
     CountLines := Les_Strings.Count + SG.FixedRows;
 
     // Get the number of columns, Anzahl der Spalten ermitteln 
     T := Les_Strings[0];
     for i := 0 to Length(T) - 1 do Inc(CountCols,
     Ord(IsDelimiter(FieldSeparator, T, i)));
     Inc(CountCols, 1 + SG.FixedCols);
 
     // Adjust Grid dimensions, Anpassung der Grid-Gro?e 
     if CountLines > SG.RowCount then SG.RowCount := CountLines;
     if CountCols > SG.ColCount then SG.ColCount := CountCols;
 
     // Initialisierung 
     InitialCol := SG.FixedCols - 1;
     Ligne := SG.FixedRows - 1;
 
     // Iterate through all rows of the table 
     // Schleife durch allen Zeilen der Tabelle 
     for i := 0 to Les_Strings.Count - 1 do
     begin
       Colonne := InitialCol;
       Inc(Ligne);
       StartPos := 1;
       S := Les_Strings[i];
       TabPos := Pos(FieldSeparator, S);
       repeat
         Inc(Colonne);
         SG.Cells[Colonne, Ligne] := Copy(S, StartPos, TabPos - 1);
         S := Copy(S, TabPos + 1, 999);
         TabPos := Pos(FieldSeparator, S);
       until TabPos = 0;
     end;
   finally
     Les_Strings.Free;
   end;
 end;
 
 // Example, Beispiel: 
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   Screen.Cursor := crHourGlass;
   // Open tab-delimited files 
   ReadTabFile('C:\TEST.TXT', #9, StringGrid1);
   Screen.Cursor := crDefault;
 end;
 




Поиск звуковой платы

Hа уроке литературы в компьютерном лицее: - Герасим был это... этим... Hу, звуковой карты у него не было.


 uses MMsystem;
 
 begin
   if WaveOutGetNumDevs>0 then
     Result:='Yes'
   else
     Result:='No';
 end;
 




Процедура поиска закладок и перехода по ним


 // процедура поиска закладок и перехода по ней
 
 procedure WordGotoBookmark(rBookmark: string);
 var
   Whatr: OLEVariant;
   // OleEnum;
   // OLEVariant;
   // What :TWordDocument;
   Which: OLEVariant;
   Count: OLEVariant;
   Name: OLEVariant;
 begin
   Whatr := wdGoToBookmark;
   Which := unAssigned;
   Count := unAssigned;
   Name := rBookmark;
   Form1.WrdApp.Selection.GoTo_(Whatr, Which, Count, Name);
 end;
 




Произвести поиск байта или слова в строке

Автор: http://sunsb.dax.ru

У семейства x86 есть группа специализированных строковых инструкций, одна из которых - scasb/scasw - производит поиск байта/слова в строке. Использовать преимущества этой инструкции в Delphi позволяют длинные строки, которых в старых паскалях не было.

Никаких сложностей с пониманием, на мой взгляд, быть не должно. Единственное это смена режима открытия файла (FileMode := 0), которая позволит открыть файлы заблокированные ядром Windows и сдвиг указателя файла при чтении нового блока влево на длину искомой строки. Сдвиг делается на случай разрезания искомой строки на части при чтении файла. Полный текст проверенной программы:


 program search;
 {$APPTYPE CONSOLE}
 uses  SysUtils;
 const buffSize  = 16384;
 var F           : File;
 var buff        : AnsiString;
 var oldFileMode : integer;
 var SearchString: shortString='SunSB';
 var SearchPos   : integer = -1;
 var readed      : integer;
 var blockStart: integer;
 begin
    SetLength( buff, buffSize);
    assignFile( F, 'Speedometer2.exe');
    oldFileMode := FileMode;
    FileMode := 0;
    reset( F,1);
    while not eof( F ) do begin
       blockStart := filePos( F );
       blockRead( F, buff[1], buffSize, readed);
       SearchPos:=Pos( SearchString, buff );
       if SearchPos >  0 then begin
          WriteLn( 'Substr found at pos ',
                         blockStart+SearchPos );
          break;
       end;
       if readed=buffSize then
          seek( F, ( filePos( F ) -
                     length( SearchString )));
    end;
    closeFile( F );
    FileMode := oldFileMode;
    SetLength( buff, 0 );
    if SearchPos = 0 then
       WriteLn( 'Substr not found.');
    readLn;
 end.
 




Поиск класса

Автор: Mike Scott

Могу ли я во время выполнения приложения определить, существует ли класс с именем Tlog?

Используйте в модуле TLog RegisterClass( TLog ) или потомка TLog, затем FindClass( 'TLog' ) или FindClass( 'TLogSubclass' ) для получения ссылки на класс в вызывающем модуле, позволяя тем самым пользоваться объектами данного класса. Вы также могли бы добавить классовый метод, возвращающий существующий экземпляр или NIL, или который создает и возвращает новый экземпляр при отсутствии текущего.

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

Тем не менее, я считаю не лучшим решением технологию поиска класса по его имени. Вот что предлагаю я:


 unit LogUnit;
 interface
 
 type
   TLog = class
   public
     constructor Create;
     procedure LogMessage(const Message: string); virtual; abstract;
   end;
 
 var
   Log: TLog;
 
 implementation
 
 constructor TLog.Create;
 begin
   Log := Self;
 end;
 
 procedure TidyUp; far;
 begin
   Log.Free;
 end;
 
 initialization
 
   AddExitProc(TidyUp);
 end.
 


 unit LogImpl;
 
 interface
 
 implementation
 
 uses Log;
 
 type
   TLogImplementation = class(TLog)
   public
     procedure LogMessage(const Message: string); override;
   end;
 
 procedure TLogImplementation.LogMessage(const Message: string);
 begin
   { записываем сообщение в журнальный файл }
 end;
 
 initialization
 
   TLogImplementation.Create;
 end.
 

Обратите внимание на то, что здесь используются "скрытые" данные - класс TLogImplementation объявлен внутри секции реализации модуля LogImpl, поэтому никакой другой модуль их не видит. Фактически, интерфейсная часть полностью пустая! Вы можете протестировать это, изучив Log и увидев NIL в самом начале.

Кроме того, вы могли бы иметь ничего не делающий TLog.LogMessage. Затем вы могли бы создать экземпляр TLog в секции инициализации модуля LogUnit.pas, и освобождать его перед созданием экземпляра TLogImplementation в LogImpl.pas. Таким образом, для подключения к приложению класса, нужно просто добавить к проекту модуль LogImpl.




Поиск DOS-окна


Как отладить Windows. Заходите в DOS, набираете "format c:", а затем нажимаете "y". По другому он не понимает.

При поиске окон, как отмечалось, нужен класс и имя, так вот - если Вы ищите DOS-окно, то его класс всегда = 'tty'.




Поиск файлов


Новая русскоязычная поисковая система "Иван Сусанин"

Не правда ли, знакомая ситуация? Необходимо сделать так, чтобы программа искала какой-либо файл... Все, хорошо, если у Вас для этого есть специальная компонента (кстати, не входящая в стандартный набор). А если ее нет? Здесь придется писать алгоритм поиска файла.

В Delphi существует две функции для поиска файлов. Это:


 function FindFirst(const Path: string; Attr: Integer;
   var F: TSearchRec): Integer;
 
 function FindNext(var F: TSearchRec): Integer;
 

Разберемся, что же означают эти функции. Для начала возьмем первую - FindFirst. Разберемся сначала с переменными.

Path
Это переменная, как видно из названия, показывающая путь к директории, где будет производиться поиск файла. Кроме этого, в эту переменную входит также и имя файла (файлов), которые должны быть найдены. Причем, в названии файла можно пользоваться такими символами: * (звездочка) и ? (знак вопроса). Значения этих символов стандартны: знак вопроса - любой допустимый символ, звездочка - комбинация любых допустимых символов. Под допустимыми символами я понимаю символы, которые могут использоваться в операционной системе для обозначения имен файлов.

Пример использования переменной Path:


 {поиск файлов с любым именем в корне диска C:}
 Path:='c:\*.*';
 
 {поиск файлов в директории E:\AUDIO с именем, которое
 начинается на song3, с расширением .wav}
 Path:='e:\audio\song3?.wav';
 

Обратите внимание:

Недопустимо использовать символы * и ? в названии директории. Эти символы могут использоваться только в имени файла.

Attr
Переменная задает тип файлов, которые будут найдены. Тип переменной - Integer. Чтобы не мучаться с запоминанием цифр, рекомендую Вам запомнить такие слова:
  • faReadOnly - файлы, у которых установлен аттрибут "Только для чтения".
  • faHidden - файлы, у которых установлен атрибут "Скрытые".
  • faSysFile - файлы, у которых установлен атрибут "Системный".
  • faArchive - файлы, у которых установлен атрибут "Архивный".
  • faDirectory - директория. То есть поиск поддиректорий в директории.
  • faAnyFile - любой файл (в том числе и faDirectory, и faVolumeID).

Теперь с этими словами можно обращаться как с цифрами - складывать их и вычитать. Например:


 {поиск Скрытых и Системных файлов}
 Attr := faHidden + faSysFile;
 
 {поиск всех файлов, кроме файлов,
 имеющих атрибут "Только для чтения"}
 Attr := faAnyFile - faReadOnly;
 

Однако учтите:

При применении вычитания результат может получиться несколько неожиданным, поэтому им лучше не злоупотреблять.

Теперь разберемся, что же выдает функция. Функция возвращает 0, если была выполнена успешно, или, в противном случае, код ошибки. Кроме того, если функция нашла файл, удовлетворяющий и условиям переменной Path, и условиям переменной Attr, то она записывает результат в переменную F (типа TSearchRec), которая, естественно, должна быть объявлена командой Var.

Тип TSearchRec можно представить как:


 type TSearchRec = record
   Time: Integer;
   Size: Integer;
   Attr: Integer;
   name: TFileName;
   ExcludeAttr: Integer;
   FindHandle: THandle;
   FindData: TWin32FindData;
 end;
 

Теперь разберемся, что означает функция FindNext.

Если команда FindFirst нашла какой-либо файл, то, возможно, если имя файла задано с символами * и/или ?, есть еще один или несколько файлов, удовлетворяющих условию поиска. В этом случае и используется команда FindNext. Функция также возвращает 0, если была выполнена успешно, или, в противном случае, код ошибки. И также записывает данные в переменную F.

Теперь, зная эти две команды, можно составить и алгоритм поиска заданного файла.

Простейший алгоритм:


 var
   F: TSearchRec;
   Path: string;
   Attr: Integer;
 begin
   {Искать все файлы в заданной директории с расширение .wav}
   Path := 'e:\audio\album31\*.wav';
   {которые имеют атрибуты "Только для чтения" и "Архивный"}
   Attr := faReadOnly + faArchive;
 
   FindFirst(Path, Attr, F);
 
   {Если хотя бы один файл найден, то продолжить поиск}
   if F.name <> '' then
   begin
     ListBox1.Items.Add(F.name); {Добавление в TListBox имени найденного файла}
     while FindNext(F) = 0 do
       ListBox1.Items.Add(F.name);
   end;
   FindClose(F);
 end.
 

Обратите внимание на процедуру FindClose. Она освобождает память, которую заняли функции FindFirst и FindNext.




Как запустить диалог поиска файла

Автор: Олег Кулабухов

У программиста потерялся файл, и он его никак не может найти. После пяти минут поисков он громко объявляет:
- Так, потерялся файл. Просьба никому не выходить из комнаты!


 procedure TForm1.Button1Click(Sender: TObject);
 begin
   with TDDEClientConv.Create(Self) do
   begin
     ConnectMode := ddeManual;
     ServiceApplication := 'explorer.exe';
     SetLink('Folders', 'AppProperties');
     OpenLink;
     ExecuteMacro('[FindFolder(, C:\DOWNLOAD)]', False);
     CloseLink;
     Free;
   end;
 end;
 




Поиск в базе данных ADO

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

В данной статье будут рассмотрены различные способы поиска данных разработке ADO-приложений в Delphi

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

Давайте рассмотрим несколько способов расположения данных, полученных из БД посредствам компонента ADODataset (для Таблицы и для Запроса).

Locate

Этот универсальный метод поиска устанавливает текущую запись как первую строку, удовлетворяющую набору критериев поиска. Используя метод Locate мы можем искать значения одного или более полей, расположенных в массиве переменных. В приведённом ниже коде, метод Locate ищет первую запись, содержащую строку 'Zoom' в поле 'Name'. Если вызов Locate возвращает True - то запись найдена и установлена как текущая.


 AdoTable1.Locate('Name','Zoom',[]);
 
 {...или...}
 
 var ffield, fvalue: string;
     opts : TLocateOptions;
  
 ffield := 'Name';
 fvalue := 'zoom';
 opts := [loCaseInsensitive];
 
 if not AdoTable1.Locate(ffield, fvalue, opts) then
   ShowMessage(fvalue + ' not found in ' + ffield);
 

Lookup

Метод Lookup не перемещает курсор в соответствующую строку, а только возвращает её значение. Lookup возвращает массив переменных, содержащих значения из полей, указанных в разделённом точкой с запятой списке имён, значения которых должны быть возвращены из интересующей нас строки. Если соответствующих нашему запросу строк не найдено, то Lookup вернёт пустую (Null) переменную.

Следующий пример заполняет заполняет массив переменных LookupRes


 var LookupRes: Variant;
 
 LookupRes := ADOTable1.Lookup
   ('Name', 'Zoom', 'Author; Description');
 
 if not VarIsNull(LookupRes) then
  ShowMessage(VarToStr(LookupRes[0])) //имя автора
 
 

Одно из преимуществ методов Locate и Lookup, состоит в том, что они не требуют, чтобы таблица была проиндексирована. Однако, функция Locate будет работать намного быстрее, если таблица будет проиндексирована.

Индексирование

Индексирование помогает находить и сортировать записи намного быстрее. Вы можете создавать индексы основанные на одном поле либо на нескольких полях. Индексирование нескольких полей позволяет Вам различать записи, в которых первое поле может иметь то же самое значение. В большинстве случаев при частом поиске/сортировке желательно индексировать поля. Например, если Вы ищете определённый тип приложения в поле Type, то Вы можете создать индекс на это поле для ускорения поиска по типу. Следует упомянуть, что первичный ключ таблицы автоматически проиндексирован, а так же Вы не можете индексировать поля с типом данных OLE Object. И ещё, обратите внимание, что если многие из значений в поле те же самые, то индексирование в данном случае не ускорит процесс получения данных из БД.

BDE (не ADO) Delphi предоставляет нам определённые функции для работы с таблицами базы данных, которые позволяют нам производить поиск необходимых значений. Вот некоторые из них Goto, GoToKey, GoToNearest, Find, FindKey, Find Nearest, и т.д. Для более полной справки по этим методам, Вам следует посмотреть в справке Delphi, в разделе: Searching for records based on indexed fields. ADO напротив не поддерживает эти методы. Вместо этого он представляет метод Seek.

Seek

В ADO метод Seek использует индекс для поиска данных. Наример, при поиске в базе данных Access, если не задать индекс, то базSeek используется для поиска записей с указанным значением (или значениями) в поле (либо полях) на которых основан текущий индекс. Если Seek не находит желаемую строку, то никакой ошибки не выдаётся, а курсор устанавливается в конец данных. Seek возвращает значение boolean, указывающее на успешность поиска: True если запись была найдена либо False если записей удовлетворяющих нашим требований не было найдено.

Метод GetIndexNames в компоненте TADOTable возвращает список (например: ячеек combo box) доступных индексов для таблицы.


 ADOTable1.GetIndexNames(ComboBox1.Items);
 

Этот же список доступен в режиме разработки в свойстве IndexName компонента TADOTable. Свойство IndexFieldNames может использоваться как альтернативный метод для определения индекса используемого в таблице. В IndexFieldNames, мы указываем имя каждого поля для использования в таблице.

Метод Seek имеет следующее определение:


 function Seek(const KeyValues: Variant; SeekOption:
  TSeekOption = soFirstEQ): Boolean;
 

  • KeyValues массив значений Variant. Так как индекс состоит из одного или более столбцов, то массив содержит значения, которые будут сравниваться с соответствующими столбцами.
  • SeekOption указывает на тип сравнивания между колонками индекса и соответствующим KeyValues.

SeekOption - Назначение

  • soFirstEQ Указатель на запись позиционируется в первую удовлетворяющую требованиям запись, если она найдена, либо в конец таблицы, если не найдена
  • soLastEQ Указатель на запись позиционируется на последнюю удовлетворяющую требованиям запись если она найдена, либо в конец таблицы если нет.
  • soAfterEQ Указатель на запись позиционируется на удовлетворяющую требованиям запись, если таковая найдена, либо сразу после той, которая была найдена.
  • soAfter Указатель на запись позиционируется сразу после той, которая была найдена.
  • soBeforeEQ Указатель на запись позиционируется на удовлетворяющую требованиям запись, если таковая найдена, либо перед той, которая была найдена.
  • soBefore Указатель на запись позиционируется перед той записью, которая была найдена.

Примечание 1: метод Seek поддерживает курсоры только на стороне сервера (server-side). Seek не будет работать, если значение свойства CursorLocation равно clUseClient. Для этого используется метод Supports для определения основного провайдера, поддерживающего Seek.

Примечание 2: когда Вы используйте метод Seek для нескольких полей, то Seek поля должны быть в том же самом порядке как поля в основной таблице. Если это не так, то метод Seek выдаст ошибку.

Примечание 3: Вы не сможете использовать метод Seek в компоненте TADOQuery.

Чтобы определять, была ли соответствующая запись найдена, мы используем свойства BOF или EOF (в зависимости от направления поиска). Следующий код использует индекс, указанный в ComboBox, чтобы найти значение, содержащееся в окне редактирования Edit1.


 var strIndex: string;
 
 strIndex := ComboBox1.Text; //из примера выше
 
 if ADOTable1.Supports(coSeek) then begin
  with ADOTable1 do begin
    Close;
    IndexName := strIndex;
    CursorLocation := clUseServer;
    Open;
    Seek (Edit1.Text, soFirstEQ);
   end;
   if ADOTable1.EOF then
    ShowMessage ('Record value NOT found');
 end;
 




Поиск записи в больших таблицах

Автор: Александр Куприн

Прочитал Ваши "Советы по Delphi" - спасибо большое: понравилось и, главное, помогло - никак не получалось нарисовать круглую форму. В свою очередь хочу предложить на Ваш суд небольшую процедуру, которая мне очень помогла. Процедура позволяет переходить на любую из записей в таблице (формат Paradox или DBase). Необходимость в ней возникла, когда мне пришлось работать с таблицей размером в 10 и более тысяч записей у которой было несколько калькулируемых полей и полей подлинкованных из объектов TQuery. При использовании метода TTable.MoveBy программа медленно и печально замолкала (вообще-то она работала, но как?!). Встретил я этот пример в технической документации Borland (2656), где сравнивались функции Paradox Engine и BDE. Пример был написан на C. Вот его интерпретация на Delphi:


 uses BDE;
 ...
 
 procedure MoveToRec(RecNo: longint; taSingle: TDBDataSet);
 // переход на логическую запись
 var
   ErrorCode: DBIResult;
   CursorProps: CurProps;
 begin
   ErrorCode := DbiGetCursorProps(taSingle.Handle, CursorProps);
   if ErrorCode = DBIERR_NONE then
   begin
     case TTable(taSingle).TableType of
       ttParadox: ErrorCode := DbiSetToSeqNo(taSingle.Handle, RecNo);
       ttDBase: ErrorCode := DbiSetToRecordNo(taSingle.Handle, RecNo);
     end; { case..}
     taSingle.Resync([rmCenter]);
   end { if..}
 end; { procedure MoveToRec }
 




Поиск в базе данных


- Я спpосил y Рэмблеpа: "где моя любимая?"
- Ты б еще у Яндекса, идиот, спpосил!

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

В данной статье будут рассмотрены различные способы поиска данных разработке ADO-приложений в Delphi

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

Давайте рассмотрим несколько способов расположения данных, полученных из БД посредствам компонента ADODataset (для Таблицы и для Запроса).

Locate

Этот универсальный метод поиска устанавливает текущую запись как первую строку, удовлетворяющую набору критериев поиска. Используя метод Locate мы можем искать значения одного или более полей, расположенных в массиве переменных. В приведённом ниже коде, метод Locate ищет первую запись, содержащую строку 'Zoom' в поле 'Name'. Если вызов Locate возвращает True - то запись найдена и установлена как текущая.


 AdoTable1.Locate('Name','Zoom',[]);
 
 {...или...}
 
 var
   ffield, fvalue: string;
   opts : TLocateOptions;
 
 ffield := 'Name';
 fvalue := 'zoom';
 opts := [loCaseInsensitive];
 
 if not AdoTable1.Locate(ffield, fvalue, opts) then
   ShowMessage(fvalue + ' not found in ' + ffield);
 

Lookup

Метод Lookup не перемещает курсор в соответствующую строку, а только возвращает её значение. Lookup возвращает массив переменных, содержащих значения из полей, указанных в разделённом точкой с запятой списке имён, значения которых должны быть возвращены из интересующей нас строки. Если соответствующих нашему запросу строк не найдено, то Lookup вернёт пустую (Null) переменную.

Следующий пример заполняет заполняет массив переменных LookupRes


 var
   LookupRes: Variant;
 
 LookupRes := ADOTable1.Lookup
 ('Name', 'Zoom', 'Author; Description');
 
 if not VarIsNull(LookupRes) then
   ShowMessage(VarToStr(LookupRes[0])) //имя автора
 

Одно из преимуществ методов Locate и Lookup, состоит в том, что они не требуют, чтобы таблица была проиндексирована. Однако, функция Locate будет работать намного быстрее, если таблица будет проиндексирована.

Индексирование

Индексирование помогает находить и сортировать записи намного быстрее. Вы можете создавать индексы основанные на одном поле либо на нескольких полях. Индексирование нескольких полей позволяет Вам различать записи, в которых первое поле может иметь то же самое значение. В большинстве случаев при частом поиске/сортировке желательно индексировать поля. Например, если Вы ищете определённый тип приложения в поле Type, то Вы можете создать индекс на это поле для ускорения поиска по типу. Следует упомянуть, что первичный ключ таблицы автоматически проиндексирован, а так же Вы не можете индексировать поля с типом данных OLE Object. И ещё, обратите внимание, что если многие из значений в поле те же самые, то индексирование в данном случае не ускорит процесс получения данных из БД.

BDE (не ADO) Delphi предоставляет нам определённые функции для работы с таблицами базы данных, которые позволяют нам производить поиск необходимых значений. Вот некоторые из них Goto, GoToKey, GoToNearest, Find, FindKey, Find Nearest, и т.д. Для более полной справки по этим методам, Вам следует посмотреть в справке Delphi, в разделе: Searching for records based on indexed fields. ADO напротив не поддерживает эти методы. Вместо этого он представляет метод Seek.

Seek

В ADO метод Seek использует индекс для поиска данных. Наример, при поиске в базе данных Access, если не задать индекс, то база данных будет использовать Первичный индексный ключ.

Seek используется для поиска записей с указанным значением (или значениями) в поле (либо полях) на которых основан текущий индекс. Если Seek не находит желаемую строку, то никакой ошибки не выдаётся, а курсор устанавливается в конец данных. Seek возвращает значение boolean, указывающее на успешность поиска: True если запись была найдена либо False если записей удовлетворяющих нашим требований не было найдено.

Метод GetIndexNames в компоненте TADOTable возвращает список (например: ячеек combo box) доступных индексов для таблицы.


 ADOTable1.GetIndexNames(ComboBox1.Items);
 

Этот же список доступен в режиме разработки в свойстве IndexName компонента TADOTable. Свойство IndexFieldNames может использоваться как альтернативный метод для определения индекса используемого в таблице. В IndexFieldNames, мы указываем имя каждого поля для использования в таблице.

Метод Seek имеет следующее определение:


 function Seek(const KeyValues: Variant;
 SeekOption: TSeekOption = soFirstEQ): Boolean;
 

  • KeyValues массив значений Variant. Так как индекс состоит из одного или более столбцов, то массив содержит значения, которые будут сравниваться с соответствующими столбцами.
  • SeekOption указывает на тип сравнивания между колонками индекса и соответствующим KeyValues.

Значения SeekOption:

soFirstEQ
Указатель на запись позиционируется в первую удовлетворяющую требованиям запись, если она найдена, либо в конец таблицы, если не найдена
soLastEQ
Указатель на запись позиционируется на последнюю удовлетворяющую требованиям запись если она найдена, либо в конец таблицы если нет.
soAfterEQ
Указатель на запись позиционируется на удовлетворяющую требованиям запись, если таковая найдена, либо сразу после той, которая была найдена.
soAfter
Указатель на запись позиционируется сразу после той, которая была найдена.
soBeforeEQ
Указатель на запись позиционируется на удовлетворяющую требованиям запись, если таковая найдена, либо перед той, которая была найдена.
soBefore
Указатель на запись позиционируется перед той записью, которая была найдена.

Примечание 1:

метод Seek поддерживает курсоры только на стороне сервера (server-side). Seek не будет работать, если значение свойства CursorLocation равно clUseClient. Для этого используется метод Supports для определения основного провайдера, поддерживающего Seek.

Примечание 2:

когда Вы используйте метод Seek для нескольких полей, то Seek поля должны быть в том же самом порядке как поля в основной таблице. Если это не так, то метод Seek выдаст ошибку.

Примечание 3:

Вы не сможете использовать метод Seek в компоненте TADOQuery.

Чтобы определять, была ли соответствующая запись найдена, мы используем свойства BOF или EOF (в зависимости от направления поиска). Следующий код использует индекс, указанный в ComboBox, чтобы найти значение, содержащееся в окне редактирования Edit1.


 var
   strIndex: string;
 
 strIndex := ComboBox1.Text; //из примера выше
 
 if ADOTable1.Supports(coSeek) then
 begin
   with ADOTable1 do
   begin
     Close;
     IndexName := strIndex;
     CursorLocation := clUseServer;
     Open;
     Seek (Edit1.Text, soFirstEQ);
   end;
   if ADOTable1.EOF then
     ShowMessage ('Record value NOT found');
 end;
 




Поиск в DBGride без ввода искомого значения в поле ввода

Твой Windows свопиться украдкой
На твой заполненый хард драйв
В него тихонько кинь гранаткой
Чтоб больше места он не взял.

Можно обрабатывать событие OnKeyPress компонента DBGrid:


 procedure TSubscriber_frm.RxDBGrid1KeyPress(Sender: TObject;
           var Key: Char);
 begin
   // если набор номера (численного значения)
   if ((Ord(key)>=48) and (Ord(key)<=57)) or ((Ord(key)>=96) and (Ord(key)<=105)) then
   begin
     edit1.Visible:=True;
     edit1.SetFocus;
     edit1.Text:=key;
     edit1.SelStart:=1;
   end;
   // если набор текста
   if (Ord(key)>=192) and (Ord(key)<=255) then
   begin
     edit2.Visible:=True;
     edit2.SetFocus;
     edit2.Text:=key;
     edit2.SelStart:=1;
   end;
 end;
 

А в обработке события OnChange edit1 и edit2 применить ф-цию FindNearest по нужному полю. Прятать edit-ы , после удачного поиска, либо по нажатии пользователем стрелки, Enter-a и т.п.




Простейший сканер диска

Первое правило сисадина: "Лежаший на столе винчестер с данными выглядит точно так же как и винчестер без данных".

Вот пример, который ищет мп3 файлы на жестком диске...


 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 + '\*.mp3');
   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.
 




Поиск свойств

Я хотел бы во время выполнения приложения получить, если возможно, список всех свойств компонента. (Список и тип каждого свойства)

Хороший материал по этому вопросу вы найдете в typinfo.pas (каталог Docs); нижеследующий код заполнит компонент Memo именами свойств:


 Uses TypInfo;
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
   PropList: pPropList;
   J, I: Integer;
 begin
   Memo1.Lines.Clear;
   getMem(PropList, sizeof(tPropList));
   J := GetPropList(TypeInfo(tButton), tkProperties, PropList);
   for I := 0 to J - 1 do
     Memo1.Lines.Add(PropList^[I]^.Name);
   FreeMem(PropList, sizeof(tPropList));
 end;
 




Поиск строки текста в наследниках TCustomEdit

Автор: Aleksey

Пришло мне письмо от Алексея. На этот раз он прислал (цитирую): "юнит для поиска строки(текста) в TEdit, TMemo, или других компонентах (дочерних TCustomEdit'у)." Так как тескт "авторский" (более того, здесь также присутствует наследование), помещаю его здесь в том виде, в котором он был прислан, т.е. без перевода. В случае каких-либо вопросов и недоразумений обращайтесь по вышеуказанносу адресу электронной почты.


 {ПРИМЕР :
 
 [...]
 
 implementation
 
 uses Search;}
 {$R *.DFM}
 
 {procedure TForm1.Button1Click(Sender: TObject);
 begin
 
 SearchMemo(RichEdit1, 'Найди меня', [frDown]);
 end;
 
 В опции поиска можно подключать, отключать, комбинировать следующие
 параметры:
 frDown - указывает на то, что происходит поиск вниз по тексту от курсора(при
 отключенном frDown'е будет происходит поиск вверх по тексту).
 frMatchCase - указывает на то, что следует проводить поиск с учетом
 регистра.
 frWholeWord - указывает на то, что следует искать только слово целиком.
 
 [...]
 
 Авторские права на этот юнит пренадлежат неизвесно кому.
 
 В каком виде этот юнит попал мне, практически в этом же
 виде я отдаю его вам. Пользуйтесь и благодарите неизвесного
 героя.}
 
 unit Search;
 
 interface
 
 uses
 
   WinProcs, SysUtils, StdCtrls, Dialogs;
 
 const
   {****************************************************************************
 
   * Default word delimiters are any character except the core alphanumerics. *
   ****************************************************************************}
   WordDelimiters: set of Char = [#0..#255] - ['a'..'z', 'A'..'Z', '1'..'9',
     '0'];
   {******************************************************************************
 
   * SearchMemo scans the text of a TEdit, TMemo, or other TCustomEdit-derived  *
   * component for a given search string. The search starts at the current      *
   * caret position in the control.  The Options parameter determines whether   *
   * the search runs forward (frDown) or backward from the caret position,      *
   * whether or not the text comparison is case sensitive, and whether the      *
   * matching string must be a whole word.  If text is already selected in the  *
   * control, the search starts at the 'far end' of the selection (SelStart if  *
   * searching backwards, SelEnd if searching forwards).  If a match is found,  *
   * the control's text selection is changed to select the found text and the   *
   * function returns True.  If no match is found, the function returns False.  *
   ******************************************************************************}
 function SearchMemo(Memo: TCustomEdit;
 
   const SearchString: string;
   Options: TFindOptions): Boolean;
 {******************************************************************************
 
 * SearchBuf is a lower-level search routine for arbitrary text buffers.      *
 * Same rules as SearchMemo above. If a match is found, the function returns  *
 * a pointer to the start of the matching string in the buffer. If no match,  *
 * the function returns nil.                                                  *
 ******************************************************************************}
 function SearchBuf(Buf: PChar; BufLen: Integer;
 
   SelStart, SelLength: Integer;
   SearchString: string;
   Options: TFindOptions): PChar;
 
 implementation
 
 function SearchMemo(Memo: TCustomEdit;
 
   const SearchString: string;
   Options: TFindOptions): Boolean;
 var
 
   Buffer, P: PChar;
   Size: Word;
 begin
 
   Result := False;
   if (Length(SearchString) = 0) then
     Exit;
   Size := Memo.GetTextLen;
   if Size = 0 then
     Exit;
   Buffer := StrAlloc(Size + 1);
   try
     Memo.GetTextBuf(Buffer, Size + 1);
     P := SearchBuf(Buffer, Size, Memo.SelStart, Memo.SelLength, SearchString,
       Options);
     if P <> nil then
     begin
       Memo.SelStart := P - Buffer;
       Memo.SelLength := Length(SearchString);
       Result := True;
     end;
   finally
     StrDispose(Buffer);
   end;
 end;
 
 function SearchBuf(Buf: PChar; BufLen: Integer;
 
   SelStart, SelLength: Integer;
   SearchString: string;
   Options: TFindOptions): PChar;
 var
 
   SearchCount, I: Integer;
   C: Char;
   Direction: Shortint;
   CharMap: array[Char] of Char;
 
   function FindNextWordStart(var BufPtr: PChar): Boolean;
   begin { (True XOR N) is equivalent to (not N) }
     //    Result := False;      { (False XOR N) is equivalent to (N)    }
 
     { When Direction is forward (1), skip non delimiters, then skip delimiters. }
     { When Direction is backward (-1), skip delims, then skip non delims }
 
     while (SearchCount > 0) and
       ((Direction = 1) xor
       (BufPtr^ in WordDelimiters)) do
     begin
       Inc(BufPtr, Direction);
       Dec(SearchCount);
     end;
 
     while (SearchCount > 0) and
       ((Direction = -1) xor
       (BufPtr^ in WordDelimiters)) do
     begin
       Inc(BufPtr, Direction);
       Dec(SearchCount);
     end;
 
     Result := SearchCount > 0;
     if Direction = -1 then
     begin {back up one char, to leave ptr on first non delim}
       Dec(BufPtr, Direction);
       Inc(SearchCount);
     end;
   end;
 
 begin
 
   Result := nil;
 
   if BufLen <= 0 then
     Exit;
 
   if frDown in Options then
   begin {if frDown...}
     Direction := 1;
     Inc(SelStart, SelLength); { start search past end of selection }
     SearchCount := BufLen - SelStart - Length(SearchString);
 
     if SearchCount < 0 then
       Exit;
 
     if Longint(SelStart) + SearchCount > BufLen then
       Exit;
 
   end {if frDown...}
   else
   begin {else}
     Direction := -1;
     Dec(SelStart, Length(SearchString));
     SearchCount := SelStart;
   end; {else}
 
   if (SelStart < 0) or (SelStart > BufLen) then
     Exit;
 
   Result := @Buf[SelStart];
   { Using a Char map array is faster than calling AnsiUpper on every character }
 
   for C := Low(CharMap) to High(CharMap) do
     CharMap[C] := C;
 
   if not (frMatchCase in Options) then
   begin {if not (frMatchCase}
     AnsiUpperBuff(PChar(@CharMap), sizeof(CharMap));
     AnsiUpperBuff(@SearchString[1], Length(SearchString));
   end; {if not (frMatchCase}
 
   while SearchCount > 0 do
   begin {while SearchCount}
     if frWholeWord in Options then
     begin
       if not FindNextWordStart(Result) then
         Break;
     end;
     I := 0;
 
     while (CharMap[Result[I]] = SearchString[I + 1]) do
     begin {while (CharMap...}
       Inc(I);
       if I >= Length(SearchString) then
       begin {if I >=...}
         if (not (frWholeWord in Options)) or
           (SearchCount = 0) or
           (Result[I] in WordDelimiters) then
           Exit;
         Break;
       end; {if I >=...}
     end; {while (CharMap...}
 
     Inc(Result, Direction);
     Dec(SearchCount);
   end; {while SearchCount}
 
   Result := nil;
 end;
 
 end.
 




Поиск текста в текстовом файле


 unit BMSearch;
 
 (* -------------------------------------------------------------------
 
 Поиск строки методом Boyer-Moore.
 
 Это - один из самых быстрых алгоритмов поиска строки.
 See a description in:
 
 R. Boyer и S. Moore.
 Быстрый алгоритм поиска строки.
 Communications of the ACM 20, 1977, страницы 762-772
 ------------------------------------------------------------------- *)
 
 interface
 
 type
 {$IFDEF WINDOWS}
 
   size_t = Word;
 {$ELSE}
 
   size_t = LongInt;
 {$ENDIF}
 
 type
 
   TTranslationTable = array[char] of char; { таблица перевода }
 
   TSearchBM = class(TObject)
   private
     FTranslate: TTranslationTable; { таблица перевода }
     FJumpTable: array[char] of Byte; { таблица переходов }
     FShift_1: integer;
     FPattern: pchar;
     FPatternLen: size_t;
 
   public
     procedure Prepare(Pattern: pchar; PatternLen: size_t; IgnoreCase: Boolean);
     procedure PrepareStr(const Pattern: string; IgnoreCase: Boolean);
 
     function Search(Text: pchar; TextLen: size_t): pchar;
     function Pos(const S: string): integer;
   end;
 
 implementation
 
 uses SysUtils;
 
 (* -------------------------------------------------------------------
 
 Игнорируем регистр таблицы перевода
 ------------------------------------------------------------------- *)
 
 procedure CreateTranslationTable(var T: TTranslationTable; IgnoreCase: Boolean);
 var
 
   c: char;
 begin
 
   for c := #0 to #255 do
     T[c] := c;
 
   if not IgnoreCase then
     exit;
 
   for c := 'a' to 'z' do
     T[c] := UpCase(c);
 
   { Связываем все нижние символы с их эквивалентом верхнего регистра }
 
   T['Б'] := 'A';
   T['А'] := 'A';
   T['Д'] := 'A';
   T['В'] := 'A';
 
   T['б'] := 'A';
   T['а'] := 'A';
   T['д'] := 'A';
   T['в'] := 'A';
 
   T['Й'] := 'E';
   T['И'] := 'E';
   T['Л'] := 'E';
   T['К'] := 'E';
 
   T['й'] := 'E';
   T['и'] := 'E';
   T['л'] := 'E';
   T['к'] := 'E';
 
   T['Н'] := 'I';
   T['М'] := 'I';
   T['П'] := 'I';
   T['О'] := 'I';
 
   T['н'] := 'I';
   T['м'] := 'I';
   T['п'] := 'I';
   T['о'] := 'I';
 
   T['У'] := 'O';
   T['Т'] := 'O';
   T['Ц'] := 'O';
   T['Ф'] := 'O';
 
   T['у'] := 'O';
   T['т'] := 'O';
   T['ц'] := 'O';
   T['ф'] := 'O';
 
   T['Ъ'] := 'U';
   T['Щ'] := 'U';
   T['Ь'] := 'U';
   T['Ы'] := 'U';
 
   T['ъ'] := 'U';
   T['щ'] := 'U';
   T['ь'] := 'U';
   T['ы'] := 'U';
 
   T['с'] := 'С';
 end;
 
 (* -------------------------------------------------------------------
 
 Подготовка таблицы переходов
 ------------------------------------------------------------------- *)
 
 procedure TSearchBM.Prepare(Pattern: pchar; PatternLen: size_t;
 
   IgnoreCase: Boolean);
 var
 
   i: integer;
   c, lastc: char;
 begin
 
   FPattern := Pattern;
   FPatternLen := PatternLen;
 
   if FPatternLen < 1 then
     FPatternLen := strlen(FPattern);
 
   { Данный алгоритм базируется на наборе из 256 символов }
 
   if FPatternLen > 256 then
     exit;
 
   { 1. Подготовка таблицы перевода }
 
   CreateTranslationTable(FTranslate, IgnoreCase);
 
   { 2. Подготовка таблицы переходов }
 
   for c := #0 to #255 do
     FJumpTable[c] := FPatternLen;
 
   for i := FPatternLen - 1 downto 0 do
   begin
     c := FTranslate[FPattern[i]];
     if FJumpTable[c] >= FPatternLen - 1 then
       FJumpTable[c] := FPatternLen - 1 - i;
   end;
 
   FShift_1 := FPatternLen - 1;
   lastc := FTranslate[Pattern[FPatternLen - 1]];
 
   for i := FPatternLen - 2 downto 0 do
     if FTranslate[FPattern[i]] = lastc then
     begin
       FShift_1 := FPatternLen - 1 - i;
       break;
     end;
 
   if FShift_1 = 0 then
     FShift_1 := 1;
 end;
 
 procedure TSearchBM.PrepareStr(const Pattern: string; IgnoreCase: Boolean);
 var
 
   str: pchar;
 begin
 
   if Pattern <> '' then
   begin
 {$IFDEF Windows}
 
     str := @Pattern[1];
 {$ELSE}
 
     str := pchar(Pattern);
 {$ENDIF}
 
     Prepare(str, Length(Pattern), IgnoreCase);
   end;
 end;
 
 { Поиск последнего символа & просмотр справа налево }
 
 function TSearchBM.Search(Text: pchar; TextLen: size_t): pchar;
 var
 
   shift, m1, j: integer;
   jumps: size_t;
 begin
 
   result := nil;
   if FPatternLen > 256 then
     exit;
 
   if TextLen < 1 then
     TextLen := strlen(Text);
 
   m1 := FPatternLen - 1;
   shift := 0;
   jumps := 0;
 
   { Поиск последнего символа }
 
   while jumps <= TextLen do
   begin
     Inc(Text, shift);
     shift := FJumpTable[FTranslate[Text^]];
     while shift <> 0 do
     begin
       Inc(jumps, shift);
       if jumps > TextLen then
         exit;
 
       Inc(Text, shift);
       shift := FJumpTable[FTranslate[Text^]];
     end;
 
     { Сравниваем справа налево FPatternLen - 1 символов }
 
     if jumps >= m1 then
     begin
       j := 0;
       while FTranslate[FPattern[m1 - j]] = FTranslate[(Text - j)^] do
       begin
         Inc(j);
         if j = FPatternLen then
         begin
           result := Text - m1;
           exit;
         end;
       end;
     end;
 
     shift := FShift_1;
     Inc(jumps, shift);
   end;
 end;
 
 function TSearchBM.Pos(const S: string): integer;
 var
 
   str, p: pchar;
 begin
 
   result := 0;
   if S <> '' then
   begin
 {$IFDEF Windows}
 
     str := @S[1];
 {$ELSE}
 
     str := pchar(S);
 {$ENDIF}
 
     p := Search(str, Length(S));
     if p <> nil then
       result := 1 + p - str;
   end;
 end;
 
 end.
 




Как найти директорию TEMP в Windows



 function c_GetTempPath: string;
 var
   Buffer: array[0..1023] of Char;
 begin
   SetString(Result, Buffer, GetTempPath(Sizeof(Buffer) - 1, Buffer));
 end;
 

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

  • GetCurrentDirectory
  • GetSystemDirectory
  • GetWindowsDirectory



Как найти каталог Windows

Преподаватель в театральном вузе - студенту-компьютерщику:
- Нежность надо изобразить! Нежность! А не эту идиотскую ухмылку!
Ну, представьте, что вы смотрите на монитор с OS/2. Хорошо. Вот так лучше. А теперь представьте на мониторе Юникс. Браво! Отлично! Сам Станиславский был бы доволен. А теперь изобразите чувство негодования. Опять не получается. Хорошо. Представьте на мониторе Windows 95.Я просил негодование, а не взрыв бешенства. Ладно. Тогда представьте на мониторе Windows 3.11. Это скепсис, а не негодование. Представьте тогда Windows NT. Мне не нужна ласковая улыбка! Мне, нужно негодование! Ну, давайте вообразим на мониторе Internet Exрlorer. О! Негодование сыграно отлично. Ну, и наконец, сами изобразите мне какое-нибудь чувство, представив на экране Лексикон. Молодой человек! Не надо блевать в аудитории!


 public
   { Public declarations }
   Windir: string;
   WindirP: PChar;
   Res: Cardinal;
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   WinDirP := StrAlloc(MAX_PATH);
   Res := GetWindowsDirectory(WinDirP, MAX_PATH);
   if Res > 0 then
     WinDir := StrPas(WinDirP);
   Label1.Caption := WinDir;
 end;
 




Как найти каталог Windows 2

Win95 как самолет - тошнит, а выйти некуда!


 {$IFNDEF WIN32}
 const MAX_PATH = 144;
 {$ENDIF}
 
 ...
 implementation
 ...
 
 var
   a : array[0..MAX_PATH] of char;
 begin
   GetWindowsDirectory(a, sizeof(a));
   ShowMessage(StrPas(a));
   GetSystemDirectory(a, sizeof(a));
   ShowMessage(StrPas(a));
 




Как найти каталог Windows 3

Продается стиральная машина "Windows-95". Стирает все.

%WinDir - что бы это значило?

Часто можно видеть что-то похожее на это: "файл располагается в директории %WinDir\file.ext, где %WinDir - системная директория Windows." Так что бы это значило - %WinDir?

Если Вы устанавливали Windows, принимая все по умолчанию, то Windows у Вас установлен в директорию C:\WINDOWS. Однако иногда люди по каким-либо побуждениям устанавливают Windows в другую директорию, например, C:\WIN0000.

Иногда нужно бывает обратиться к какому-либо файлу, который находится как раз в этой %WinDir директории. Можно, конечно, написать C:\WINDOWS, но, тогда с уверенностью можно сказать, что на части компьютеров эта программа не пройдет.

Предлагаю Вам такую процедуру:


 procedure TForm1.Button2Click(Sender: TObject);
 var
   F: TextFile;
   St, Res: string;
 begin
   AssignFile(F,'c:\msdos.sys');
   Reset(F);
   while not Eof(F) do
   begin
     ReadLn(F, St);
     if Copy(St, 1, 6) = 'WinDir' then
       Break;
   end;
   CloseFile(F);
   Res := Copy(St, 8, Length(St) - 7);
   Edit1.Text := res;
 end;
 

После выполнения этой процедуры в переменную Res записывается значение %WinDir.




Перевести секунды в формат времени

В одной старой-старой стране, в старом-старом городе, в старом-старом замке, в старой-старой комнате, сидит, окутанный старой-старой паутиной, старый-старый скелет. Перед ним монитор, а на мониторе надпись:
- Windows is now loading. Please wait!


 const
   SecPerDay = 86400;
   SecPerHour = 3600;
   SecPerMinute = 60;
 
 function SecondToTime(const Seconds: Cardinal): Double;
 var
   ms, ss, mm, hh, dd: Cardinal;
 begin
   dd := Seconds div SecPerDay;
   hh := (Seconds mod SecPerDay) div SecPerHour;
   mm := ((Seconds mod SecPerDay) mod SecPerHour) div SecPerMinute;
   ss := ((Seconds mod SecPerDay) mod SecPerHour) mod SecPerMinute;
   ms := 0;
   Result := dd + EncodeTime(hh, mm, ss, ms);
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   label1.Caption := DateTimeToStr(Date + SecondToTime(86543));
 end;
 




Как захватить весь вывод в консоли


 unit consoleoutput;
 
 interface
 
 uses
   Controls, Windows, SysUtils, Forms;
 
 function GetDosOutput(const CommandLine: string): string;
 
 implementation
 
 function GetDosOutput(const CommandLine: string): string;
 var
   SA: TSecurityAttributes;
   SI: TStartupInfo;
   PI: TProcessInformation;
   StdOutPipeRead, StdOutPipeWrite: THandle;
   WasOK: Boolean;
   Buffer: array[0..255] of Char;
   BytesRead: Cardinal;
   WorkDir, Line: string;
 begin
   Application.ProcessMessages;
   with SA do
   begin
     nLength := SizeOf(SA);
     bInheritHandle := True;
     lpSecurityDescriptor := nil;
   end;
   // созда¸м пайп для перенаправления стандартного вывода
   CreatePipe(StdOutPipeRead, // дескриптор чтения
     StdOutPipeWrite, // дескриптор записи
     @SA, // аттрибуты безопасности
     0 // количество байт принятых для пайпа - 0 по умолчанию
     );
   try
     // Созда¸м дочерний процесс, используя StdOutPipeWrite в качестве стандартного вывода,
     // а так же проверяем, чтобы он не показывался на экране.
     with SI do
     begin
       FillChar(SI, SizeOf(SI), 0);
       cb := SizeOf(SI);
       dwFlags := STARTF_USESHOWWINDOW or STARTF_USESTDHANDLES;
       wShowWindow := SW_HIDE;
       hStdInput := GetStdHandle(STD_INPUT_HANDLE); // стандартный ввод не перенаправляем
       hStdOutput := StdOutPipeWrite;
       hStdError := StdOutPipeWrite;
     end;
 
     // Запускаем компилятор из командной строки
     WorkDir := ExtractFilePath(CommandLine);
     WasOK := CreateProcess(nil, PChar(CommandLine), nil, nil, True, 0, nil, PChar(WorkDir), SI, PI);
 
     // Теперь, когда дескриптор получен, для безопасности закрываем запись.
     // Нам не нужно, чтобы произошло случайное чтение или запись.
     CloseHandle(StdOutPipeWrite);
     // если процесс может быть создан, то дескриптор, это его вывод
     if not WasOK then
       raise Exception.Create('Could not execute command line!')
     else
     try
         // получаем весь вывод до тех пор, пока DOS-приложение не будет завершено
       Line := '';
       repeat
           // читаем блок символов (могут содержать возвраты каретки и переводы строки)
         WasOK := ReadFile(StdOutPipeRead, Buffer, 255, BytesRead, nil);
 
           // есть ли что-нибудь ещ¸ для чтения?
         if BytesRead > 0 then
         begin
             // завершаем буфер PChar-ом
           Buffer[BytesRead] := #0;
             // добавляем буфер в общий вывод
           Line := Line + Buffer;
         end;
       until not WasOK or (BytesRead = 0);
         // жд¸м, пока завершится консольное приложение
       WaitForSingleObject(PI.hProcess, INFINITE);
     finally
         // Закрываем все оставшиеся дескрипторы
       CloseHandle(PI.hThread);
       CloseHandle(PI.hProcess);
     end;
   finally
     result := Line;
     CloseHandle(StdOutPipeRead);
   end;
 end;
 
 end.
 




Как скопировать выбранные в DBGrid записи в клипборд

Автор: Тенцер А.Л.


 const
  FIELD_DELIMITER = #9;
  RECORD_DELIMITER = #10;
 
 
 procedure CopyDBGridToClipboard( Grid : TDBGrid );
 var
  BM : String;
  S : String;
  S1: String;
  I : Integer;
 begin
  with Grid  do begin
   if Assigned( DataSource ) and
      Assigned( DataSource.DataSet ) and
      DataSource.DataSet.Active then
   with DataSource.DataSet do begin
    S := '';
    DisableControls;
    BM := BookMark;
    for I := 0 to Pred( Columns.Count ) do begin
     if Assigned(Columns.Items[I].Field) then
       S := S + Columns.Items[I].Title.Caption + FIELD_DELIMITER;
    end;
    S[ Length( S ) ] := RECORD_DELIMITER;
    First;
    while not Eof do begin
     S1 := '';
     for I := 0 to Pred( Columns.Count ) do begin
       if Assigned(Columns.Items[I].Field) then
         S1 := S1 + FieldByName( Columns[I].FieldName ).AsString +
 FIELD_DELIMITER;
     end;
     S1[ Length( S1 ) ] := RECORD_DELIMITER;
     S := S + S1;
     Next;
    end;
    BookMark := BM;
    EnableControls;
 //   Clipboard.SetTextBuf( PChar( S ) );
    SendToClipboard( S );
   end;
  end;
 end;
 




Каким обpазом выбиpать pазмеp шpифта

Автор: Nomadic

Каким обpазом выбиpать pазмеp шpифта, т.к. все мои стpадания по выбоpyпаpаметpов шpифта в CreateFont() никак не отpажались на его pазмеpе. Все что я пpидyмал, это юзать glScale(), но в этом слyчае полyчаем плохое качество (по сpавнению с той-же Воpдой) пpи малом pазмеpе символов

Вот часть работающего примера на Си (переведенного мною на Паскаль (АА)).


 procedure GLSetupRC(pData: Pointer)
   //void GLSetupRC(void *pData)
 //{
 var
   //  HDC hDC;
 
   hDC: HDC;
   //  HFONT hFont;
 
   hFont: HFONT;
   //  GLYPHMETRICSFLOAT agmf[128];
   agmf: array[0..127] of GLYPHMETRICSFLOAT;
   //  LOGFONT logfont;
 
   logfont: LOGFONT;
 
 begin
 
   logfont.lfHeight := -10;
   logfont.lfWidth := 0;
   logfont.lfEscapement := 0;
   logfont.lfOrientation := 0;
   logfont.lfWeight := FW_BOLD;
   logfont.lfItalic := FALSE;
   logfont.lfUnderline := FALSE;
   logfont.lfStrikeOut := FALSE;
   logfont.lfCharSet := ANSI_CHARSET;
   logfont.lfOutPrecision := OUT_DEFAULT_PRECIS;
   logfont.lfClipPrecision := CLIP_DEFAULT_PRECIS;
   logfont.lfQuality := DEFAULT_QUALITY;
   logfont.lfPitchAndFamily := DEFAULT_PITCH;
   //strcpy(logfont.lfFaceName,"Arial");
   //  strcpy(logfont.lfFaceName,"Decor");
 
   StrPCopy(logfont.lfFaceName, 'Decor');
 
   glDepthFunc(GL_LESS);
   glEnable(GL_DEPTH_TEST); // Hidden surface removal
   glFrontFace(GL_CCW); // Counter clock-wise polygons face out
   glEnable(GL_CULL_FACE); // Do not calculate insides
   glShadeModel(GL_SMOOTH); // Smooth shading
   glEnable(GL_AUTO_NORMAL);
   glEnable(GL_NORMALIZE);
   glEnable(GL_COLOR_MATERIAL);
 
   glClearColor(0.0, 0.0, 0.0, 1.0);
 
   glEnable(GL_LIGHTING);
   glLightfv(GL_LIGHT0, GL_AMBIENT, ambientLight);
   glLightfv(GL_LIGHT0, GL_DIFFUSE, diffuseLight);
   glLightfv(GL_LIGHT0, GL_SPECULAR, specular);
   glLightfv(GL_LIGHT0, GL_POSITION, lightPos);
   glEnable(GL_LIGHT0);
 
   glColorMaterial(GL_FRONT, GL_AMBIENT_AND_DIFFUSE);
   glMaterialfv(GL_FRONT, GL_SPECULAR, specular);
   glMateriali(GL_FRONT, GL_SHININESS, 100);
 
   // Blue 3D Text
   glRGB(0, 0, 255);
 
   // Select the font into the DC
   hDC := (HDC)pData;
   //  hFont = CreateFontIndirect(&logfont);
 
   hFont := CreateFontIndirect(Addr(logfont));
   SelectObject(hDC, hFont);
 
   //create display lists for glyphs 0 through 255 with 0.3 extrusion
   // and default deviation. The display list numbering starts at 1000
   // (it could be any number).
   //  if(!wglUseFontOutlines(hDC, 0, 128, 1000, 0., 0.3,
   //                            WGL_FONT_POLYGONS, agmf))
 
   if not wglUseFontOutlines(hDC, 0, 128, 1000, 0., 0.3,
 
     //>                                         ``` - это тебе поможет
     //> Выводить текст можно в любым масштабе
 
     WGL_FONT_POLYGONS, agmf) then
 
     Windows.MessageBox(nil, 'Could not create Font Outlines',
       'Error', MB_OK or MB_ICONSTOP);
 
   // Delete the font now that we are done
   DeleteObject(hFont);
   //}
 end;
 
 // void GLRenderScene(void *pData)
 
 procedure GLRenderScene(pData: Pointer);
 begin
 
   (*  ...  *)
 
   // Draw 3D text
   glListBase(1000);
   glPushMatrix();
   // Set up transformation to draw the string.
   glTranslatef(-35.0, 0.0, -5.0);
   glScalef(60.0, 60.0, 60.0);
   glCallLists(3, GL_UNSIGNED_BYTE, 'Decor');
   glPopMatrix(); // Clear the window with current clearing color
 
   (* ... *)
 end;
 




Как выделить в RichEdit 4 строки

Год назад. Раздается в нашей конторе звонок. Поднимает трубку человек, там кого-то просят, кто в другой комнате ... человек оглядывает присутствующих "Как в соседню комнату перевести? Какай там адрес? www а дальше что?"

Строки нумеруются с 0!


 with richedit1 do
 begin
   selstart:=FindText(lines[3],0,length(text), [stWholeWord]);
   sellength:=length(lines[3]);
   selattributes.color:=clBlue;
 end;
 

работает, если строка уникальная,
иначе можно - вычислять начало


 sstart := 0;
 for i := 0 to numstr - 1 do
   sstart := sstart + length(lines[i]) + 2; // numstr=3
 selstart := sstart; // для 4 строки
 




Выделить строку в Memo

Возвращаюсь вечером с работы домой, устал естессно, причём день выдался сплошь да рядом связаный с аккаунтами... подхожу к двери подъезда, вставляю ключ, дёргаю дверь... дверь не открывается - первая мысль "БЛИН , ОПЯТЬ ПАРОЛЬ СМЕНИЛИ"...(на самом деле ключ не до конца вставил)


 procedure TfrmMain.Memo1Click(Sender: TObject);
 var
   Line: Integer;
 begin
   with (Sender as TMemo) do
   begin
     Line      := Perform(EM_LINEFROMCHAR, SelStart, 0);
     SelStart  := Perform(EM_LINEINDEX, Line, 0);
     SelLength := Length(Lines[Line]);
   end;
 end;
 




Выделение меню

- Как размножается Microsoft?
- Делением.


 Function SelectMenu(winname,item,subitem:string):boolean;
 // winname - имя окна, item - имя пункта меню, subitem - имя подпункта
 var winhandle,menuhandle,submenuhandle,i,j,res:integer;
    itemname,subitemname:pchar;
 begin
 res:=-1;
 winhandle:=FindWindow(nil,pchar(winname));
 menuhandle:=getmenu(winhandle);
 getmem(itemname,255);
 getmem(subitemname,255);
 for i:=0 to getmenuitemcount(menuhandle)-1 do
    begin
    getmenustring(menuhandle,i,itemname,255,MF_BYPOSITION);
    if string(itemname)=item then begin
    submenuhandle:=getsubmenu(menuhandle,i);
    for j:=0 to getmenuitemcount(submenuhandle)-1 do
    begin
    getmenustring(submenuhandle,j,subitemname,255,MF_BYPOSITION);
    if string(subitemname)=subitem then
 res:=SendMessage(winhandle,WM_COMMAND,makelong(getmenuitemid(submenuhandle,j),0
 ),0);
    end;
    end;
 end;
 freemem(itemname);
 freemem(subitemname);
 if res=0 then result:=true else result:=false;
 end;
 




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

Автор: Даниил Карапетян
WEB сайт: http://program.dax.ru

- Как тpи пpогpаммиста могyт оpганизовать бизнес?
- Один пишет виpyсы, а дpyгой антивиpyсы.
- А тpетий?
- Опеpационные системы, под котоpыми это все pаботает.

Как реализовать выделение " резиновым прямоугольником" . Иными словами, когда пользоватьль нажимает на левую кнопку мыши и сдвигает ее, на экране появляется прямоугольник, изменяющий размеры при движении мыши, причем все объекты, попавшие в этот прямоугольник выделяются.

В качестве объекта я взял Label, меняющий цвет в зависимости от того, выделен он или нет. При нажатии мышью на форме в FirstPoint кладутся координата курсора. При дальнейшем движении мыши координаты прямоугольника будут высчитываться по FirstPoint и текущим координатам курсора. Причем, чтобы программа нормально отрабатывала случай, когда высота или ширина прямоугольника отрицательная (это произойдет, если увести мышь левее или выше начальной точки), создана процедура NormalRect. NormalRect устанавливает ко Скачать необходимые для компиляции файлы проекта можно на program.dax.ru/subscribe/. http://program.dax.ru/subscribe/index.htm


 uses stdctrls;
 
 var
   Selecting: boolean = false;
   FirstPoint: TPoint;
   sel: TRect;
 
 procedure DrawRect;
 begin
   with Form1.Canvas do begin
     Pen.Style := psDot;
     Pen.Color := clGray;
     Pen.Mode := pmXor;
     Brush.Style := bsClear;
     Rectangle(sel.Left, sel.Top, sel.Right, sel.Bottom);
   end;
 end;
 
 procedure NormalRect(p1, p2: TPoint);
 begin
   if p1.x <  p2.x then begin
     sel.Left := p1.x;
     sel.Right := p2.x;
   end else begin
     sel.Left := p2.x;
     sel.Right := p1.x;
   end;
   if p1.y <  p2.y then begin
     sel.Top := p1.y;
     sel.Bottom := p2.y;
   end else begin
     sel.Top := p2.y;
     sel.Bottom := p1.y;
   end;
 end;
 
 procedure TForm1.FormCreate(Sender: TObject);
 var i: integer;
 begin
   randomize;
   for i := 1 to random(5) + 5 do begin
     with TLabel.Create(Form1) do begin
       Caption := 'Label' + IntToStr(i);
       Left := random(Form1.ClientWidth - Width);
       Top := random(Form1.ClientHeight - Height);
       Visible := true;
       Parent := Form1;
     end;
   end;
 end;
 
 procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
   Shift: TShiftState; X, Y: Integer);
 begin
   if selecting or (Button < >  mbLeft) then Exit;
   SetCapture(Form1.Handle);
   Selecting := true;
   FirstPoint := Point(X, Y);
   sel := Bounds(X, Y, 0, 0);
 end;
 
 procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
   Y: Integer);
   procedure SelectLebel(lb: TLabel; r: TRect);
   var
     select: boolean;
     res: TRect;
   begin
     select := IntersectRect(res, lb.BoundsRect, r);
     if select and (lb.Color = clNavy) then Exit;
     if select then begin
       lb.Color := clNavy;
       lb.Font.Color := clWhite;
     end else begin
       lb.Color := clBtnFace;
       lb.Font.Color := clBlack;
     end;
   end;
 var
   i: integer;
 begin
   if not Selecting then Exit;
   DrawRect;
   NormalRect(FirstPoint, Point(X, Y));
   for i := 0 to Form1.ComponentCount - 1 do
     if (Form1.Components[i] is TLabel) then
       SelectLebel(Form1.Components[i] as TLabel, sel);
   Application.ProcessMessages;
   DrawRect;
 end;
 
 procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton;
   Shift: TShiftState; X, Y: Integer);
 begin
   if (not Selecting) or (Button < >  mbLeft) then Exit;
   NormalRect(FirstPoint, Point(X, Y));
   DrawRect;
   ReleaseCapture;
   Selecting := false;
 end;
 
 {
 Программа была протестирована:
 Дмитрий Бажин mailto:bsdriver@mail.ru
 Юрий Кравченко mailto:ykravchenko@ukr.net
 
 Все советы и замечания, пожалуйста,
 присылайте на subscribe@program.dax.ru
 
 Всего доброго,
 Даниил Карапетян.
 }
 




Почти полный аналог метода SendKeys из VB

Автор: Ken Henderson


 (*
 SendKeys routine for 32-bit Delphi.
 
 Written by Ken Henderson
 
 Copyright (c) 1995 Ken Henderson     email:khen@compuserve.com
 
 This unit includes two routines that simulate popular Visual Basic
 routines: Sendkeys and AppActivate.  SendKeys takes a PChar
 as its first parameter and a boolean as its second, like so:
 
 SendKeys('KeyString', Wait);
 
 where KeyString is a string of key names and modifiers that you want
 to send to the current input focus and Wait is a boolean variable or value
 that indicates whether SendKeys should wait for each key message to be
 processed before proceeding.  See the table below for more information.
 
 AppActivate also takes a PChar as its only parameter, like so:
 
 AppActivate('WindowName');
 
 where WindowName is the name of the window that you want to make the
 current input focus.
 
 SendKeys supports the Visual Basic SendKeys syntax, as documented below.
 
 Supported modifiers:
 
 + = Shift
 ^ = Control
 % = Alt
 
 Surround sequences of characters or key names with parentheses in order to
 modify them as a group.  For example, '+abc' shifts only 'a', while  '+(abc)' shifts
 all three characters.
 
 Supported special characters
 
 ~ = Enter
 ( = begin modifier group (see above)
 ) = end modifier group (see above)
 { = begin key name text (see below)
 } = end key name text (see below)
 
 Supported characters:
 
 Any character that can be typed is supported.  Surround the modifier keys
 listed above with braces in order to send as normal text.
 
 Supported key names (surround these with braces):
 
 BKSP, BS, BACKSPACE
 BREAK
 CAPSLOCK
 CLEAR
 DEL
 DELETE
 DOWN
 END
 ENTER
 ESC
 ESCAPE
 F1
 F2
 F3
 F4
 F5
 F6
 F7
 F8
 F9
 F10
 F11
 F12
 F13
 F14
 F15
 F16
 HELP
 HOME
 INS
 LEFT
 NUMLOCK
 PGDN
 PGUP
 PRTSC
 RIGHT
 SCROLLLOCK
 TAB
 UP
 
 Follow the keyname with a space and a number to send the specified key a
 given number of times (e.g., {left 6}).
 *)
 
 unit sndkey32;
 
 interface
 
 Uses SysUtils, Windows, Messages;
 
 Function SendKeys(SendKeysString : PChar; Wait : Boolean) : Boolean;
 function AppActivate(WindowName : PChar) : boolean;
 
 {Buffer for working with PChar's}
 
 const
   WorkBufLen = 40;
 var
   WorkBuf : array[0..WorkBufLen] of Char;
 
 implementation
 type
   THKeys = array[0..pred(MaxLongInt)] of byte;
 var
   AllocationSize : integer;
 
 (*
 Converts a string of characters and key names to keyboard events and
 passes them to Windows.
 
 Example syntax:
 
 SendKeys('abc123{left}{left}{left}def{end}456{left 6}ghi{end}789', True);
 
 *)
 
 Function SendKeys(SendKeysString : PChar; Wait : Boolean) : Boolean;
 type
   WBytes = array[0..pred(SizeOf(Word))] of Byte;
 
   TSendKey = record
     Name : ShortString;
     VKey : Byte;
   end;
 
 const
   {Array of keys that SendKeys recognizes.
 
   If you add to this list, you must be sure to keep it sorted alphabetically
   by Name because a binary search routine is used to scan it.}
 
   MaxSendKeyRecs = 41;
   SendKeyRecs : array[1..MaxSendKeyRecs] of TSendKey =
   (
    (Name:'BKSP';            VKey:VK_BACK),
    (Name:'BS';              VKey:VK_BACK),
    (Name:'BACKSPACE';       VKey:VK_BACK),
    (Name:'BREAK';           VKey:VK_CANCEL),
    (Name:'CAPSLOCK';        VKey:VK_CAPITAL),
    (Name:'CLEAR';           VKey:VK_CLEAR),
    (Name:'DEL';             VKey:VK_DELETE),
    (Name:'DELETE';          VKey:VK_DELETE),
    (Name:'DOWN';            VKey:VK_DOWN),
    (Name:'END';             VKey:VK_END),
    (Name:'ENTER';           VKey:VK_RETURN),
    (Name:'ESC';             VKey:VK_ESCAPE),
    (Name:'ESCAPE';          VKey:VK_ESCAPE),
    (Name:'F1';              VKey:VK_F1),
    (Name:'F10';             VKey:VK_F10),
    (Name:'F11';             VKey:VK_F11),
    (Name:'F12';             VKey:VK_F12),
    (Name:'F13';             VKey:VK_F13),
    (Name:'F14';             VKey:VK_F14),
    (Name:'F15';             VKey:VK_F15),
    (Name:'F16';             VKey:VK_F16),
    (Name:'F2';              VKey:VK_F2),
    (Name:'F3';              VKey:VK_F3),
    (Name:'F4';              VKey:VK_F4),
    (Name:'F5';              VKey:VK_F5),
    (Name:'F6';              VKey:VK_F6),
    (Name:'F7';              VKey:VK_F7),
    (Name:'F8';              VKey:VK_F8),
    (Name:'F9';              VKey:VK_F9),
    (Name:'HELP';            VKey:VK_HELP),
    (Name:'HOME';            VKey:VK_HOME),
    (Name:'INS';             VKey:VK_INSERT),
    (Name:'LEFT';            VKey:VK_LEFT),
    (Name:'NUMLOCK';         VKey:VK_NUMLOCK),
    (Name:'PGDN';            VKey:VK_NEXT),
    (Name:'PGUP';            VKey:VK_PRIOR),
    (Name:'PRTSC';           VKey:VK_PRINT),
    (Name:'RIGHT';           VKey:VK_RIGHT),
    (Name:'SCROLLLOCK';      VKey:VK_SCROLL),
    (Name:'TAB';             VKey:VK_TAB),
    (Name:'UP';              VKey:VK_UP)
   );
 
   {Extra VK constants missing from Delphi's Windows API interface}
   VK_NULL=0;
   VK_SemiColon=186;
   VK_Equal=187;
   VK_Comma=188;
   VK_Minus=189;
   VK_Period=190;
   VK_Slash=191;
   VK_BackQuote=192;
   VK_LeftBracket=219;
   VK_BackSlash=220;
   VK_RightBracket=221;
   VK_Quote=222;
   VK_Last=VK_Quote;
 
   ExtendedVKeys : set of byte =
   [VK_Up,
    VK_Down,
    VK_Left,
    VK_Right,
    VK_Home,
    VK_End,
    VK_Prior,  {PgUp}
    VK_Next,   {PgDn}
    VK_Insert,
    VK_Delete];
 
 const
   INVALIDKEY = $FFFF {Unsigned -1};
   VKKEYSCANSHIFTON = $01;
   VKKEYSCANCTRLON = $02;
   VKKEYSCANALTON = $04;
   UNITNAME = 'SendKeys';
 var
   UsingParens, ShiftDown, ControlDown, AltDown, FoundClose : Boolean;
   PosSpace : Byte;
   I, L : Integer;
   NumTimes, MKey : Word;
   KeyString : String[20];
 
 procedure DisplayMessage(Message : PChar);
 begin
   MessageBox(0,Message,UNITNAME,0);
 end;
 
 function BitSet(BitTable, BitMask : Byte) : Boolean;
 begin
   Result:=ByteBool(BitTable and BitMask);
 end;
 
 procedure SetBit(var BitTable : Byte; BitMask : Byte);
 begin
   BitTable:=BitTable or Bitmask;
 end;
 
 procedure KeyboardEvent(VKey, ScanCode : Byte; Flags : Longint);
 var
   KeyboardMsg : TMsg;
 begin
   keybd_event(VKey, ScanCode, Flags,0);
   If (Wait) then While (PeekMessage(KeyboardMsg,0,WM_KEYFIRST, WM_KEYLAST, PM_REMOVE)) do begin
     TranslateMessage(KeyboardMsg);
     DispatchMessage(KeyboardMsg);
   end;
 end;
 
 procedure SendKeyDown(VKey: Byte; NumTimes : Word; GenUpMsg : Boolean);
 var
   Cnt : Word;
   ScanCode : Byte;
   NumState : Boolean;
   KeyBoardState : TKeyboardState;
 begin
   If (VKey=VK_NUMLOCK) then begin
     NumState:=ByteBool(GetKeyState(VK_NUMLOCK) and 1);
     GetKeyBoardState(KeyBoardState);
     If NumState then KeyBoardState[VK_NUMLOCK]:=(KeyBoardState[VK_NUMLOCK] and not 1)
     else KeyBoardState[VK_NUMLOCK]:=(KeyBoardState[VK_NUMLOCK] or 1);
     SetKeyBoardState(KeyBoardState);
     exit;
   end;
 
   ScanCode:=Lo(MapVirtualKey(VKey,0));
   For Cnt:=1 to NumTimes do
     If (VKey in ExtendedVKeys)then begin
       KeyboardEvent(VKey, ScanCode, KEYEVENTF_EXTENDEDKEY);
       If (GenUpMsg) then
         KeyboardEvent(VKey, ScanCode, KEYEVENTF_EXTENDEDKEY or KEYEVENTF_KEYUP)
     end  else begin
       KeyboardEvent(VKey, ScanCode, 0);
       If (GenUpMsg) then KeyboardEvent(VKey, ScanCode, KEYEVENTF_KEYUP);
     end;
 end;
 
 procedure SendKeyUp(VKey: Byte);
 var
   ScanCode : Byte;
 begin
   ScanCode:=Lo(MapVirtualKey(VKey,0));
   If (VKey in ExtendedVKeys)then
     KeyboardEvent(VKey, Sca
   else KeyboardEvent(VKey, ScanCode, KEYEVENTF_KEYUP);
 end;
 
 procedure SendKey(MKey: Word; NumTimes : Word; GenDownMsg : Boolean);
 begin
   If (BitSet(Hi(MKey),VKKEYSCANSHIFTON)) then SendKeyDown(VK_SHIFT,1,False);
   If (BitSet(Hi(MKey),VKKEYSCANCTRLON)) then SendKeyDown(VK_CONTROL,1,False);
   If (BitSet(Hi(MKey),VKKEYSCANALTON)) then SendKeyDown(VK_MENU,1,False);
   SendKeyDown(Lo(MKey), NumTimes, GenDownMsg);
   If (BitSet(Hi(MKey),VKKEYSCANSHIFTON)) then SendKeyUp(VK_SHIFT);
   If (BitSet(Hi(MKey),VKKEYSCANCTRLON)) then SendKeyUp(VK_CONTROL);
   If (BitSet(Hi(MKey),VKKEYSCANALTON)) then SendKeyUp(VK_MENU);
 end;
 
 {Implements a simple binary search to locate special key name strings}
 
 function StringToVKey(KeyString : ShortString) : Word;
 var
   Found, Collided : Boolean;
   Bottom, Top, Middle : Byte;
 begin
   Result:=INVALIDKEY;
   Bottom:=1;
   Top:=MaxSendKeyRecs;
   Found:=false;
   Middle:=(Bottom+Top) div 2;
   Repeat
     Collided:=((Bottom=Middle) or (Top=Middle));
     If (KeyString=SendKeyRecs[Middle].Name) then begin
        Found:=True;
        Result:=SendKeyRecs[Middle].VKey;
     end  else begin
        If (KeyString>SendKeyRecs[Middle].Name) then Bottom:=Middle
        else Top:=Middle;
        Middle:=(Succ(Bottom+Top)) div 2;
     end;
   Until (Found or Collided);
   If (Result=INVALIDKEY) then DisplayMessage('Invalid Key Name');
 end;
 
 procedure PopUpShiftKeys;
 begin
   If (not UsingParens) then begin
     If ShiftDown then SendKeyUp(VK_SHIFT);
     If ControlDown then SendKeyUp(VK_CONTROL);
     If AltDown then SendKeyUp(VK_MENU);
     ShiftDown:=false;
     ControlDown:=false;
     AltDown:=false;
   end;
 end;
 
 begin
   AllocationSize:=MaxInt;
   Result:=false;
   UsingParens:=false;
   ShiftDown:=false;
   ControlDown:=false;
   AltDown:=false;
   I:=0;
   L:=StrLen(SendKeysString);
   If (L>AllocationSize) then L:=AllocationSize;
   If (L=0) then Exit;
 
   while  (Ibegin
     case SendKeysString[I] of
     '(' : begin
             UsingParens:=True;
             Inc(I);
           end;
     ')' : begin
             UsingParens:=False;
             PopUpShiftKeys;
             Inc(I);
           end;
     '%' : begin
              AltDown:=True;
              SendKeyDown(VK_MENU,1,False);
              Inc(I);
           end;
     '+' :  begin
              ShiftDown:=True;
              SendKeyDown(VK_SHIFT,1,False);
              Inc(I);
            end;
     '^' :  begin
              ControlDown:=True;
              SendKeyDown(VK_CONTROL,1,False);
              Inc(I);
            end;
     '{' : begin
             NumTimes:=1;
             If (SendKeysString[Succ(I)]='{') then begin
               MKey:=VK_LEFTBRACKET;
               SetBit(Wbytes(MKey)[1],VKKEYSCANSHIFTON);
               SendKey(MKey,1,True);
               PopUpShiftKeys;
               Inc(I,3);
               Continue;
             end;
             KeyString:='';
             FoundClose:=False;
             while  (I<=L) do begin
               Inc(I);
               If (SendKeysString[I]='}') then begin
                 FoundClose:=True;
                 Inc(I);
                 Break;
               end;
               KeyString:=KeyString+Upcase(SendKeysString[I]);
             end;
             If (Not FoundClose) then begin
                DisplayMessage('No Close');
                Exit;
             end;
             If (SendKeysString[I]='}') then begin
               MKey:=VK_RIGHTBRACKET;
               SetBit(Wbytes(MKey)[1],VKKEYSCANSHIFTON);
               SendKey(MKey,1,True);
               PopUpShiftKeys;
               Inc(I);
               Continue;
             end;
             PosSpace:=Pos(' ',KeyString);
             If (PosSpace<>0) then begin
                NumTimes:=StrToInt(Copy(KeyString,Succ(PosSpace),Length(KeyString)-PosSpace));
                KeyString:=Copy(KeyString,1,Pred(PosSpace));
             end;
             If (Length(KeyString)=1) then MKey:=vkKeyScan(KeyString[1])
             else MKey:=StringToVKey(KeyString);
             If (MKey<>INVALIDKEY) then begin
               SendKey(MKey,NumTimes,True);
               PopUpShiftKeys;
               Continue;
             end;
           end;
     '~' : begin
             SendKeyDown(VK_RETURN,1,True);
             PopUpShiftKeys;
             Inc(I);
           end;
     else  begin
              MKey:=vkKeyScan(SendKeysString[I]);
              If (MKey<>INVALIDKEY) then begin
                SendKey(MKey,1,True);
                PopUpShiftKeys;
              end else DisplayMessage('Invalid KeyName');
              Inc(I);
           end;
     end;
   end;
   Result:=true;
   PopUpShiftKeys;
 end;
 
 {AppActivate
 
 This is used to set the current input focus to a given window using its
 name.  This is especially useful for ensuring a window is active before
 sending it input messages using the SendKeys function.  You can specify
 a window's name in its entirety, or only portion of it, beginning from
 the left.
 
 }
 
 var
   WindowHandle : HWND;
 
 function EnumWindowsProc(WHandle: HWND; lParam: LPARAM): BOOL; export; stdcall;
 const
   MAX_WINDOW_NAME_LEN = 80;
 var
   WindowName : array[0..MAX_WINDOW_NAME_LEN] of char;
 begin
   {Can't test GetWindowText's return value since some windows don't have a title}
   GetWindowText(WHandle,WindowName,MAX_WINDOW_NAME_LEN);
   Result := (StrLIComp(WindowName,PChar(lParam), StrLen(PChar(lParam))) <> 0);
   If (not Result) then WindowHandle:=WHandle;
 end;
 
 function AppActivate(WindowName : PChar) : boolean;
 begin
   try
     Result:=true;
     WindowHandle:=FindWindow(nil,WindowName);
     If (WindowHandle=0) then EnumWindows(@EnumWindowsProc,Integer(PChar(WindowName)));
     If (WindowHandle<>0) then begin
       SendMessage(WindowHandle, WM_SYSCOMMAND, SC_HOTKEY, WindowHandle);
       SendMessage(WindowHandle, WM_SYSCOMMAND, SC_RESTORE, WindowHandle);
     end else Result:=false;
   except
     on Exception do Result:=false;
   end;
 end;
 
 end.
 




Как отправить нажатие клавиши с кодом 255 в элемент управления Windows

Ученые исследовательского подразделения MicroSoft подсчитали точное количество клавиш на клавиатуре...

Функция keybd_event() принимает значения до 244 - как мне отправить нажатие клавиши с кодом #255 в элемент управления Windows? Это может понадобится для иностранных языков или для специальных символов. (например, в русских шрифтах символ с кодом #255 - я прописное). Приведенный в примере метод, не стоит использовать в случае если символ может быть передан обычным способом (функцией keybd_event()).


 procedure TForm1.Button1Click(Sender: TObject);
 var
       KeyData : packed record
                 RepeatCount : word;
                 ScanCode : byte;
                 Bits : byte;
         end;
 begin
         {Let the button repaint}
         Application.ProcessMessages;
         {Set the focus to the window}
         Edit1.SetFocus;
         {Send a right so the char is added to the end of the line}
         //  SimulateKeyStroke(VK_RIGHT, 0);
         keybd_event(VK_RIGHT, 0,0,0);
         {Let the app get the message}
         Application.ProcessMessages;
         FillChar(KeyData, sizeof(KeyData), #0);
         KeyData.ScanCode := 255;
         KeyData.RepeatCount := 1;
         SendMessage(Edit1.Handle, WM_KEYDOWN, 255,LongInt(KeyData));
         KeyData.Bits := KeyData.Bits or (1 shl 30);
         KeyData.Bits := KeyData.Bits or (1 shl 31);
         SendMessage(Edit1.Handle, WM_KEYUP, 255, LongInt(KeyData));
         KeyData.Bits := KeyData.Bits and not (1 shl 30);
         KeyData.Bits := KeyData.Bits and not (1 shl 31);
         SendMessage(Edit1.Handle, WM_CHAR, 255, LongInt(KeyData));
         Application.ProcessMessages;
 end;
 




Отправить письмо на E-mail так, чтобы пользователь не подозревал об отправке


У одной провайдерской фирмы спросили:
- Почему Вы так активно создаёте сервисы бесплатного e-mail?
- Ну, как Вам сказать... А Вы читали когда-нибудь чужую почту?


 unit Email;
 
 interface
 
 uses
   Windows, SusUtils, Classes;
 
 function SendEmail(const RecipName, RecipAddress,
 Subject, Attachment: string): Boolean;
 
 function IsOnline: Boolean;
 
 implementation
 uses Mapi;
 
 function SendEmail(const RecipName, RecipAddress,
 Subject, Attachment: string): Boolean;
 var
   MapiMessage: TMapiMessage;
   MapiFileDesc: TMapiFileDesc;
   MapiRecipDesc: TMapiRecipDesc;
   i: integer;
   s: string;
 begin
   with MapiRecipDesc do
   begin
     ulRecerved:= 0;
     ulRecipClass:= MAPI_TO;
     lpszName:= PChar(RecipName);
     lpszAddress:= PChar(RecipAddress);
     ulEIDSize:= 0;
     lpEntryID:= nil;
   end;
 
   with MapiFileDesc do
   begin
     ulReserved:= 0;
     flFlags:= 0;
     nPosition:= 0;
     lpszPathName:= PChar(Attachment);
     lpszFileName:= nil;
     lpFileType:= nil;
   end;
 
   with MapiMessage do
   begin
     ulReserved := 0;
     lpszSubject := nil;
     lpszNoteText := PChar(Subject);
     lpszMessageType := nil;
     lpszDateReceived := nil;
     lpszConversationID := nil;
     flFlags := 0;
     lpOriginator := nil;
     nRecipCount := 1;
     lpRecips := @MapiRecipDesc;
     if length(Attachment) > 0 then
     begin
       nFileCount:= 1;
       lpFiles := @MapiFileDesc;
     end
     else
     begin
       nFileCount:= 0;
       lpFiles:= nil;
     end;
   end;
 
   Result:= MapiSendMail(0, 0, MapiMessage, MAPI_DIALOG
   or MAPI_LOGON_UI or MAPI_NEW_SESSION, 0) = SUCCESS_SUCCESS;
 end;
 
 
 function IsOnline: Boolean;
 var
   RASConn: TRASConn;
   dwSize,dwCount: DWORD;
 begin
   RASConns.dwSize:= SizeOf(TRASConn);
   dwSize:= SizeOf(RASConns);
   Res:=RASEnumConnectionsA(@RASConns, @dwSize, @dwCount);
   Result:= (Res = 0) and (dwCount > 0);
 end;
 
 end.
 




Как послать широковещательный UDP пакет

Смотрит ламер на папку "Удаленный доступ к сети", и думает: "Как он ещё тут, когда его уже удалили?"


 procedure TMainForm.FormCreate(Sender: TObject);
 var
   Init: TWSAData;
   SockOpt: BOOL;
   Sock: TSocket;
   Target: TSockAddrIn;
 begin
   WSAStartup($101,Init);
   Sock:=Socket(PF_INET,SOCK_DGRAM,IPPROTO_UDP);
   SockOpt:=TRUE;
   SetSockOpt(Sock,SOL_SOCKET,SO_BROADCAST, PChar(@SockOpt),SizeOf(SockOpt)) ;
   Target.sin_port:=htons(8167); //номер порта
   Target.sin_addr.S_addr:=INADDR_BROADCAST;
   Target.sa_family:=AF_INET;
   SendTo(Sock,Data,DataBytes,0,Target,SizeOf(Target));
   WSACleanup;
 end;
 




Пересылка данных в ячейки Excel

Автор: Mikhail Andronov

Новые компьютерные вирусы:
"Виагра" - делает из вашей старой гибкой дискеты - жёсткий диск.
"Монка Левински" - высасывает из вашего жёсткого диска информацию и тут же сообщает всем по сети о случившемся.
"Рональд Рейган" - сохраняет все ваши данные, но забывает, где они находятся.
"Борис Ельцин" - выставляет в биосе, что ваш 486 - это Р-III, обьясняет медленную скорость работы тем, что подцепил легкий вирус, постоянно обновляет системный регистр и драйвера. Проблемы 2000 для него не существует. Его дочерние версии могут тайком перекачивать деньги на зарубежные счета.
"Майк Тайсон" - вырубает ваш компьютер с первых двух байтов.
"Арнольд Шварцнеггер" - Terminate all programs and say -I'LL BE BACK!!!
"Титаник" - показывает вам физиономию Ди-Каприо до тех пор, пока вы не утопите свой PC в ванной со льдом.

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

Привожу полностью все файлы проекта:


 // *-*-*-*-*-*-*-*
 // SelectToExcel.dpr
 // *-*-*-*-*-*-*-*
 
 program SelectToExcel;
 
 uses
   Forms,
   Main in 'Main.pas' {Form1};
 
 {$R *.RES}
 
 begin
   Application.Initialize;
   Application.CreateForm(TForm1, Form1);
   Application.Run;
 end.
 
 // *-*-*-*-*-*-*-*
 // Main.dfm
 // *-*-*-*-*-*-*-*
 
 object Form1: TForm1
 
   Left = 267
     Top = 137
     AutoScroll = False
     Caption = 'Экспорт результатов SELECT в Excel'
     ClientHeight = 277
     ClientWidth = 519
     Color = clBtnFace
     Font.Charset = DEFAULT_CHARSET
     Font.Color = clWindowText
     Font.Height = -11
     Font.Name = 'MS Sans Serif'
     Font.Style = []
     OldCreateOrder = False
     Position = poScreenCenter
     PixelsPerInch = 96
     TextHeight = 13
     object Label1: TLabel
     Left = 8
       Top = 4
       Width = 114
       Height = 13
       Caption = 'Предложение SELECT'
   end
   object Label2: TLabel
     Left = 8
       Top = 224
       Width = 91
       Height = 13
       Caption = 'Имя базы данных'
   end
   object btnExport: TButton
     Left = 436
       Top = 20
       Width = 75
       Height = 25
       Caption = 'Экспорт'
       TabOrder = 0
       OnClick = btnExportClick
   end
   object memSelect: TMemo
     Left = 8
       Top = 20
       Width = 417
       Height = 197
       TabOrder = 1
   end
   object edtDatabaseName: TEdit
     Left = 8
       Top = 240
       Width = 413
       Height = 21
       TabOrder = 2
   end
   object queSelect: TQuery
     Left = 24
       Top = 20
   end
 end
 
 // *-*-*-*-*-*-*-*
 // Main.pas
 // *-*-*-*-*-*-*-*
 
 unit Main;
 
 interface
 
 uses
 
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
   StdCtrls, Db, DBTables;
 
 type
 
   TForm1 = class(TForm)
     queSelect: TQuery;
     btnExport: TButton;
     memSelect: TMemo;
     edtDatabaseName: TEdit;
     Label1: TLabel;
     Label2: TLabel;
     procedure btnExportClick(Sender: TObject);
   private
     { Private declarations }
   public
     { Public declarations }
   end;
 
 var
 
   Form1: TForm1;
 
 implementation
 uses
 
   ComObj;
 {$R *.DFM}
 
 procedure TForm1.btnExportClick(Sender: TObject);
 var
 
   XL, // Приложение Excel
   TableVals: Variant; // Врем. массив для переноса значений в Excel
   i, LineCounter, // Счетчик строк для переноса записей в Excel
   queSelectRecCount,
     queSelectFieldsCount: Integer;
 begin
 
   inherited;
   try
     Application.ProcessMessages;
     Screen.Cursor := crSQLWait;
 
     with queSelect do
     begin
       SQL.Assign(memSelect.Lines);
       DatabaseName := edtDatabaseName.Text;
       Open;
       {AMA: Экспорт в Excel}
 
       queSelectRecCount := RecordCount;
       queSelectFieldsCount := FieldCount;
       TableVals := VarArrayCreate([0, queSelectRecCount - 1, //кол-во строк
         0, queSelectFieldsCount - 1], // кол-во столбцов
         varOleStr);
 
       First;
       LineCounter := 0;
       while not EOF do
       begin
         for i := 0 to queSelectFieldsCount - 1 do
           if not Fields[i].IsNull then
             TableVals[LineCounter, i] := Fields[i].AsString
           else
             TableVals[LineCounter, i] := '';
         LineCounter := LineCounter + 1;
         Next;
       end;
       Close;
     end;
 
     try
       try
         XL := GetActiveOleObject('Excel.Application');
       except
         XL := CreateOleObject('Excel.Application');
       end;
     except
       raise Exception.Create('Не могу запустить Excel');
     end;
 
     XL.Visible := True;
     XL.Workbooks.Add;
     XL.Range[XL.Cells[1, 1],
       XL.Cells[queSelectRecCount,
       queSelectFieldsCount]].Value := TableVals;
     XL.Range[XL.Cells[1, 1],
       XL.Cells[queSelectRecCount,
       queSelectFieldsCount]].Borders.Weight := 2;
   finally
     Screen.Cursor := crDefault;
   end;
 end;
 
 end.
 




Отправить E-mail

BATMAN - человек-почтовый ящик.


 procedure TForm1.Button1Click(Sender: TObject);
 begin
   NMSMTP1.Host   := 'mail.host.com';
   NMSMTP1.UserID := 'Username';
   NMSMTP1.Connect;
   NMSMTP1.PostMessage.FromAddress       := 'your_mail@host.com';
   NMSMTP1.PostMessage.ToAddress.Text    := 'delphiworld@mail.ru';
   NMSMTP1.PostMessage.ToCarbonCopy.Text := 'your_mail@host.com';
   NMSMTP1.PostMessage.ToBlindCarbonCopy.Text := 'second_your_mail@host.com';
   NMSMTP1.PostMessage.Body.Text         := 'This is the message from Delphi World project';
   NMSMTP1.PostMessage.Attachments.Text  := 'c:\File.txt';
   NMSMTP1.PostMessage.Subject           := 'Delphi World is Great!';
   NMSMTP1.SendMail;
   ShowMessage('Mail sent !');
   NMSMTP1.Disconnect;
 end;
 




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



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



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


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