Текущий архив: 2004.07.04;
Скачать: CL | DM;

Вниз

Программа без VCL   Найти похожие ветки 

← →
ormada ©   (2004-05-22 21:29) [0]

Доб день/вечер! Вот возникла такая проблема делаю прогру без VCL чисто хочу сделать трайикон+попменю к нему. Делаю это так

Program Tray_Launcher;

Uses
 Menus,
 Classes;

Procedure PopupItemClick(Sender: TObject);
Begin
 With Sender As TMenuItem Do
 Begin
   Case Tag Of
     0: ;//ShowMessage("first item clicked");
     1: ;//ShowMessage("second item clicked");
     2: ;//ShowMessage("third item clicked");
     3: ;//ShowMessage("fourth item clicked");
   End;
 End;
End;

Var
 PopupMenu                             : TPopupMenu;
 i:integer;
 NewItem: TMenuItem;

 Begin
 Application.Initialize;

 PopupMenu := TPopupMenu.Create(Application);
for i := 0 to 3 do
 begin
   NewItem := TMenuItem.Create(PopupMenu); // create the new item
   PopupMenu.Items.Add(NewItem);// add it to the Popupmenu
   NewItem.OnClick := PopupItemClick;// вот здеся ругается говорит
[Error] : Incompatible types: "method pointer and regular procedure"

 end;
 Application.Run;
End.



Хотя если сделать всё тож самое в форме и добавит в её раздел ну например в private PopupItemClick то всё работает.

Можно ли как нить это сделать без VCL ?

---

← →
Sergey Masloff   (2004-05-22 21:41) [1]

>TPopupMenu.Create
это ты называешь "без VCL"?!!!!

про ошибку
>"method pointer and regular procedure"
Указатель на метод отличается от обычной процедуры тем что в нем присутствует неявный дополнительный параметр - ссылка на экземпляр класса метод которого вызывается.
поэтому твоя процедура

Procedure PopupItemClick(Sender: TObject);

не подходит в качестве указателя на метод. О чем тебе и сообщает компилятор.

---

← →
Mim1 ©   (2004-05-22 21:46) [2]

Ругается от по тому что обработкис обытия должен быть методом класса

обойти можно вот так

procedure SomeProc(ASelf,  Sender:  TObject);
begin
 DoError(Sender,e);
end;
...
var
 amethod: TMethod;
begin
 amethod.Code := @SomeProc;
 amethod.Data := Application;
 Application.OnException := TNotifyEvent(amethod);
end;

Хотя программа все равно будет vclная

---

← →
Mim1 ©   (2004-05-22 21:48) [3]

Ругается от по тому что обработкис обытия должен быть методом класса

звиняюсь за ошибки, без ошибок и более подробн написано в [1]

---

← →
ormada ©   (2004-05-22 21:49) [4]

2 Sergey Masloff
Ну я имел ввиду без формы :) она ведь лишний 300 кило потянет причём толку от неё в этой программе никакого...
Дык а как тогда сделать можно чё-то не догоняю....

---

← →
Mim1 ©   (2004-05-22 21:49) [5]

строку
Application.OnException := TNotifyEvent(amethod);
надо заменить на
NewItem.OnClick := TNotifyEvent(amethod);

---

← →
Mim1 ©   (2004-05-22 21:54) [6]

300 кило вы все равно не скините, если надо чтоб программа была мелкая то в uses  должны присутствовать только windows, messages, shlapi и подобные модули, sysutils и classes добавят в программу по несколько десяткой килобайт. forms потянет за собой три сотни килл (он связан с многоими другими модулями). А модуль menus связан с forms в разделе реализации.

на api меню создавать методом createmenu

---

← →
ormada ©   (2004-05-22 22:02) [7]

2 Mim1 на апи делал ? пример можеш кинуть а то я в апи практически 0 :)

---

← →
Mim1 ©   (2004-05-22 22:20) [8]

Программа на апи ~20 к
добавляет в тей иконку отображает загрузку процессора и количество свободной памяти
писал стол тет назад
Выполнена в виде бибилиотеки, запускать так
rundll32 nebzz.dll,InitApp Config or InitTray
Коментарии наверное не верны.

Library nebzz;

uses Windows, Messages, ShellApi, CpuUsage;

{$DESCRIPTION "NilSoft Nebzz version 1.0002"} // description
{$R ICONDIGITS.RES}

const
 // menu items offstes
 FirstItemOffset=50;
 CPVMI_CBMSG_Offset=10;
 // Tray icon id
 TIMainID=100;
 // timer id
 TimerID = 3322;
 // Messages
 wm_TrayIconCb=WM_USER + 1;
 wm_SecondRun=wm_user + 2;

var
 // save old window proc
 OldWndProc:Integer;
 // tray icon varibles
 ProtoTrayIcon : TNotifyIconData;

Function StrToIntDef(const v:string;const def : integer):integer;
 var cd,
     rz:integer;
begin
 val(v,rz,cd);
 if cd=0 then Result:=rz else Result:=def;
end;
       
function rect(aleft, atop, aright, abottom: integer): trect;
begin
 with result do
 begin
   left := aleft;
   top := atop;
   right := aright;
   bottom := abottom;
 end;
end;

function geninfobitmap(Num1, Num2:integer):hbitmap;
var
 digitsbmp, olddigitsbmp, holddestbitmap, hdestbitmap : hbitmap;
 hmemsrc, hmemdest : integer;
 whitebr,blackbr:hbrush;
 s : string;
begin
 digitsbmp := loadbitmap(hinstance,"Digits4x8");

 hmemsrc := createcompatibledc(0);
 hmemdest := createcompatibledc(0);

 olddigitsbmp := selectobject(hmemsrc, digitsbmp);
 hdestbitmap := createbitmap(16, 16, 1, 1, nil);
 holddestbitmap := selectobject(hmemdest, hdestbitmap);
//
 whitebr := createsolidbrush($ffffff);
 blackbr := createsolidbrush($000000);
 ///
   str(Num1 :3,s);
   if length(s) > 3 then s:="999";
   fillrect(hmemdest,rect(0,0,16,16),whitebr);
   bitblt(hmemdest,1,1,4,8,hmemsrc,succ(strtointdef(s[1],0)*5),1,srccopy);
   bitblt(hmemdest,6,1,4,8,hmemsrc,succ(strtointdef(s[2],0)*5),1,srccopy);
   bitblt(hmemdest,11,1,4,8,hmemsrc,succ(strtointdef(s[3],0)*5),1,srccopy);
   str(Num2 :3,s);
   if length(s) > 3 then s:="999";
   bitblt(hmemdest,1,9,4,8,hmemsrc,succ(strtointdef(s[1],0)*5),1,srccopy);
   bitblt(hmemdest,6,9,4,8,hmemsrc,succ(strtointdef(s[2],0)*5),1,srccopy);
   bitblt(hmemdest,11,9,4,8,hmemsrc,succ(strtointdef(s[3],0)*5),1,srccopy);
 ///
 deleteobject(whitebr);
 deleteobject(blackbr);
//
 selectobject(hmemsrc, olddigitsbmp);
 selectobject(hmemdest, holddestbitmap);
 deletedc(hmemdest);
 deletedc(hmemsrc);

 result := hdestbitmap;

 deleteobject(digitsbmp);
end;

function geninfoicon(hsourcebitmap:hbitmap;x,y:integer):hicon;
var
 hOldSourceBitmap,
 hOldMaskBitmap, hMaskBitmap,
 hOldColorBitmap, hColorBitmap : HBITMAP;
 hMemSrc, hMaskMem, hColorMem : HDC;
 IconInfo : TIconInfo;
 BlackBR : HBRUSH;
begin
 BlackBR := CreateSolidBrush($000000);
 hMaskBitmap := CreateBitmap(x, y, 1, 1, nil);
 hColorBitmap := CreateBitmap(x, y, 1, 1, nil);

 hMemSrc := CreateCompatibleDC(0);
 hMaskMem := CreateCompatibleDC(0);
 hColorMem := CreateCompatibleDC(0);


---

← →
Mim1 ©   (2004-05-22 22:21) [9]

продолжение


 hOldSourceBitmap := SelectObject(hMemSrc, hSourceBitmap);
 hOldMaskBitmap := SelectObject(hMaskMem, hMaskBitmap);
 hOldColorBitmap := SelectObject(hColorMem, hColorBitmap);

 FillRect(hColorMem,rect(0,0,x,y),BlackBR);
 StretchBlt(hMaskMem,0,0,x,y,hMemSrc,0,0,16,16,SRCCOPY);

 SelectObject(hMemSrc, hOldSourceBitmap);
 SelectObject(hMaskMem, hOldMaskBitmap);
 SelectObject(hColorMem, hOldColorBitmap);

 DeleteDC(hMemSrc);
 DeleteDC(hMaskMem);
 DeleteDC(hColorMem);

 DeleteObject(BlackBR);

 FillChar(IconInfo,SizeOf(TIconInfo),#0);
 IconInfo.fIcon:=true;
 IconInfo.hbmColor:=hColorBitmap;
 IconInfo.hbmMask:=hMaskBitmap;
 Result := CreateIconIndirect(IconInfo);

 DeleteObject(hColorBitmap);
 DeleteObject(hMaskBitmap);
end;

Procedure DestroyTray();
begin
 Shell_NotifyIcon(NIM_DELETE, @ProtoTrayIcon);
end;

Procedure UpdateTrayIcon;
var
 ms : TMemoryStatus;
 bmp : hbitmap;
 mem, cpu:integer;
begin
 // collecting cpu data
 CollectCPUData; // Get the data for all processors
 // getting memory information
 FillChar(ms,sizeof(TMemoryStatus),#0);
 ms.dwLength := sizeof(TMemoryStatus);
 GlobalMemoryStatus(ms);
 // modifyng icon
 DestroyIcon(ProtoTrayIcon.hIcon);
 mem := ms.dwAvailPhys div 1024 div 1024;
 if GetCPUCount >0 then cpu := Round(GetCPUUsage(0)*100) else cpu := 0; // :-}
 bmp := GENINFOBITMAP(mem,cpu);
 ProtoTrayIcon.hIcon := GenInfoIcon(bmp,GetSystemMetrics(SM_CXSMICON),
                                        GetSystemMetrics(SM_CYSMICON));
 DeleteObject(bmp);
 // update information
 Shell_NotifyIcon(NIM_MODIFY,@ProtoTrayIcon);
end;

Procedure CreateTray(const cbwnd:integer;IcoId:Integer);
begin
 FillChar(ProtoTrayIcon,sizeof(TNotifyIconData),0);
 ProtoTrayIcon.cbSize:=sizeof(ProtoTrayIcon);
 ProtoTrayIcon.Wnd:=cbwnd;
 ProtoTrayIcon.uID := IcoId;
 ProtoTrayIcon.uFlags := NIF_MESSAGE + NIF_ICON + NIF_TIP;
 ProtoTrayIcon.uCallbackMessage := wm_TrayIconCb;
 ProtoTrayIcon.hIcon := LoadIcon(0,IDI_APPLICATION);
 ProtoTrayIcon.szTip:="Mim info tool";
 Shell_NotifyIcon(NIM_ADD, @ProtoTrayIcon);
 UpdateTrayIcon;
end;

Procedure UpdateTrayIconEx();
begin
 Shell_NotifyIcon(NIM_DELETE, @ProtoTrayIcon);
 Shell_NotifyIcon(NIM_ADD, @ProtoTrayIcon);
 UpdateTrayIcon;
end;

function HkRunDllProc(wnd:Hwnd; Message:integer;Wparam:WPARAM;
                    LParam:LParam):LongInt; stdcall;
 Procedure z;
 begin
   Result := CallWindowProc(ptr(OldWndProc),wnd,Message,wParam,lParam);
 end;
begin
 case Message of
   wm_timer :
     if wParam = timerid then UpdateTrayIcon;
   wm_SecondRun :
     UpdateTrayIconEx ;
   wm_TrayIconCb:
     case wparam of
       TIMainID:
         case LParam of
           WM_LBUTTONDBLCLK :;
           WM_LBUTTONDOWN   :;
           WM_LBUTTONUP     :;
           WM_MBUTTONDBLCLK :;
           WM_MBUTTONDOWN   :;
           WM_MBUTTONUP     :;
           WM_MOUSEMOVE     :;
           WM_RBUTTONDBLCLK :;
           WM_RBUTTONDOWN   :;
           WM_RBUTTONUP     :;
         end;
     end;
   else z;
 end;
end;

Procedure MainZLine;
var xMsg:tmsg;
begin
   While GetMessage(xMsg,0,0,0) do
     begin
       TranslateMessage(xMsg);
       DispatchMessage(xMsg);
     end;
end;

Function InitApp(RunDllhWnd: hwnd;RunDllhInstance: HMODULE;lpCmdLine: PChar;dummy: Longint): Integer; StdCall; Export;
var   PrevInstWnd:hwnd;
Const WndName="NilSoft Nebzz";
begin
 Result := 0;//errorcode - код ошибки для rundll
 PrevInstWnd:=FindWindow("RunDll",WndName);
 // устанавливаем текст окна  !!! важно это должно идти после FindWindow
 // иначе программа будет находить сама себя
 SetWindowText(RunDllhWnd,WndName);
 // если нашол еще одно окошко
 // то посылаем ему сообщение
 if PrevInstWnd<>0 then SendMessage(PrevInstWnd,wm_SecondRun,0,0) else
 // проверяем не переименован ли Nebzz.dll
   begin
       OldWndProc:= GetWindowLong(RunDllhWnd,GWL_WNDPROC);
       SetWindowLong(RunDllhWnd,GWL_WNDPROC,LongInt(@HkRunDllProc));
       // создаем иконку в трай
       CreateTray(RunDllhWnd,TIMainID);
       SetTimer(RunDllhWnd,TimerID,1000,nil);
       // основной поток
       MainZLine;
       // убираем иконку в трай
       KillTimer(RunDllhWnd,TimerID);
       DestroyTray;
       // возвращаем стандатный WindowProc
       SetWindowLong(RunDllhwnd,GWL_WNDPROC,OldWndProc);
       // отключаем плагины
 end;
end;

EXPORTS InitApp;

end.

---

← →
Mim1 ©   (2004-05-22 22:22) [10]

Ресурс с картинками для иконки

компилить при помощи brcc32

/****************************************************************************

ICONDIGITS.RC

produced by Borland Resource Workshop

*****************************************************************************/

LANGUAGE LANG_RUSSIAN,1

DIGITS4X8 BITMAP
{
"42 4D 86 00 00 00 00 00 00 00 3E 00 00 00 28 00"
"00 00 33 00 00 00 09 00 00 00 01 00 01 00 00 00"
"00 00 48 00 00 00 C4 0E 00 00 C4 0E 00 00 00 00"
"00 00 00 00 00 00 00 00 00 00 FF FF FF 00 FF FF"
"FF FF FF FF E0 00 86 21 0F 42 1E 84 20 00 97 6F"
"6F 7A DE B7 A0 00 B7 77 EF 7A DE B7 A0 00 B7 7B"
"98 42 1E 84 20 00 B7 7D EB 5E FE D5 A0 00 A6 6D"
"6B 5E FE D5 A0 00 87 61 0B C2 10 C4 20 00 FF FF"
"FF FF FF FF E0 00"
}

DIGITS3X5 BITMAP
{
"42 4D A6 00 00 00 00 00 00 00 3E 00 00 00 28 00"
"00 00 29 00 00 00 0D 00 00 00 01 00 01 00 00 00"
"00 00 68 00 00 00 C4 0E 00 00 C4 0E 00 00 00 00"
"00 00 00 00 00 00 00 00 00 00 FF FF FF 00 FF FF"
"FF FF FF 80 00 00 D8 89 E9 DE D9 80 00 00 AD BE"
"EE AE AE 80 00 00 AD DD 89 9E DC 80 00 00 AD EE"
"AB BE AA 80 00 00 D9 99 B8 C8 DD 80 00 00 FF FF"
"FF FF FF 80 00 00 88 88 E8 8E 88 80 00 00 AD BE"
"EE AE AE 80 00 00 AD DC 88 8E 88 80 00 00 AD EE"
"AB BE AA 80 00 00 89 88 B8 88 88 80 00 00 FF FF"
"FF FF FF 80 00 00"
}

---

← →
Mim1 ©   (2004-05-22 22:27) [11]

модуль для сбора инфы о загрузке проца. НЕ МОЙ, немножко мной измененный

unit CpuUsage;

//   Author:       Alexey A. Dynnikov
//   EMail:        aldyn@chat.ru
//   WebSite:      http://www.aldyn.ru/
//   Support:      Use the e-mail aldyn@chat.ru
//                          or support@aldyn.ru
//
//   modifyed by proton
//     removed sysutils depends

interface

uses
 Windows;

procedure CollectCPUData;
function GetCPUCount: Integer;
function GetCPUUsage(Index: Integer): Double;
procedure ReleaseCPUData;

implementation

type
   PInt64 = ^int64;

type
   TPERF_DATA_BLOCK = record
       Signature : array[0..4 - 1] of WCHAR;
       LittleEndian : DWORD;
       Version : DWORD;
       Revision : DWORD;
       TotalByteLength : DWORD;
       HeaderLength : DWORD;
       NumObjectTypes : DWORD;
       DefaultObject : Longint;
       SystemTime : TSystemTime;
       Reserved: DWORD;
       PerfTime : int64;
       PerfFreq : int64;
       PerfTime100nSec : int64;
       SystemNameLength : DWORD;
       SystemNameOffset : DWORD;
   end;

   PPERF_DATA_BLOCK = ^TPERF_DATA_BLOCK;

   TPERF_OBJECT_TYPE = record
       TotalByteLength : DWORD;
       DefinitionLength : DWORD;
       HeaderLength : DWORD;
       ObjectNameTitleIndex : DWORD;
       ObjectNameTitle : LPWSTR;
       ObjectHelpTitleIndex : DWORD;
       ObjectHelpTitle : LPWSTR;
       DetailLevel : DWORD;
       NumCounters : DWORD;
       DefaultCounter : Longint;
       NumInstances : Longint;
       CodePage : DWORD;
       PerfTime : int64;
       PerfFreq : int64;
   end;

   PPERF_OBJECT_TYPE = ^TPERF_OBJECT_TYPE;

type
   TPERF_COUNTER_DEFINITION = record
       ByteLength : DWORD;
       CounterNameTitleIndex : DWORD;
       CounterNameTitle : LPWSTR;
       CounterHelpTitleIndex : DWORD;
       CounterHelpTitle : LPWSTR;
       DefaultScale : Longint;
       DetailLevel : DWORD;
       CounterType : DWORD;
       CounterSize : DWORD;
       CounterOffset : DWORD;
   end;

---

← →
Mim1 ©   (2004-05-22 22:28) [12]

продолжение
   PPERF_COUNTER_DEFINITION = ^TPERF_COUNTER_DEFINITION;

   TPERF_COUNTER_BLOCK = record
       ByteLength : DWORD;
   end;

   PPERF_COUNTER_BLOCK = ^TPERF_COUNTER_BLOCK;

   TPERF_INSTANCE_DEFINITION = record
       ByteLength : DWORD;
       ParentObjectTitleIndex : DWORD;
       ParentObjectInstance : DWORD;
       UniqueID : Longint;
       NameOffset : DWORD;
       NameLength : DWORD;
   end;

   PPERF_INSTANCE_DEFINITION = ^TPERF_INSTANCE_DEFINITION;

//------------------------------------------------------------------------------
{$ifdef ver130}
{$L-}         // The L+ causes internal error in Delphi 5 compiler
{$O-}         // The O+ causes internal error in Delphi 5 compiler
{$Y-}         // The Y+ causes internal error in Delphi 5 compiler
{$endif}

{$ifndef ver110}
type
   int64F = int64;
{$else}
type
   int64F = Extended;
{$endif}

{$ifdef ver110}
function FInt64(Value: int64): int64F;
function Int64D(Value: DWORD): int64;
{$else}
type
   FInt64 = int64F;
   Int64D = int64;
{$endif}

{$ifdef ver110}
function FInt64(Value: int64): int64F;
var V: int64;
begin
   if (Value.HighPart and $80000000) = 0 then // positive value
   begin
       result:=Value.HighPart;
       result:=result*$10000*$10000;
       result:=result+Value.LowPart;
   end else
   begin
       V.HighPart:=Value.HighPart xor $FFFFFFFF;
       V.LowPart:=Value.LowPart xor $FFFFFFFF;
       result:= -1 - FInt64(V);
   end;
end;

function Int64D(Value: DWORD): int64;
begin
   result.LowPart:=Value;
   result.HighPart := 0; // positive only
end;
{$endif}

//------------------------------------------------------------------------------

const
   Processor_IDX_Str = "238";
   Processor_IDX = 238;
   CPUUsageIDX = 6;

type
   AInt64F = array[0..$FFFF] of int64F;
   PAInt64F = ^AInt64F;

var
   _PerfData : PPERF_DATA_BLOCK;
   _BufferSize: Integer;
   _POT : PPERF_OBJECT_TYPE;
   _PCD: PPerf_Counter_Definition;
   _ProcessorsCount: Integer;
   _Counters: PAInt64F;
   _PrevCounters: PAInt64F;
   _SysTime: int64F;
   _PrevSysTime: int64F;
   _IsWinNT: Boolean;

   _W9xCollecting: Boolean;
   _W9xCpuUsage: DWORD;
   _W9xCpuKey: HKEY;

//------------------------------------------------------------------------------
function GetCPUCount: Integer;
begin
   if _IsWinNT then
   begin
       if _ProcessorsCount < 0 then CollectCPUData;
       result:=_ProcessorsCount;
   end else
   begin
       result:=1;
   end;

end;

//------------------------------------------------------------------------------
procedure ReleaseCPUData;
var H: HKEY;
   R: DWORD;
   dwDataSize, dwType: DWORD;
begin
   if _IsWinNT then exit;
   if not _W9xCollecting then exit;
   _W9xCollecting:=False;

   RegCloseKey(_W9xCpuKey);

   R:=RegOpenKeyEx( HKEY_DYN_DATA, "PerfStats\StopStat", 0, KEY_ALL_ACCESS, H );

   if R <> ERROR_SUCCESS then exit;

   dwDataSize:=sizeof(DWORD);

   RegQueryValueEx ( H, "KERNEL\CPUUsage", nil, @dwType, PBYTE(@_W9xCpuUsage), @dwDataSize);

   RegCloseKey(H);

end;

---

← →
Mim1 ©   (2004-05-22 22:28) [13]

Продолжение



//------------------------------------------------------------------------------
function GetCPUUsage(Index: Integer): Double;
begin
   if _IsWinNT then
   begin
       if _ProcessorsCount < 0 then CollectCPUData;
       if (Index >= _ProcessorsCount) or (Index < 0) then
           MessageBox(0,"CPU index out of bounds","error",mb_IconError or mb_ok);
       if _PrevSysTime = _SysTime then result:=0 else
       result:=1-(_Counters[index] - _PrevCounters[index])/(_SysTime-_PrevSysTime);
   end else
   begin
       if Index <> 0 then
           MessageBox(0,"CPU index out of bounds","error",mb_IconError or mb_ok);
       if not _W9xCollecting then CollectCPUData;
       result:=_W9xCpuUsage / 100;
   end;
end;

var VI: TOSVERSIONINFO;

//------------------------------------------------------------------------------
procedure CollectCPUData;
var BS: integer;
   i: Integer;
   _PCB_Instance: PPERF_COUNTER_BLOCK;
   _PID_Instance: PPERF_INSTANCE_DEFINITION;
   ST: TFileTime;

var H: HKEY;
   R: DWORD;
   dwDataSize, dwType: DWORD;
begin
   if _IsWinNT then
   begin
       BS:=_BufferSize;
       while RegQueryValueEx( HKEY_PERFORMANCE_DATA, Processor_IDX_Str, nil, nil,
               PByte(_PerfData), @BS ) = ERROR_MORE_DATA do
       begin
           // Get a buffer that is big enough.
           INC(_BufferSize,$1000);
           BS:=_BufferSize;
           ReallocMem( _PerfData, _BufferSize );
       end;

       // Locate the performance object
       _POT := PPERF_OBJECT_TYPE(DWORD(_PerfData) + _PerfData.HeaderLength);
       for i := 1 to _PerfData.NumObjectTypes do
       begin
           if _POT.ObjectNameTitleIndex = Processor_IDX then Break;
           _POT := PPERF_OBJECT_TYPE(DWORD(_POT) + _POT.TotalByteLength);
       end;

       // Check for success
       if _POT.ObjectNameTitleIndex <> Processor_IDX then
           MessageBox(0,"Unable to locate the "Processor" performance object",
               "error",mb_IconError or mb_ok);

       if _ProcessorsCount < 0 then
       begin
           _ProcessorsCount:=_POT.NumInstances;
           GetMem(_Counters,_ProcessorsCount*SizeOf(int64));
           GetMem(_PrevCounters,_ProcessorsCount*SizeOf(int64));
       end;

       // Locate the "% CPU usage" counter definition
       _PCD := PPERF_Counter_DEFINITION(DWORD(_POT) + _POT.HeaderLength);
       for i := 1 to _POT.NumCounters do
       begin
           if _PCD.CounterNameTitleIndex = CPUUsageIDX then break;
           _PCD := PPERF_COUNTER_DEFINITION(DWORD(_PCD) + _PCD.ByteLength);
       end;

       // Check for success
       if _PCD.CounterNameTitleIndex <> CPUUsageIDX then
           MessageBox(0,"Unable to locate the "% of CPU usage" performance counter",
               "error",mb_IconError or mb_ok);

       // Collecting coutners
       _PID_Instance := PPERF_INSTANCE_DEFINITION(DWORD(_POT) + _POT.DefinitionLength);
       for i := 0 to _ProcessorsCount-1 do
       begin
           _PCB_Instance := PPERF_COUNTER_BLOCK(DWORD(_PID_Instance) + _PID_Instance.ByteLength );

           _PrevCounters[i]:=_Counters[i];
           _Counters[i]:=FInt64(PInt64(DWORD(_PCB_Instance) + _PCD.CounterOffset)^);

           _PID_Instance := PPERF_INSTANCE_DEFINITION(DWORD(_PCB_Instance) + _PCB_Instance.ByteLength);
       end;

       _PrevSysTime:=_SysTime;
       SystemTimeToFileTime(_PerfData.SystemTime, ST);
       _SysTime:=FInt64(int64(ST));
   end else
   begin
       if not _W9xCollecting then
       begin
           R:=RegOpenKeyEx( HKEY_DYN_DATA, "PerfStats\StartStat", 0, KEY_ALL_ACCESS, H );
           if R <> ERROR_SUCCESS then
               MessageBox(0,"Unable to start performance monitoring",
                       "error",mb_IconError or mb_ok);

           dwDataSize:=sizeof(DWORD);

           RegQueryValueEx( H, "KERNEL\CPUUsage", nil, @dwType, PBYTE(@_W9xCpuUsage), @dwDataSize );

           RegCloseKey(H);

           R:=RegOpenKeyEx( HKEY_DYN_DATA, "PerfStats\StatData", 0,KEY_READ, _W9xCpuKey );

           if R <> ERROR_SUCCESS then
               MessageBox(0,"Unable to read performance data",
                       "error",mb_iconerror or mb_ok);

           _W9xCollecting:=True;
       end;

       dwDataSize:=sizeof(DWORD);
       RegQueryValueEx( _W9xCpuKey, "KERNEL\CPUUsage", nil,@dwType, PBYTE(@_W9xCpuUsage), @dwDataSize );
   end;
end;

initialization
   _ProcessorsCount:= -1;
   _BufferSize:= $2000;
   //_PerfData := AllocMem(_BufferSize);
   GetMem(_PerfData,_BufferSize);

   VI.dwOSVersionInfoSize:=SizeOf(VI);
   if not GetVersionEx(VI) then
     MessageBox(0,"Can""t get the Windows version",
       "error",mb_iconerror or mb_ok);

   _IsWinNT := VI.dwPlatformId = VER_PLATFORM_WIN32_NT;
finalization
   ReleaseCPUData;
   FreeMem(_PerfData);
end.

вот кажется и все

ЗЫ агда же заработает проклятая кладовка :(

---

← →
Mim1 ©   (2004-05-22 22:30) [14]

и напоследок работа с меню в api

Function StructToMenu(pits:pointer;cnt:integer;var ItemId:integer):hmenu;
 var
     i:integer;
     mn:HMENU;
     mii : TMenuItemInfo;
     its : ^NZItems;
begin
 its := pits;
 mn := CreatePopupMenu;
 for i:= 0 to pred(cnt) do
   with its[i] do
     begin
       FillChar (mii,sizeof(TMenuItemInfo),#0);
       mii.cbSize := sizeof(TMenuItemInfo);

       mii.fMask := MIIM_STATE or MIIM_SUBMENU or MIIM_TYPE;
     // test for seproator
       if text = nil then
           mii.fType := mii.fType or MFT_SEPARATOR
         else
           begin
             mii.fType := mii.fType or MFT_STRING;
             mii.dwTypeData := text;
           end;
     // item parameters
       if params and NZPChecked = NZPChecked then
         mii.fState := mii.fState or MFS_CHECKED;

       if params and NZPRadioCheck = NZPRadioCheck then
         begin
           mii.fType := mii.fType or MFT_RADIOCHECK;
           mii.fState := mii.fState or MFS_CHECKED;
         end;

       if params and NZPDefault = NZPDefault then
         mii.fState := mii.fState or MFS_DEFAULT;

       if params and NZPHiLite = NZPHiLite then
         mii.fState := mii.fState or MFS_HILITE;

       if params and NZPNoId <> NZPNoId then
           begin
             mii.fMask := mii.fMask or MIIM_ID;
             mii.wID := ItemId;
             Inc (ItemId);
           end;

     // sub menu items
       if SubItemsCount > 0 then
         mii.hSubMenu := StructToMenu(SubItems,SubItemsCount,ItemId);

       InsertMenuItem(mn,i,true,mii);

       if params and NZPDisabled = NZPDisabled then
         EnableMenuItem(mn,i,MF_BYPOSITION + MF_DISABLED);

       if params and NZPGrayed = NZPGrayed then
         EnableMenuItem(mn,i,MF_BYPOSITION + MF_GRAYED);
     end;
 Result := mn;
end;

Procedure InitMenu(mdh:hmodule;MenuCbWnd:hwnd);
var pt:TPoint;
   zmn, mn:hmenu;
 Procedure zzx(znm:hmenu);
   var tmp:hmenu;
       itscnt, // itsms count
       i,  // temp integer value
       tmpids : integer; // temp value for indifiters
       itspt : pointer;  // itsms pointer (point to ^nzitems struct)
       PutItems :  Procedure (var its:Pointer;var cnt:integer); stdcall;
   begin
     tmpids := FirstItemOffset;
       for i := 0 to pred(ZPlgzzCnt) do
         begin
           @PutItems := GetProcAddress(zPlgzz[i].Handle,"PutItems");
             if Assigned (PutItems) then
               begin
                 PutItems(itspt,itscnt);
                 zPlgzz[i] .MenuItemsIds.x := tmpids;
                 tmp:=StructToMenu(itspt,itscnt,tmpids);
                 if IsMenu(tmp) then
                   InsertMenu(mn,0,MF_BYPOSITION+MF_POPUP+MF_STRING,
                     tmp,zplgzz[i].ShortName);
                 zPlgzz[i] .MenuItemsIds.y := pred(tmpids);
               end;
             end;
        end;
begin
// init menu
   zmn:=loadmenu(mdh,"BASICMENU");
   mn:=GetSubMenu(zmn,0);
// add plug items
   zzx(mn);
// check autorun item
   if QueryAutorun then CheckMenuItem(mn,8,MF_BYCOMMAND+MF_CHECKED);
// zulll
   SetForegroundWindow(MenuCbWnd);// :-)
   GetCursorPos(pt);
   TrackPopupMenu(mn,0,pt.x,pt.y,0,MenuCbWnd,nil);
   SetForegroundWindow(MenuCbWnd);// ;-)
   PostMessage(MenuCbWnd,WM_USER,0,0);
// destroy menu
   DestroyMenu(zmn);
end;

---

← →
Юрий Зотов ©   (2004-05-23 06:19) [15]

> ormada ©   (22.05.04 21:49) [4]

> Ну я имел ввиду без формы :) она ведь лишний 300 кило
> потянет причём толку от неё в этой программе никакого...

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

Можно сделать такое окно и без формы, на чистом API - но окно все равно должно быть. Как это сделать - см. ниже.

Еще момент: если Вы используете Application, TPopupMenu и TMenuItem - как же можно говорить о том, что Вы не используете VCL? Вот эти самые Application, TPopupMenu и TMenuItem - они откуда взялись, не из VCL разве?

Напоследок привожу пример, как сделать Tray-программу с popup-меню на чистом API (весь EXE весит примерно 15 килобайт). Вообще-то, такой пример уже приводился выше, но, поскольку разобраться в нем не слишком-то просто, привожу гораздо более простой (можно сказать, этот код практически минимальный).

program TrayWithoutVCL;

uses
 Windows,
 Messages,
 ShellAPI;

const
 AppName = "WinApiTrayApp";
 WM_TRAYMSG = WM_USER + 100;

var
 WndClass: TWndClassEx;
 WndHandle: HWND = 0;
 Msg: TMsg;
 IconData: TNotifyIconData;
 IconMenu: HMENU = 0;
 SecondIcon: HICON;

function WndFunc(Wnd, Msg: DWORD; wParam, lParam: integer): integer; stdcall;
var
 P: TPoint;
begin
 case Msg of
   WM_DESTROY, WM_QUERYENDSESSION:
     begin
       Result := Integer(Msg = WM_QUERYENDSESSION);
       PostQuitMessage(0)
     end;
   WM_TRAYMSG:
     begin
       Result := 0;
       if (lParam = WM_RBUTTONDOWN) and GetCursorPos(P) then
       begin
         SetForegroundWindow(Wnd);
         TrackPopupMenuEx(IconMenu, 0, P.X, P.Y, Wnd, nil);
         PostMessage(Wnd, WM_NULL, 0, 0)
       end
     end;
   WM_COMMAND:
     begin
       Result := 0;
       case wParam and $FFFF of
         0: begin
              if IconData.hIcon = SecondIcon then
                IconData.hIcon := WndClass.hIcon
              else
                IconData.hIcon := SecondIcon;
              Shell_NotifyIcon(NIM_MODIFY, @IconData)
            end;
         1: PostMessage(Wnd, WM_CLOSE, 0, 0)
       end
     end;
   else
     Result := DefWindowProc(Wnd, Msg, wParam, lParam)
 end
end;

begin { main }
 with WndClass do
 begin
   cbSize := SizeOf(WndClass);
   Style := CS_HREDRAW or CS_VREDRAW ;
   lpfnWndProc := @WndFunc;
   hIcon := LoadIcon(0, IDI_EXCLAMATION);
   hCursor := LoadCursor(0, IDC_ARROW);
   hbrBackground := hBrush(COLOR_WINDOW);
   lpszMenuName := nil;
   lpszClassName := AppName;
   hIconSm := hIcon
 end;
 WndClass.hInstance := hInstance;
 if RegisterClassEx(WndClass) = 0 then
   Exit;
 WndHandle := CreateWindowEx(WS_EX_TOOLWINDOW, AppName, AppName, WS_OVERLAPPEDWINDOW,
   0, 0, 0, 0, 0, 0, hInstance, nil);
 if WndHandle = 0 then
   Exit;
 with IconData do
 begin
   cbSize := SizeOf(IconData);
   Wnd:= WndHandle;
   uID := 100;
   uFlags := NIF_MESSAGE or NIF_ICON or NIF_TIP;
   uCallbackMessage := WM_TRAYMSG;
   hIcon:= WndClass.hIcon;
   szTip := AppName
 end;
 if Shell_NotifyIcon(NIM_ADD, @IconData) then
 try
   IconMenu := CreatePopupMenu;
   if IconMenu <> 0 then
   try
     if AppendMenu(IconMenu, MF_STRING, 0, "&#209;&#236;&#229;&#237;&#232;&#242;&#252; &#232;&#234;&#238;&#237;&#234;&#243;") and
        AppendMenu(IconMenu, MF_STRING, 1, "&#194;&#251;&#245;&#238;&#228;") then
     begin
       SecondIcon := LoadIcon(0, IDI_QUESTION);
       while GetMessage(Msg, 0, 0, 0) do
       begin
         TranslateMessage(Msg);
         DispatchMessage(Msg)
       end
     end
   finally
     DestroyMenu(IconMenu)
   end;
 finally
   Shell_NotifyIcon(NIM_DELETE, @IconData)
 end
end.


---

← →
Юрий Зотов ©   (2004-05-23 06:27) [16]

При переносе из Delphi съехал русский шрифт. Должно быть так:

if AppendMenu(IconMenu, MF_STRING, 0, "Сменить иконку") and
  AppendMenu(IconMenu, MF_STRING, 1, "Выход") then


---

← →
ormada ©   (2004-05-23 08:45) [17]

БАААААЛЬШОЕ СПАСИБО! Сам бы я такое не сделал. :)

---

← →
ORMADA ©   (2004-05-24 11:41) [18]

Удалено модератором
Примечание: Это разве не новый вопрос?

---

← →
ORMADA ©   (2004-05-24 12:33) [19]

Удалено модератором

---

← →
ORMADA ©   (2004-05-24 12:48) [20]

2 Юрий Зотов ПРИМЕР-СУПЕР!
В нём есть фсё что мне надо только подскажите плиз ещё одну вещь как сделать подменю
т.е
главное меню
пункт1->пункт1
пункт2  пункт2
какеие параметры нада задать  AppendMenu
чё -то связанное с mf_popup ?

---

Страницы: 1 вся ветка

Текущий архив: 2004.07.04;
Скачать: CL | DM;

Наверх

Память: 0.59 MB
Время: 0.034 c