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

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


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

БОЛЬШОЙ FAQ ПО DELPHI



Как узнать, какой язык активен в Windows

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


 function WhichLanguage:string;
 var
   ID: LangID;
   Language: array [0..100] of char;
 begin
   ID := GetSystemDefaultLangID;
   VerLanguageName(ID, Language, 100);
   Result := string(Language);
 end;
 
 ...
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   Edit1.Text := WhichLanguage;
 end;
 




Ошибка EOLESYS..OPERATION UNAVAILABLE (операция недоступна) при использовании GETACTIVEOLEOBJECT

- Надо снять порчу с компьютера, - сказала цыганка, запустив DrWeb.

Это происходит при использовании сервера автоматизации Delphi, или когда сервер автоматизации (например, word.basic) не запущен.


 procedure TForm1.Button1Click(Sender: TObject);
 var
   V: OleVariant;
 begin
   V := GetActiveOleObject('Word.Basic');
   V.FileNew;
   V.Insert('тест');
 end;
 

GetActiveOleObject определен в ComObj.pas. Он преобразует имя класса в guid и передает его при вызове Windows api функции GetActiveObject.


 function GetActiveOleObject(const ClassName: string): IDispatch;
 var
   ClassID: TCLSID;
   Unknown: IUnknown;
 begin
   ClassID := ProgIDToClassID(ClassName);
   OleCheck(GetActiveObject(ClassID, nil, Unknown));
   OleCheck(Unknown.QueryInterface(IDispatch, Result));
 end;
 

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




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

Автор: Vimil Saju

Я выбросил из окна два компа - 386 и 486. В самом деле, 486 был быстрее...

В реестре есть раздел HKEY_DYN_DATA. Основная информация о системе хранится в ключе PerfStats.

О получении информации,например, о загруженности процессора, необходимо проделать следующие шаги:

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

Например

Просто считываем значение ключа 'PerfStats\StartStat\KERNEL\CPUusage' в секции HKEY_DYN_DATA. данное действие запускает счётчик. После этого в ключе 'PerfStats\StatData\KERNEL\CPUusage' будет храниться значение в процентах о загруженности процессора.

Далее, если добавить считывание загруженности процессора в событие On timer, то мы сможем наблюдать изменение загруженности процессора в динамике.

По завершении, Ваша программа должна остановить счётчик в реестре. Для этого просто считай ключ 'PerfStats\StopStat\KERNEL\CPUusage'.Это остановит счётчик.

Так же в системе есть много других счётчиков. Весь список счётчиков можно посмотреть в ключе PerfStats\StatData, используя редактор реестра.

Представленный ниже исходник получает значения всех счётчиков, расположенных в секции HKEY_DYN_DATA.


 unit SystemInfo;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
   Dialogs,extctrls;
 
 //Информация о Dialup адаптере
 type TDialupAdapterInfo = record
   alignment:dword;
   buffer:dword;
   bytesrecieved:dword;
   bytesXmit:dword;
   ConnectSpeed:dword;
   CRC:dword;
   framesrecieved:dword;
   FramesXmit:dword;
   Framing:dword;
   runts:dword;
   Overrun:dword;
   timeout:dword;
   totalbytesrecieved:dword;
   totalbytesXmit:dword;
 end;
 
 type TKernelInfo = record
   CpuUsagePcnt:dword;
   Numthreads:dword;
   NumVMS:dword;
 end;
 
 type TVCACHEInfo = record
   ccurpages:dword;
   cMacPages:dword;
   cminpages:dword;
   FailedRecycles:dword;
   Hits:dword;
   LRUBuffers:dword;
   LRURecycles:dword;
   Misses:dword;
   RandomRecycles:dword;
 end;
 
 type TFATInfo = record
   BreadsSec:dword;
   BwritesSec:dword;
   Dirtydata:dword;
   ReadsSec:dword;
   WritesSec:dword;
 end;
 
 type TVMMInfo = record
   CDiscards:dword;
   CInstancefaults:dword;
   CPageFaults:dword;
   cPageIns:dword;
   cPageOuts:dword;
   cpgCommit:dword;
   cpgDiskCache:dword;
   cpgDiskCacheMac:dword;
   cpgDiskCacheMid:dword;
   cpgDiskCacheMin:dword;
   cpgfree:dword;
 
   cpglocked:dword;
   cpglockedNoncache:dword;
   cpgother:dword;
   cpgsharedpages:dword;
   cpgswap:dword;
   cpgswapfile:dword;
   cpgswapfiledefective:dword;
   cpgswapfileinuse:dword;
 end;
 
 type
   TSysInfo = class(TComponent)
   private
     fDialupAdapterInfo:TDialupAdapterInfo;
     fKernelInfo:TKernelInfo;
     fVCACHEInfo:TVCACHEInfo;
     fFATInfo:TFATInfo;
     fVMMInfo:TVMMInfo;
     ftimer:TTimer;
     fupdateinterval:integer;
     tmp:dword;
     vsize:dword;
     pkey:hkey;
     regtype:pdword;
     fstopped:boolean;
     procedure fupdatinginfo(sender:tobject);
     procedure fsetupdateinterval(aupdateinterval:integer);
   protected
     fsysInfoChanged:TNotifyEvent;
   public
     constructor Create(Aowner:Tcomponent);override;
     destructor Destroy;override;
 
     property DialupAdapterInfo: TDialupAdapterInfo read fDialupAdapterInfo;
     property KernelInfo: TKernelInfo read fKernelInfo;
     property VCACHEInfo: TVCACHEInfo read fVCACHEInfo;
     property FATInfo: TFATInfo read fFATInfo;
     property VMMInfo: TVMMInfo read fVMMInfo;
     procedure StartRecievingInfo;
     procedure StopRecievingInfo;
   published
     property SysInfoChanged:TNotifyEvent read fsysInfoChanged write
     fsysInfoChanged;//Это событие вызывается после определённого интервала времени.
     property UpdateInterval:integer read fupdateInterval write
     fsetupdateinterval default 5000;
 end;
 
 procedure register;
 
 implementation
 
 constructor TSysInfo.Create(Aowner:Tcomponent);
 begin
   inherited;
   ftimer:=ttimer.Create(self);
   ftimer.enabled:=false;
   ftimer.OnTimer:=fupdatinginfo;
   vsize:=4;
   fstopped:=true;
 end;
 
 procedure TSysInfo.startrecievingInfo;
 var
   res:integer;
 begin
   res:=RegOpenKeyEx(HKEY_DYN_DATA, 'PerfStats\StartStat',0,KEY_ALL_ACCESS,pkey);
   if res<>0 then
     raise exception.Create('Could not open registry key');
   fstopped:=false;
   // Для Dial Up Адаптера
   RegQueryValueEx(pkey,'Dial-Up Adapter\Alignment',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'Dial-Up Adapter\Buffer',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'Dial-Up Adapter\Framing',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'Dial-Up Adapter\Overrun ',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'Dial-Up Adapter\Timeout',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'Dial-Up Adapter\CRC',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'Dial-Up Adapter\Runts',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'Dial-Up Adapter\FramesXmit',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'Dial-Up Adapter\FramesRecvd',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'Dial-Up Adapter\BytesXmit',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'Dial-Up Adapter\BytesRecvd',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'Dial-Up Adapter\TotalBytesXmit',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'Dial-Up Adapter\TotalBytesRecvd',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'Dial-Up Adapter\ConnectSpeed',nil,regtype,@tmp,@vsize);
 
   // Для VCACHE
   RegQueryValueEx(pkey,'VCACHE\LRUBuffers',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'VCACHE\FailedRecycles',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'VCACHE\RandomRecycles',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'VCACHE\LRURecycles',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'VCACHE\Misses',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'VCACHE\Hits',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'VCACHE\cMacPages',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'VCACHE\cMinPages',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'VCACHE\cCurPages',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'Dial-Up Adapter\BytesXmit',nil,regtype,@tmp,@vsize);
 
   //Для VFAT
 
   RegQueryValueEx(pkey,'VFAT\DirtyData',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'VFAT\BReadsSec',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'VFAT\BWritesSec',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'VFAT\ReadsSec',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'VFAT\WritesSec',nil,regtype,@tmp,@vsize);
   //Для VMM
 
   RegQueryValueEx(pkey,'VMM\cpgLockedNoncache',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'VMM\cpgCommit',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'VMM\cpgSharedPages',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'VMM\cpgDiskcacheMid',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'VMM\cpgDiskcacheMac',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'VMM\cpgDiskcacheMin',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'VMM\cpgDiskcache',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'VMM\cpgSwapfileDefective',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'VMM\cpgSwapfileInUse',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'VMM\cpgSwapfile',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'VMM\cDiscards',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'VMM\cPageOuts',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'VMM\cPageIns',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'VMM\cInstanceFaults',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'VMM\cPageFaults',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'VMM\cpgOther',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'VMM\cpgSwap',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'VMM\cpgLocked',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'VMM\cpgFree',nil,regtype,@tmp,@vsize);
   //Для KERNEL
   RegQueryValueEx(pkey,'KERNEL\CPUUsage',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'KERNEL\VMs',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'KERNEL\Threads',nil,regtype,@tmp,@vsize);
   RegCloseKey(pkey);
   ftimer.enabled:=true;
 end;
 
 procedure tsysinfo.fupdatinginfo(sender:tobject);
 var
   res:integer;
 begin
   res:=RegOpenKeyEx(HKEY_DYN_DATA, 'PerfStats\StatData',0,KEY_ALL_ACCESS,pkey);
   if res<>0 then
     raise exception.Create('Could not open registry key');
   //Для Dial Up Адаптера
   RegQueryValueEx(pkey,'Dial-Up Adapter\Alignment',nil,regtype,@fDialupAdapterInfo.alignment,@vsize);
   RegQueryValueEx(pkey,'Dial-Up Adapter\Buffer',nil,regtype,@fDialupAdapterInfo.buffer,@vsize);
   RegQueryValueEx(pkey,'Dial-Up Adapter\Framing',nil,regtype,@fDialupAdapterInfo.framing,@vsize);
   RegQueryValueEx(pkey,'Dial-Up Adapter\Overrun ',nil,regtype,@fDialupAdapterInfo.overrun,@vsize);
   RegQueryValueEx(pkey,'Dial-Up Adapter\Timeout',nil,regtype,@fDialupAdapterInfo.timeout,@vsize);
   RegQueryValueEx(pkey,'Dial-Up Adapter\CRC',nil,regtype, @fDialupAdapterInfo.crc,@vsize);
   RegQueryValueEx(pkey,'Dial-Up Adapter\Runts',nil,regtype,@fDialupAdapterInfo.runts,@vsize);
   RegQueryValueEx(pkey,'Dial-Up Adapter\FramesXmit',nil,regtype,@fDialupAdapterInfo.framesxmit,@vsize);
   RegQueryValueEx(pkey,'Dial-Up Adapter\FramesRecvd',nil,regtype, @fDialupAdapterInfo.framesrecieved,@vsize);
   RegQueryValueEx(pkey,'Dial-Up Adapter\BytesXmit',nil,regtype,@fDialupAdapterInfo.bytesxmit,@vsize);
   RegQueryValueEx(pkey,'Dial-Up Adapter\BytesRecvd',nil,regtype, @fDialupAdapterInfo.bytesrecieved,@vsize);
   RegQueryValueEx(pkey,'Dial-Up Adapter\TotalBytesXmit',nil,regtype, @fDialupAdapterInfo.totalbytesxmit,@vsize);
   RegQueryValueEx(pkey,'Dial-Up Adapter\TotalBytesRecvd',nil,regtype, @fDialupAdapterInfo.totalbytesrecieved,@vsize);
   RegQueryValueEx(pkey,'Dial-Up Adapter\ConnectSpeed',nil,regtype, @fDialupAdapterInfo.connectspeed,@vsize);
   // Для VCACHE
   RegQueryValueEx(pkey,'VCACHE\LRUBuffers',nil,regtype, @fVCACHEInfo.lrubuffers,@vsize);
   RegQueryValueEx(pkey,'VCACHE\FailedRecycles',nil,regtype, @fVCACHEInfo.failedrecycles,@vsize);
   RegQueryValueEx(pkey,'VCACHE\RandomRecycles',nil,regtype, @fVCACHEInfo.randomrecycles,@vsize);
   RegQueryValueEx(pkey,'VCACHE\LRURecycles',nil,regtype, @fVCACHEInfo.lrurecycles,@vsize);
   RegQueryValueEx(pkey,'VCACHE\Misses',nil,regtype, @fVCACHEInfo.misses,@vsize);
   RegQueryValueEx(pkey,'VCACHE\Hits',nil,regtype,@fVCACHEInfo.hits,@vsize);
   RegQueryValueEx(pkey,'VCACHE\cMacPages',nil,regtype, @fVCACHEInfo.cmacpages,@vsize);
   RegQueryValueEx(pkey,'VCACHE\cMinPages',nil,regtype, @fVCACHEInfo.cminpages,@vsize);
   RegQueryValueEx(pkey,'VCACHE\cCurPages',nil,regtype, @fVCACHEInfo.ccurpages,@vsize);
   //Для VFAT
   RegQueryValueEx(pkey,'VFAT\DirtyData',nil,regtype, @ffatinfo.dirtydata,@vsize);
   RegQueryValueEx(pkey,'VFAT\BReadsSec',nil,regtype, @ffatinfo.breadssec,@vsize);
   RegQueryValueEx(pkey,'VFAT\BWritesSec',nil,regtype, @ffatinfo.bwritessec,@vsize);
   RegQueryValueEx(pkey,'VFAT\ReadsSec',nil,regtype, @ffatinfo.readssec,@vsize);
   RegQueryValueEx(pkey,'VFAT\WritesSec',nil,regtype, @ffatinfo.writessec,@vsize);
   //Для VMM
   RegQueryValueEx(pkey,'VMM\cpgLockedNoncache',nil,regtype, @fvmminfo.cpglockednoncache,@vsize);
   RegQueryValueEx(pkey,'VMM\cpgCommit',nil,regtype, @fvmminfo.cpgcommit,@vsize);
   RegQueryValueEx(pkey,'VMM\cpgSharedPages',nil,regtype, @fvmminfo.cpgsharedpages,@vsize);
   RegQueryValueEx(pkey,'VMM\cpgDiskcacheMid',nil,regtype, @fvmminfo.cpgdiskcacheMid,@vsize);
   RegQueryValueEx(pkey,'VMM\cpgDiskcacheMac',nil,regtype, @fvmminfo.cpgdiskcacheMac,@vsize);
   RegQueryValueEx(pkey,'VMM\cpgDiskcacheMin',nil,regtype, @fvmminfo.cpgdiskcacheMin,@vsize);
   RegQueryValueEx(pkey,'VMM\cpgDiskcache',nil,regtype, @fvmminfo.cpgdiskcache,@vsize);
   RegQueryValueEx(pkey,'VMM\cpgSwapfileDefective',nil,regtype, @fvmminfo.cpgswapfiledefective,@vsize);
   RegQueryValueEx(pkey,'VMM\cpgSwapfileInUse',nil,regtype, @fvmminfo.cpgswapfileinuse,@vsize);
   RegQueryValueEx(pkey,'VMM\cpgSwapfile',nil,regtype, @fvmminfo.cpgswapfile,@vsize);
   RegQueryValueEx(pkey,'VMM\cDiscards',nil,regtype, @fvmminfo.cdiscards,@vsize);
   RegQueryValueEx(pkey,'VMM\cPageOuts',nil,regtype, @fvmminfo.cpageouts,@vsize);
   RegQueryValueEx(pkey,'VMM\cPageIns',nil,regtype, @fvmminfo.cpageins,@vsize);
   RegQueryValueEx(pkey,'VMM\cInstanceFaults',nil,regtype, @fvmminfo.cinstancefaults,@vsize);
   RegQueryValueEx(pkey,'VMM\cPageFaults',nil,regtype, @fvmminfo.cpagefaults,@vsize);
   RegQueryValueEx(pkey,'VMM\cpgOther',nil,regtype, @fvmminfo.cpgother,@vsize);
   RegQueryValueEx(pkey,'VMM\cpgSwap',nil,regtype, @fvmminfo.cpgswap,@vsize);
   RegQueryValueEx(pkey,'VMM\cpgLocked',nil,regtype, @fvmminfo.cpglocked,@vsize);
   RegQueryValueEx(pkey,'VMM\cpgFree',nil,regtype, @fvmminfo.cpgfree,@vsize);
   //Для KERNEL
   RegQueryValueEx(pkey,'KERNEL\CPUUsage',nil,regtype, @fkernelinfo.cpuusagepcnt,@vsize);
   RegQueryValueEx(pkey,'KERNEL\VMs',nil,regtype,@fkernelinfo.numvms,@vsize);
   RegQueryValueEx(pkey,'KERNEL\Threads',nil,regtype, @fkernelinfo.numThreads,@vsize);
   RegCloseKey(pkey);
   if assigned(SysInfoChanged) then
     SysInfoChanged(self);
 end;
 
 procedure TSysInfo.stoprecievingInfo;
 var
   res:integer;
 begin
   res:=RegOpenKeyEx(HKEY_DYN_DATA, 'PerfStats\StopStat',0,KEY_ALL_ACCESS,pkey);
   if not fstopped then
   begin
     if res<>0 then
       raise exception.Create('Could not open registry key');
     //Для Dial Up Адаптера
     RegQueryValueEx(pkey,'Dial-Up Adapter\Alignment',nil,regtype,@tmp,@vsize);
     RegQueryValueEx(pkey,'Dial-Up Adapter\Buffer',nil,regtype,@tmp,@vsize);
     RegQueryValueEx(pkey,'Dial-Up Adapter\Framing',nil,regtype,@tmp,@vsize);
     RegQueryValueEx(pkey,'Dial-Up Adapter\Overrun ',nil,regtype,@tmp,@vsize);
     RegQueryValueEx(pkey,'Dial-Up Adapter\Timeout',nil,regtype,@tmp,@vsize);
     RegQueryValueEx(pkey,'Dial-Up Adapter\CRC',nil,regtype,@tmp,@vsize);
     RegQueryValueEx(pkey,'Dial-Up Adapter\Runts',nil,regtype,@tmp,@vsize);
     RegQueryValueEx(pkey,'Dial-Up Adapter\FramesXmit',nil,regtype,@tmp,@vsize);
     RegQueryValueEx(pkey,'Dial-Up Adapter\FramesRecvd',nil,regtype,@tmp,@vsize);
     RegQueryValueEx(pkey,'Dial-Up Adapter\BytesXmit',nil,regtype,@tmp,@vsize);
     RegQueryValueEx(pkey,'Dial-Up Adapter\BytesRecvd',nil,regtype,@tmp,@vsize);
     RegQueryValueEx(pkey,'Dial-Up Adapter\TotalBytesXmit',nil,regtype,@tmp,@vsize);
     RegQueryValueEx(pkey,'Dial-Up Adapter\TotalBytesRecvd',nil,regtype,@tmp,@vsize);
     RegQueryValueEx(pkey,'Dial-Up Adapter\ConnectSpeed',nil,regtype,@tmp,@vsize);
 
     // Для VCACHE
     RegQueryValueEx(pkey,'VCACHE\LRUBuffers',nil,regtype,@tmp,@vsize);
     RegQueryValueEx(pkey,'VCACHE\FailedRecycles',nil,regtype,@tmp,@vsize);
     RegQueryValueEx(pkey,'VCACHE\RandomRecycles',nil,regtype,@tmp,@vsize);
     RegQueryValueEx(pkey,'VCACHE\LRURecycles',nil,regtype,@tmp,@vsize);
     RegQueryValueEx(pkey,'VCACHE\Misses',nil,regtype,@tmp,@vsize);
     RegQueryValueEx(pkey,'VCACHE\Hits',nil,regtype,@tmp,@vsize);
     RegQueryValueEx(pkey,'VCACHE\cMacPages',nil,regtype,@tmp,@vsize);
     RegQueryValueEx(pkey,'VCACHE\cMinPages',nil,regtype,@tmp,@vsize);
     RegQueryValueEx(pkey,'VCACHE\cCurPages',nil,regtype,@tmp,@vsize);
     RegQueryValueEx(pkey,'Dial-Up Adapter\BytesXmit',nil,regtype,@tmp,@vsize);
 
     //Для VFAT
     RegQueryValueEx(pkey,'VFAT\DirtyData',nil,regtype,@tmp,@vsize);
     RegQueryValueEx(pkey,'VFAT\BReadsSec',nil,regtype,@tmp,@vsize);
     RegQueryValueEx(pkey,'VFAT\BWritesSec',nil,regtype,@tmp,@vsize);
     RegQueryValueEx(pkey,'VFAT\ReadsSec',nil,regtype,@tmp,@vsize);
     RegQueryValueEx(pkey,'VFAT\WritesSec',nil,regtype,@tmp,@vsize);
 
     //Для VMM
     RegQueryValueEx(pkey,'VMM\cpgLockedNoncache',nil,regtype,@tmp,@vsize);
     RegQueryValueEx(pkey,'VMM\cpgCommit',nil,regtype,@tmp,@vsize);
     RegQueryValueEx(pkey,'VMM\cpgSharedPages',nil,regtype,@tmp,@vsize);
     RegQueryValueEx(pkey,'VMM\cpgDiskcacheMid',nil,regtype,@tmp,@vsize);
     RegQueryValueEx(pkey,'VMM\cpgDiskcacheMac',nil,regtype,@tmp,@vsize);
     RegQueryValueEx(pkey,'VMM\cpgDiskcacheMin',nil,regtype,@tmp,@vsize);
     RegQueryValueEx(pkey,'VMM\cpgDiskcache',nil,regtype,@tmp,@vsize);
     RegQueryValueEx(pkey,'VMM\cpgSwapfileDefective',nil,regtype,@tmp,@vsize);
     RegQueryValueEx(pkey,'VMM\cpgSwapfileInUse',nil,regtype,@tmp,@vsize);
     RegQueryValueEx(pkey,'VMM\cpgSwapfile',nil,regtype,@tmp,@vsize);
     RegQueryValueEx(pkey,'VMM\cDiscards',nil,regtype,@tmp,@vsize);
     RegQueryValueEx(pkey,'VMM\cPageOuts',nil,regtype,@tmp,@vsize);
     RegQueryValueEx(pkey,'VMM\cPageIns',nil,regtype,@tmp,@vsize);
     RegQueryValueEx(pkey,'VMM\cInstanceFaults',nil,regtype,@tmp,@vsize);
     RegQueryValueEx(pkey,'VMM\cPageFaults',nil,regtype,@tmp,@vsize);
     RegQueryValueEx(pkey,'VMM\cpgOther',nil,regtype,@tmp,@vsize);
     RegQueryValueEx(pkey,'VMM\cpgSwap',nil,regtype,@tmp,@vsize);
     RegQueryValueEx(pkey,'VMM\cpgLocked',nil,regtype,@tmp,@vsize);
     RegQueryValueEx(pkey,'VMM\cpgFree',nil,regtype,@tmp,@vsize);
 
     //Для KERNEL
     RegQueryValueEx(pkey,'KERNEL\CPUUsage',nil,regtype,@tmp,@vsize);
     RegQueryValueEx(pkey,'KERNEL\VMs',nil,regtype,@tmp,@vsize);
     RegQueryValueEx(pkey,'KERNEL\Threads',nil,regtype,@tmp,@vsize);
 
     RegCloseKey(pkey);
     ftimer.enabled:=false;
     fstopped:=true;
   end;
 end;
 
 procedure tsysinfo.fsetupdateinterval(aupdateinterval:integer);
 begin
   if (ftimer<>nil) and(aupdateinterval>0) then
   begin
     ftimer.Interval:=aupdateinterval;
     fupdateinterval:=aupdateinterval;
   end;
   if (ftimer<>nil) and(aupdateinterval=0) then
   begin
     ftimer.Interval:=500;
     fupdateinterval:=500;
   end;
 end;
 
 destructor tsysinfo.Destroy;
 begin
   StopRecievingInfo;
   ftimer.Destroy;
   inherited;
 end;
 
 procedure register;
 begin
   RegisterComponents('Samples', [TSysInfo]);
 end;
 
 end.
 

Скопируйте это в файл .pas и проинсталлируйте его.




Получение информации об альясах


 uses DB, DBTables, DBITypes, DBIProcs;
 
 procedure TForm1.FormCreate(Sender: TObject);
 begin
   Session.GetAliasNames(ListBox1.Items);
 end;
 
 procedure TForm1.ListBox1Click(Sender: TObject);
 var
   tStr: array[0..100] of char;
   Desc: DBDesc;
 {
  The DBDesc structure describes a database, using the following fields:
 
  szName     DBINAME  Specifies the database alias name.
  szText     DBINAME  Descriptive text.
  szPhyName  DBIPATH  Specifies the physical name/path.
  szDbType   DBINAME  Specifies the database type.
 }
 begin
   if ListBox1.Items.Count = 0 then
     exit;
   StrPLCopy(tStr, ListBox1.Items.Strings[ListBox1.ItemIndex], High(tStr));
   DbiGetDatabaseDesc(tStr, @Desc);
   with Desc do
   begin
     Label1.Caption := StrPas(Desc.szName);
     Label2.Caption := StrPas(Desc.szPhyName);
     Label3.Caption := StrPas(Desc.szDbType);
     Label4.Caption := StrPas(Desc.szText);
   end;
 end;
 




Отображение всех псевдонимов в ComboBox

Автор: GromovRV@Bashneft.Bashnet.ru


 //Для этого надо в Uses добавить ExtCtrls
 Session.GetAliasNames(ComboBox1.Items);
 




Получение пути псевдонима и таблицы

Автор: Reinhard Kalinke

Есть три способа сделать это... No1 годится только для постоянных псевдонимов BDE. No2 работает с BDE и локальными псевдонимами, и No3 работает с BDE и локальными псевдонимами, используя "тяжелый" путь, через вызовы DBI.


 function GetDBPath1(AliasName: string): TFileName;
 var
   ParamList: TStringList;
 begin
   ParamList := TStringList.Create;
   with Session do
   try
     GetAliasParams(AliasName, ParamList);
     Result := UpperCase(ParamList.Values['PATH']) + '\';
   finally
     Paramlist.Free;
   end;
 end;
 
 function GetDBPath2(AliasName: string): TFileName;
 var
   ParamList: TStringList;
   i: integer;
 begin
   ParamList := TStringList.Create;
   with Session do
   try
     try
       GetAliasParams(AliasName, ParamList);
     except
       for i := 0 to pred(DatabaseCount) do
         if (Databases[i].DatabaseName = AliasName) then
           ParamList.Assign(Databases[i].Params);
     end;
     Result := UpperCase(ParamList.Values['PATH']) + '\';
   finally
     Paramlist.Free;
   end;
 end;
 
 function GetDBPath3(ATable: TTable): TFileName;
 var
   TblProps: CURProps;
   pTblName, pFullName: DBITblName;
 begin
   with ATable do
   begin
     AnsiToNative(Locale, TableName, pTblName, 255);
     Check(DBIGetCursorProps(Handle, TblProps));
     Check(DBIFormFullName(DBHandle,
       pTblName,
       TblProps.szTableType,
       pFullName));
     Result := ExtractFilePath(StrPas(pFullName));
   end;
 end;
 




Получение пути псевдонима и таблицы 2

Вот маленький примерчик того, как в Delphi можно получить информацию о псевдонимах. Для начала создайте новый проект с ListBox и тремя метками (с именамиListBox1, Label1, Label2 и Label3). Затем создайте обработчик события формы OnCreate с примерно следующим кодом:


 procedure TForm1.FormCreate(Sender: TObject);
 begin
   Session.GetAliasNames(ListBox1.Items);
 end;
 

Теперь создайте обработчик OnClick для ListBox:


 procedure TForm1.ListBox1Click(Sender: TObject);
 var
   tStr: array[0..100] of char;
   Desc: DBDesc;
 begin
   if ListBox1.Items.Count = 0 then
     exit;
   StrPLCopy(tStr, ListBox1.Items.Strings[ListBox1.ItemIndex], High(tStr));
   DbiGetDatabaseDesc(tStr, @Desc);
   with Desc do
   begin
     Label1.Caption := StrPas(Desc.szName);
     Label2.Caption := StrPas(Desc.szPhyName);
     Label3.Caption := StrPas(Desc.szDbType);
   end;
 end;
 

Добавьте следующие модули в секцию 'uses' в верхней части модуля:


 DB, DBTables, DBITypes, DBIProcs;
 

Теперь вы можете увидеть путь для всех ваших стандартных псевдонимов (Paradox и dBase).




Получение пути псевдонима и таблицы 3

Используйте Session.GetAliasParams. В ответ вы получите объект Tstrings, откуда вы можете получить значение для переменной 'PATH". Для получения дополнительной информации обратитесь к электронной справке к разделу, описывающему TSession. Объект Session объявлен в модуле DB.


 uses  db;
 
 var
   aliaspath: string[128];
 begin
   aliaspath := Session.GetAliasParams['MyAlias'].values['PATH'];
 end;
 


 uses SysUtils,DbiProcs, DBiTypes;
 ...
 
 function GetDataBaseDir(const Alias : string): String;
 (* Возвращает каталог базы данных, на которую
 ссылается псевдним (без конечного обратного слеша) *)
 var
   sp: PChar;
   Res: pDBDesc;
 begin
   try
     New(Res);
     sp := StrAlloc(length(Alias)+1);
     StrPCopy(sp,Alias);
     if DbiGetDatabaseDesc(sp,Res) =  0 then
       Result := StrPas(Res^.szPhyName)
     else
       Result := '';
   finally
     StrDispose(sp);
     Dispose(Res);
   end;
 end;
 




Получение пути псевдонима и таблицы 4

Автор: Nomadic

По таблице (фактически по Database) получить физическое местонахождение.

Примечание: Database можно создать явно, если нет, Дельфи сама его создаст, доступ к ней по Table(Query).Database


 uses DbiProcs;
 
 function GetDirByDatabase( Database: TDatabase ): string;
 var
   pszDir: PChar;
 begin
   pszDir := StrAlloc( 255 );
   try
     DbiGetDirectory( Database.Handle, True, pszDir );
     Result := StrPas( pszDir );
   finally
     StrDispose( pszDir );
   end;
 end;
 

По алиасу


 function GetPhNameByAlias( sAlias: string ): string;
 var
   Database: TDatabase;
   pszDir: PChar;
 begin
   Database := TDatabase.Create( nil ); {allocate memory}
   pszDir := StrAlloc( 255 );
   try
     Database.AliasName := sAlias;
     Database.DatabaseName := 'TEMP'; {requires a name -- is ignored}
     Database.Connected := True; {connect without opening any table}
     DbiGetDirectory( Database.Handle, True, pszDir ); {get the dir.}
     Database.Connected := False; {disconnect}
     Result := StrPas( pszDir ); {convert to a string}
   finally
     Database.Free; {free memory}
     StrDispose( pszDir );
   end;
 end;
 
 




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

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


 procedure TForm1.Button1Click(Sender: TObject);
 var
   DC: THandle;      // display context
   Bits: integer;    // bits per pixel
   HRes: integer;    // horizontal resolution
   VRes: integer;    // vertical resolution
   DM: TDevMode;     // to Save EnumDisplaySettings
   ModeNum: longint; // video mode number
   Ok: Bool;
   fre: integer;     // refresh rate 
 begin
   DC   := GetDC(Handle);
   Bits := GetDeviceCaps(DC, BITSPIXEL);
   HRes := GetDeviceCaps(DC, HORZRES);
   VRes := GetDeviceCaps(DC, VERTRES);
   fre  := GetDeviceCaps(DC, VREFRESH);
   // Show Current Resolution 
   Edit1.Text := Format('%d bit, %d x %d', [Bits, HRes, VRes]);
   ReleaseDC(Handle, DC); // Show all modes available ModeNum := 0;  // The 1st one 
   EnumDisplaySettings(nil, ModeNum, DM);
   ListBox1.Items.Add(Format('%d bit, %d x %d bei %d Hz', [DM.dmBitsPerPel,
     DM.dmPelsWidth, DM.dmPelsHeight, Dm.dmDisplayFrequency]));
   Ok := True;
   while Ok do
   begin
     Inc(ModeNum); // Get next one 
     Ok := EnumDisplaySettings(nil, ModeNum, DM);
     ListBox1.Items.Add(Format('%d bit, %d x %d bei %d Hz', [DM.dmBitsPerPel,
       DM.dmPelsWidth, DM.dmPelsHeight, Dm.dmDisplayFrequency]));
   end;
 end;
 




Как получить все Dial-Up соединения


Один пpогpаммеp пpишел в гости к дpугому. Сидят, пиво попивают. Тут на кухню заваливает огpомный сеpый котяpа.
- Это мой кот. Зовут Зухель.
- Почему Зухель?
- Смотpи. - беpет веник, тычет в кота. - Зухель! Коннект!
(Кот): - Шшшшшшшшш...

Способ 1 - из реестра:


 uses Registry;
 
 function DUNGetConnections(out OutList: TStringList): Boolean;
   var Reg: TRegistry;
 begin
   OutList.Clear;
   Reg := TRegistry.Create;
   Reg.RootKey := HKEY_CURRENT_USER;
   if Reg.OpenKey('\RemoteAccess\Profile', False) then
   begin
     Reg.GetKeyNames(OutList);
     Result := True;
   end
   else
     Result := False;
   Reg.Free;
 end;
 

Способ 2 - через RASApi:

Для этого воспользуемся функцией Use RASEnumConnections.

Далее можно определить состояние каждого соединения при помощи RASGetConnectStatus.

Так же можно использовать RASEnumEntries для получения всех сервисов из определённой телефонной книжки.

Толька для этого потребуется преобразовать заголовочный файл RAS.h в эквивалент Delphi.




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

Автор: Brian Pedersen

Данный объект может быть использован для получения исчерпывающей информации о любом файле. Так же включена функция выполнения файла Execute().

Использование: создайте объект с именем файла или путём


 unit FileInfo;
 
 interface
 
 uses
   forms, shellapi, windows, sysutils;
 
 type
   EFileInfo = exception;
   TLangInfoBuffer = array [1..4] of SmallInt;
   TFileInfo = class
   private
     f : TSearchRec;
     fVerBlk : TVSFixedFileInfo;
     fFileName : string;
     function GetFileVersion( AFileName : string ) : boolean;
   public
     constructor Create( AFileName : string ); // Создаём объект
     destructor Destroy; override;
     function Execute : integer; // Открывает файл в программе, связанной с ним
     function VersionString : string; // Версия файла. Строка пустая, если строка не найдена
     function OS : string; // Операционная система
     function Path : string; // Путь файла
     function FileName : string; // Имя файла
     function name : string; // Имя файла без расширения
     function DosFileName : string; // Имя файла в DOS
     function FileExt : string; // Расширение файла
     function FileType : string; // Тип файла
     function FileSize : longint; // Размер файла
     function isDebugBuild : boolean; // True если флаг отладки (debug build) установлен
     function isPreRelease : boolean; // True если флаг prerelease установлен
     function isPrivateBuild : boolean; // True если флаг private установлен
     function isSpecialBuild : boolean; // True если флаг special build установлен
     function isDirectory : boolean; // True если файл является директорией
     function isHidden : boolean; // True если файл является скрытым (hidden)
     function isSystemFile : boolean; // True если файл является системным
     function isVolumeId : boolean; // True если файл является меткой тома
     function isArchive : boolean; // True если файл является архивом
     function CreationTime : TDateTime; // Время создания файла
     function LastAccessed : TDateTime; // Время последнего доступа к файлу
     function LastWritten : TDateTime; // Время последней записи в файл
 end;
 
 implementation
 
 constructor TFileInfo.Create(AFileName: string);
 var
   ret: integer;
 begin
   inherited Create;
   fFileName := AFileName;
   ret := FindFirst( AFileName, faReadOnly + faHidden+ faSysFile +
     faVolumeID + faDirectory + faArchive + faAnyFile, f );
   if ret <> 0 then
     SysUtils.RaiseLastWin32Error;
 end;
 
 destructor TFileInfo.Destroy;
 begin
   FindClose( f );
 end;
 
 function TFileInfo.GetFileVersion(AFileName: string): boolean;
 var
   InfoSize, puLen: DWord;
   Pt, InfoPtr: Pointer;
 begin
   InfoSize := GetFileVersionInfoSize( PChar(AFileName), puLen );
   fillchar( fVerBlk, sizeof(TVSFixedFileInfo), 0);
   if InfoSize > 0 then
   begin
     GetMem(Pt,InfoSize);
     GetFileVersionInfo( PChar(AFileName), 0, InfoSize, Pt);
     VerQueryValue(Pt,'\',InfoPtr,puLen);
     move(InfoPtr^, fVerBlk, sizeof(TVSFixedFileInfo) );
     FreeMem(Pt);
     result := true;
   end
   else
     result := false;
 end;
 
 function TFileInfo.VersionString: string;
 begin
   if GetFileVersion( fFileName ) then
     result := Format('%u.%u.%u.%u',
     [HiWord(fVerBlk.dwProductVersionMS),
     LoWord(fVerBlk.dwProductVersionMS),
     HiWord(fVerBlk.dwProductVersionLS),
     LoWord(fVerBlk.dwProductVersionLS)])
   else
     result := '';
 end;
 
 function TFileInfo.isDebugBuild : boolean;
 begin
   result := FALSE;
   if GetFileVersion( fFileName ) then
     result := (fVerBlk.dwFileFlagsMask and fVerBlk.dwFileFlags and
     VS_FF_DEBUG) <> 0
 end;
 
 function TFIleInfo.isPreRelease : boolean;
 begin
   result := FALSE;
   if GetFileVersion( fFileName ) then
     result := (fVerBlk.dwFileFlagsMask and fVerBlk.dwFileFlags and
     VS_FF_PRERELEASE) <> 0
 end;
 
 function TFIleInfo.isPrivateBuild : boolean;
 begin
   result := FALSE;
   if GetFileVersion( fFileName ) then
     result := (fVerBlk.dwFileFlagsMask and fVerBlk.dwFileFlags and
     VS_FF_PRIVATEBUILD) <> 0
 end;
 
 function TFIleInfo.isSpecialBuild : boolean;
 begin
   result := FALSE;
   if GetFileVersion( fFileName ) then
     result := (fVerBlk.dwFileFlagsMask and fVerBlk.dwFileFlags and
     VS_FF_SPECIALBUILD) <> 0
 end;
 
 function TFileInfo.OS : string;
 begin
   if GetFileVersion( fFileName ) then
     case fVerBlk.dwFileOS of
       VOS_DOS_WINDOWS16 : result := 'MS-DOS or 16 bit Windows';
       VOS_DOS_WINDOWS32 : result := '32 bit Windows';
       VOS_OS216_PM16 : result := '16 bit OS/2';
       VOS_OS232_PM32 : result := '32 bit OS/2';
       VOS_NT_WINDOWS32 : result := 'Win32 or Windows NT';
       else
         result := 'Unknown OS';
     end
   else
     result := '';
 end;
 
 function TFileInfo.FileType : string;
 var
   S: string;
 begin
   S := '';
   if GetFileVersion( fFileName ) then
   begin
     case fVerBlk.dwFileType of
       VFT_APP : S := 'Application';
       VFT_DLL : S := 'Dynamic Link Library (DLL)';
       VFT_DRV :
       begin
         S := 'Device Driver - ';
         case fVerBlk.dwFileSubtype of
           VFT2_DRV_PRINTER : S := S + 'Printer';
           VFT2_DRV_KEYBOARD : S := S + 'Keyboard';
           VFT2_DRV_LANGUAGE : S := S + 'Language';
           VFT2_DRV_DISPLAY : S := S + 'Display';
           VFT2_DRV_MOUSE : S := S + 'Mouse';
           VFT2_DRV_NETWORK : S := S + 'Network';
           VFT2_DRV_SYSTEM : S := S + 'System';
           VFT2_DRV_INSTALLABLE : S := S + 'Installable';
           VFT2_DRV_SOUND : S := S + 'Sound';
           else
             S := S + 'Unknown';
         end;
       end;
       VFT_FONT :
       begin
         S := 'Font File - ';
         case fVerBlk.dwFileSubType of
           VFT2_FONT_RASTER : S := S + 'Raster';
           VFT2_FONT_VECTOR : S := S + 'Vector';
           VFT2_FONT_TRUETYPE : S := S + 'TrueType';
           else
             S := S + 'Unknown';
         end;
       end;
       VFT_VXD : S := 'Virtual Device';
       VFT_STATIC_LIB : S := 'Static Link Library';
       else
         S := 'Unknown File Type';
     end;
   end;
   Result := S;
 end;
 
 function TFileInfo.Path : string;
 begin
   result := ExtractFilePath( fFileName );
 end;
 
 function TFileInfo.FileName : string;
 begin
   result := ExtractFileName( fFileName );
 end;
 
 function TFileInfo.name : string;
 begin
   if Pos( FileExt, FileName ) > 0 then
     result := Copy( FileName, 0, pos( FileExt, FileName )-1 )
   else
     result := FileName;
 end;
 
 function TFileInfo.DosFileName : string;
 begin
   result := StrPas( f.FindData.cAlternateFileName )
 end;
 
 function TFileInfo.FileExt : string;
 begin
   result := ExtractFileExt( fFileName );
 end;
 
 function TFileInfo.isDirectory : boolean;
 begin
   result := f.Attr and faDirectory = faDirectory;
 end;
 
 function TFileInfo.isHidden : boolean;
 begin
   result := f.Attr and faHidden = faHidden;
 end;
 
 function TFileInfo.isSystemFile : boolean;
 begin
   result := f.Attr and faSysFile = faSysFile;
 end;
 
 function TFileInfo.isVolumeId : boolean;
 begin
   result := f.Attr and faVolumeId = faVolumeId;
 end;
 
 function TFileInfo.isArchive : boolean;
 begin
   result := f.Attr and faArchive = faArchive;
 end;
 
 function TFileInfo.FileSize : longint;
 begin
   result := f.Size;
 end;
 
 function TFileInfo.CreationTime : TDateTime;
 var
   LTime: TFileTime;
   Systemtime: TSystemtime;
 begin
   FileTimeToLocalFileTime( f.FindData.ftCreationTime, LTime);
   FileTimeToSystemTime( LTime, SystemTime );
   result := SystemTimeToDateTime( SystemTime);
 end;
 
 function TFileInfo.LastAccessed : TDateTime;
 var
   LTime : TFileTime;
   Systemtime : TSystemtime;
 begin
   FileTimeToLocalFileTime( f.FindData.ftLastAccessTime, LTime);
   FileTimeToSystemTime( LTime, SystemTime );
   result := SystemTimeToDateTime( SystemTime);
 end;
 
 function TFileInfo.LastWritten : TDateTime;
 var
   LTime : TFileTime;
   Systemtime : TSystemtime;
 begin
   FileTimeToLocalFileTime( f.FindData.ftLastWriteTime, LTime);
   FileTimeToSystemTime( LTime, SystemTime );
   result := SystemTimeToDateTime( SystemTime);
 end;
 
 function TFileInfo.Execute : integer;
 begin
   result := shellapi.ShellExecute( Application.Handle, 'open',
     pChar( fFileName ), '', pChar(Path), SW_SHOWDEFAULT );
   case result of
     0 :
       raise Exception.Create( 'Недостаточно памяти или ресурсов.' );
     ERROR_FILE_NOT_FOUND :
       raise Exception.Create( 'Указанный файл не найден.' );
     ERROR_PATH_NOT_FOUND :
       raise Exception.Create( 'Указанный путь не найден.' );
     ERROR_BAD_FORMAT :
       raise Exception.Create( 'Ошибка файла .EXE (не -Win32 .EXE или ошибка ' + 'в .EXE).' );
     SE_ERR_ACCESSDENIED :
       raise Exception.Create( 'Доступ к файлу запрещён.' );
     SE_ERR_ASSOCINCOMPLETE :
       raise Exception.Create( 'The filename association is incomplete or invalid.' );
     SE_ERR_DDEBUSY :
       raise Exception.Create( 'Транзакция DDE не может быть завершена, потому что ' +
       'другая транзакция DDE находится в процессе выполнения.' );
     SE_ERR_DDEFAIL :
       raise Exception.Create( 'Ошибка транзакции DDE.' );
     SE_ERR_DDETIMEOUT :
       raise Exception.Create( 'DDE транзакция не может быть завершина из-за тайм-аута.' );
     SE_ERR_DLLNOTFOUND :
       raise Exception.Create( 'Указанная dynamic-link library не найдена.' );
     SE_ERR_NOASSOC :
       raise Exception.Create( 'Не найдено приложение связанной с данным расширением файла.' );
     SE_ERR_OOM :
       raise Exception.Create( 'Недостаточно памяти для завершения операции.' );
     SE_ERR_SHARE :
       raise Exception.Create( 'Файл используется другим приложением.' );
     else
   end;
 end;
 
 end.
 




Как получить список всех запущенных процессов

Поставь на форму список TListbox и кнопку TButton, по нажатию на кнопке напиши такой код:


 procedure TForm1.Button1Click(Sender: TObject);
 var
   Wnd: hWnd;
   buff: array[0..127] of Char;
 begin
   ListBox1.Clear;
   Wnd := GetWindow(Handle, gw_HWndFirst);
   while Wnd <> 0 do begin {Не показываем:}
     if (Wnd <> Application.Handle) and {-Собственное окно}
       IsWindowVisible(Wnd) and {-Невидимые окна}
       (GetWindow(Wnd, gw_Owner) = 0) and {-Дочернии окна}
       (GetWindowText(Wnd, buff, sizeof(buff)) <> 0) {-Окна без заголовков}
       then begin
       GetWindowText(Wnd, buff, sizeof(buff));
       ListBox1.Items.Add(StrPas(buff));
     end;
     Wnd := GetWindow(Wnd, gw_hWndNext);
   end;
   ListBox1.ItemIndex := 0;
 end;
 




Получаем заголовок чужого компонента, который под мышью


 procedure TForm1.Timer1Timer(Sender: TObject);
 var
  s: string;
  h: HWND;
 begin
  h := WindowFromPoint(Mouse.CursorPos);
  SetLength(s, SendMessage(h, WM_GETTEXTLENGTH, 0, 0)+1);
  SendMessage(h, WM_GETTEXT, length(s), Integer(PChar(s)));
  SetLength(s, lStrLen(PChar(s)));
  Label1.Caption := s;
 end;
 

Некрасиво то, что вся эта ерунда висит на таймере...




Определение базовой системной информации

Не кажется ли вам символичным, что праздник мелких пакостей и легких ужасов в Штатах назывется "Хелло, Win"?

Часто при создании систем привязки программ к компьютеру или окон типа System Info или About Box необходимо определить данные о пользователе и о системе. Это можно сделать следующим образом (из примеров по Delphi - программа COA):


 ...
  Buffer : Array[0..30] of Char;    // Буфер под ASCIIZ строку
 begin
  // Открыли библиотеку User
  hInstUser := LoadLibrary('USER');
  LoadString(hInstUser, 514, Buffer, 30);
  // Имя пользователя
  LabelUserName.Caption := StrPas(Buffer);
  LoadString(hInstUser, 515, Buffer, 30);
  FreeLibrary(hInstUser);
  // Компания
  LabelCompName.Caption := StrPas(Buffer);
  WinVer := GetVersion;
  // Версия Windows
  LabelWinVer.Caption := Format('Windows %u.%.2u',
         [LoByte(LoWord(WinVer)), HiByte(LoWord(WinVer))]);
  // Версия DOS
  LabelDosVer.Caption := Format('DOS %u.%.2u',
         [HiByte(HiWord(WinVer)), LoByte(HiWord(WinVer))]);
  WinFlags := GetWinFlags;
  // Режим
  IF WinFlags AND WF_ENHANCED > 0 THEN
    LabelWinMode.Caption := '386 Enhanced Mode'
  ELSE IF WinFlags AND WF_PMODE > 0 THEN
    LabelWinMode.Caption := 'Standard Mode'
  ELSE LabelWinMode.Caption := 'Real Mode';
  // Сопроцессор
  IF WinFlags AND WF_80x87 > 0 THEN
   ValueMathCo.Caption := 'Present'
  ELSE ValueMathCo.Caption := 'Absent';
 
  // Свободно ресурсов
  Fmt := GetFreeSystemResources(GFSR_SYSTEMRESOURCES);
  ValueFSRs.Caption := Format('%d%% Free', [Fmt1]);
  // Свободно памяти
  ValueMemory.Caption := FormatFloat(',#######', MemAvail DIV
 1024) + ' KB Free';
 end;
 
 




Как получить дату BIOS

Народная примета: если программист в девять утра уже на работе, значит, он еще на работе.


 unit BiosDate;
 
 interface
 
 function GetBiosDate: string;
 
 implementation
 
 function SegOfsToLinear(Segment, Offset: Word): Integer;
 begin
   result := (Segment shl 4) or Offset;
 end;
 
 function GetBiosDate: string;
 begin
   result := string(PChar(Ptr(SegOfsToLinear($F000, $FFF5))));
 end;
 
 end.
 




Как в Delphi определить дату BIOS

Автор: Nomadic

Определить дату BIOS, равно как тип ПК или поиметь другие данные, находящиеся по фиксированому _физическому_ адресу, в Delphi можно так:


 var
   BiosDate: array[0..7] of char absolute
   $FFFF5;
   PCType: byte absolute $FFFFE;
 
 procedure TForm1.FormCreate(Sender: TObject);
 var
   S: string;
 begin
   case PCType of
     $FC: S := 'AT';
     $FD: S := 'PCjr';
     $FE: S := 'XT =8-O';
     $FF: S := 'PC';
   else
     S := 'Нестандартный';
   end;
   Caption := 'Дата BIOS: ' + BiosDate + '  Тип ПК: ' + S;
 end;
 




Как из Handle битовой картинки, получить адрес битового изображения в памяти

Автор: Nomadic

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

Сразу оговорюсь, что все это работает только под Win95/NT.


 type
   TarrRGBTriple = array[byte] of TRGBTriple;
   ParrRGBTriple = ^TarrRGBTriple;
 
   {организует битмэп размером SX,SY;true_color}
 
 procedure TMBitmap.Allocate(SX, SY: integer);
 var
   DC: HDC;
 begin
   if BM <> 0 then
     DeleteObject(BM); {удаляем старый битмэп, если был}
   BM := 0;
   PB := nil;
   fillchar(BI, sizeof(BI), 0);
   with BI.bmiHeader do {заполняем структуру с параметрами битмэпа}
   begin
     biSize := sizeof(BI.bmiHeader);
     biWidth := SX;
     biHeight := SY;
     biPlanes := 1;
     biBitCount := 24;
     biCompression := BI_RGB;
     biSizeImage := 0;
     biXPelsPerMeter := 0;
     biYPelsPerMeter := 0;
     biClrUsed := 0;
     biClrImportant := 0;
 
     FLineSize := (biWidth + 1) * 3 and (-1 shl 2);
       {размер строки(кратна 4 байтам)}
 
     if (biWidth or biHeight) <> 0 then
     begin
       DC := CreateDC('DISPLAY', nil, nil, nil);
       {замечательная функция (см.HELP), возвращает HBITMAP, позволяет сразу
       разместить выделяемый битмэп в спроецированном файле, что позволяет
       ускорять работу и экономить память при генерировании большого битмэпа}
       {!} BM := CreateDIBSection(DC, BI, DIB_RGB_COLORS, pointer(PB), nil, 0);
       DeleteDC(DC); {в PB получаем указатель на битмэп-----^^}
       if BM = 0 then
         Error('error creating DIB');
     end;
   end;
 end;
 
 {эта процедура загружает из файла true-color'ный битмэп}
 
 procedure TMBitmap.LoadFromFile(const FileName: string);
 var
   HF: integer; {file handle}
   HM: THandle; {file-mapping handle}
   PF: pchar; {pointer to file view in memory}
   i, j: integer;
   Ofs: integer;
 begin
   {открываем файл}
   HF := FileOpen(FileName, fmOpenRead or fmShareDenyWrite);
   if HF < 0 then
     Error('open file ''' + FileName + '''');
   try
     {создаем объект-проецируемый файл}
     HM := CreateFileMapping(HF, nil, PAGE_READONLY, 0, 0, nil);
     if HM = 0 then
       Error('can''t create file mapping');
     try
       {собственно проецируем объект в адресное }
       PF := MapViewOfFile(HM, FILE_MAP_READ, 0, 0, 0);
       {получаем указатель на область памяти, в которую спроецирован файл}
       if PF = nil then
         Error('can''t create map view of file');
       try
         {работаем с файлом как с областью памяти через указатель PF}
         if PBitmapFileHeader(PF)^.bfType <> $4D42 then
           Error('file format');
         Ofs := PBitmapFileHeader(PF)^.bfOffBits;
         with PBitmapInfo(PF + sizeof(TBitmapFileHeader))^.bmiHeader do
         begin
           if (biSize <> 40) or (biPlanes <> 1) then
             Error('file format');
           if (biCompression <> BI_RGB) or
             (biBitCount <> 24) then
             Error('only true-color BMP supported');
           {выделяем память под битмэп}
           Allocate(biWidth, biHeight);
         end;
 
         for j := 0 to BI.bmiHeader.biHeight - 1 do
           for i := 0 to BI.bmiHeader.biWidth - 1 do
             {Pixels - это property, возвр. указатель на соотв. RGBTriple в битмэпе}
             Pixels[i, j]^.Tr := ParrRGBTriple(PF + j * FLineSize + Ofs)^[i];
       finally
         UnmapViewOfFile(PF);
       end;
     finally
       CloseHandle(HM);
     end;
   finally
     FileClose(HF);
   end;
 end;
 
 {эта функция - реализация Pixels read}
 
 function TMBitmap.GetPixel(X, Y: integer): PRGB;
 begin
   if (X >= 0) and (X < BI.bmiHeader.biWidth) and
     (Y >= 0) and (Y < BI.bmiHeader.biHeight) then
     Result := PRGB(PB + (Y) * FLineSize + X * 3)
   else
     Result := PRGB(PB);
 end;
 

Если у вас на форме есть компонент TImage, то можно сделать так:


 var BMP:TMBitmap;
   B: TBitmap;
 ...
 
 BMP.LoadFromFile(..);
 B:=TBitmap.Create;
 B.Handle:=BMP.Handle;
 Image1.Picture.Bitmap:=B;
 

и загруженный битмэп появится на экране.




Как выяснить размер BLOB-поля


 function GetBlobSize(Field: TBlobField): LongInt;
 begin
   with TBlobStream.Create(Field, bmRead) do
     try
       Result := Seek(0, 2);
     finally
       Free;
     end;
 end;
 




Определить букву CD-ROM


Драйверы вашего CD-ROM привода находятся на прилагаемом компакт диске...


 procedure TForm1.Button1Click(Sender: TObject);
 var
   w: dword;
   Root: string;
   i: integer;
 begin
   w := GetLogicalDrives;
   Root := '#:\';
   for i := 0 to 25 do
   begin
     Root[1] := Char(Ord('A') + i);
     if (W and (1 shl i)) > 0 then
       if GetDriveType(Pchar(Root)) = DRIVE_CDROM then
         Form1.Label1.Caption := Root;
   end;
 end;
 




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

Программисты ругаются:
- Типун тебе на модем!
- Эх ты, защёлка от дисковода!
- Не бита совести у тебя нет!

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

Вот пример. Эта подпрограмма работает с дочерним окном, которое может иметь только один экземпляр. Если оно не открыто, подпрограмма создаст его, если оно открыто, оно переместит его на передний план.


 procedure FormLoader (FormClassType: TFormClass; var FormName);
 begin
   if TForm(FormName) = nil then
   begin
     Application.CreateForm (FormClassType, FormName);
   end
   else
   begin
     TForm(FormName).BringToFront;
     TForm(FormName).WindowState := wsNormal;
   end;
 end;
 

Вот как это вызывать:


 procedure TfrmTest.sbOpenClick(Sender: TObject);
 begin
   FormLoader (TfrmTest, frmTest);
 end;
 




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



 unit InternF;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
   StdCtrls, ExtCtrls, Buttons;
 
 type
   TFormInternal = class(TForm)
     Panel1: TPanel;
     SpeedChoose: TSpeedButton;
     LabelTarget: TLabel;
     Splitter1: TSplitter;
     MemoClass: TMemo;
     MemoWin: TMemo;
     CheckDrag: TCheckBox;
     procedure FormCreate(Sender: TObject);
     procedure FormResize(Sender: TObject);
     procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X,
       Y: Integer);
     procedure FormMouseUp(Sender: TObject; Button: TMouseButton;
       Shift: TShiftState; X, Y: Integer);
     procedure SpeedChooseMouseDown(Sender: TObject;
       Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
   public
     procedure UpdateData (hWnd: THandle);
     function GetClassStyles (Style: Cardinal): string;
     function GetWinStyles (Style: Cardinal): string;
     function GetWinExStyles (Style: Cardinal): string;
   private
     Capture: Boolean;
   end;
 
 var
   FormInternal: TFormInternal;
 
 implementation
 
 {$R *.DFM}
 
 function TFormInternal.GetClassStyles (Style: Cardinal): string;
 begin
   Result := '';
   if (cs_bytealignclient and style) = cs_bytealignclient then
     Result := Result + 'ByteAlignClient ';
   if (cs_bytealignwindow and style) = cs_bytealignwindow then
     Result := Result + 'cs_bytealignwindow';
   if (cs_classdc and style) = cs_classdc then
     Result := Result + 'ClassDC ';
   if (cs_dblclks and style) = cs_dblclks then
     Result := Result + 'DblClks ';
   if (cs_globalclass and style) = cs_globalclass then
     Result := Result + 'GlobalClass ';
   if (cs_hredraw and style) = cs_hredraw then
     Result := Result + 'HRedraw ';
   if (cs_noclose and style) = cs_noclose then
     Result := Result + 'NoClose ';
   if (cs_owndc and style) = cs_owndc then
     Result := Result + 'OwnDc ';
   if (cs_parentdc and style) = cs_parentdc then
     Result := Result + 'ParentDc ';
   if (cs_savebits and style) = cs_savebits then
     Result := Result + 'SaveBits ';
   if (cs_vredraw and style) = cs_vredraw then
     Result := Result + 'VRedraw ';
 end;
 
 function TFormInternal.GetWinStyles (Style: Cardinal): string;
 begin
   // show the kind of window
   if (ws_child and style) = ws_child then
     Result := 'Child '
   else if (ws_popup and style) = ws_popup then
     Result := 'Popup '
   else
     Result := 'Overlapped ';
   // borders
   if (ws_border and style) = ws_border then
     Result := Result + 'Border ';
   if (ws_caption and style) = ws_caption then
     Result := Result + 'Caption ';
   if (ws_thickframe and style) = ws_thickframe then
     Result := Result + 'ThickFrame ';
   if (ws_dlgframe and style) = ws_dlgframe then
     Result := Result + 'DlgFrame ';
   // border buttons
   if (ws_maximizebox and style) = ws_maximizebox then
     Result := Result + 'MaximizeBox ';
   if (ws_minimizebox and style) = ws_minimizebox then
     Result := Result + 'MinimizeBox ';
   if (ws_sysmenu and style) = ws_sysmenu then
     Result := Result + 'SysMenu ';
   // scrollbars
   if (ws_hscroll and style) = ws_hscroll then
     Result := Result + 'HScroll ';
   if (ws_vscroll and style) = ws_vscroll then
     Result := Result + 'VScroll ';
   // clipping
   if (ws_clipchildren and style) = ws_clipchildren then
     Result := Result + 'ClipChildren ';
   if (ws_clipsiblings and style) = ws_clipsiblings then
     Result := Result + 'ClipSiblings ';
   // initial status information
   if (ws_disabled and style) = ws_disabled then
     Result := Result + 'Disabled ';
   if (ws_group and style) = ws_group then
     Result := Result + 'Group ';
   if (ws_maximize and style) = ws_maximize then
     Result := Result + 'Maximize ';
   if (ws_minimize and style) = ws_minimize then
     Result := Result + 'Minimize ';
   if (ws_tabstop and style) = ws_tabstop then
     Result := Result + 'TabStop ';
   if (ws_visible and style) = ws_visible then
     Result := Result + 'Visible ';
   // note: controls styles are not supported
 end;
 
 function TFormInternal.GetWinExStyles (style: Cardinal): string;
 begin
   Result := '';
   // add the extended styles
   if (ws_ex_acceptfiles and style) = ws_ex_acceptfiles then
     Result := Result + 'AcceptFiles ';
   if (ws_ex_appwindow and style) = ws_ex_appwindow then
     Result := Result + 'AppWindow ';
   if (ws_ex_mdichild and style) = ws_ex_mdichild then
     Result := Result + 'MdiChild ';
   if (ws_ex_noparentnotify and style) = ws_ex_noparentnotify then
     Result := Result + 'NoParentNotify ';
   if (ws_ex_contexthelp and style) = ws_ex_contexthelp then
     Result := Result + 'ContextHelp ';
   if (ws_ex_controlparent and style) = ws_ex_controlparent then
     Result := Result + 'ControlParent ';
   if (ws_ex_topmost and style) = ws_ex_topmost then
     Result := Result + 'TopMost ';
   if (ws_ex_transparent and style) = ws_ex_transparent then
     Result := Result + 'Transparent ';
 
   // border - edge styles
   if (ws_ex_clientedge and style) = ws_ex_clientedge then
     Result := Result + 'ClientEdge ';
   if (ws_ex_staticedge and style) = ws_ex_staticedge then
     Result := Result + 'StaticEdge ';
   if (ws_ex_dlgmodalframe and style) = ws_ex_dlgmodalframe then
     Result := Result + 'DlgModalFrame ';
   if (ws_ex_windowedge and style) = ws_ex_windowedge then
     Result := Result + 'WindowEdge ';
   if (ws_ex_palettewindow and style) = ws_ex_palettewindow then
     Result := Result + 'PaletteWindow ';
   if (ws_ex_toolwindow and style) = ws_ex_toolwindow then
     Result := Result + 'ToolWindow ';
 
   // left/right input mode and scrollbars
   if (ws_ex_left and style) = ws_ex_left then
     Result := Result + 'Left ';
   if (ws_ex_leftscrollbar and style) = ws_ex_leftscrollbar then
     Result := Result + 'LeftScrollBar ';
   if (ws_ex_ltrreading and style) = ws_ex_ltrreading then
     Result := Result + 'LtrReading ';
   if (ws_ex_right and style) = ws_ex_right then
     Result := Result + 'Right ';
   if (ws_ex_rightscrollbar and style) = ws_ex_rightscrollbar then
     Result := Result + 'RightScrollBar ';
   if (ws_ex_rtlreading and style) = ws_ex_rtlreading then
     Result := Result + 'RtlReading ';
 end;
 
 function GetCursorName (hCur: THandle): string;
 var
   I: Integer;
 begin
   // default: handle value
   Result := IntToHex (hCur, 16);
   // looks for Delphi cursor
   for I := crHelp to crArrow do
     if Screen.Cursors [I] = hCur then
       Result := CursorToString (I);
 end;
 
 procedure TFormInternal.FormCreate (Sender: TObject);
 begin
   UpdateData (Handle);
 end;
 
 procedure TFormInternal.UpdateData (hWnd: THandle);
 var
   WndClassName, Title: string;
   WndClass: TWndClass;
   hInst, hwndParent: THandle;
 begin
   MemoClass.Lines.BeginUpdate;
   MemoWin.Lines.BeginUpdate;
   try
     SetLength (Title, 100);
     // retrieve the WNDCLASS name
     SetLength (WndClassName, 100);
     hInst := GetWindowLong (hWnd, GWL_HINSTANCE);
     GetClassName (hWnd, PChar (WndClassName), 100);
     GetClassInfo (hInst, PChar (WndClassName), WndClass);
     // show class information
     with WndClass, MemoClass.Lines do
     begin
       Clear;
       Add ('Class Name: ' + WndClassName);
       Add ('Window Procedure: ' + IntToHex (Cardinal (lpfnWndProc), 8));
       Add ('Class Extra Bytes: ' + IntToStr (cbClsExtra));
       Add ('Window Extra Bytes: ' + IntToStr (cbWndExtra));
       Add ('Instance Handle: ' + IntToHex (hInstance, 8));
       GetModuleFileName (hInstance, PChar (Title), 100);
       Add ('Module Name: ' + Title);
       Add ('Icon Handle: ' + IntToHex (hIcon, 8));
       Add ('Cursor: ' + GetCursorName (hCursor));
       Add ('Brush handle: ' + IntToHex (hbrBackground, 8));
       if lpszMenuName <> nil then
         if HiWord (Cardinal(lpszMenuName)) <> 0 then
           Add ('Menu name: ' + PChar (lpszMenuName))
         else
           Add ('Menu ID: ' + IntToStr (LoWord (lpszMenuName)));
       Add (#13);
       Add ('Class styles:');
       Add (GetClassStyles (Style));
     end;
 
     // show window data
     with MemoWin.Lines do
     begin
       Clear;
       GetWindowText (hWnd, PChar (Title), 100);
       Add ('Window Handle: ' + IntToHex (hWnd, 8));
       Add ('  Title: "' + PChar (Title) + '"');
       Add ('Window Procedure: ' + IntToHex (GetWindowLong (hWnd, GWL_WNDPROC), 8));
       Add ('Instance Handle: ' + IntToHex (GetWindowLong (hWnd, GWL_HINSTANCE), 8));
       hwndParent := GetWindowLong (hWnd, GWL_HWNDPARENT);
       Add ('Parent/Owner Window: ' + IntToHex (hwndParent, 8));
       if hwndParent <> 0 then
       begin
         GetWindowText (hwndParent, PChar (Title), 100);
         Add ('  Par/Own Title: "' + PChar (Title) + '"');
       end;
       hwndParent := GetParent (hWnd);
       Add ('Real Parent Window: ' + IntToHex (hwndParent, 8));
       if hwndParent <> 0 then
       begin
         GetWindowText (hwndParent, PChar (Title), 100);
         Add ('  Parent Title: "' + PChar (Title) + '"');
       end;
       if GetParent (hWnd) <> 0 then
         Add ('Child ID: ' + IntToHex (GetWindowLong (hWnd, GWL_ID), 8))
       else
         Add ('Menu Handle: ' + IntToHex (GetWindowLong (hWnd, GWL_ID), 8));
       Add ('User Data: ' + IntToHex (GetWindowLong (hWnd, GWL_USERDATA), 8));
       Add (#13);
       Add ('Window Styles: ' +
         GetWinStyles (GetWindowLong (hWnd, GWL_STYLE)));
       Add (#13);
       Add ('Extended Styles: ' +
         GetWinExStyles (GetWindowLong (hWnd, GWL_EXSTYLE)));
     end;
   finally
     MemoClass.Lines.EndUpdate;
     MemoWin.Lines.EndUpdate;
   end;
 end;
 
 procedure TFormInternal.FormResize(Sender: TObject);
 begin
   // split the area equally
   MemoClass.Width := ClientWidth div 2;
 end;
 
 procedure TFormInternal.FormMouseMove(Sender: TObject;
   Shift: TShiftState; X, Y: Integer);
 var
   hWnd: THandle;
   Title: string;
   Pt: TPoint;
 begin
   if Capture then
   begin
     Pt := Point (X, Y);
     Pt := ClientToScreen (Pt);
     hWnd := WindowFromPoint (Pt);
     if hWnd = 0 then
       Exit;
     SetLength (Title, 100);
     GetWindowText (hWnd, PChar (Title), 100);
     LabelTarget.Caption :=
       'Window: ' + IntToHex (hWnd, 8) +
       ' - "' + string (PChar (Title)) + '"';
     if CheckDrag.Checked then
       UpdateData (hWnd);
   end;
 end;
 
 procedure TFormInternal.FormMouseUp(Sender: TObject; Button: TMouseButton;
   Shift: TShiftState; X, Y: Integer);
 var
   hWnd: THandle;
   Pt: TPoint;
 begin
   if Capture then
   begin
     Pt := Point (X, Y);
     Pt := ClientToScreen (Pt);
     hWnd := WindowFromPoint (Pt);
     if hWnd <> 0 then
       UpdateData (hWnd);
     MouseCapture := False;
     Capture := False;
     // release the speed button
     SpeedChoose.Perform (
       wm_LButtonUp, mk_LButton, 0);
   end;
 end;
 
 procedure TFormInternal.SpeedChooseMouseDown(Sender: TObject;
   Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
 begin
   MouseCapture := True;
   Capture := True;
 end;
 
 end.

Загрузить исходный код проекта




Вычисление тактовой частоты процессора


Дневник программиста:
ВТОРИК: "Устанавливал полуось- чуть не умер."
СРЕДА: "Устанавливал Windows 95- лучше бы я умер во вторник."

Автор: Alex Novikov


 function GetCPUSpeed: double;
 const
   DelayTime = 500; // время измерения в миллисекундах
 var
   TimerHi, TimerLo: DWORD;
   PriorityClass, Priority: integer;
 begin
   PriorityClass := GetPriorityClass(GetCurrentProcess);
   Priority := GetThreadPriority(GetCurrentThread);
   SetPriorityClass(GetCurrentProcess, REALTIME_PRIORITY_CLASS);
   SetThreadPriority(GetCurrentThread, THREAD_PRIORITY_TIME_CRITICAL);
   Sleep(10);
   asm
     dw 310Fh // rdtsc
     mov TimerLo, eax
     mov TimerHi, edx
   end;
   Sleep(DelayTime);
   asm
     dw 310Fh // rdtsc
     sub eax, TimerLo
     sbb edx, TimerHi
     mov TimerLo, eax
     mov TimerHi, edx
   end;
   SetThreadPriority(GetCurrentThread, Priority);
   SetPriorityClass(GetCurrentProcess, PriorityClass);
   Result := TimerLo / (1000.0 * DelayTime);
 end;
 
 begin
   LabelCPUSpeed.Caption := Format('CPU speed: %f MHz', [GetCPUSpeed]);
 end;
 




Получить текущую глубину цвета

Программисты фирмы "Майкрософт" нашли действенное решение по устранению "синих экранов смерти" в операционной системе Windows. С официального сайта Вы можете скачать официальный патч. Теперь в "Панели управления" можно выбрать любой другой цвет для этого режима. А в будущих версиях ОС планируется возможность выбора фоновой картинки на свой вкус.


 function GetColorDepth: string;
 var
   DesktopDC: HDC; // LongWord 
   BitsPerPixel: Integer;
 begin
   DesktopDC    := GetDC(0);
   BitsPerPixel := GetDeviceCaps(DesktopDC, BITSPIXEL);
   case BitsPerPixel of
     4: Result  := '4-Bit';
     8: Result  := '8-Bit';
     16: Result := '16-Bit';
     24: Result := '24-Bit';
     32: Result := '32-Bit';
   end;
   ReleaseDC(0, DesktopDC);
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   ShowMessage(GetColorDepth);
 end;
 




Как узнать размеры TComboBox с показанным выпадающим списком до показа списка

Программист после очень длительного сидения за компьютером выходит на улицу и смотрит на небо:
- Боже, у Тебя тоже Windows стоит?!

На событии FormShow пошлите сообщение CB_SHOWDROPDOWN в ComboBox дважды - один раз чтобы заставить список выпасть, второй - чтобы убрать его. Затем пошлите сообщение CB_GETDROPPEDCONTROLRECT, передав в качестве параметра адрес TRect. TRect будет содержать экранные кординаты прямоугольника описывающего ComboBox вместе с выпавшим списком. Затем Вы можете вызвать ScreenToClient чтобы преобразовать экранные кординаты в координаты клиентской области окна.


 var
   R: TRect;
 
 procedure TForm1.FormShow(Sender: TObject);
 var
   T: TPoint;
 begin
   SendMessage(ComboBox1.Handle, CB_SHOWDROPDOWN, 1, 0);
   SendMessage(ComboBox1.Handle, CB_SHOWDROPDOWN, 0, 0);
   SendMessage(ComboBox1.Handle, CB_GETDROPPEDCONTROLRECT, 0,
   LongInt(@r));
   t := ScreenToClient(Point(r.Left, r.Top));
   r.Left := t.x;
   r.Top := t.y;
   t := ScreenToClient(Point(r.Right, r.Bottom));
   r.Right := t.x;
   r.Bottom := t.y;
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   Form1.Canvas.Rectangle(r.Left, r.Top, r.Right, r.Bottom );
 end;
 




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


Пpиходит мужик в компьютеpный салон:
- Я у вас вчеpа компьютеp пpикупил...
- У вас пpоблемы?
- Сгоpел он...
- Hет пpоблем - он на гаpантии. А что у вас сгоpело?
- Все!
- Hу, так не бывает. Пpоцесоp цел?
- Сгоpел.
- А винчестеp?
- Сгоpел.
- А память?
- Сгоpела.
- А монитоp?
- Сгоpел.
- Господи! Что же вы с ним делали?
- Да у меня пожаp вчеpа был....

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


 uses Windows;
 
 function GetComputerNetName: string;
 var
   buffer: array[0..255] of char;
   size: dword;
 begin
   size := 256;
   if GetComputerName(buffer, size) then
     Result := buffer
   else
     Result := ''
 end;
 




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

- Чем отличается программист от сперматозоида?
- У сперматозоида есть один шанс из 50000000 стать человеком.

Hужно использовать пайпы (CreatePipe), и работать с ними как с обычным файлом.


 const
   H_IN_READ = 1;
   H_IN_WRITE = 2;
   H_OUT_READ = 3;
   H_OUT_WRITE = 4;
   H_ERR_READ = 5;
   H_ERR_WRITE = 6;
 
 type
   TPipeHandles = array [1..6] of THandle;
 var
   hPipes: TPipeHandles;
   ProcessInfo: TProcessInformation;
 
 (************CREATE HIDDEN CONSOLE PROCESS************)
 function CreateHiddenConsoleProcess(szChildName: string;
          ProcPriority: DWORD; ThreadPriority: integer): Boolean;
 label
   error;
 var
   fCreated: Boolean;
   si: TStartupInfo;
   sa: TSecurityAttributes;
 begin
   // Initialize handles
   hPipes[ H_IN_READ ] := INVALID_HANDLE_VALUE;
   hPipes[ H_IN_WRITE ] := INVALID_HANDLE_VALUE;
   hPipes[ H_OUT_READ ] := INVALID_HANDLE_VALUE;
   hPipes[ H_OUT_WRITE ] := INVALID_HANDLE_VALUE;
   hPipes[ H_ERR_READ ] := INVALID_HANDLE_VALUE;
   hPipes[ H_ERR_WRITE ] := INVALID_HANDLE_VALUE;
   ProcessInfo.hProcess := INVALID_HANDLE_VALUE;
   ProcessInfo.hThread := INVALID_HANDLE_VALUE;
   // Create pipes
   // initialize security attributes for handle inheritance (for WinNT)
   sa.nLength := sizeof(sa);
   sa.bInheritHandle := TRUE;
   sa.lpSecurityDescriptor := nil;
   // create STDIN pipe
   if not CreatePipe( hPipes[ H_IN_READ ], hPipes[ H_IN_WRITE ], @sa, 0 ) then
     goto error;
   // create STDOUT pipe
   if not CreatePipe( hPipes[ H_OUT_READ ], hPipes[ H_OUT_WRITE ], @sa, 0 ) then
     goto error;
   // create STDERR pipe
   if not CreatePipe( hPipes[ H_ERR_READ ], hPipes[ H_ERR_WRITE ], @sa, 0 ) then
     goto error;
   // process startup information
   ZeroMemory(Pointer(@si), sizeof(si));
   si.cb := sizeof(si);
   si.dwFlags := STARTF_USESHOWWINDOW or STARTF_USESTDHANDLES;
   si.wShowWindow := SW_HIDE;
   // assign "other" sides of pipes
   si.hStdInput := hPipes[ H_IN_READ ];
   si.hStdOutput := hPipes[ H_OUT_WRITE ];
   si.hStdError := hPipes[ H_ERR_WRITE ];
   // Create a child process
   try
     fCreated := CreateProcess( nil, PChar(szChildName), nil, nil, True,
     ProcPriority, // CREATE_SUSPENDED,
     nil, nil, si, ProcessInfo );
   except
     fCreated := False;
   end;
 
   if not fCreated then
     goto error;
 
   Result := True;
   CloseHandle(hPipes[ H_OUT_WRITE ]);
   CloseHandle(hPipes[ H_ERR_WRITE ]);
   // ResumeThread( pi.hThread );
   SetThreadPriority(ProcessInfo.hThread, ThreadPriority);
   CloseHandle( ProcessInfo.hThread );
   Exit;
   //-----------------------------------------------------
   error:
     ClosePipes( hPipes );
     CloseHandle( ProcessInfo.hProcess );
     CloseHandle( ProcessInfo.hThread );
     ProcessInfo.hProcess := INVALID_HANDLE_VALUE;
     ProcessInfo.hThread := INVALID_HANDLE_VALUE;
     Result := False;
 end;
 




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

Автор: Igor Popov

Встретились четыре компьютерщика, а бутылка ВОДКИ только одна. Мало! Долго недумая взяли и разогнали её до 400.

Если Вам необходимо не только "вычислить" частоту процессора, а и узнать о процессоре как можно больше, пожалуйста, пользуйтесь следующим модулем:


 unit ExpandCPUInfo;
 
 interface
 
 type
 
 TCPUInfo = packed record
 IDString : array [0..11] of Char;
 Stepping : Integer;
 Model    : Integer;
 Family   : Integer;
 FPU,
 VirtualModeExtensions,
 DebuggingExtensions,
 PageSizeExtensions,
 TimeStampCounter,
 K86ModelSpecificRegisters,
 MachineCheckException,
 CMPXCHG8B,
 APIC,
 MemoryTypeRangeRegisters,
 GlobalPagingExtension,
 ConditionalMoveInstruction,
 MMX     : Boolean;
 SYSCALLandSYSRET,
 FPConditionalMoveInstruction,
 AMD3DNow : Boolean;
 CPUName : String;
 end;
 {информация об идентификации процессора}
 function ExistCPUID:Boolean;
 function CPUIDInfo(out info: TCPUInfo):Boolean;
 {инф-я о технологии процессора}
 function ExistMMX:Boolean;
 function Exist3DNow:Boolean;
 function ExistKNI:Boolean;
 {------------------------}
 procedure EMMS;
 procedure FEMMS;
 procedure PREFETCH(p: Pointer); register;
 
 implementation
 
 function ExistCPUID : Boolean;
 asm
 
 pushfd
 pop eax
 mov ebx, eax
 xor eax, 00200000h
 push eax
 popfd
 pushfd
 pop ecx
 mov eax,0
 cmp ecx, ebx
 jz @NO_CPUID
 inc eax
 @NO_CPUID:
 end;
 
 function CPUIDInfo(out info: TCPUIDInfo):Boolean;
 
 function ExistExtendedCPUIDFunctions:Boolean;
 asm
 mov eax,080000000h
 db $0F,$A2
 end;
 var
 
 name : array [0..47] of Char;
 p : Pointer;
 begin
 
 if ExistCPUID then asm
 jmp @Start
 @BitLoop:
 mov al,dl
 and al,1
 mov [edi],al
 shr edx,1
 inc edi
 loop @BitLoop
 ret
 @Start:
 mov edi,info
 mov eax,0
 db $0F,$A2
 mov [edi],ebx
 mov [edi+4],edx
 mov [edi+8],ecx
 mov eax,1
 db $0F,$A2
 mov ebx,eax
 and eax,0fh;
 mov [edi+12],eax;
 shr ebx,4
 mov eax,ebx
 and eax,0fh
 mov [edi+12+4],eax
 shr ebx,4
 mov eax,ebx
 and eax,0fh
 mov [edi+12+8],eax
 add edi,24
 mov ecx,6
 call @BitLoop
 shr edx,1
 mov ecx,3
 call @BitLoop
 shr edx,2
 mov ecx,2
 call @BitLoop
 shr edx,1
 mov ecx,1
 call @BitLoop
 shr edx,7
 mov ecx,1
 call @BitLoop
 mov p,edi
 end;
 if (info.IDString = 'AuthenticAMD') and ExistExtendedCPUIDFunctions then begin
 asm
 mov edi,p
 mov eax,080000001h
 db $0F,$A2
 mov eax,edx
 shr eax,11
 and al,1
 mov [edi],al
 mov eax,edx
 shr eax,16
 and al,1
 mov [edi+1],al
 mov eax,edx
 shr eax,31
 and al,1
 mov [edi+2],al
 lea edi,name
 mov eax,0
 mov [edi],eax
 mov eax,080000000h
 db $0F,$A2
 cmp eax,080000004h
 jl @NoString
 mov eax,080000002h
 db $0F,$A2
 mov [edi],eax
 mov [edi+4],ebx
 mov [edi+8],ecx
 mov [edi+12],edx
 add edi,16
 mov eax,080000003h
 db $0F,$A2
 mov [edi],eax
 mov [edi+4],ebx
 mov [edi+8],ecx
 mov [edi+12],edx
 add edi,16
 mov eax,080000004h
 db $0F,$A2
 mov [edi],eax
 mov [edi+4],ebx
 mov [edi+8],ecx
 mov [edi+12],edx
 @NoString:
 end;
 info.CPUName:=name;
 end else with info do begin
 SYSCALLandSYSRET:=False;
 FPConditionalMoveInstruction:=False;
 AMD3DNow:=False;
 CPUName:='';
 end;
 Result:=ExistCPUID;
 end;
 
 function ExistMMX:Boolean;
 var
 
 info : TCPUIDInfo;
 begin
 
 if CPUIDInfo(info) then
 Result:=info.MMX
 else
 Result:=False;
 end;
 
 function Exist3DNow:Boolean;
 var
 
 info : TCPUIDInfo;
 begin
 
 if CPUIDInfo(info) then
 Result:=info.AMD3DNow
 else
 Result:=False;
 end;
 
 function ExistKNI:Boolean;
 begin
 
 Result:=False;
 end;
 
 procedure EMMS;
 asm
 
 db $0F,$77
 end;
 
 procedure FEMMS;
 asm
 
 db $0F,$03
 end;
 
 procedure PREFETCH(p: Pointer); register;
 asm
 
 // PREFETCH byte ptr [eax]
 end;
 
 end.
 




Как определить скорость процессора


Hа боpтy самолёта: "Здpавствyйте, дамы и господа, говоpит командиp экипажа. Мы благодаpим вас за то, что вы выбpали нашy авиакомпанию для пеpвого полёта в пеpвый день нового 2000 года. Мы находимся на высоте 3 тыс. фyтов, наша скоpость... ваy!... ох мля!... вот фак!... Извините за те неyдобства, котоpые вы испытываете, находясь вниз головой, надеюсь все были пpистёгнyты. Есть ли сpеди пассажиpов на боpтy пpогpаммист?"


 function GetCPUSpeed: real;
 
 function IsCPUID_Available: Boolean; assembler; register;
 asm
   PUSHFD { прямой доступ к флагам невозможен, только через стек }
   POP EAX { флаги в EAX }
   MOV EDX,EAX { сохраняем текущие флаги }
   xor EAX,$200000 { бит ID не нужен }
   PUSH EAX { в стек }
   POPFD { из стека в флаги, без бита ID }
   PUSHFD { возвращаем в стек }
   POP EAX { обратно в EAX }
   xor EAX,EDX { проверяем, появился ли бит ID }
   JZ @exit { нет, CPUID не доступен }
   MOV AL,True { Result=True }
   @exit:
 end;
 
 function hasTSC: Boolean;
 var
   Features: Longword;
 begin
   asm
     MOV Features,0 { Features = 0 }
 
     PUSH EBX
     xor EAX,EAX
     DW $A20F
     POP EBX
 
     CMP EAX,$01
     JL @Fail
 
     xor EAX,EAX
     MOV EAX,$01
     PUSH EBX
     DW $A20F
     MOV Features,EDX
     POP EBX
     @Fail:
   end;
 
   hasTSC := (Features and $10) <> 0;
 end;
 
 const
   DELAY = 500;
 var
   TimerHi, TimerLo: Integer;
   PriorityClass, Priority: Integer;
 begin
   Result := 0;
   if not (IsCPUID_Available and hasTSC) then
     Exit;
   PriorityClass := GetPriorityClass(GetCurrentProcess);
   Priority := GetThreadPriority(GetCurrentThread);
 
   SetPriorityClass(GetCurrentProcess, REALTIME_PRIORITY_CLASS);
   SetThreadPriority(GetCurrentThread,
   THREAD_PRIORITY_TIME_CRITICAL);
 
   SleepEx(10, FALSE);
 
   asm
     DB $0F { $0F31 op-code for RDTSC Pentium инструкции }
     DB $31 { возвращает 64-битное целое (Integer) }
     MOV TimerLo,EAX
     MOV TimerHi,EDX
   end;
 
   SleepEx(DELAY, FALSE);
 
   asm
     DB $0F { $0F31 op-code для RDTSC Pentium инструкции }
     DB $31 { возвращает 64-битное целое (Integer) }
     SUB EAX,TimerLo
     SBB EDX,TimerHi
     MOV TimerLo,EAX
     MOV TimerHi,EDX
   end;
 
   SetThreadPriority(GetCurrentThread, Priority);
   SetPriorityClass(GetCurrentProcess, PriorityClass);
   Result := TimerLo / (1000 * DELAY);
 end;
 




Как определить скорость процессора 2


 program ....;
 ..
 ..
 
 
 const
   ID_BIT = $200000; // EFLAGS ID bit
 
 function GetCPUSpeed: Double;
 const
   DelayTime = 500;
 var
   TimerHi, TimerLo: DWORD;
   PriorityClass, Priority: Integer;
 begin
   try
     PriorityClass := GetPriorityClass(GetCurrentProcess);
     Priority := GetThreadPriority(GetCurrentThread);
 
     SetPriorityClass(GetCurrentProcess, REALTIME_PRIORITY_CLASS);
     SetThreadPriority(GetCurrentThread,THREAD_PRIORITY_TIME_CRITICAL);
 
     Sleep(10);
     asm
       dw 310Fh // rdtsc
       mov TimerLo, eax
       mov TimerHi, edx
     end;
     Sleep(DelayTime);
     asm
       dw 310Fh // rdtsc
       sub eax, TimerLo
       sbb edx, TimerHi
       mov TimerLo, eax
       mov TimerHi, edx
     end;
 
     SetThreadPriority(GetCurrentThread, Priority);
     SetPriorityClass(GetCurrentProcess, PriorityClass);
 
     Result := TimerLo / (1000.0 * DelayTime);
   except
   end;
 end;
 
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
   cpuspeed: string;
 begin
   cpuspeed := Format('%f MHz', [GetCPUSpeed]);
   edit1.text := cpuspeed;
 end;
 




Как определить скорость процессора 3


 function RdTSC : int64; register;
 asm
   db $0f, $31
 end;
 
 function GetCyclesPerSecond : int64;
 var
   hF, T, et, sc : int64;
 begin
   QueryPerformanceFrequency(hF); // HiTicks / second
   QueryPerformanceCounter(T); // Determine start HiTicks
   et := T + hF; // (Cycles are passing, but we can still USE them!)
   sc := RdTSC; // Get start cycles
   repeat // Use Hi Perf Timer to loop for 1 second
     QueryPerformanceCounter(T); // Check ticks NOW
   until (T >= et); // Break the moment we equal or exceed et
     Result := RdTSC - sc; // Get stop cycles and calculate result
 end;
 




Узнать текущие время и дату по Гринвичу


 procedure TForm1.Button4Click(Sender: TObject);
 var
   lt: TSYSTEMTIME;
   st: TSYSTEMTIME;
 begin
   GetLocalTime(lt);
   GetSystemTime(st);
   Memo1.Lines.Add('LocalTime = ' +
     IntToStr(lt.wmonth) + '/' +
     IntToStr(lt.wDay) + '/' +
     IntToStr(lt.wYear) + ' ' +
     IntToStr(lt.wHour) + ':' +
     IntToStr(lt.wMinute) + ':' +
     IntToStr(lt.wSecond));
   Memo1.Lines.Add('UTCTime = ' +
     IntToStr(st.wmonth) + '/' +
     IntToStr(st.wDay) + '/' +
     IntToStr(st.wYear) + ' ' +
     IntToStr(st.wHour) + ':' +
     IntToStr(st.wMinute) + ':' +
     IntToStr(st.wSecond));
 end;
 




Как захватить текущий URL из окна Internet Explorer


Сначала Джон Леннон назвал свою группу "Beetles". Но оказалось, что адрес www.beetles.com уже занят какими-то жуками. С тех пор группа называется "Beatles".

Описываем две функции GetText и GetURL:


 function GetText(WindowHandle: hwnd):string;
 var
   txtLength : integer;
   buffer: string;
 begin
   TxtLength := SendMessage(WindowHandle, WM_GETTEXTLENGTH, 0, 0);
   txtlength := txtlength + 1;
   setlength (buffer, txtlength);
   sendmessage (WindowHandle,wm_gettext, txtlength, longint(@buffer[1]));
   result := buffer;
 end;
 
 function GetURL:string;
 var
   ie,toolbar,combo,
   comboboxex,edit,
   worker,toolbarwindow:hwnd;
 begin
   ie := FindWindow(pchar('IEFrame'),nil);
   worker := FindWindowEx(ie,0,'WorkerA',nil);
   toolbar := FindWindowEx(worker,0,'rebarwindow32',nil);
   comboboxex := FindWindowEx(toolbar, 0, 'comboboxex32', nil);
   combo := FindWindowEx(comboboxex,0,'ComboBox',nil);
   edit := FindWindowEx(combo,0,'Edit',nil);
   toolbarwindow := FindWindowEx(comboboxex, 0, 'toolbarwindow32', nil);
   result := GetText(edit);
 end;
 

Ну а затем пользуемся функцией GetURL, например, можем в поле ввода по нажатию на кнопку выводит текущий URL:


 procedure TForm1.Button1Click(Sender: TObject);
 begin
   Edit1.Text := GetURL;
 end;
 




Как узнать текущие координаты мышки

Для этого можно воспользоваться API функцией GetCursorPos. Передав в эту функцию TPoint, мы получим текущие координаты курсора. Следующий код показывает, как получить значения координат курсора по нажатию кнопки.


 procedure Form1.Button1Click(Sender: TObject);
 var
   foo: TPoint;
 begin
   GetCursorPos(foo);
   ShowMessage('(' + IntToStr(foo.X) + ' ,' + IntToStr(foo.Y) + ')');
 end;
 




Как по имени Базы Данных получить ссылку на компоненет TDataBase

Автор: Max Rezanov


 var
   db: TDataBase;
 begin
   db := Session.FindDatabase(FDataBaseName);
   db.StartTransaction;
 




Универсальная функция возврата значения элемента даты

Автор: Галимарзанов Фанис

Универсальная функция возврата значения элемента даты (год, месяц, день, квартал):


 function RetDate(inDate: TDateTime; inTip: integer): integer;
 var
   xYear, xMonth, xDay: word;
 begin
   Result := 0;
   DecodeDate(inDate, xYear, xMonth, xDay);
   case inTip of
     1: Result := xYear;  // год
     2: Result := xMonth; // месяц
     3: Result := xDay;   // день
     4: if xMonth < 4 then
          Result := 1
        else // квартал
        if xMonth < 7 then
          Result := 2
        else
        if xMonth < 10 then
          Result := 3
        else
          Result := 4;
   end;
 end;
 




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



 function GetFileDate(FileName: string): string;
 var
   FHandle: Integer;
 begin
   FHandle := FileOpen(FileName, 0);
   try
     Result := DateTimeToStr(FileDateToDateTime(FileGetDate(FHandle)));
   finally
     FileClose(FHandle);
   end;
 end;
 




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

Чтобы получить дату и время файла, необходимо вызвать функцию FileAge и преобразовать полученное значение при помощи функции FileDateToDateTime в значение TDateTime:


 function GetFileDateTime(FileName: string): TDateTime;
 var
   intFileAge: LongInt;
 begin
   intFileAge := FileAge(FileName);
   if intFileAge = -1 then
     Result := 0
   else
     Result := FileDateToDateTime(intFileAge)
 end;
 




Как определить день недели

Все люди встретили новый век в этот новый год, а программисты встретят его в 2048 году.... т.к. по мнению программистов в 1 веке не 1000 лет, а 1024.


 procedure TForm1.Button1Click(Sender: TObject);
 var
   d: TDateTime;
 begin
   d := StrToDate(Edit1.Text);
   ShowMessage(FormatDateTime('dddd',d));
 end;
 




Как узнать путь базы данных и её имя

Делается это при помощи dbiGetDatabaseDesc:


 uses
   BDE;
 
 procedure ShowDatabaseDesc(DBName: string);
 const
   DescStr = 'Driver Name: %s'#13#10'AliasName: %s'#13#10 +
   'Text: %s'#13#10'Physical Name/Path: %s';
 var
   dbDes: DBDesc;
 begin
   dbiGetDatabaseDesc(PChar(DBName), @dbDes);
   with dbDes do
     ShowMessage(Format(DescStr, [szDbType, szName, szText, szPhyName]));
 end;
 




Узнать физическое расположение локальной БД по Alias

  • По Table(Query).Database:

 uses
   DbiProcs;
 
 function GetDirByDatabase(Database: TDatabase): string;
 var
   pszDir: PChar;
 begin
   pszDir := StrAlloc(255);
   try
     DbiGetDirectory(Database.Handle, True, pszDir);
     Result := StrPas(pszDir);
   finally
     StrDispose(pszDir);
   end;
 end;
 

  • По алиасу:

 function GetPhNameByAlias(sAlias: string): string;
 var
   Database: TDatabase;
   pszDir: PChar;
 begin
   Database := TDatabase.Create(nil); {allocate memory}
   pszDir := StrAlloc(255);
   try
     Database.AliasName := sAlias;
     Database.DatabaseName := 'TEMP'; {requires a name -- is ignored}
     Database.Connected := True; {connect without opening any table}
     DbiGetDirectory(Database.Handle, True, pszDir); {get the dir.}
     Database.Connected := False; {disconnect}
     Result := StrPas(pszDir); {convert to a string}
   finally
     Database.Free; {free memory}
   end;
 end;
 




Определение типа базы данных

Автор: OAmiry (Borland)

"Могу ли я при помощи объекта Tdatabase узнать с каким типом базы данных он связан?"


 {uses должен включать в себя db, dbitypes, dbiprocs }
 procedure TForm1.FormCreate(Sender: TObject);
 var
   rDB: DBDesc ;
 begin
   { Первый аргумент DbiGetDatabaseDesc - имя псевдонима базы данных типа PChar }
   Check(DbiGetDatabaseDesc('IBLOCAL', @rDB)) ;
   { член szDbType структуры DBDesc содержит информацию о типе
   базы данных и имеет тип PChar }
   ShowMessage( 'Database имеет тип: ' + StrPas(rDB.szDbType) ) ;
   { Совет: Если вам просто необходимо узнать -
   SQL server это или нет, используйте свойсто TDatabase
   IsSQLBased }
 end;
 




Получение DC элемента управления


 {Bitmap в TImage}
 HDC:=Image1.PICTURE.bitmap.canvas.handle;
 

DC - что-нибудь с Canvas.handle.




Как во время компиляции модуля определить, под какой версией Delphi она происходит

Вечный вопрос:
- Что было раньше: компилятор или исходники компилятора?

Используйте


 {$IFDEF VERXXX}
 ...
 {$ELSE}
 ...
 {$ENDIF}
 

Пользуйтесь вот такой таблицей:

     * VER80 -- Delphi 1
      * VER90 -- Delphi 2
      * VER93 -- C++Builder 1
      * VER100 -- Delphi 3
      * VER110 -- C++Builder 3
      * VER120 -- Delphi 4
      * VER130 -- Delphi 5



Как получить имя папки pабочего стола (не чеpез registry)

Автор: Nomadic

Пpосто очень хочется поpаботать с shell functions.

В этом примере делается и это


 procedure TForm1.Button1Click(Sender: TObject);
 
   procedure madd(s: string);
   begin
     memo1.lines.add(s);
   end;
 
 var
   ppmalloc: imalloc;
   id: ishellfolder;
   pi: pitemidlist;
   lpname: tstrret;
 begin
 
   if succeeded(shgetspecialfolderlocation(0, CSIDL_PROGRAMS, pi)) then
   begin
     madd('Succeeded programs location');
     if succeeded(shgetdesktopfolder(id)) then
     begin
       madd('Succeeded get desktop folder');
       if succeeded(id.getdisplaynameof(pi, 0, lpname)) then
       begin
         madd('Succeeded get display name');
         if lpname.uType = 2 then
         begin
           madd(lpname.cstr);
         end;
       end
       else
         madd('UnSucceeded get display name');
     end
     else
       madd('UnSucceeded get desktop folder');
   end
   else
     madd('UNSucceeded programs location');
 end;
 




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

Девушка приходит к психологу.
- На что жалуетесь?
- Да вот доктор, депрессия, все надоело, мужики козлы, подруги стервы.
- Я думаю, вам нужно обновить свою жизнь, - сделать стрижку, переставить мебель в комнате.
- Все перепробовала, уж и не знаю, что еще сделать.
- Хм... О ! Попробуйте переставить иконки на своем рабочем столе...

Рабочий стол перекрыт сверху компонентом ListView. Вам просто необходимо взять хэндл этого органа управления. Пример:


 function GetDesktopListViewHandle: THandle;
 var
   S: string;
 begin
   Result := FindWindow('ProgMan', nil);
   Result := GetWindow(Result, GW_CHILD);
   Result := GetWindow(Result, GW_CHILD);
   SetLength(S, 40);
   GetClassName(Result, PChar(S), 39);
   if PChar(S) <> 'SysListView32' then
     Result := 0;
 end;
 

После того, как Вы взяли тот хэндл, Вы можете использовать API этого ListView, определенный в модуле CommCtrl, для того, чтобы манипулировать рабочим столом. Смотрите тему "LVM_xxxx messages" в оперативной справке по Win32.

К примеру, следующая строка кода:


 SendMessage(GetDesktopListViewHandle, LVM_ALIGN, LVA_ALIGNLEFT, 0);
 

разместит иконки рабочего стола по левой стороне рабочего стола Windows.




Вычисление размера каталога



 uses FileCtrl;
 
 function DirSize(Dir: string): integer;
 var
   SearchRec: TSearchRec;
   Separator: string;
   DirBytes: integer;
 begin
   Result:=-1;
   if Copy(Dir,Length(Dir),1)='\' then
     Separator := ''
   else
     Separator := '\';
   if FindFirst(Dir+Separator+'*.*',faAnyFile,SearchRec) = 0 then
   begin
     if FileExists(Dir+Separator+SearchRec.name) then
       DirBytes := DirBytes + SearchRec.Size
     else
     if DirectoryExists(Dir+Separator+SearchRec.name) then
     begin
       if (SearchRec.name<>'.') and (SearchRec.name<>'..') then
         DirSize(Dir+Separator+SearchRec.name);
     end;
     while FindNext(SearchRec) = 0 do
     begin
       if FileExists(Dir+Separator+SearchRec.name) then
         DirBytes := DirBytes + SearchRec.Size
       else
       if DirectoryExists(Dir+Separator+SearchRec.name) then
       begin
         if (SearchRec.name<>'.') and (SearchRec.name<>'..') then
           DirSize(Dir+Separator+SearchRec.name);
       end;
     end;
   end;
   FindClose(SearchRec);
   Result:=DirBytes;
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
   DirBytes: integer;
 begin
   DirBytes := DirSize('c:\windows');
   Form1.Label1.Caption := IntToStr(DirBytes);
 end;
 




Как подсчитать занимаемое директорией место

Источник: http://www.proext.com


 var
   DirBytes: integer;
 
 function TFileBrowser.DirSize(Dir: string): integer;
 var
   SearchRec: TSearchRec;
   Separator: string;
 begin
   if Copy(Dir, Length(Dir), 1) = '\' then Separator := ''
   else Separator := '\';
   if FindFirst(Dir + Separator + '*.*', faAnyFile, SearchRec) = 0 then begin
     if FileExists(Dir + Separator + SearchRec.Name) then begin
       DirBytes := DirBytes + SearchRec.Size;
       {Memo1.Lines.Add(Dir+Separator+SearchRec.Name);}
     end
     else
       if DirectoryExists(Dir + Separator + SearchRec.Name) then begin
         if (SearchRec.Name <> '.') and (SearchRec.Name <> '..') then
           DirSize(Dir + Separator + SearchRec.Name);
       end;
     while FindNext(SearchRec) = 0 do begin
       if FileExists(Dir + Separator + SearchRec.Name) then begin
         DirBytes := DirBytes + SearchRec.Size;
         {Memo1.Lines.Add(Dir+Separator+SearchRec.Name);}
       end
       else
         if DirectoryExists(Dir + Separator + SearchRec.Name) then begin
           if (SearchRec.Name <> '.') and (SearchRec.Name <> '..') then begin
             DirSize(Dir + Separator + SearchRec.Name);
           end;
         end;
     end;
   end;
   FindClose(SearchRec);
 end;
 




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

Для получения размера свободного места на дисках, ёмкость которых больше 2Гб, необходимо использовать функцию GetDiskFreeSpaceEx. Ниже приведён небольшой пример использования данной функции:


 var
   FreeBytesAvailableToCaller: TLargeInteger;
   FreeSize: TLargeInteger;
   TotalSize: TLargeInteger;
 begin
   GetDiskFreeSpaceEx('c:',
     FreeBytesAvailableToCaller,
     Totalsize,
     @FreeSize);
 end;
 

Результатом будет значение в байтах.




Получение идентификатора диска

Автор: Vasili Pincuk

Только что прошло сообщение по компьютерным сетям!!! Внимание!!!! Предупреждение!!! Новый вирус "Виагра"! Превращает ваш трех-с-половиной дюймовый флоппи в ХАРД-драйв!!!

Как получить идентификатор находящегося в CD-ROM'е аудио-компакта?


 const
   MCI_INFO_PRODUCT = $00000100;
   MCI_INFO_FILE = $00000200;
   MCI_INFO_MEDIA_UPC = $00000400;
   MCI_INFO_MEDIA_IDENTITY = $00000800;
   MCI_INFO_NAME = $00001000;
   MCI_INFO_COPYRIGHT = $00002000;
   { блок параметров для командного сообщения MCI_INFO }
 
 type
   PMCI_Info_ParmsA = ^TMCI_Info_ParmsA;
   PMCI_Info_ParmsW = ^TMCI_Info_ParmsW;
   PMCI_Info_Parms = PMCI_Info_ParmsA;
   TMCI_Info_ParmsA = record
     dwCallback: DWORD;
     lpstrReturn: PAnsiChar;
     dwRetSize: DWORD;
   end;
   TMCI_Info_ParmsW = record
     dwCallback: DWORD;
     lpstrReturn: PWideChar;
     dwRetSize: DWORD;
   end;
   TMCI_Info_Parms = TMCI_Info_ParmsA;
 

Идентификатор возвращается функцией MCI_INFO_MEDIA_IDENTITY в виде строки с десятичным числом. Для получения дополнительной информации обратитесь к электронной справке (Win32 и компонент TMediaPlayer).

Исправления


 // метка диска
 
 procedure GetDriveInfo(VolumeName: string;
   var VolumeLabel, SerialNumber, FileSystem: string);
 var
   VolLabel, FileSysName: array[0..255] of char;
   SerNum: pdword;
   MaxCompLen, FileSysFlags: dword;
 begin
   New(SerNum);
   GetVolumeInformation(PChar(VolumeName), VolLabel,
     255, SerNum, MaxCompLen, FileSysFlags, FileSysName, 255);
   VolumeLabel := VolLabel;
   SerialNumber := Format('%x', [SerNum^]);
   FileSystem := FileSysName;
   Dispose(SerNum);
 end;
 
 // далее
 var
   VolLabel, SN, FileSystem, S: string;
 begin
   s := 'g:\'; // имя CD дисковода
   GetDriveInfo(S, VolLabel, SN, FileSystem);
 

получаем:

VolLabel   - 'ARMSTRONG' // метка диска
 SN         -  B5FF77AD   // номер серийный
 FileSystem -  CDFS       // тип файловой системы

Работает не только для CD для всех типов дисков ... Далее:


 // метка диска
 procedure GetAllDrive(Sender: TObject);
 var
   i, mask: integer;
   s: string;
 begin
   mask := GetLogicalDrives;
   i := 0;
   while mask <> 0 do
   begin
     s := chr(ord('a') + i) + ':\';
     if (mask and 1) <> 0 then
       case GetDriveType(PChar(s)) of
         0: ListBox1.Items.Add(s + ' unknown.');
         1: ListBox1.Items.Add(s + ' not exist.');
         DRIVE_REMOVABLE: ListBox1.Items.Add(s + ' removable.'); // floppy,zip
         DRIVE_FIXED: ListBox1.Items.Add(s + ' fixed.');
         DRIVE_REMOTE: ListBox1.Items.Add(s + ' network.');
         DRIVE_CDROM: ListBox1.Items.Add(s + ' CD-ROM.');
         DRIVE_RAMDISK: ListBox1.Items.Add(s + ' RAM.');
       end;
     inc(i);
     mask := mask shr 1;
   end;
 end;
 

В ListBox1 получаем все диски на данном компьютере.

Whith best regards Vasili Pincuk
ICQ 10558844
http://www.geocities.com/pvasili
E-mail: pvasili@geocities.com




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



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



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


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