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

ВИДЕОКУРС ВЗЛОМ
выпущен 8 октября!


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

БОЛЬШОЙ FAQ ПО DELPHI



Запуск внешней программы. Как послать E-mail и сделать ссылку на сайт


Для запуска внешней программы, для посылки письма или для создания ссылки на сайт вам понадобиться всего одна функция ShellExecute, которая описывается в модуле ShellAPI - не забудьте подключить его в uses.

Этой функции нужно указать несколько параметров:

  • Дескриптор родительского окна
  • Выполняемое действие. Этот параметр может принимать следующие значения "open", "print", "explore" - соответственно открытие, печать или исследование. Можно указывать nil - тогда будет выполняться действие по умолчанию - "open".
  • Имя файла или папки, или e-mail, или URL
  • Параметры
  • Каталог по умолчанию
  • Способ вывода окна. В качестве значения можно указать:
    • SW_HIDE Скрывает окно и активизирует другое.
    • SW_MAXIMIZE Разворачивает окно.
    • SW_MINIMIZE Сворачивает окно.
    • SW_RESTORE Активизирует и выводит окно. Если окно было развёрнуто или свёрнуто - восстанавливает исходный размер и позицию.
    • SW_SHOW Активизирует и выводит окно с его оригинальным размером и положением.
    • SW_SHOWDEFAULT Активизирует с установками, заданными в структуре STARTUPINFO, которая была передана при создании процесса приложением запускающим нужную программу.
    • SW_SHOWMAXIMIZED Выводит окно в развёрнутом виде.
    • SW_SHOWMINIMIZED Выводит окно в виде пиктограммы на панели задач.
    • SW_SHOWMINNOACTIVE Выводит окно в свёрнутом виде на панели задач и не передаёт ему фокус ввода, т.е. окно, которое до этого было активно остаётся активно по прежнему.
    • SW_SHOWNA Отображает окно в его текущем состоянии. Активное окно остаётся активным по прежнему.
    • SW_SHOWNOACTIVATE Выводит окно в его последнем положении и с последними используемыми размерами. Активное окно остаётся активным по прежнему.
    • SW_SHOWNORMAL Выводит окно. Если оно было свёрнуто или развёрнуто - восстанавливает его оригинальные размеры и позицию

Примеры:


 // Запуск файла
 ShellExecute(Handle, nil, 'c:\windows\calc.exe', nil, nil, SW_SHOW);
 
 // Просмотр каталога
 ShellExecute(Handle, nil, 'c:\windows', nil, nil, SW_SHOW);
 
 // Ссылка на сайт
 ShellExecute(Handle, nil, 'http://www.site.ru', nil, nil, SW_SHOW);
 
 // Послать E-mail
 ShellExecute(Handle, nil, 'mailto:DelphiWorld@mail.ru', nil, nil, SW_SHOW);
 




Соpтиpовка Шелла

Соpтиpовка Шелла. Это еще одна модификация пyзыpьковой соp- тиpовки. Сyть ее состоит в том, что здесь выполняется сpавнение ключей, отстоящих один от дpyгого на некотоpом pасстоянии d. Ис- ходный pазмеp d обычно выбиpается соизмеpимым с половиной общего pазмеpа соpтиpyемой последовательности. Выполняется пyзыpьковая соpтиpовка с интеpвалом сpавнения d. Затем величина d yменьшается вдвое и вновь выполняется пyзыpьковая соpтиpовка, далее d yмень- шается еще вдвое и т.д. Последняя пyзыpьковая соpтиpовка выполня- ется пpи d=1. Качественный поpядок соpтиpовки Шелла остается O(N^2), сpеднее же число сpавнений, опpеделенное эмпиpическим пy- тем - log2(N)^2*N. Ускоpение достигается за счет того, что выяв- ленные "не на месте" элементы пpи d>1, быстpее "всплывают" на свои места.

Пpимеp иллюстpиpyет соpтиpовкy Шелла.


 {===== Пpогpаммный пpимеp =====}
  { Соpтиpовка Шелла }
  Procedure Sort( var a : seq);
  Var d, i, t : integer;
     k : boolean; { пpизнак пеpестановки }
    begin
    d:=N div 2;  { начальное значение интеpвала }
 
    while d>0 do begin { цикл с yменьшением интеpвала до 1 }
 
      { пyзыpьковая соpтиpовка с интеpвалом d }
      k:=true;
      while k do begin  { цикл, пока есть пеpестановки }
        k:=false; i:=1;
        for i:=1 to N-d do begin
          { сpавнение эл-тов на интеpвале d }
          if a[i]>a[i+d] then begin
            t:=a[i]; a[i]:=a[i+d]; a[i+d]:=t; { пеpестановка }
            k:=true;  { пpизнак пеpестановки }
            end; { if ... }
          end; { for ... }
        end; { while k }
      d:=d div 2;  { yменьшение интеpвала }
      end;  { while d>0 }
  end;
 

Резyльтаты тpассиpовки пpогpаммного пpимеpа 3.9 пpедставлены в таблице

 ----------T---T-------------------------------------------------¬
 ¦   шаг   ¦ d ¦    содеpжимое массива a                         ¦
 +---------+---+-------------------------------------------------+
 ¦исходный ¦   ¦ 76 22  4 17 13 49  4 18 32 40 96 57 77 20  1 52 ¦
 ¦   1     ¦ 8 ¦ 32 22  4 17 13 20  1 18 76 40 96 57 77 49  4 52 ¦
 ¦   2     ¦ 8 ¦ 32 22  4 17 13 20  1 18 76 40 96 57 77 49  4 52 ¦
 ¦   3     ¦ 4 ¦ 13 20  1 17 32 22  4 18 76 40  4 52 77 49 96 57 ¦
 ¦   4     ¦ 4 ¦ 13 20  1 17 32 22  4 18 76 40  4 52 77 49 96 57 ¦
 ¦   5     ¦ 2 ¦  1 17 13 20  4 18 32 22  4 40 76 49 77 52 96 57 ¦
 ¦   6     ¦ 2 ¦  1 17  4 18 13 20  4 22 32 40 76 49 77 52 96 57 ¦
 ¦   7     ¦ 2 ¦  1 17  4 18  4 20 13 22 32 40 76 49 77 52 96 57 ¦
 ¦   8     ¦ 2 ¦  1 17  4 18  4 20 13 22 32 40 76 49 77 52 96 57 ¦
 ¦   9     ¦ 1 ¦  1  4 17  4 18 13 20 22 32 40 49 76 52 77 57 96 ¦
 ¦  10     ¦ 1 ¦  1  4  4 17 13 18 20 22 32 40 49 52 76 57 77 96 ¦
 ¦  11     ¦ 1 ¦  1  4  4 13 17 18 20 22 32 40 49 52 57 76 77 96 ¦
 ¦  12     ¦ 1 ¦  1  4  4 13 17 18 20 22 32 40 49 52 57 76 77 96 ¦
 ¦pезyльтат¦   ¦  1  4  4 13 17 18 20 22 32 40 49 52 57 76 77 96 ¦
 L---------+---+--------------------------------------------------
 



Клавиши-акселераторы для TPageControl

Приходит программист на работу с красными глазами, злой, не в настроении. У него же и спрашивают:
- Слышь, Вась, что ты такой невеселый?
- Да я тут всю ночь программу писал.
- И что не работает?
- Работает.
- Может с глюками какими?
- Нет, без.
- Так чтo ты злой такой?
- Да я, бл@, на клавише Backspace заснул.

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

В приведенном ниже коде показана реализация такого компонента. Наследник TPageControl осуществляет захват и обработку сообщения CM_DIALOGCHAR. Это позволяет перехватывать комбинации клавиш, которые могут быть акселератороми для данной формы. Обработчик со бытия CMDialogChar использует функцию IsAccel, которая позволяет определить, имеет ли отношение перехваченный код клавиш к акселератору одной из страниц TPageControl. В этом случае делаем страницу активной и передаем ей фокус.


 unit tapage;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics,
   Controls, Forms, Dialogs, ComCtrls;
 
 type
 
   TAPageControl = class(TPageControl)
   private
     procedure CMDialogChar(var Msg: TCMDialogChar); message CM_DIALOGCHAR;
   end;
 
 procedure Register;
 
 implementation
 
 procedure TAPageControl.CMDialogChar(var Msg: TCMDialogChar);
 var
   i: Integer;
   S: string;
 begin
   if Enabled then
     for I := 0 to PageCount - 1 do
       if IsAccel(Msg.CharCode, Pages[i].Caption) and
         Pages[I].TabVisible then
       begin
         Msg.Result := 1;
         ActivePage := Pages[I];
         Change;
         Exit; // выход из цикла.
       end;
   inherited;
 end;
 
 procedure Register;
 begin
   RegisterComponents('Test', [TAPageControl]);
 end;
 
 end.
 




Как сделать клавишу-акселератор (keyboard shortcut) компонету, у которого нет заголовка


...Ну! И кто открывал бутылку о кнопку "F8"?!

Возможный вариант - присвоить ссылку на этот компонент свойству FocusControl TLabel'а. В примере используется невидимый Label для создания "быстрой" клавиши (Alt+M) компонента Memo. Чтобы использовать пример, разместите на форме компонент TMemo, Label и несколько других компонентов, которые могут принимать фокус ввода. Запустите программу, переведите фокус ввода куда-нибудь вне Memo и нажмите Alt+M - фокус ввода вернется в Memo.


 procedure TForm1.FormCreate(Sender: TObject);
 begin
   Label1.Visible := false;
   Label1.Caption := '&M';
   Label1.FocusControl := Memo1;
 end;
 




Нужно чтобы клавиши shortcut пунктов действовали только в этой форме, а не в модальных окнах.

Знакомая проблема. Лечится так:


 function WindowHook(var Message: TMessage): Boolean;
 ...
 
 procedure.FormCreate(Sender: TObject);
 begin
   // MainForm
   Application.HookMainWindow(WindowHook);
 end;
 
 function.WindowHook;
 begin
   Result := False;
 
   with Message do
     case Msg of
       CM_APPKEYDOWN, CM_APPSYSCOMMAND: Msg := WM_NULL;
 end;
 




Сокращенное имя каталога

Есть имя каталога:

c:\windows\media\temp\abc\sound\chime.wav

Мне необходима сокращенная запись, такая как

c:\windows\..\sound\chime.wav

а не полный путь к файлу.

Есть ли простой способ для этого?

Я разработал процедуру, которая делает нечто похожее. Она сокращает имя каталога, когда он и текущий путь имеют в корне тот же диск и/или часть пути, совпадающие вначале. Полученный результат (сокращенная запись) действительно легче для восприятия. Я производил кодирование в шестнадцатиричном редакторе в Borland Pascal и некоторое время не использовал. Я не думаю, что данный код может быть несовместим с последними версиями Delphi.


 function shortenfilename(s: string): string;
 var
   drive, curdrive: string[2];
   dir, curdir: string[80];
   name: string[20];
   ext: string[5];
   i: byte;
 begin
   for i := 1 to length(s) do
     s[i] := upcase(s[i]);
   s := fexpand(s);
   fsplit(s, dir, name, ext);
   drive := copy(dir, 1, 2);
   dir := copy(dir, 4, length(dir) - 3);
   getdir(0, curdir);
   curdrive := copy(curdir, 1, 2);
   curdir := copy(curdir, 4, length(curdir) - 3) + '\';
   if drive = curdrive then
   begin
     if copy(dir, 1, length(curdir)) = curdir then
     begin
       i := length(curdir);
       if length(dir) <> i then
         dir := dir + '\';
       shortenfilename := copy(dir, i + 1, length(dir) - i - 1) + name + ext;
     end
     else
       shortenfilename := copy(s, 3, length(s) - 2);
   end
   else
     shortenfilename := s;
 end;
 




Как использовать функцию ShowMessageFmt


 procedure TForm1.Button1Click(Sender: TObject);
 begin
   ShowMessageFmt('This is %s.'#13'Handle: %.8x '#13'WindowProc: %p',
     [Caption, Handle, @WindowProc]);
 end;
 

%s — вместо нее подставляется первый параметр из [], приведенный к типу String
%.8x — подставляется целое, переведенное в 16-ричную систему, дополненное слева нулями до 8-ми цифр
%p — подставляется указатель




Отобразить, присоединить сетевые диски

Вовочка прибегает домой 1-го сентября после уроков, подходит к папе-фидошнику и говорит: - Пап, мы сегодня писали сочинение на тему "Как я провёл лето", а мне влепили тройбан. Сам помотри - за что? Батя отрывается от монитора, долго всматривается в сочинение и отвечает: - А ты что хотел?! Оффтопик, оверквотинг...


 function ConnectDrive(_drvLetter: string; _netPath: string; _showError: Boolean;
   _reconnect: Boolean): DWORD;
 var
   nRes: TNetResource;
   errCode: DWORD;
   dwFlags: DWORD;
 begin
   { Fill NetRessource with #0 to provide uninitialized values }
   { NetRessource mit #0 fullen => Keine unitialisierte Werte }
   FillChar(NRes, SizeOf(NRes), #0);
   nRes.dwType := RESOURCETYPE_DISK;
   { Set Driveletter and Networkpath }
   { Laufwerkbuchstabe und Netzwerkpfad setzen }
   nRes.lpLocalName  := PChar(_drvLetter);
   nRes.lpRemoteName := PChar(_netPath); { Example: \\Test\C }
   { Check if it should be saved for use after restart and set flags }
   { Uberprufung, ob gespeichert werden soll }
   if _reconnect then
     dwFlags := CONNECT_UPDATE_PROFILE and CONNECT_INTERACTIVE
   else
     dwFlags := CONNECT_INTERACTIVE;
 
   errCode := WNetAddConnection3(Form1.Handle, nRes, nil, nil, dwFlags);
   { Show Errormessage, if flag is set }
   { Fehlernachricht aneigen }
   if (errCode <> NO_ERROR) and (_showError) then
   begin
     Application.MessageBox(PChar('An error occured while connecting:' + #13#10 +
       SysErrorMessage(GetLastError)),
       'Error while connecting!',
       MB_OK);
   end;
   Result := errCode; { NO_ERROR }
 end;
 
 function ConnectPrinterDevice(_lptPort: string; _netPath: string; _showError: Boolean;
   _reconnect: Boolean): DWORD;
 var
   nRes: TNetResource;
   errCode: DWORD;
   dwFlags: DWORD;
 begin
   { Fill NetRessource with #0 to provide uninitialized values }
   { NetRessource mit #0 fullen => Keine unitialisierte Werte }
   FillChar(NRes, SizeOf(NRes), #0);
   nRes.dwType := RESOURCETYPE_PRINT;
   { Set Printername and Networkpath }
   { Druckername und Netzwerkpfad setzen }
   nRes.lpLocalName  := PChar(_lptPort);
   nRes.lpRemoteName := PChar(_netPath); { Example: \\Test\Printer1 }
   { Check if it should be saved for use after restart and set flags }
   { Uberprufung, ob gespeichert werden soll }
   if _reconnect then
     dwFlags := CONNECT_UPDATE_PROFILE and CONNECT_INTERACTIVE
   else
     dwFlags := CONNECT_INTERACTIVE;
 
   errCode := WNetAddConnection3(Form1.Handle, nRes, nil, nil, dwFlags);
   { Show Errormessage, if flag is set }
   { Fehlernachricht aneigen }
   if (errCode <> NO_ERROR) and (_showError) then
   begin
     Application.MessageBox(PChar('An error occured while connecting:' + #13#10 +
       SysErrorMessage(GetLastError)),
       'Error while connecting!',
       MB_OK);
   end;
   Result := errCode; { NO_ERROR }
 end;
 
 function DisconnectNetDrive(_locDrive: string; _showError: Boolean; _force: Boolean;
   _save: Boolean): DWORD;
 var
   dwFlags: DWORD;
   errCode: DWORD;
 begin
   { Set dwFlags, if necessary }
   { Setze dwFlags auf gewunschten Wert }
   if _save then
     dwFlags := CONNECT_UPDATE_PROFILE
   else
     dwFlags := 0;
   { Cancel the connection see also at http://www.swissdelphicenter.ch/en/showcode.php?id=391 }
   { Siehe auch oben genannten Link (Netzlaufwerke anzeigen) }
   errCode := WNetCancelConnection2(PChar(_locDrive), dwFlags, _force);
   { Show Errormessage, if flag is set }
   { Fehlernachricht anzeigen }
   if (errCode <> NO_ERROR) and (_showError) then
   begin
     Application.MessageBox(PChar('An error occured while disconnecting:' + #13#10 +
       SysErrorMessage(GetLastError)),
       'Error while disconnecting',
       MB_OK);
   end;
   Result := errCode; { NO_ERROR }
 end;
 
 
 {Beispiel / Example:}
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   ConnectDrive('h:', '\\Servername\C', True, True);
 end;
 
 procedure TForm1.Button2Click(Sender: TObject);
 begin
   DisconnectNetDrive('h:', True, True, True);
 end;
 




Как вывести окно модальное для всех окон кроме одного

Автор: Serge Buzadzhy


 procedure ShowAlmostModal(FormModal:TForm);
 begin
   NavigatorForm.Enabled := false;
   FormModal.ShowModal
 end;
 

И вот это пpивесь на OnShow почти модальной фоpмы


 procedure FormShow(Sender:Tobject);
 begin
   NavigatorForm.Enabled := true;
 end;
 




Просмотр буфера обмена


 unit ClipboardViewer;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
   Dialogs;
 
 type
   TForm1 = class(TForm)
     procedure FormCreate(Sender: TObject);
     procedure FormDestroy(Sender: TObject);
   private
     FNextViewerHandle: THandle;
     procedure WMDrawClipboard(var message: TMessage);
       message WM_DRAWCLIPBOARD;
     procedure WMChangeCBCHain(var message: TMessage);
       message WM_CHANGECBCHAIN;
   public
   end;
 
 var
   Form1: TForm1;
 
 implementation
 {$R *.DFM}
 
 procedure TForm1.FormCreate(Sender: TObject);
 begin
   // Проверяем работоспособность функции.
   // При невозможности просмотра буфера обмена
   // функция возвратит значение Nil.
   FNextViewerHandle := SetClipboardViewer(Handle);
 end;
 
 procedure TForm1.FormDestroy(Sender: TObject);
 begin
   // Восстанавливаем цепочки.
   ChangeClipboardChain(Handle, FNextViewerHandle);
 end;
 
 procedure TForm1.WMDrawClipboard(var message: TMessage);
 begin
   // Вызывается при любом изменении содержимого буфера обмена
   message.Result := SendMessage(WM_DRAWCLIPBOARD, FNextViewerHandle, 0, 0);
 end;
 
 procedure TForm1.WMChangeCBCHain(var message: TMessage);
 begin
   // Вызывается при любом изменении цепочек буфера обмена.
   if message.wParam = FNextViewerHandle then
   begin
     // Удаляем следующую цепочку просмотра. Корректируем внутреннюю переменную.
     FNextViewerHandle := message.lParam;
     // Возвращаем 0 чтобы указать, что сообщение было обработано
     message.Result := 0;
   end
   else
   begin
     // Передаем сообщение следующему окну в цепочке.
     message.Result := SendMessage(FNextViewerHandle, WM_CHANGECBCHAIN,
       message.wParam, message.lParam);
   end;
 end;
 
 end.
 




Просмотр буфера обмена 2

Автор: Neil

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


 ...
 private
   { Private declarations }
   PrevHwnd: Hwnd;
 
   procedure WMChangeCBChain(var Msg: TWMChangeCBChain);
     message WM_CHANGECBCHAIN;
 
   procedure WMDrawClipboard(var Msg: TWMDrawClipboard);
     message WM_DRAWCLIPBOARD;
 ...
 
 procedure TForm1.WMChangeCBChain(var Msg: TWMChangeCBChain);
 begin
   if PrevHWnd = Msg.Remove then
     PrevHWnd := Msg.Next;
   if Msg.Remove <> Handle then
     SendMessage(PrevHWnd, WM_CHANGECBCHAIN, Msg.Remove, Msg.Next);
 end;
 
 procedure TForm1.WMDrawClipboard(var Msg: TWMDrawClipboard);
 var
   P: PChar;
   H: THandle;
 begin
   SendMessage(PrevHWnd, WM_DRAWCLIPBOARD, 0, 0);
   if Clipboard.HasFormat(CF_TEXT) then
   begin
     H := Clipboard.GetAsHandle(CF_TEXT);
     Len := GlobalSize(H) + 1;
     P := GlobalLock(H);
     Memo1.SetTextBuf(P);
     GlobalUnlock(H);
   end;
   Msg.Result := 0;
 end;
 
 procedure TForm1.FormCreate(Sender: TObject);
 begin
   PrevHwnd := SetClipboardViewer(Handle);
 end;
 
 procedure TForm1.FormDestroy(Sender: TObject);
 begin
   ChangeClipboardChain(Handle, PrevHwnd);
 end;
 

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




Отображение ломанной линии

Автор: Jim Gunkel (Nevrona Designs)

Как мне вывести ломанную линию на холсте, если я не знаю размер массива (количество точек) до момента запуска программы??? По-моему, это невозможно. Просветите меня!

Недавно я решал аналогичную проблему при кодировании ReportPrinter и не нашел хорошего решения для создания открытого массива параметров заданного размера. Решение, которое я, наконец, использовал, заключалось в хитрой комбинации функции polyline и polygon с ассемблерным кодом. Я публикую исходный код, поскольку думаю что он будет полезен, пока Borland не создаст стандартные и простые методы для работы с массивами заданного размера.


 type
   PPointArr = ^TPointArr;
   TPointArr = array[0..16380] of TPoint;
 
 var
   I1: integer;
   Elements: word;
   PointArr: PPointArr;
 
 begin
   GetMem(PointArr, (Elements + 1) * SizeOf(TPoint));
   try
     for I1 := 0 to Elements do
     begin
       PointArr^[I1].X := ReadNextXValue;
       PointArr^[I1].Y := ReadNextYValue;
     end; { for }
 
     { Вызов Polygon(PointArr^), но только с Elements+1-элеменами
       в открытом массиве }
     asm
       les di,PointArr { Помещаем указатель на PointArr }
       push es
       push di
       push Elements { Помещаем High(PointArr^) }
       les di,self { Помещаем указатель self }
       push es
       push di
       les di,es:[di] { Вызов self.Polygon }
       call Polygon
     end; { asm }
   finally
     FreeMem(PointArr, (Elements + 1) * SizeOf(TPoint));
   end; { try }
 end;
 




Показ удаленных записей в таблице dBASE

В таблицах dBASE записи не удаляются до тех пор, пока таблица не будет упакована. Пока же это не произойдет, удаленные записи остаются в таблице, только имеют при этом флажок "к удалению". Для того, чтобы показать эти существующие, но не отображаемые записи, существует функция ShowDeleted(), которая использует функцию BDE API DbiSetProp(), показывающая записи, помеченные к удалению. При использовании этой функции нет необходимости закрывать и вновь открывать таблицу. ShowDeleted() в качестве параметров передается TTable и логическое значение. Логический параметр указывает на необходимость показа удаленных записей.

Демонстрационный проект:


 unit Unit1;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
   Dialogs, StdCtrls, ExtCtrls, DBCtrls, Grids, DBGrids, DB, DBTables;
 
 type
   TForm1 = class(TForm)
     Table1: TTable;
     DataSource1: TDataSource;
     DBGrid1: TDBGrid;
     DBNavigator1: TDBNavigator;
     CheckBox1: TCheckBox;
     procedure CheckBox1Click(Sender: TObject);
   public
     procedure ShowDeleted(Table: TTable; ShowDeleted: Boolean);
   end;
 
 var
   Form1: TForm1;
 
 implementation
 
 uses DBITYPES, DBIERRS, DBIPROCS;
 
 {$R *.DFM}
 
 procedure TForm1.ShowDeleted(Table: TTable; ShowDeleted: Boolean);
 var
   rslt: DBIResult;
   szErrMsg: DBIMSG;
 begin
   Table.DisableControls;
   try
     Check(DbiSetProp(hDBIObj(Table.Handle), curSOFTDELETEON,
       LongInt(ShowDeleted)));
   finally
     Table.EnableControls;
   end;
   Table.Refresh;
 end;
 
 procedure TForm1.CheckBox1Click(Sender: TObject);
 begin
   ShowDeleted(Table1, CheckBox1.Checked);
 end;
 
 end.
 




Как заставить приложение показывать различные иконки при различных разрешениях дисплея

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

Поместите следующий код в файл проекта (.DPR) Вашего приложения:


 Application.Initialize;
 Application.CreateForm(TForm1, Form1);
 case GetDeviceCaps(GetDC(Form1.Handle), HORZRES) of
    640 : Application.Icon.Handle := LoadIcon (hInstance, 'ICON640');
    800 : Application.Icon.Handle := LoadIcon (hInstance, 'ICON800');
   1024 : Application.Icon.Handle := LoadIcon (hInstance, 'ICON1024');
   1280 : Application.Icon.Handle := LoadIcon (hInstance, 'ICON1280');
 end;
 Application.Run;
 




Как вывести сведения о диске (метка тома, серийный номер, файловая система и т.д.)


Звонок в службу технической поддержки:
- У меня компьютер не работает!
- После чего это произошло?
- Я его включил - загрузился Нортон. Смотрю - у меня слева диск С: и справа диск С:. Я подумал - нафиг мне два диска С:? И стер правый к чертовой матери.


 procedure TForm1.Button2Click(Sender: TObject);
 var
   VolumeName,
   FileSystemName : array [0..MAX_PATH-1] of Char;
   VolumeSerialNo : DWord;
   MaxComponentLength,FileSystemFlags: Cardinal;
 begin
   GetVolumeInformation('C:\',VolumeName,MAX_PATH,@VolumeSerialNo,
   MaxComponentLength,FileSystemFlags, FileSystemName,MAX_PATH);
   Memo1.Lines.Add('VolumeName = '+VolumeName);
   Memo1.Lines.Add('SerialNo = $'+IntToHex(VolumeSerialNo,8));
   Memo1.Lines.Add('CompLen = '+IntToStr(MaxComponentLength));
   Memo1.Lines.Add('Flags = $'+IntToHex(FileSystemFlags,4));
   Memo1.Lines.Add('FSName = '+FileSystemName);
 end;
 




Как пpогpаммно вывести окно свойств экpана

Автор: Nomadic


 ShellExecute(Application.Handle, 'open', 'desk.cpl', nil, nil, sw_ShowNormal);
 




Показать свойства файла


 unit Unit1;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
   StdCtrls, SoCtrls, SoSpecEdit, ShellAPI;
 
 type
   TForm1 = class(TForm)
     Button1: TButton;
     sohoFilenameEdit1: TsohoFilenameEdit;
     procedure Button1Click(Sender: TObject);
   private
     { Private declarations }
   public
     { Public declarations }
   end;
 
 var
   Form1: TForm1;
 
 implementation
 
 {$R *.DFM}
 
 procedure ShowPropertiesDialog(FName: string);
 var
   SExInfo: TSHELLEXECUTEINFO;
   Error: LongInt;
 begin
   ZeroMemory(Addr(SExInfo),SizeOf(SExInfo));
   SExInfo.cbSize := SizeOf(SExInfo);
   SExInfo.lpFile := PChar(FName);
   SExInfo.lpVerb := 'properties';
   SExInfo.fMask  := SEE_MASK_INVOKEIDLIST;
   ShellExecuteEx(Addr(SExInfo));
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   ShowPropertiesDialog(sohoFilenameEdit1.FileName);
 end;
 
 end.
 
 




Как показать иконку, ассоциированную с данным типом файла


Приходит программист в магазин. Там продавщица - полная такая тетенька. Программист (меланхолично оглядевшись):
- Бутылку пива и пачку презервативов. Продавщица:
- Это ты девушку охмурить бутылкой пива собрался? Вино надо дорогое покупать.... Программист (отрешенно):
- Да нет. Пиво я выпью, когда она уйдет.


 uses
   ShellAPI;
 ...
 procedure TForm1.Button1Click(Sender: TObject);
 var
   Icon: hIcon;
   IconIndex: word;
 begin
   IconIndex := 1;
   Icon := ExtractAssociatedIcon(HInstance,
     Application.ExeName, IconIndex);
   DrawIcon(Canvas.Handle, 10, 10, Icon);
 end;
 




Показать первый кадр AVI-файла

Следом за акцией "Кликни Деда Мороза!" компания Coca-Cola планирует с Нового года запустить акции "Бэкапни Деда Мороза" и "Форматни Снегурочку"


 procedure TForm1.Button1Click(Sender: TObject);
 begin
   Application.ProcessMessages;
   MediaPlayer1.Open;
   Application.ProcessMessages;
   MediaPlayer1.Step;
   Application.ProcessMessages;
   MediaPlayer1.Previous;
 end;
 




Показ формы без фокуса


 ShowWindow(theWindowHandle, SW_SHOWNOACTIVE);
 




Отображение полных строк списка при перемещении мыши по списку

Автор: Serzs

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

Текст формы примера:


 object MainForm: TMainForm
 Left = 7
 Top = 121
 Width = 200
 Height = 157
 Hint = '34534535'
 Caption = 'Long hints'
 Font.Charset = DEFAULT_CHARSET
 Font.Color = clWindowText
 Font.Height = -13
 Font.name = 'MS Sans Serif'
 Font.Style = []
 ShowHint = True
 OnCreate = FormCreate
 PixelsPerInch = 120
 TextHeight = 16
 object ListBox1: TListBox
 Left = 12
 Top = 12
 Width = 165
 Height = 97
 Hint = '1|2'
 ItemHeight = 16
 Items.Strings = (
 '1234567890ABCDEFGHIJKLMNOPQRSTUVWXYZ'
 'A1234567890ABCDEFGHIJKLMNOPQRSTUVWXYZ'
 '1234567890'
 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
 'ABCD')
 ParentShowHint = False
 ShowHint = True
 TabOrder = 0
 OnMouseMove = ListBox1MouseMove
 end
 end
 

Текст модуля:


 unit Main;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
   Dialogs, StdCtrls;
 
 type
   TMainForm = class(TForm)
     ListBox1: TListBox;
     procedure FormCreate(Sender: TObject);
     procedure ListBox1MouseMove(Sender: TObject; Shift: TShiftState; X,
     Y: Integer);
   private
     { Private declarations }
     FHintRow : Integer; // Номер строки в списке, на которую указывает мышь
   public
     { Public declarations }
     // Обработчик подсказок
     procedure OnShowHint(var HintStr: string; var CanShow: Boolean;
     var HintInfo: THintInfo);
 end;
 
 var
   MainForm: TMainForm;
 
 implementation
 
 {$R *.DFM}
 
 procedure TMainForm.FormCreate(Sender: TObject);
 begin
   FHintRow := -1;
   Application.OnShowHint := OnShowHint; // Установка обработчика
 end;
 
 procedure TMainForm.OnShowHint(var HintStr: string; var CanShow: Boolean;
 var HintInfo: THintInfo);
 var
   Pos: TPoint;
 begin
   with HintInfo do
     // Проверка на нужный объект
     if HintControl is TListBox then
       with HintControl as TListBox do
       begin
         Pos.X := 0;
         Pos.Y := ListBox1.Tag;
         HintPos := ListBox1.ClientToScreen(Pos);
         HintStr := ListBox1.Hint;
       end;
 end;
 
 procedure TMainForm.ListBox1MouseMove(Sender: TObject; Shift: TShiftState; X,
 Y: Integer);
 var
   MousePos : TPoint;
   ItemPos : TRect;
   RowWidth,
   ItemNum : Integer;
   FHint : string;
 begin
   MousePos.X := X;
   MousePos.Y := Y;
   // Определение номера строки в списке
   ItemNum := ListBox1.ItemAtPos(MousePos, True);
 
   // Проверка на перемещение мыши на другую строку
   if (ItemNum <> FHintRow) then
   begin
     FHintRow := ItemNum;
     // Проверка на наличие элементов в списке
     if ItemNum <> -1 then
     begin
       ItemPos := ListBox1.ItemRect(ItemNum);
 
       Application.CancelHint; // Снять текущую подсказку
       ListBox1.Tag := ItemPos.Top; // Запоминаем позицию строки по вертикали
 
       FHint := ListBox1.Items[ItemNum];
 
       // Проверка на ширину строки
       RowWidth := ListBox1.Canvas.TextWidth( FHint );
       if (RowWidth > ListBox1.ClientWidth) then
         FHint := FHint + '|'
       else
         FHint := '';
 
       ListBox1.Hint := FHint;
     end
     else
     begin
       ListBox1.Hint := '';
       Application.CancelHint;
       ListBox1.Tag := -1;
     end;
   end
 end;
 
 end.
 

Текст проекта:


 program PrjHint;
 
 uses
   Forms,
   Main in 'Main.pas' {MainForm};
 
 {$R *.RES}
 
 begin
   Application.Initialize;
   Application.CreateForm(TMainForm, MainForm);
 
   Application.ShowHint := True;
   Application.HintPause := 100;
   Application.HintHidePause := 999999;
 
   Application.Run;
 end.
 




Как вывести главное окно справочной системы

В тюpемной камеpе:
- Тебе сколько дали?
- 15 лет.
- А за что?
- Окно pазбил.
- Да где ж ты pаботаешь?
- В Майкpософте...

В 16-битных версиях справочной системы необходимо было вызывать начальное (главное) окно помощи с параметром HELP_CONTENTS в комманде HelpCommand. В 32-битном варианте это осуществляется следующим образом:


 Application.HelpCommand(HELP_FINDER, 0);
 

Примечание: Для того, чтобы показывались "книжки" (или главные темы) - необходимо создать .CNT-файл.




Как скрыть или показать иконки на рабочем столе


 procedure TForm1.Button1Click(Sender: TObject);
 begin
   // скрыть иконки
   ShowWindow(FindWindow(nil, 'Program Manager'), SW_HIDE);
 end;
 
 procedure TForm1.Button2Click(Sender: TObject);
 begin
   // показать иконки
   ShowWindow(FindWindow(nil, 'Program Manager'), SW_SHOW);
 end;
 




Как скрыть или показать иконки на рабочем столе 2


 procedure ShowDesktop(const YesNo : boolean);
 var h : THandle;
 begin
  h := FindWindow('ProgMan', nil);
  h := GetWindow(h, GW_CHILD);
  if YesNo = True then
    ShowWindow(h, SW_SHOW)
  else
    ShowWindow(h, SW_HIDE);
 end;
 
 {Использование:}
 {Скрыть иконки на рабочем столе}
 ShowDesktop(False);
 {Показать иконки на рабочем столе}
 ShowDesktop(true);
 




Показ и скрытие дочерних MDI-окон

Автор: Neil

...да, я понял: необходим гарантированный показ или скрытие MDI-окна. Гарантированно скрыть можно вызовом ShowWindow(theHandle, SW_HIDE), но в этом случае при показе *НЕ* используется ShowWindow. Вместо это сделайте так:


 SetWindowPos(theHandle, HWND_TOP, 0, 0, 0, 0, SWP_NOMOVE OR
 SWP_NOSIZE OR SWP_SHOWWINDOW);
 

Далее я обнаружил, что дочерние окна не скрывались/показывались, *ЕСЛИ* для осуществления этих функций использовались оконные компоненты (например, кнопки). Для решения проблемы добавьте следующую строку после вызова SetWindowPos:


 WinProcs.SetFocus(TheHandle);
 

*НЕ* используйте метод SetFocus; SetFocus здесь - Windows API функция.

Дополнение

По моему,все-таки, вызов ShowWindow(theHandle, SW_HIDE)проще, короче и, по крайней мере, в Delphi5 нормально работает с оконными компонентами.


 procedure TMainForm.Button1Click(Sender: TObject);
 begin
   //кнопка для показа/скрытия дочернего MDI-окна
   If ShowWindow(form1MDI.Handle, SW_HIDE)=False then
     ShowWindow(form1MDI.Handle, SW_SHOW);
 end;
 

С уважением Михаил Шпанер




Спрятать или показать кнопку ПУСК

По нажатию на кнопку пишем следующее


 Startbutton(false);
 

...круто!!!...а чтобы сделать ПУСК опять видимым:


 Startbutton(true);
 

Если вы думаете, что на этом дело и закончится, хочу поспешить вас разубедить, ведь вам ещё нужно реализовать процедуру Startbutton:


 procedure Startbutton(visi:boolean);
 var
   Tray, Child : hWnd;
   C : array[0..127] of Char;
   S : string;
 begin
   Tray := FindWindow('Shell_TrayWnd', nil);
   Child := GetWindow(Tray, GW_CHILD);
   while Child <> 0 do
   begin
     if GetClassName(Child, C, SizeOf(C)) > 0 then
     begin
       S := StrPAS(C);
       if UpperCase(S) = 'BUTTON' then
       begin
         if Visi then
           ShowWindow(Child, 1)
         else
           ShowWindow(Child, 0);
       end;
     end;
     Child := GetWindow(Child, GW_HWNDNEXT);
   end;
 end;
 




Как программно спрятать или показать заголовок окна TitleBar


 procedure TForm1.HideTitlebar;
 var
   Save: Longint;
 begin
   if BorderStyle=bsNone then
     Exit;
   Save:=GetWindowLong(Handle, GWL_STYLE);
   if (Save and WS_CAPTION)=WS_CAPTION then
   begin
     case BorderStyle of
       bsSingle, bsSizeable:
         SetWindowLong(Handle, GWL_STYLE, Save and (not WS_CAPTION) or WS_BORDER);
       bsDialog:
         SetWindowLong(Handle, GWL_STYLE, Save and
         (not WS_CAPTION) or DS_MODALFRAME or WS_DLGFRAME);
     end;
     Height:=Height-GetSystemMetrics(SM_CYCAPTION);
     Refresh;
   end;
 end;
 
 procedure TForm1.ShowTitlebar;
 var
   Save: Longint;
 begin
   if BorderStyle=bsNone then
     Exit;
   Save:=GetWindowLong(Handle, GWL_STYLE);
   if (Save and WS_CAPTION)<>WS_CAPTION then
   begin
     case BorderStyle of
       bsSingle, bsSizeable:
         SetWindowLong(Handle, GWL_STYLE, Save or WS_CAPTION or WS_BORDER);
       bsDialog:
         SetWindowLong(Handle, GWL_STYLE, Save or WS_CAPTION or
         DS_MODALFRAME or WS_DLGFRAME);
     end;
     Height:=Height+getSystemMetrics(SM_CYCAPTION);
     Refresh;
   end;
 end;
 




Заставляем появиться Hint в нужный момент

Сделаем это по нажатию на первую кнопку, а по нажатию на вторую кнопку будем скрывать окно hint'a:


 public
   { Public declarations }
   h: THintWindow;
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   if h<>nil then
     H.ReleaseHandle;
   H:=THintWindow.Create(Form1);
   H.ActivateHint(Form1.ClientRect, 'Это всплывающая подсказка');
 end;
 
 procedure TForm1.Button2Click(Sender: TObject);
 begin
   if h<>nil then
     H.ReleaseHandle;
 end;
 




Как вывести hint, когда курсор мышки над определённым контролом


 var  hintWnd: THintWindow;
 
 procedure TForm1.ActivateHintNOW( x,y: Integer);
 var
   rect: TRect;
 begin
   HintTxt := 'qq';
   if hintTxt <> '' then
   begin
     rect := hintWnd.CalcHintRect( Screen.Width, hinttxt, nil);
     rect.Left := rect.Left + x;
     rect.Right := rect.Right + x;
     rect.Top := rect.Top + y;
     rect.Bottom := rect.Bottom + y;
     hintWnd.ActivateHint( rect, hinttxt);
   end;
 end;
 
 // Замечание: Не забудьте каждый раз создавать hintWnd:
 //   hintwnd:= THintWindow.create(self);
 
 // а затем освобождать его:
 //   hintwnd.releasehandle;
 




Показ изображений в DBGrid

Муж-программист (М) с женой (Ж) сидят в цирке на выступлении иллюзиониста. Во время очередного номера из небольшого ящика выходят много девушек.
Ж: - Как они могли поместится в таком маленьком ящике?...
М: - Ерунда! Если бы он использовал WinRAR он бы еще больше их туда запихнул...

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

Код компонента:


 {
 // DBPICGRD.PAS (C)
 //      ВСЕ ПРАВА ЗАЩИЩЕНЫ.
 //
 // ОПИСАНИЕ:
 //      Компонент DBGrid, способный
 //      отображать графику в ячейках.
 }
 
 unit DBPicGrd;
 
 interface
 
 uses
 
   DBGrids, DB, DBTables, Grids, WinTypes, Classes, Graphics;
 
 type
 
   TDBPicGrid = class(TDBGrid)
   protected
     procedure DrawDataCell(const Rect: TRect;
       Field: TField; State: TGridDrawState); override;
   public
     constructor Create(AOwner: TComponent); override;
   published
     property DefaultDrawing default False;
   end;
 
 procedure Register;
 
 implementation
 
 constructor TDBPicGrid.Create(AOwner: TComponent);
 begin
 
   inherited Create(AOwner);
   DefaultDrawing := False;
 end;
 
 procedure TDBPicGrid.DrawDataCell(const Rect: TRect; Field: TField;
   State: TGridDrawState);
 var
 
   bmp: TBitmap;
 begin
 
   with Canvas do
   begin
     FillRect(Rect);
     if Field is TGraphicField then
     try
       bmp := TBitmap.Create;
       bmp.Assign(Field);
       Draw(Rect.Left, Rect.Top, bmp);
     finally
       bmp.Free;
     end
     else
       TextOut(Rect.Left, Rect.Top, Field.Text);
   end;
 end;
 
 procedure Register;
 begin
 
   RegisterComponents('Custom', [TDBPicGrid]);
 end;
 
 end.
 




Подскажите как правильно показать на экpане и сохранить в базе картинку формата JPEG


 if Picture.Graphic is TJPegImage then
 begin
   bs:=TBlobStream.Create(TBlobField(Field),bmWrite);
   Picture.Graphic.SaveToStream(bs);
   bs.Free;
 end
 else
 if Picture.Graphic is TBitmap then
 begin
   Jpg:=TJPegImage.Create;
   Jpg.CompressionQuality:=...;
   Jpg.PixelFormat:=...;
   Jpg.Assign(Picture.Graphic);
   Jpg.JPEGNeeded;
   bs:=TBlobStream.Create(TBlobField(Field),bmWrite);
   Jpg.SaveToStream(bs);
   bs.Free;
   Jpg.Free;
 end
 else
   Field.Clear;
 




Показывать номер страницы


  Sub ShowViewPageNo()
     ActiveDocument.Repaginate
     varTotalPages = Selection.Information(wdNumberOfPagesInDocument)
     varVertScrollPercent = ActiveDocument.ActiveWindow _
        .VerticalPercentScrolled
     varViewPage = Int((varVertScrollPercent / 100) * varTotalPages) + 1
     varIPPage = Selection.Information(wdActiveEndPageNumber)
     MsgBox "Your insertion point is on page [" & varIPPage & "]." + _
        "You are looking at page [" & varViewPage & "].""
  End Sub
 




Как показать окно свойств экрана

Я сижу за монитором
нажимаю на мыша
и смотрю погасшим взором,
как стреляет П.П.Ш.

Для этого воспользуемся 'Rundll32.exe' и запустим её в 'shellexecute'. Не забудьте добавить 'shellapi' в Ваш список uses.


 //Эта функция совместима со всеми версиями Windows
 function GetSystemDir: TFileName;
 var
   SysDir: array [0..MAX_PATH-1] of char;
 begin
   SetString(Result, SysDir, GetSystemDirectory(SysDir, MAX_PATH));
   if Result = '' then
     raise Exception.Create(SysErrorMessage(GetLastError));
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
   x: Tfilename;
 begin
   x := getsystemdir;
   ShellExecute(Form11.Handle, 'open', Pchar('rundll32.exe'),
   'shell32.dll,Control_RunDLL Desk.cpl,@0,3', Pchar(X), SW_normal);
 end;
 




Показать диалог выбора компьютера

- Дорогой, ты кого больше любишь? Меня или эту дурацкую штуку, за которой ты проводить целый, св#лочь!!!
- Ну, киса, как ты можешь сравнивать неодушевленный предмет с компьютером?!


 {
   The "Choose Computer" is a dialog provided by network services
   (NTLANMAN.DLL) for Windows 2k/NT/XP
   to display the servers and their computers.
 }
 
 type
   TServerBrowseDialogA0 = function(hwnd: HWND; pchBuffer: Pointer; cchBufSize: DWORD): bool;
   stdcall;
 
 
 function ShowServerDialog(AHandle: THandle): string;
 var
   ServerBrowseDialogA0: TServerBrowseDialogA0;
   LANMAN_DLL: DWORD;
   buffer: array[0..1024] of char;
   bLoadLib: Boolean;
 begin
   LANMAN_DLL := GetModuleHandle('NTLANMAN.DLL');
   if LANMAN_DLL = 0 then
   begin
     LANMAN_DLL := LoadLibrary('NTLANMAN.DLL');
     bLoadLib := True;
   end;
   if LANMAN_DLL <> 0 then
   begin @ServerBrowseDialogA0 := GetProcAddress(LANMAN_DLL, 'ServerBrowseDialogA0');
     DialogBox(HInstance, MAKEINTRESOURCE(101), AHandle, nil);
     ServerBrowseDialogA0(AHandle, @buffer, 1024);
     if buffer[0] = '\' then
     begin
       Result := buffer;
     end;
     if bLoadLib then
       FreeLibrary(LANMAN_DLL);
   end;
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   label1.Caption := ShowServerDialog(Form1.Handle);
 end;
 




Как показать число, разделив каждые три цифры запятыми

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


 procedure TForm1.Button1Click(Sender: TObject);
 var
   i: integer;
 begin
   i := 12345678;
   Memo1.Lines.Add(FormatFloat('#,', i));
 end;
 




Показ логотипа при запуске приложения

Автор: Алексей

Компания Макросос разработала новый продвинутый бюстгальтер СиСи++ с открывающимися окнами и возможностью удаленного доступа. Бета версия рассылается для тестирования всем желающим (но без застежек).

Это очень просто.

Создайте форму и поместите на нее логотип, используя компонент Timage. В моем примере я создал форму с логотипом и именем "logoform". Зайдите в настройки проекта и исключите форму их списка "автосоздаваемых" форм.

Затем в вашем файле PROJECT.DPR где-то сразу после ключевого слова begin напишите примерно следующее:


 logoform := TLogoform.Create(nil);
 { ВНИМАНИЕ! show!   НЕ showmodal }
 logoform.Show;
 
 { Здесь может размещаться код инициализации приложения,
   например, открытие базы данных... }
 
 { После блока кода, создающего все ваши формы и перед
   строчкой Application.Run напишите: }
 
 logoform.Hide;
 logoform.Release;
 

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




Показ логотипа при запуске приложения 2

Автор: Howard Harkness

Юзер - это человек, который иногда наступает на грабли.
Чайник - это человек, который всегда наступает на грабли.
Ламер - это человек, который считает, что не наступает на грабли, но на самом деле наступает на них чаще, чем чайник.
Программист - это человек, который изобретает новые грабли.
Билл Гейтс - некое мифическое существо, покровителей граблей.
МикроСофт - завод по производству граблей.
Ассемблер - язык программирования, в котором программист наступает на грабли миллион раз в секунду.

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

После моего хирургического вмешательства осталось всего пять или шесть строк кода, вплетенных в скелет формы. После сравнения моего кода с демо-проектом, поставляемым с Delphi (MastApp), я понял, что мой код много проще.

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

Код производит впечатление, что создание окошка с логотипом в Delphi плевое дело. Ну за дело: сначала, с помощью редактора, создайте форму (лучшим решением будет создание нового проекта в отдельном каталоге) и установите лучшие, на ваш художественный взгляд, значения таких свойств, как позиция, размеры и границы. Затем создайте обработчик события OnDeactivate и добавьте единственную строчку кода, в которой мы освобождаем форму. И, последнее, добавьте секцию initialization с тремя строчками кода, которые создают, выводят и обновляют форму.

Для того, чтобы использовать новое окошко с логотипом, скопируйте получившийся .PAS-файл в каталог с проектом, в котором вы намереваетесь его использовать, и вставьте ссылку на модуль в самую верхнюю часть секции uses. НЕ добавляйте форму к проекту.

Ниже приведен пример кода (форма имеет имя SplashForm, модуль обозван как SPLASH). Мой код добавлен между закомментаренных блоков {>>вставить} и {<<конец вставки}, весь остальной код генерируется Delphi.


 type
   TSplashForm = class(TForm)
     [...labels, bitmaps, и пр., добавляется редактором Delphi...]
     procedure FormDeactivate(Sender: TObject);
   end;
 
 var
   SplashForm: TSplashForm;
 
 implementation
 
 {$R *.DFM}
 
 { Это шаманское место. Application.Run в нашем случае
 вызывает программу деактивации.}
 
 procedure TSplashForm.FormDeactivate(Sender: TObject);
 begin
   {>>вставить}
   Free;
   {<<конец вставки}
 
 end;
 
 {>>вставить}
 
 initialization
   begin
     SplashForm := TSplashForm.Create(nil);
     SplashForm.Show;
 
     { Я не уверен, но причина наличия здесь Update в том,
     что, как мне кажется, приложение пока не может работать
     c очередью своих сообщений}
 
     SplashForm.Update;
   end;
   {<<конец вставки}
 end.
 

В головном модуле после строчки USES (.DPR-файл) просто добавьте "SPLASH," (не заключайте это в кавычки). Это все. Никакой головной боли с таймерами, никаких запусков отдельных приложений. Логотип быстро появляется и остается до тех пор, пока приложение не начнет свою работу.




Показ логотипа при запуске приложения 3


 program Project1;
 uses
   Forms,
   Unit1 in 'Unit1.pas' {Form1};
   ULogo in 'ULogo.pas' {LogoForm};
 
 {$R *.RES}
 
 begin
   Application.Initialize; {до этого момента никаких изменений}
 
   with TLogoForm.Create(Application) do
   try
     Show;
     Update;
     Application.CreateForm(TForm1, Form1);
     {GProgress.AddProgress(1); - здесь можно двигать прогресс, если TGauge
     или TProgressBar лежат на TLogoForm'е}
 
     {если есть еще формы, то Application.CreateForm(TForm2, Form2); и т.д.}
   finally
     Free;
   end;
 
   Application.Run;
 end.
 




Существует ли средство для вывода определения структуры таблицы

Автор: Nomadic

Для этого существует утилита DB2LOOK. Она находится в SQLLIB\MISC.

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

CONNECT TO SAMPLE USER xxx USING yyy
 DB2LOOK -d SAMPLE -u xxx -e -t employee
Вывод может быть перенаправлен в файл. Полный синтаксис выдаётся по команде:
DB2LOOK ?



Показ окна без главной формы

Как мне сделать так, чтобы видимой была только выбранная форма? (то есть без главной формы)

Попробуйте этот код в любом вторичном окне, которое вы НЕ хотите сопровождать главным окном:


 ...
 private {Это включается в объявления формы.}
   { Private declarations }
   procedure CreateParams(VAR Params: TCreateParams); override;
 ...
 
 procedure TForm2.CreateParams(VAR Params: TCreateParams);
 begin
   Inherited CreateParams(Params);
   Params.WndParent := GetDesktopWindow;
 end;
 

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




Как правильно завершить некое приложение

Автор: Nomadic

Если не принудительно, то можно послать на его Instance сообщение WM_QUIT. Если же необходимо принудительно терминировать приложение, то смотрите ниже - под Windows NT процесс можно терминировать через специально предназначенный для этого хэндл. Иначе гарантии нет. Предположим, что процесс создаем мы, ожидая его завершения в течение maxworktime. Тогда -


 var
   dwResult: Longint; // This example was converted from C source.
 begin
   // Not tested. Some 'nil' assignments must be applied
   // as zero assignments in Pascal. Some vars need to
   // be declared (maxworktime, si, pi). AA.
   if CreateProcess(nil, CmdStr, nil, nil, FALSE,
     CREATE_NEW_CONSOLE, nil, nil, si, pi) then
   begin
     CloseHandle(pi.hThread);
     dwResult := WaitForSingleObject(pi.hProcess, maxworktime * 1000 * 60);
     CloseHandle(pi.hProcess);
     if dwResult <> WAIT_OBJECT_0 then
     begin
       pi.hProcess := OpenProcess(PROCESS_TERMINATE, FALSE, pi.dwProcessId);
       if pi.hProcess <> nil then
       begin
         TerminateProcess(pi.hProcess, 0);
         CloseHandle(pi.hProcess);
       end;
     end;
   end;
 end;
 




Как правильно завершить некое приложение 2

Автор: Панферов Андрей

Если бы колбаса продавалась так же как программное обеспечение, то под прозрачной оберткой у нее было бы следующее соглашение:
1) изготовитель не гарантирует совместимость данного продукта с организмом и не несет никаких последствий за его употребление;
2) потребителю запрещается исследовать содержимое этой колбасы (например, на наличие крысиных хвостов);
3) покупатель может сьесть колбасу, но все равно не станет ее владельцем;
4) употребить колбасу может только один человек;
5) покупатель не может продать колбасу кому-либо;
6)производитель не гарантирует, что данный продукт свободен от ошибок (например, от примесей цианистого калия);
7) возможная ответственность за здоровье покупателя не может превысить стоимость колбасы;
8) разрывая обертку, покупатель принимает условия данного соглашения.


 var
   Form1: TForm1;
 
   // Глобальные переменные:
 
   StartupInfo: TStartupInfo;
   ProcessInfo: TProcessInformation;
   StartEn: Boolean = False;
 
 implementation
 
 {$R *.DFM}
 
 // Запуск процесса
 
 procedure TForm1.StartButtonClick(Sender: TObject);
 var
   CmdStr: PChar; // Командная строка для запуска приложения
 begin
   CmdStr := PChar(FilenameEdit1.FileName); // Определение командной строки
 
   StartEn := False; // Запущено ли приложение
 
   // Без этого приложение не стартует =<
   FillChar(StartupInfo, Sizeof(StartupInfo), #0);
   StartupInfo.cb := Sizeof(StartupInfo);
 
   StartupInfo.dwFlags := STARTF_USESHOWWINDOW;
   StartupInfo.wShowWindow := SW_NORMAL; // Состояние окна запущенного приложения
   // <= Без этого приложение не стартует
 
   // Запускаем процесс
   StartEn := CreateProcess(nil,
     CmdStr, { указатель командной строки }
     nil, { указатель на процесс атрибутов безопасности }
     nil, { указатель на поток атрибутов безопасности }
     False, { флаг родительского обработчика }
     CREATE_NEW_CONSOLE or { флаг создания }
     NORMAL_PRIORITY_CLASS,
     nil, { указатель на новую среду процесса }
     nil, { указатель на имя текущей директории }
     StartupInfo, { указатель на STARTUPINFO }
     ProcessInfo); { указатель на PROCESS_INF }
 
   EndButton.Enabled := StartEn;
 end;
 
 // Терминация процесса
 
 procedure TForm1.EndButtonClick(Sender: TObject);
 begin
   if StartEn then
   begin
     ProcessInfo.hProcess := OpenProcess(PROCESS_TERMINATE, False,
       ProcessInfo.dwProcessId);
     if ProcessInfo.hProcess <> Null then
     begin
       TerminateProcess(ProcessInfo.hProcess, 0);
       CloseHandle(ProcessInfo.hThread);
       CloseHandle(ProcessInfo.hProcess);
     end;
   end;
   StartEn := False;
   EndButton.Enabled := StartEn;
 end;
 




Как выключить компьютер с любой версией Windows


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


 function GetWinVersion: string;
 var
   VersionInfo: TOSVersionInfo;
   OSName: string;
 begin
   // устанавливаем размер записи
   VersionInfo.dwOSVersionInfoSize := SizeOf( TOSVersionInfo );
   if Windows.GetVersionEx( VersionInfo ) then
   begin
     with VersionInfo do
     begin
       case dwPlatformId of
         VER_PLATFORM_WIN32s: OSName := 'Win32s';
         VER_PLATFORM_WIN32_WINDOWS: OSName := 'Windows 95';
         VER_PLATFORM_WIN32_NT: OSName := 'Windows NT';
       end; // case dwPlatformId
       Result := OSName + ' Version ' + IntToStr( dwMajorVersion ) + '.' + IntToStr( dwMinorVersion ) +
       #13#10' (Build ' + IntToStr( dwBuildNumber ) + ': ' + szCSDVersion + ')';
     end; // with VersionInfo
   end // if GetVersionEx
   else
   Result := '';
 end;
 
 procedure ShutDown;
 const
   SE_SHUTDOWN_NAME = 'SeShutdownPrivilege'; // Borland forgot this declaration
 var
   hToken: THandle;
   tkp: TTokenPrivileges;
   tkpo: TTokenPrivileges;
   zero: DWORD;
 begin
   if Pos('Windows NT', GetWinVersion) = 1 then // we've got to do a whole buch of things
   begin
     zero := 0;
     if not OpenProcessToken(GetCurrentProcess(), TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY, hToken) then
     begin
       MessageBox(0, 'Exit Error', 'OpenProcessToken() Failed', MB_OK);
       Exit;
     end; // if not OpenProcessToken( GetCurrentProcess(), TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY, hToken)
 
     if not OpenProcessToken( GetCurrentProcess(), TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY, hToken) then
     begin
       MessageBox(0, 'Exit Error', 'OpenProcessToken() Failed', MB_OK);
       Exit;
     end; // if not OpenProcessToken( GetCurrentProcess(), TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY, hToken)
 
     // SE_SHUTDOWN_NAME
     if not LookupPrivilegeValue( nil, 'SeShutdownPrivilege' , tkp.Privileges[0].Luid ) then
     begin
       MessageBox(0, 'Exit Error', 'LookupPrivilegeValue() Failed', MB_OK);
       Exit;
     end; // if not LookupPrivilegeValue( nil, 'SeShutdownPrivilege' , tkp.Privileges[0].Luid )
 
     tkp.PrivilegeCount := 1;
     tkp.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED;
 
     AdjustTokenPrivileges(hToken, False, tkp, SizeOf( TTokenPrivileges ), tkpo, zero);
     if Boolean(GetLastError()) then
     begin
       MessageBox(0, 'Exit Error', 'AdjustTokenPrivileges() Failed', MB_OK);
       Exit;
     end // if Boolean( GetLastError() )
     else
       ExitWindowsEx( EWX_FORCE or EWX_SHUTDOWN, 0 );
 
   end // if OSVersion = 'Windows NT'
   else
   begin // just shut the machine down
     ExitWindowsEx( EWX_FORCE or EWX_SHUTDOWN, 0 );
   end; // else
 end;
 




Вырубить монитор

Сидят программисты за компами, заходит начальник:
- Почему мониторы грязные?
- Да чем мы их только не чистили, даже спиртом все равно не помогает.
- А вы их Кометом, говорят он еще и вирусы убивает.

Давайте прикольнёмся над пользователем. Допустим выведем внезапно сообщение, типа... "Уже поздно. Будь послушным мальчиком. Туши свет и вали спать!" и... вырубим монитор...(включить его чудилка уже не сможет)...


 procedure TForm1.Button3Click(Sender: TObject);
 begin
   MessageDlg('Уже поздно. Будь послушным мальчиком. '+
   'Туши свет и вали спать!', mtInformatoion, [mbOk], 0);
   SendMessage(Application.Handle, WM_SYSCOMMAND, SC_MONITORPOWER, 0);
 end;
 

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


 procedure TForm1.Button3Click(Sender: TObject);
 begin
   SendMessage(Application.Handle, WM_SYSCOMMAND, SC_MONITORPOWER, -1);
 end;
 




Вырубить монитор 2

Во рожа! Попеняю монитору...


 SendMessage(HWND_BROADCAST,WM_SYSCOMMAND, 0);
 


 SendMessage(HWND_BROADCAST,WM_SYSCOMMAND, -1);
 




Выключить или перезагрузить компьютер


Меломана, алкоголика и программера спросили, что бы те делали, если бы они вдруг проснулись в 80-м году... Меломан пошел бы спасать Джона Леннона. Алкоголик бы упился дешевой водки. А программер бы повесился... Почему? А что, опять за ЕС садиться?

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


 ExitWindowsEx(EWX_LOGOFF or ewx_force,0);
 

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


 ExitWindowsEx(EWX_SHUTDOWN or ewx_force,0);
 

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


 ExitWindowsEx(EWX_REBOOT or ewx_force,0);
 

перезагрузка системы


 ExitWindowsEx(EWX_FORCE or ewx_force,0);
 

завершает работу всех запущенных в системе приложений, не посылая им сообщения WM_QUERYENDSESSION и WM_ENDSESSIO. Это может вызвать потерю не сохраненных данных


 ExitWindowsEx(EWX_POWEROFF or ewx_force,0);
 

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


 ExitWindowsEx(EWX_FORCEIFHUNG or ewx_force,0);
 

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

Ещё вариант перезагрузки:


 mov  al,0F0h
 out  64h,al
 




Как выключить Win2000


Автор: Prankster

Один другому показывает какой он крутой комп купил. И процессор охрененный и памяти вагон, тивитюнер, сканер, принтер, сидюк, ... , Windows 2000 :)) Включает, а винды ему: - Внимание сейчас попытаюсь со всей этой х....й загрузиться !!!

Известно, что с помощью стандартных функций Windows 2000 не вырубишь. Сегодня мы напишем прогу на WinApi, выключающую W2k, и занимающую всего 10 Кб! Создай обычный текстовый документ, открой его любым редактором, и пиши туда такую хрень:


 program reboot;
 
 uses
   Windows, messages;
 
 procedure RebootSystem;
 var
   handle_: THandle;
   n: DWORD;
   luid: TLargeInteger;
   priv: TOKEN_PRIVILEGES;
   ver: TOSVERSIONINFO;
 begin
   ver.dwOSVersionInfoSize := Sizeof(ver);
   GetVersionEx(ver);
   if ver.dwPlatformId=VER_PLATFORM_WIN32_NT then
   begin
     if OpenProcessToken(GetCurrentProcess, TOKEN_ADJUST_PRIVILEGES, handle_) then
       if LookupPrivilegeValue(nil, 'SeShutdownPrivilege', luid) then
       begin
         priv.PrivilegeCount := 1;
         priv.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED;
         priv.Privileges[0].Luid := luid;
         AdjustTokenPrivileges(handle_, false, priv, 0, nil, n);
       end
       else
         writeln('Ошибка')
     else
       writeln('Ошибка ');
   end
   else
     writeln('Ошибка ');
   if not ExitWindowsEx(EWX_POWEROFF,1) then
     writeln('Ошибка');
 end;
 
 begin
   RebootSystem;
 end.
 

Сохрани этот файл под именем Reboot.dpr, открой из Delphi, и компилируй!




Как выключить Win2000 2


 procedure NTShutdown;
 var
   TokenHandle: Cardinal;
   RetLength: Cardinal;
   TP: TTokenPrivileges;
 begin
   OpenProcessToken(GetCurrentProcess(), TOKEN_ADJUST_PRIVILEGES
     or TOKEN_QUERY, TokenHandle);
   if LookupPrivilegeValue(nil, 'SeShutdownPrivilege',
     TP.Privileges[0].Luid) then
   begin
     TP.PrivilegeCount := 1;
     TP.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED;
     RetLength := 0;
     if AdjustTokenPrivileges(TokenHandle, FALSE, TP, 0, nil, RetLength) then
     begin
       if not SetProcessShutdownParameters($4FF, SHUTDOWN_NORETRY) then
       begin
         MessageBox(0, 'Shutdown failed', nil, MB_OK or MB_ICONSTOP);
       end
       else
       begin
         ExitWindowsEx(EWX_FORCE or EWX_SHUTDOWN, 0);
       end;
       exit;
     end;
   end;
   MessageBox(0, 'Access denied', nil, MB_OK or MB_ICONSTOP);
 end;
 




Преобразование сигнала в спекр и обратно (методы Хартли, Фурье и классический)

Автор: Denis Furman


 {$A+,B-,C+,D+,E-,F-,G+,H+,I+,J+,K-,L+,M-,N+,O-,P+,Q-,R-,S-,T-,U-,V+,W-,X+,Y+
 ,Z1}
 
 {$MINSTACKSIZE $00004000}
 
 {$MAXSTACKSIZE $00100000}
 
 {$IMAGEBASE $00400000}
 
 {$APPTYPE GUI}
 
 unit Main;
 
 interface
 
 uses
 
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
   Buttons, ExtCtrls, ComCtrls, Menus;
 
 type
 
   TfmMain = class(TForm)
     MainMenu1: TMainMenu;
     N1: TMenuItem;
     N2: TMenuItem;
     StatusBar1: TStatusBar;
     N3: TMenuItem;
     imgInfo: TImage;
     Panel1: TPanel;
     btnStart: TSpeedButton;
     procedure btnStartClick(Sender: TObject);
     procedure FormCreate(Sender: TObject);
     procedure FormClose(Sender: TObject; var Action: TCloseAction);
   end;
 
 var
 
   fmMain: TfmMain;
 
 implementation
 
 uses PFiles;
 
 {$R *.DFM}
 
 function Power2(lPower: Byte): LongInt;
 
 begin
   Result := 1 shl lPower;
 end;
 
 procedure ClassicDirect(var aSignal, aSpR, aSpI: array of Double; N:
   LongInt);
 
 var
   lSrch: LongInt;
 var
   lGarm: LongInt;
 var
   dSumR: Double;
 var
   dSumI: Double;
 begin
   for lGarm := 0 to N div 2 - 1 do
   begin
     dSumR := 0;
     dSumI := 0;
     for lSrch := 0 to N - 1 do
     begin
       dSumR := dSumR + aSignal[lSrch] * Cos(lGarm * lSrch / N * 2 * PI);
       dSumI := dSumI + aSignal[lSrch] * Sin(lGarm * lSrch / N * 2 * PI);
     end;
     aSpR[lGarm] := dSumR;
     aSpI[lGarm] := dSumI;
   end;
 end;
 
 procedure ClassicInverce(var aSpR, aSpI, aSignal: array of Double; N:
   LongInt);
 
 var
   lSrch: LongInt;
 var
   lGarm: LongInt;
 var
   dSum: Double;
 begin
   for lSrch := 0 to N - 1 do
   begin
     dSum := 0;
     for lGarm := 0 to N div 2 - 1 do
       dSum := dSum
         + aSpR[lGarm] * Cos(lSrch * lGarm * 2 * Pi / N)
         + aSpI[lGarm] * Sin(lSrch * lGarm * 2 * Pi / N);
     aSignal[lSrch] := dSum * 2;
   end;
 end;
 
 function InvertBits(BF, DataSize, Power: Word): Word;
 
 var
   BR: Word;
 var
   NN: Word;
 var
   L: Word;
 begin
   br := 0;
   nn := DataSize;
   for l := 1 to Power do
   begin
     NN := NN div 2;
     if (BF >= NN) then
     begin
       BR := BR + Power2(l - 1);
       BF := BF - NN
     end;
   end;
   InvertBits := BR;
 end;
 
 procedure FourierDirect(var RealData, VirtData, ResultR, ResultV: array of
   Double; DataSize: LongInt);
 
 var
   A1: Real;
 var
   A2: Real;
 var
   B1: Real;
 var
   B2: Real;
 var
   D2: Word;
 var
   C2: Word;
 var
   C1: Word;
 var
   D1: Word;
 var
   I: Word;
 var
   J: Word;
 var
   K: Word;
 var
   Cosin: Real;
 var
   Sinus: Real;
 var
   wIndex: Word;
 var
   Power: Word;
 begin
   C1 := DataSize shr 1;
   C2 := 1;
   for Power := 0 to 15 //hope it will be faster then
   round(ln(DataSize) / ln(2))
     do
     if Power2(Power) = DataSize then
       Break;
   for I := 1 to Power do
   begin
     D1 := 0;
     D2 := C1;
     for J := 1 to C2 do
     begin
       wIndex := InvertBits(D1 div C1, DataSize, Power);
       Cosin := +(Cos((2 * Pi / DataSize) * wIndex));
       Sinus := -(Sin((2 * Pi / DataSize) * wIndex));
       for K := D1 to D2 - 1 do
       begin
         A1 := RealData[K];
         A2 := VirtData[K];
         B1 := ((Cosin * RealData[K + C1] - Sinus * VirtData[K + C1]));
         B2 := ((Sinus * RealData[K + C1] + Cosin * VirtData[K + C1]));
         RealData[K] := A1 + B1;
         VirtData[K] := A2 + B2;
         RealData[K + C1] := A1 - B1;
         VirtData[K + C1] := A2 - B2;
       end;
       Inc(D1, C1 * 2);
       Inc(D2, C1 * 2);
     end;
     C1 := C1 div 2;
     C2 := C2 * 2;
   end;
   for I := 0 to DataSize div 2 - 1 do
   begin
     ResultR[I] := +RealData[InvertBits(I, DataSize, Power)];
     ResultV[I] := -VirtData[InvertBits(I, DataSize, Power)];
   end;
 end;
 
 procedure Hartley(iSize: LongInt; var aData: array of Double);
 
 type
   taDouble = array[0..MaxLongInt div SizeOf(Double) - 1] of Double;
 var
   prFI, prFN, prGI: ^taDouble;
 var
   rCos, rSin: Double;
 var
   rA, rB, rTemp: Double;
 var
   rC1, rC2, rC3, rC4: Double;
 var
   rS1, rS2, rS3, rS4: Double;
 var
   rF0, rF1, rF2, rF3: Double;
 var
   rG0, rG1, rG2, rG3: Double;
 var
   iK1, iK2, iK3, iK4: LongInt;
 var
   iSrch, iK, iKX: LongInt;
 begin
   iK2 := 0;
   for iK1 := 1 to iSize - 1 do
   begin
     iK := iSize shr 1;
     repeat
       iK2 := iK2 xor iK;
       if (iK2 and iK) <> 0 then
         Break;
       iK := iK shr 1;
     until False;
     if iK1 > iK2 then
     begin
       rTemp := aData[iK1];
       aData[iK1] := aData[iK2];
       aData[iK2] := rTemp;
     end;
   end;
   iK := 0;
   while (1 shl iK) < iSize do
     Inc(iK);
   iK := iK and 1;
   if iK = 0 then
   begin
     prFI := @aData;
     prFN := @aData;
     prFN := @prFN[iSize];
     while Word(prFI) < Word(prFN) do
     begin
       rF1 := prFI^[0] - prFI^[1];
       rF0 := prFI^[0] + prFI^[1];
       rF3 := prFI^[2] - prFI^[3];
       rF2 := prFI^[2] + prFI^[3];
       prFI^[2] := rF0 - rF2;
       prFI^[0] := rF0 + rF2;
       prFI^[3] := rF1 - rF3;
       prFI^[1] := rF1 + rF3;
       prFI := @prFI[4];
     end;
   end
   else
   begin
     prFI := @aData;
     prFN := @aData;
     prFN := @prFN[iSize];
     prGI := prFI;
     prGI := @prGI[1];
     while Word(prFI) < Word(prFN) do
     begin
       rC1 := prFI^[0] - prGI^[0];
       rS1 := prFI^[0] + prGI^[0];
       rC2 := prFI^[2] - prGI^[2];
       rS2 := prFI^[2] + prGI^[2];
       rC3 := prFI^[4] - prGI^[4];
       rS3 := prFI^[4] + prGI^[4];
       rC4 := prFI^[6] - prGI^[6];
       rS4 := prFI^[6] + prGI^[6];
       rF1 := rS1 - rS2;
       rF0 := rS1 + rS2;
       rG1 := rC1 - rC2;
       rG0 := rC1 + rC2;
       rF3 := rS3 - rS4;
       rF2 := rS3 + rS4;
       rG3 := Sqrt(2) * rC4;
       rG2 := Sqrt(2) * rC3;
       prFI^[4] := rF0 - rF2;
       prFI^[0] := rF0 + rF2;
       prFI^[6] := rF1 - rF3;
       prFI^[2] := rF1 + rF3;
       prGI^[4] := rG0 - rG2;
       prGI^[0] := rG0 + rG2;
       prGI^[6] := rG1 - rG3;
       prGI^[2] := rG1 + rG3;
       prFI := @prFI[8];
       prGI := @prGI[8];
     end;
   end;
   if iSize < 16 then
     Exit;
   repeat
     Inc(iK, 2);
     iK1 := 1 shl iK;
     iK2 := iK1 shl 1;
     iK4 := iK2 shl 1;
     iK3 := iK2 + iK1;
     iKX := iK1 shr 1;
     prFI := @aData;
     prGI := prFI;
     prGI := @prGI[iKX];
     prFN := @aData;
     prFN := @prFN[iSize];
     repeat
       rF1 := prFI^[000] - prFI^[iK1];
       rF0 := prFI^[000] + prFI^[iK1];
       rF3 := prFI^[iK2] - prFI^[iK3];
       rF2 := prFI^[iK2] + prFI^[iK3];
       prFI^[iK2] := rF0 - rF2;
       prFI^[000] := rF0 + rF2;
       prFI^[iK3] := rF1 - rF3;
       prFI^[iK1] := rF1 + rF3;
       rG1 := prGI^[0] - prGI^[iK1];
       rG0 := prGI^[0] + prGI^[iK1];
       rG3 := Sqrt(2) * prGI^[iK3];
       rG2 := Sqrt(2) * prGI^[iK2];
       prGI^[iK2] := rG0 - rG2;
       prGI^[000] := rG0 + rG2;
       prGI^[iK3] := rG1 - rG3;
       prGI^[iK1] := rG1 + rG3;
       prGI := @prGI[iK4];
       prFI := @prFI[iK4];
     until not (Word(prFI) < Word(prFN));
     rCos := Cos(Pi / 2 / Power2(iK));
     rSin := Sin(Pi / 2 / Power2(iK));
     rC1 := 1;
     rS1 := 0;
     for iSrch := 1 to iKX - 1 do
     begin
       rTemp := rC1;
       rC1 := (rTemp * rCos - rS1 * rSin);
       rS1 := (rTemp * rSin + rS1 * rCos);
       rC2 := (rC1 * rC1 - rS1 * rS1);
       rS2 := (2 * (rC1 * rS1));
       prFN := @aData;
       prFN := @prFN[iSize];
       prFI := @aData;
       prFI := @prFI[iSrch];
       prGI := @aData;
       prGI := @prGI[iK1 - iSrch];
       repeat
         rB := (rS2 * prFI^[iK1] - rC2 * prGI^[iK1]);
         rA := (rC2 * prFI^[iK1] + rS2 * prGI^[iK1]);
         rF1 := prFI^[0] - rA;
         rF0 := prFI^[0] + rA;
         rG1 := prGI^[0] - rB;
         rG0 := prGI^[0] + rB;
         rB := (rS2 * prFI^[iK3] - rC2 * prGI^[iK3]);
         rA := (rC2 * prFI^[iK3] + rS2 * prGI^[iK3]);
         rF3 := prFI^[iK2] - rA;
         rF2 := prFI^[iK2] + rA;
         rG3 := prGI^[iK2] - rB;
         rG2 := prGI^[iK2] + rB;
         rB := (rS1 * rF2 - rC1 * rG3);
         rA := (rC1 * rF2 + rS1 * rG3);
         prFI^[iK2] := rF0 - rA;
         prFI^[0] := rF0 + rA;
         prGI^[iK3] := rG1 - rB;
         prGI^[iK1] := rG1 + rB;
         rB := (rC1 * rG2 - rS1 * rF3);
         rA := (rS1 * rG2 + rC1 * rF3);
         prGI^[iK2] := rG0 - rA;
         prGI^[0] := rG0 + rA;
         prFI^[iK3] := rF1 - rB;
         prFI^[iK1] := rF1 + rB;
         prGI := @prGI[iK4];
         prFI := @prFI[iK4];
       until not (LongInt(prFI) < LongInt(prFN));
     end;
   until not (iK4 < iSize);
 end;
 
 procedure HartleyDirect(
   var aData: array of Double;
 
   iSize: LongInt);
 var
   rA, rB: Double;
 var
   iI, iJ, iK: LongInt;
 begin
   Hartley(iSize, aData);
   iJ := iSize - 1;
   iK := iSize div 2;
   for iI := 1 to iK - 1 do
   begin
     rA := aData[ii];
     rB := aData[ij];
     aData[iJ] := (rA - rB) / 2;
     aData[iI] := (rA + rB) / 2;
     Dec(iJ);
   end;
 end;
 
 procedure HartleyInverce(
   var aData: array of Double;
 
   iSize: LongInt);
 
 var
   rA, rB: Double;
 var
   iI, iJ, iK: LongInt;
 begin
   iJ := iSize - 1;
   iK := iSize div 2;
   for iI := 1 to iK - 1 do
   begin
     rA := aData[iI];
     rB := aData[iJ];
     aData[iJ] := rA - rB;
     aData[iI] := rA + rB;
     Dec(iJ);
   end;
   Hartley(iSize, aData);
 end;
 
 //not tested
 
 procedure HartleyDirectComplex(real, imag: array of Double; n: LongInt);
 var
   a, b, c, d: double;
 
   q, r, s, t: double;
   i, j, k: LongInt;
 begin
 
   j := n - 1;
   k := n div 2;
   for i := 1 to k - 1 do
   begin
     a := real[i];
     b := real[j];
     q := a + b;
     r := a - b;
     c := imag[i];
     d := imag[j];
     s := c + d;
     t := c - d;
     real[i] := (q + t) * 0.5;
     real[j] := (q - t) * 0.5;
     imag[i] := (s - r) * 0.5;
     imag[j] := (s + r) * 0.5;
     dec(j);
   end;
   Hartley(N, Real);
   Hartley(N, Imag);
 end;
 
 //not tested
 
 procedure HartleyInverceComplex(real, imag: array of Double; N: LongInt);
 var
   a, b, c, d: double;
 
   q, r, s, t: double;
   i, j, k: longInt;
 begin
   Hartley(N, real);
   Hartley(N, imag);
   j := n - 1;
   k := n div 2;
   for i := 1 to k - 1 do
   begin
     a := real[i];
     b := real[j];
     q := a + b;
     r := a - b;
     c := imag[i];
     d := imag[j];
     s := c + d;
     t := c - d;
     imag[i] := (s + r) * 0.5;
     imag[j] := (s - r) * 0.5;
     real[i] := (q - t) * 0.5;
     real[j] := (q + t) * 0.5;
     dec(j);
   end;
 end;
 
 procedure DrawSignal(var aSignal: array of Double; N, lColor: LongInt);
 
 var
   lSrch: LongInt;
 var
   lHalfHeight: LongInt;
 begin
   with fmMain do
   begin
     lHalfHeight := imgInfo.Height div 2;
     imgInfo.Canvas.MoveTo(0, lHalfHeight);
     imgInfo.Canvas.Pen.Color := lColor;
     for lSrch := 0 to N - 1 do
     begin
       imgInfo.Canvas.LineTo(lSrch, Round(aSignal[lSrch]) + lHalfHeight);
     end;
     imgInfo.Repaint;
   end;
 end;
 
 procedure DrawSpector(var aSpR, aSpI: array of Double; N, lColR, lColI:
   LongInt);
 
 var
   lSrch: LongInt;
 var
   lHalfHeight: LongInt;
 begin
   with fmMain do
   begin
     lHalfHeight := imgInfo.Height div 2;
     for lSrch := 0 to N div 2 do
     begin
       imgInfo.Canvas.Pixels[lSrch, Round(aSpR[lSrch] / N) + lHalfHeight] :=
         lColR;
 
       imgInfo.Canvas.Pixels[lSrch + N div 2, Round(aSpI[lSrch] / N) +
         lHalfHeight] := lColI;
 
     end;
     imgInfo.Repaint;
   end;
 end;
 
 const
   N = 512;
 var
   aSignalR: array[0..N - 1] of Double; //
 var
   aSignalI: array[0..N - 1] of Double; //
 var
   aSpR, aSpI: array[0..N div 2 - 1] of Double; //
 var
   lFH: LongInt;
 
 procedure TfmMain.btnStartClick(Sender: TObject);
 
 const
   Epsilon = 0.00001;
 var
   lSrch: LongInt;
 var
   aBuff: array[0..N - 1] of ShortInt;
 begin
   if lFH > 0 then
   begin
     //   Repeat
 
     if F.Read(lFH, @aBuff, N) <> N then
     begin
       Exit;
     end;
     for lSrch := 0 to N - 1 do
     begin
       aSignalR[lSrch] := ShortInt(aBuff[lSrch] + $80);
       aSignalI[lSrch] := 0;
     end;
 
     imgInfo.Canvas.Rectangle(0, 0, imgInfo.Width, imgInfo.Height);
     DrawSignal(aSignalR, N, $D0D0D0);
 
     //    ClassicDirect(aSignalR, aSpR, aSpI, N);                 //result in aSpR & aSpI,
     aSignal unchanged
       //    FourierDirect(aSignalR, aSignalI, aSpR, aSpI, N);       //result in aSpR &
     aSpI, aSiggnalR & aSignalI modified
 
     HartleyDirect(aSignalR, N); //result in source aSignal ;-)
 
     DrawSpector(aSignalR, aSignalR[N div 2 - 1], N, $80, $8000);
     DrawSpector(aSpR, aSpI, N, $80, $8000);
 
     {    for lSrch := 0 to N div 2 -1 do begin                    //comparing classic & Hartley
 
     if (Abs(aSpR[lSrch] - aSignal[lSrch]) > Epsilon)
     or ((lSrch > 0) And (Abs(aSpI[lSrch] - aSignal[N - lSrch]) > Epsilon))
     then MessageDlg('Error comparing',mtError,[mbOK],-1);
     end;}
 
     HartleyInverce(aSignalR, N); //to restore original signal with
     HartleyDirect
       //    ClassicInverce(aSpR, aSpI, aSignalR, N);                //to restore original
     signal with ClassicDirect or FourierDirect
 
     for lSrch := 0 to N - 1 do
       aSignalR[lSrch] := aSignalR[lSrch] / N; //scaling
 
     DrawSignal(aSignalR, N, $D00000);
     Application.ProcessMessages;
     //   Until False;
 
   end;
 end;
 
 procedure TfmMain.FormCreate(Sender: TObject);
 
 begin
   lFH := F.Open('input.pcm', ForRead);
 end;
 
 procedure TfmMain.FormClose(Sender: TObject; var Action: TCloseAction);
 
 begin
   F.Close(lFH);
 end;
 
 end.
 




Простой пример DLL

Автор: Steve Schafer


 library MyDll;
 
 uses Windows;
 
 function SomeFunc(I: Integer): Integer; stdcall;
 begin
   if Odd(I) then
     Result := 3 * I + 1
   else
     Result := I div 2;
 end;
 
 exports
   SomeFunc;
 
 begin
 end.
 

И вот модуль импорта, который вы можете включить в любой проект, которому необходим доступ к функциям DLL:


 unit MyDllImport;
 
 interface
 
 uses Windows;
 
 function SomeFunc(I: Integer): Integer; stdcall;
 
 implementation
 
 function SomeFunc; external 'mydll.dll';
 
 end.
 




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



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



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


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