Форум: "WinAPI";
Текущий архив: 2004.07.04;
Скачать: [xml.tar.bz2];
ВнизПрограмма без 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, "Ñìåíèòü èêîíêó") and
AppendMenu(IconMenu, MF_STRING, 1, "Âûõîä") 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 вся ветка
Форум: "WinAPI";
Текущий архив: 2004.07.04;
Скачать: [xml.tar.bz2];
Память: 0.58 MB
Время: 0.033 c