| Форумы
ЧАТ |
Орешник |
|
| Форумы -» | Основная («Начинающим»)/ Базы / WinAPI / Компоненты / Сети / Media / Игры / Corba и COM / KOL / FreePascal / .Net / Прочее / RSDN.ORG |
|
| ||
|
|
Новости |
Поиск |
FAQ |
Статьи |
Книги |
Новости VCL
| | Форумы ЧАТ |
Орешник |
|
| |||
| |||
| |||
« предыдущая ветвь | форум | следующая ветвь »
Программа без VCL [D7]
ormada © (2004-05-22 21:29:00)Доб день/вечер! Вот возникла такая проблема делаю прогру без 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 ?
ORMADA (2004-05-24 12:48:00) [1]2 Юрий Зотов ПРИМЕР-СУПЕР!
В нём есть фсё что мне надо только подскажите плиз ещё одну вещь как сделать подменю
т.е
главное меню
пункт1->пункт1
пункт2 пункт2
какеие параметры нада задать AppendMenu
чё -то связанное с mf_popup ?
ORMADA (2004-05-24 12:33:00) [2]Удалено модератором
ORMADA (2004-05-24 11:41:00) [3]Удалено модератором
Примечание: Это разве не новый вопрос?
ormada (2004-05-23 08:45:00) [4]БАААААЛЬШОЕ СПАСИБО! Сам бы я такое не сделал. :)
Юрий Зотов (2004-05-23 06:27:00) [5]При переносе из Delphi съехал русский шрифт. Должно быть так:
if AppendMenu(IconMenu, MF_STRING, 0, ' Сменить иконку') and
AppendMenu(IconMenu, MF_STRING, 1, ' Выход') then
Юрий Зотов (2004-05-23 06:19:00) [6]> 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.
Mim1 (2004-05-22 22:30:00) [7]и напоследок работа с меню в 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;
Mim1 (2004-05-22 22:28:00) [8]Продолжение
//------------------------------------------------------------------------------
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:28:00) [9]продолжение
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:27:00) [10]модуль для сбора инфы о загрузке проца. НЕ МОЙ, немножко мной измененный
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:22:00) [11]Ресурс с картинками для иконки
компилить при помощи 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:21:00) [12]продолжение
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:20:00) [13]Программа на апи ~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);
ormada (2004-05-22 22:02:00) [14]2 Mim1 на апи делал ? пример можеш кинуть а то я в апи практически 0 :)
Mim1 (2004-05-22 21:54:00) [15]300 кило вы все равно не скините, если надо чтоб программа была мелкая то в uses должны присутствовать только windows, messages, shlapi и подобные модули, sysutils и classes добавят в программу по несколько десяткой килобайт. forms потянет за собой три сотни килл (он связан с многоими другими модулями). А модуль menus связан с forms в разделе реализации.
на api меню создавать методом createmenu
Mim1 (2004-05-22 21:49:00) [16]строку
Application.OnException := TNotifyEvent(amethod);
надо заменить на
NewItem.OnClick := TNotifyEvent(amethod);
ormada (2004-05-22 21:49:00) [17]2 Sergey Masloff
Ну я имел ввиду без формы :) она ведь лишний 300 кило потянет причём толку от неё в этой программе никакого...
Дык а как тогда сделать можно чё-то не догоняю....
Mim1 (2004-05-22 21:48:00) [18]Ругается от по тому что обработкис обытия должен быть методом класса
звиняюсь за ошибки, без ошибок и более подробн написано в [1]
Mim1 (2004-05-22 21:46:00) [19]Ругается от по тому что обработкис обытия должен быть методом класса
обойти можно вот так
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ная
Sergey Masloff (2004-05-22 21:41:00) [20]>TPopupMenu.Create
это ты называешь "без VCL"?!!!!
про ошибку
>'method pointer and regular procedure'
Указатель на метод отличается от обычной процедуры тем что в нем присутствует неявный дополнительный параметр - ссылка на экземпляр класса метод которого вызывается.
поэтому твоя процедура
Procedure PopupItemClick(Sender: TObject);
не подходит в качестве указателя на метод. О чем тебе и сообщает компилятор.
| |
