home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
GCW Games & More & Wacky Windows Companion
/
gcw.iso
/
win
/
util
/
mygroups
/
mygroups.pas
< prev
next >
Wrap
Pascal/Delphi Source File
|
1994-06-29
|
39KB
|
1,104 lines
{ MyGroups - Enable different icons for Program Manager groups
(c) 1994 by Charles C. Edwards
First Published in PC Magazine September 27, 1994 US Edition
This program compiles as MYGROUPS.DLL but must be renamed to
MYGROUPS.EXE prior to being run.}
{$S-,D-,L-,G-,W+,B-}
Library MyGroups;
{$R MyGroups.RES}
{$D Copyright (c) 1994 by Charles C. Edwards}
Uses WinTypes, WinProcs, WinDos, Strings, ShellAPI, CommDlg,
DDEML, DDE, CStr, GrpFile, {$IFDEF VER70} Objects; {$ELSE} WObjects; {$ENDIF}
Const Ini = 'MYGROUPS.INI';
Icon_Section = 'Icons';
Menu_Section = 'Menu';
Warnings = 'Warnings';
WarnGrp = 'WarnGroup';
WarnIcon = 'WarnIcon';
Type PIconRec = ^TIconRec;
TIconRec = Record
FileName:Array [0..255] of Char;
WindowText:Array [0..255] of Char;
Index:Integer;
End;
Const cm_ChangeIcon = $70; {Change icon menu item}
cm_UnloadProg = $80; {Unload MyGroups}
Const id_File = 100; {Change icon dialog box controls}
id_Icon = 101;
id_IconBar = 102;
id_Browse = 112;
id_Default = 113;
id_Programs = 114;
Const DidSubClass:Boolean = False;
Var pmIcon:hIcon;
oldGroupProc,oldPMProc:TFarProc;
ProgMan,Myself:Array [0..256] of Char;
MDIClient:hWnd;
WinVer:Word;
MyModule:THandle;
IniGroups:PChar;
IniSize:Integer;
Collection:PStrCollection;
pmDDE:PDDE;
Warn_Grp,Warn_Icon:Boolean;
CopyRight:hWnd;
{The following is a collection of PIconRec items}
Type TIconCollection = Object(TCollection)
Procedure FreeItem(Item:Pointer); Virtual;
End;
PIconCollection = ^TIconCollection;
Procedure TIconCollection.FreeItem(Item:Pointer);
{Free the PIconRec item in the collection
Input: Item - a pointer to a TIconRec}
Begin
Dispose(PIconRec(Item));
End;
Function GroupProc(Window:hWnd; Msg,wParam:Word; lParam:LongInt):Longint;
Export; Forward;
Function PMProc(Window:hWnd; Msg,wParam:Word; lParam:LongInt):LongInt;
Export; Forward;
Function GetIconData(Window:hWnd; Var IconRec:TIconRec):Boolean;
{Fills a TIconRec structure with data from MYGROUPS.INI for a group window.
Returns TRUE if data found in MYGROUPS.INI
Input: Window - The group window for which to return the data
Output: IconRec - Structure filled with the icon data}
Var S:String;
I:Integer;
P:PChar;
Begin
GetWindowText(Window,IconRec.WindowText,Sizeof(IconRec.WindowText));
If GetPrivateProfileString(Icon_Section,IconRec.WindowText,'',
IconRec.FileName,Sizeof(IconRec.FileName),Ini) > 0 then
Begin
P:=StrPos(IconRec.FileName,',');
S:=StrPas(P+1);
P^:=#0;
Val(S,Iconrec.Index,I);
GetIconData:=True;
End
else
Begin
StrCopy(IconRec.FileName,ProgMan);
IconRec.Index:=7;
GetIconData:=False;
End;
End;
Procedure PutIconData(Var IconRec:TIconRec);
{Writes data in a TIconRec structure to the MYGROUPS.INI file.
Input: IconRec - data to write to MYGROUPS.INI}
Const Buf:Array [0..255] of Char = '';
Var S:Array [0..10] of Char;
Begin
Str(IconRec.Index,S);
StrCopy(Buf,IconRec.FileName);
StrCat(StrCat(Buf,','),S);
WritePrivateProfileString(Icon_Section,IconRec.WindowText,Buf,Ini);
End;
Function SubclassGroups(Window:hWnd; lParam:LongInt):Boolean; Export;
{Subclasses the individual program groups.
Also superclasses the PMGroup class.
Always returns TRUE
Input: Window - The group window to be subclassed
lParam - Not used}
Const FirstMatch:Boolean = True;
Var szClassName:Array [0..255] of Char;
Msg:Array [0..255] of Char absolute szClassName;
Index:Integer;
IconRec:TIconRec;
Icon:hIcon;
I:Integer;
Begin
GetClassName(Window,szClassName,Sizeof(szClassName));
If StrIComp(szClassName,'MDIClient') = 0 then
MDIClient:=Window;
If StrIComp(szClassName,'PMGroup') = 0 then
Begin
If FirstMatch then
Begin
oldGroupProc:=TFarProc(GetClassLong(Window,gcl_WndProc));
SetClassLong(Window,gcl_WndProc,LongInt(@GroupProc));
pmIcon:=GetClassWord(Window,gcw_hIcon);
SetClassWord(Window,gcw_hIcon,0);
FirstMatch:=False;
DidSubClass:=True;
End;
SetWindowLong(Window,gwl_WndProc,LongInt(@GroupProc));
Icon:=0;
If GetIconData(Window,IconRec) then
Begin
I:=Collection^.Count-1;
While (I >= 0) and
(StrComp(Collection^.At(I),IconRec.WindowText) <> 0) do
Dec(I);
If I >= 0 then
Collection^.AtFree(I);
Icon:=ExtractIcon(hInstance,IconRec.FileName,IconRec.Index);
If Icon < 2 then
Begin
StrCopy(Msg,'Warning: Cannot find ');
StrCat(StrCat(Msg,IconRec.FileName),^M);
StrCat(Msg,'Group ');
StrCat(StrCat(Msg,'"'),IconRec.WindowText);
StrCat(Msg,'" will use the default icon.');
If Warn_Icon then
MessageBox(0,Msg,'MyGroups Error',mb_IconExclamation or mb_OK);
Icon:=pmIcon;
End
else
Icon:=GlobalReAlloc(Icon,GlobalSize(Icon),gmem_Modify or gmem_DDEShare);
End
else
Icon:=pmIcon;
SetProp(Window,Icon_Section,Icon);
SetProp(Window,Menu_Section,0);
If IsIconic(Window) then
Begin
InvalidateRgn(Window,0,True);
UpdateWindow(Window);
End;
End;
SubclassGroups:=True;
End;
Function UnsubclassGroups(Window:hWnd; lParam:LongInt):Boolean; Export;
{Removes the subclassing and superclassing performed in SubclassGroups
Always returns TRUE
Input: Window - The group window for which to remove subclassing
lParam - Not used}
Const FirstMatch:Boolean = True;
Var szClassName:Array [0..255] of Char;
Index:Integer;
Menu:hMenu;
IconRec:TIconRec;
Icon:hIcon;
Begin
GetClassName(Window,szClassName,Sizeof(szClassName));
If StrIComp(szClassName,'PMGroup') = 0 then
Begin
If FirstMatch then
Begin
SetClassLong(Window,gcl_WndProc,LongInt(oldGroupProc));
SetClassWord(Window,gcw_hIcon,pmIcon);
FirstMatch:=False;
End;
SetWindowLong(Window,gwl_WndProc,LongInt(oldGroupProc));
If RemoveProp(Window,Menu_Section) = 1 then
Begin
Menu:=GetSystemMenu(Window,False);
DeleteMenu(Menu,9,mf_ByPosition);
DeleteMenu(Menu,cm_ChangeIcon,mf_ByCommand);
DeleteMenu(Menu,cm_UnloadProg,mf_ByCommand);
End;
Icon:=RemoveProp(Window,Icon_Section);
If (Icon <> 0) and (Icon <> pmIcon) then DestroyIcon(Icon);
End;
UnsubclassGroups:=True;
End;
Function EnumProc(Window:hWnd; lParam:LongInt):Boolean; Export;
{Called during initialization and shut down to subclass and
and unsubclass the program groups. This function enumerates
all of the child windows for the Program Manager main window.
Returns the result of the child window enumeration if there are
any child windows, otherwise it returns TRUE.
Input: Window - The Program Manager top level window
lParam - 0 = Subclassing the groups
1 = Unsubclassing the groups}
Var szClassName:Array [0..255] of Char;
Begin
GetClassName(Window,szClassName,Sizeof(szClassName));
If (StrIComp(szClassName,'ProgMan') = 0) then
Begin
If lParam = 0 then
Begin
OldPMProc:=TFarProc(GetWindowLong(Window,gwl_WndProc));
SetWindowLong(Window,gwl_WndProc,LongInt(@PMProc));
End
else
SetWindowLong(Window,gwl_WndProc,LongInt(OldPMProc));
If lParam = 0 then
EnumProc:=EnumChildWindows(Window,@SubclassGroups,0)
else
EnumProc:=EnumChildWindows(Window,@UnsubclassGroups,0);
EnumProc:=False;
End
else
EnumProc:=True;
End;
Function CopyRight_Dlg(Dialog:hWnd; Msg,wParam:Word; lParam:LongInt):LongInt;
Export;
{Dialog function for the copyright dialog box. Nothing special here,
just a plain vanilla dialog function.
Returns 1 if the message was processed.
Input: The standard dialog function parameters}
Var MR,WR:TRect;
NewX,NewY:Integer;
Begin
CopyRight_Dlg:=1;
Case Msg of
wm_InitDialog:
Begin {Center dialog box in window}
GetWindowRect(Dialog,MR);
GetWindowRect(GetDesktopWindow,WR);
OffsetRect(MR,-MR.left,-MR.top);
NewX:=WR.left+((WR.right-WR.left+1)-(MR.right+1)) div 2;
NewY:=WR.top+((WR.bottom-WR.top+1)-(MR.Bottom+1)) div 2;
MoveWindow(Dialog,NewX,NewY,MR.right+1,MR.bottom+1,False);
If lParam = 1 then
ShowWindow(GetDlgItem(Dialog,IDOK),sw_ShowNormal);
End;
wm_Command:
If wParam = IDOK then
EndDialog(Dialog,0)
else
CopyRight_Dlg:=0;
else
CopyRight_Dlg:=0;
End;
End;
Function Icon_Dialog(Window:hWnd; Msg,wParam:Word; lParam:LongInt):LongInt;
Export;
{Dialog function for the "Change Icon" dialog box. Handles the loading
and drawing of icons in the listbox.
Returns 1 if the message was processed.
Input: The standard dialog function parameters}
Const IconRec:TIconRec = (FileName:''; WindowText: ''; Index:0);
Parent:hWnd = 0;
Titl:Array [0..255] of Char = '';
IconCol:PIconCollection = Nil;
OldFile:Array [0..255] of Char = '';
Var I,J:Integer;
Icon:hIcon;
Rect:TRect;
Brush:hBrush;
Procedure Adjust_Win30;
{This procedure adjusts the size of the listbox to deal with
an idiosyncracy of Windows 3.0}
Var I,VisibleIcons:Word;
Begin
GetWindowRect(GetDlgItem(Window,id_IconBar),Rect);
I:=SendDlgItemMessage(Window,id_Iconbar,lb_GetCount,0,0);
VisibleIcons:=(Rect.Right-Rect.Left) div
(GetSystemMetrics(sm_cxIcon)+4);
SetWindowPos(GetDlgItem(Window,id_IconBar),0,0,0,
Rect.Right-Rect.Left,
GetSystemMetrics(sm_cyIcon)+4+
(GetSystemMetrics(sm_cyHScroll)*Byte(I > VisibleIcons)),
swp_noZOrder or swp_NoMove);
End;
Procedure LoadIcons(FName:PChar);
{Loads the listbox with all of the icons from the specified file.
Input: FName - Name of the file containing the icons}
Const Dest:Array [0..255] of Char = '';
Var I,VisibleIcons:Word;
Icon:hIcon;
Cursor:hCursor;
Begin
If IconCol <> Nil then
Begin
Dispose(IconCol,Done);
IconCol:=Nil;
SetWindowText(GetDlgItem(Window,id_Programs),'&Programs');
End;
Cursor:=SetCursor(LoadCursor(0,idc_Wait));
FileExpand(Dest,FName);
SendDlgItemMessage(Window,id_IconBar,lb_ResetContent,0,0);
Icon:=ExtractIcon(hInstance,Dest,0);
If Icon < 2 then
Begin
MessageBox(Window,'There are no icons in this file.'^M+
'You may choose from the icons in the Program Manager.',
FName,mb_IconExclamation or mb_OK);
FileExpand(Dest,ProgMan);
Icon:=ExtractIcon(hInstance,Dest,0);
End;
StrCopy(OldFile,Dest);
I:=0;
Repeat
SendDlgItemMessage(Window,id_IconBar,lb_AddString,0,Word(Icon));
Inc(I);
Icon:=ExtractIcon(hInstance,Dest,I);
Until Icon < 2;
If (Lo(WinVer) = 3) and (Hi(WinVer) < 10) then
Adjust_Win30;
SendDlgItemMessage(Window,id_IconBar,lb_SetCurSel,0,0);
SetWindowText(GetDlgItem(Window,id_File),Dest);
SetCursor(Cursor);
End;
Function Process_OK(Check_Done:Boolean):Boolean;
{This function handles the pressing of the OK button. There are 2
cases this function has to consider.
1. If the file name in the edit control was changed, then it calls
LoadIcons to put the new icons in the list box.
2. Otherwise, replace the group icon with the currently selected icon.
Returns TRUE if the group icon was changed.
Input: Check_Done - TRUE = If edit control not changed, update the
group icon.
FLASE = If edit control not changed, do not
update the group icon.}
Const FName:Array [0..255] of Char = '';
Var I:Integer;
Icon:hIcon;
PIR:PIconRec;
Begin
Process_OK:=False;
If SendDlgItemMessage(Window,id_File,em_GetModify,0,0) <> 0 then
Begin
GetWindowText(GetDlgItem(Window,id_File),FName,Sizeof(FName));
SendDlgItemMessage(Window,id_File,em_SetModify,0,0);
LoadIcons(FName);
Exit;
End;
If not Check_Done then Exit;
GetWindowText(GetDlgItem(Window,id_File),FName,Sizeof(FName));
I:=SendDlgItemMessage(Window,id_IconBar,lb_GetCurSel,0,0);
If I = lb_Err then
Begin
MessageBox(Window,'No icon is currently selected',FName,
mb_IconExclamation or mb_OK);
Exit;
End;
If IconCol <> Nil then
Begin
PIR:=IconCol^.At(I);
StrCopy(FName,PIR^.FileName);
I:=PIR^.Index;
End;
If GetDriveType(Ord(UpCase(FName[0]))-Ord('A')) <> DRIVE_FIXED then
If MessageBox(Window,'This drive may not be available in future Windows sessions.'+
^M'Do you want to continue?',
FName,mb_IconQuestion or mb_YesNo) <> id_Yes then
Exit;
Icon:=RemoveProp(Parent,Icon_Section);
If (Icon <> 0) and (Icon <> pmIcon) then DestroyIcon(Icon);
StrCopy(IconRec.FileName,FName);
IconRec.Index:=I;
Icon:=ExtractIcon(hInstance,FName,I);
SetProp(Parent,Icon_Section,Icon);
InvalidateRgn(Parent,0,True);
UpdateWindow(Parent);
PutIconData(IconRec);
Process_OK:=True;
End;
Procedure Process_Browse;
{This procedure handles the pressing of the "Browse" button.
It invokes the Common Dialog library GetOpenFileName function to
get the name of a new icon file.}
Const Filter:PChar = 'Icon Files'#0'*.ico;*.dll;*.exe'#0+
'Programs (*.exe)'#0'*.exe'#0+
'Libraries (*.dll)'#0'*.dll'#0+
'Icons (*.ico)'#0'*.ico'#0+
'All files (*.*)'#0'*.*'#0;
Browse:PChar = 'Browse';
Buf:Array [0..127] of Char = '';
Var ofn:TOpenFileName;
Begin
With ofn do
Begin
lStructSize:=Sizeof(TOpenFileName);
hWndOwner:=Window;
lpstrFilter:=Filter;
lpstrCustomFilter:=Nil;
nFilterIndex:=1;
lpstrFile:=Buf;
lpstrFile[0]:=#0;
nMaxFile:=Sizeof(Buf);
lpstrFileTitle:=Nil;
lpstrInitialDir:=Nil;
lpstrTitle:=Browse;
Flags:=ofn_FileMustExist or ofn_PathMustExist or
ofn_HideReadOnly;
lpstrDefExt:=Nil;
End;
If GetOpenFileName(ofn) then
Begin
SetWindowText(GetDlgItem(Window,id_File),Buf);
SendDlgItemMessage(Window,id_File,em_SetModify,1,0);
Process_OK(False);
End;
End;
Procedure Process_Default;
{This procedure handles the pressing of the "Default" button.
It restores the group icon to the Program Manager default and
removes any entry from the MYGROUPS.INI file}
Var Icon:hIcon;
Begin
Icon:=RemoveProp(Parent,Icon_Section);
If Icon <> pmIcon then
Begin
DestroyIcon(Icon);
WritePrivateProfileString(Icon_Section,IconRec.WindowText,Nil,Ini);
Icon:=pmIcon;
End;
SetProp(Parent,Icon_Section,Icon);
InvalidateRgn(Parent,0,True);
UpdateWindow(Parent);
End;
Procedure Process_Program_Item(S:PChar);
{This procedure adds a program item, retrived via DDE from ProgMan
to the IconCol collection. First it looks for the icon specified
in the parameter line. If none is found, it looks at the
executable.
Input: S - A pointer to a string in the following format
"Group name","Command line",path,Icon file,X coordinate,
Y coordinate,Icon index,Hot Key,Minimized flag}
Const Msg:Array [0..255] of Char = '';
Var P1,P2:PChar;
I:Integer;
PIcon,OIcon:PIconRec;
Icon:hIcon;
Prog,Path:PChar;
Begin
New(PIcon);
P1:=S;
P1:=StrScan(P1,',')+2; {Skip comma and first quote}
P2:=P1+1;
While (P2^ <> ' ') and (P2^ <> '"') do {Skip until space or quote}
Inc(P2);
GetMem(Prog,StrDelta(P1,P2)+1);
StrLCopy(Prog,P1,StrDelta(P1,P2)); {Copy program name}
P2:=StrScan(P1,'"'); {Find next quote}
P1:=StrScan(P2,',')+1; {Point to path}
P2:=StrScan(P1,',');
GetMem(Path,StrDelta(P1,P2)+1);
StrLCopy(Path,P1,StrDelta(P1,P2)); {Copy program path}
P1:=P2+1; {Point to icon file}
P2:=StrScan(P1,',');
StrLCopy(Msg,P1,StrDelta(P1,P2));
If StrScan(Msg,'.') = Nil then
StrCat(Msg,'.EXE');
FileExpand(PIcon^.FileName,Msg);
StrCopy(PIcon^.WindowText,IconRec.WindowText);
P1:=StrScan(P2+1,',')+1; {Skip 2 more commas}
P1:=StrScan(P1,',')+1;
P2:=StrScan(P1,',');
PIcon^.Index:=StrVal(P1,StrDelta(P1,P2));
Icon:=ExtractIcon(hInstance,PIcon^.FileName,PIcon^.Index);
If Icon < 2 then
Begin {No icon...check executable}
If FindExecutable(Prog,Path,Msg) > 32 then
Begin
Icon:=ExtractIcon(hInstance,Msg,0);
If Icon > 1 then
Begin
FileExpand(PIcon^.FileName,Msg);
PIcon^.Index:=0;
End;
End;
End;
FreeMem(Prog,StrLen(Prog)+1);
FreeMem(Path,StrLen(Path)+1);
If Icon > 1 then
Begin
I:=IconCol^.Count-1;
While I >= 0 do {We can't use an iterator method since}
Begin {...it causes the stack to get too big}
OIcon:=IconCol^.At(I);
If (StrIComp(OIcon^.FileName,PIcon^.FileName) = 0) and
(OIcon^.Index = PIcon^.Index) then
I:=-1;
Dec(I);
End;
If I > -2 then
Begin
IconCol^.Insert(PIcon);
SendDlgItemMessage(Window,id_IconBar,lb_AddString,0,Word(Icon));
End
else
Begin
DestroyIcon(Icon);
Dispose(PIcon);
End;
End
else
Begin
StrCopy(Msg,'Cannot get icon from file'^M'"');
StrCat(Msg,PIcon^.FileName);
StrCat(Msg,'"');
MessageBox(0,Msg,'MyGroups Error',mb_IconExclamation or mb_OK);
Dispose(PIcon);
End;
End;
Function Process_Programs:Boolean;
{This procedure handles the pressing of the "Programs" button.
It establishes a DDE conversation with the Program Manager and
gets the icons for the current group.
Returns TRUE if successful.}
Var P,PGroup,PItem,PFile:PChar;
Len:LongInt;
Cursor:hCursor;
Begin
Cursor:=SetCursor(LoadCursor(0,idc_Wait));
SendDlgItemMessage(Window,id_IconBar,lb_ResetContent,0,0);
Process_Programs:=False;
pmDDE:=New(PDDE,Init(Nil,cbf_Skip_AllNotifications or appcmd_ClientOnly));
If pmDDE <> Nil then
Begin
If pmDDE^.Connect('PROGMAN','PROGMAN') then
Begin
If (Lo(WinVer) = 3) and (Hi(WinVer) < 10) then
Begin
GetMem(PFile,256);
GetGroupName(IconRec.WindowText,PFile,256);
If PFile^ = #0 then
P:=Nil
else
P:=GetGroupDDE(PFile);
FreeMem(PFile,256);
End
else
P:=pmDDE^.Request(IconRec.WindowText,cf_Text,Len);
If P <> Nil then
Begin
New(IconCol,Init(40,10));
PGroup:=StrTok(P,^M);
PItem:=StrTok(Nil,^M)+1;
While StrLen(PItem) > 0 do
Begin
Process_Program_ITem(PItem);
PItem:=StrTok(Nil,^M)+1;
End;
If (Lo(WinVer) = 3) and (Hi(WinVer) < 10) then
StrDispose(P)
else
pmDDE^.FreeRequest;
If IconCol^.Count = 0 then
Begin
MessageBox(0,'No programs in group','MyGroups Error',
mb_IconExclamation or mb_OK);
Dispose(IconCol,Done);
IconCol:=Nil;
End
else
Begin
If (Lo(WinVer) = 3) and (Hi(WinVer) < 10) then
Adjust_Win30;
Process_Programs:=True;
SendDlgItemMessage(Window,id_IconBar,lb_SetCurSel,0,0);
SetWindowText(GetDlgItem(Window,id_File),'"Program Icons"');
SetWindowText(GetDlgItem(Window,id_Programs),'&Prior File');
SendDlgItemMessage(Window,id_File,em_SetModify,0,0);
End;
End
else
MessageBox(0,'Cannot get programs','MyGroups Error',
mb_IconExclamation or mb_OK);
pmDDE^.Disconnect;
End
else
MessageBox(0,'Cannot establish DDE with Program Manager',
'MyGroups Error',mb_IconExclamation or mb_OK);
Dispose(pmDDE,Done);
End
else
MessageBox(0,'Cannot initialize DDE interface','MyGroups Error',
mb_IconExclamation or mb_OK);
SetCursor(Cursor);
End;
Begin
Icon_Dialog:=1;
Case Msg of
wm_InitDialog:
{Initialize the listbox to the proper size and load the icons
from the current file.}
Begin
IconCol:=Nil;
GetWindowRect(GetDlgItem(Window,id_IconBar),Rect);
SetWindowPos(GetDlgItem(Window,id_IconBar),0,0,0,
((Rect.Right-Rect.Left) div (GetSystemMetrics(sm_cxIcon)+10)) *
(GetSystemMetrics(sm_cxIcon)+10),
GetSystemMetrics(sm_cyIcon)+4+GetSystemMetrics(sm_cyHScroll),
swp_noZOrder or swp_NoMove);
Parent:=lParam;
GetIconData(Parent,IconRec);
LoadIcons(IconRec.FileName);
SendDlgItemMessage(Window,id_IconBar,lb_SetCurSel,
IconRec.Index,0);
SendDlgItemMessage(Window,id_IconBar,lb_SetColumnWidth,
(GetSystemMetrics(sm_cxIcon)+10),0);
SetWindowText(Window,IconRec.WindowText);
End;
wm_Destroy:
{Finished with the dialog. Dispose of the collection if necessary}
If IconCol <> Nil then
Dispose(IconCol,Done);
wm_DrawItem:
{Draw the "Current icon" and the icons in the icon box}
With PDrawItemStruct(lParam)^ do
If CtlID = id_IconBar then
If (ItemAction = oda_DrawEntire) or
(ItemAction = oda_Select) then
Begin
J:=SetMapMode(hDC,mm_Text);
If (ItemState and ods_Selected) = ods_Selected then
Brush:=SelectObject(hDC,CreateSolidBrush(
GetSysColor(COLOR_HIGHLIGHT)))
else
Brush:=SelectObject(hDC,CreateSolidBrush(
GetSysColor(COLOR_WINDOW)));
PatBlt(hDC,rcItem.Left,rcItem.Top,
rcItem.Right-rcItem.Left,
rcItem.Bottom-rcItem.Top,
PatCopy);
DrawIcon(hDC,rcItem.Left+5,rcItem.Top+2,
LoWord(itemData));
DeleteObject(SelectObject(hDC,Brush));
SetMapMode(hDC,J);
End
else
else If CtlID = id_Icon then
Begin
J:=SetMapMode(hDC,mm_Text);
Brush:=SelectObject(hDC,CreateSolidBrush(
GetSysColor(COLOR_WINDOW)));
PatBlt(hDC,rcItem.Left,rcItem.Top,
rcItem.Right-rcItem.Left,
rcItem.Bottom-rcItem.Top,
PatCopy);
DrawIcon(hDC,0,0,GetProp(Parent,Icon_Section));
DeleteObject(SelectObject(hDC,Brush));
SetMapMode(hDC,J);
End;
wm_Command:
Case wParam of
id_OK: {OK button pressed}
If Process_OK(True) then
EndDialog(Window,1);
id_Cancel: {Cancel button pressed}
EndDialog(Window,0);
id_IconBar: {Notification messages for the listbox}
Case HiWord(lParam) of
lbn_DblClk: {An icon was double clicked}
If Process_OK(True) then
EndDialog(Window,1);
lbn_SetFocus: {Focus changed...see if we need to load icons}
Process_OK(False);
else
Icon_Dialog:=0;
End;
id_Browse: {Browse button pressed}
Process_Browse;
id_Default: {Default button pressed}
Begin
Process_Default;
EndDialog(Window,1);
End;
id_Programs: {Programs button pressed}
If (IconCol <> Nil) or not Process_Programs then
Begin
SetWindowText(GetDlgItem(Window,id_File),OldFile);
SendDlgItemMessage(Window,id_File,em_SetModify,1,0);
Process_OK(False);
End;
id_Icon: {"Current icon" pressed}
Begin
If (($8000) and GetKeyState(vk_Shift) and
GetKeyState(vk_Control) and GetKeyState(vk_Menu)) <> 0 then
DialogBoxParam(hInstance,'Copyright',Window,@Copyright_Dlg,1);
End;
else
Icon_Dialog:=0;
End;
wm_MeasureItem: {Set the height of the icons in the listbox}
With PMeasureItemStruct(lParam)^ do
If CtlID = id_IconBar then
itemHeight:=GetSystemMetrics(sm_cyIcon)+4;
wm_DeleteItem:
{An icon in the listbox is being deleted...destroy the icon}
With PDeleteItemStruct(lParam)^ do
If CtlID = id_IconBar then
DestroyIcon(LoWord(itemData));
else
Icon_Dialog:=0;
End;
End;
Function PMProc(Window:hWnd; Msg,wParam:Word; lParam:LongInt):LongInt;
{This is the new window function for the Program Manager main window.
We need to deal with a special case here. If the current group window
is maximized, and the user selects one of our new menu items, the
wm_SysCommand and wm_InitMenu messagees are not posted to the child window.
Instead a wm_Command and wm_InitMenu are posted to the frame window.
This function intercepts those messages and posts the expected messages
to the MDI child.
Always returns the result of the default window function.
Input - Standard window function parameters}
Var MDIActive:LongInt;
Begin
Case Msg of
wm_Command:
Begin
If ((wParam and $FFF0 = cm_ChangeIcon) or (wParam and $FFF0 = cm_UnloadProg)) and
(LoWord(lParam) = 0) then
Begin
MDIActive:=SendMessage(MDIClient,wm_MDIGetActive,0,0);
If HiWord(MDIActive) = 1 then {Maximized}
PostMessage(LoWord(MDIActive),wm_SysCommand,wParam,0);
PMProc:=0;
End;
End;
wm_InitMenu:
Begin
MDIActive:=SendMessage(MDIClient,wm_MDIGetActive,0,0);
If HiWord(MDIActive) = 1 then {Maximized}
SendMessage(LoWord(MDIActive),wm_InitMenu,wParam,lParam);
End;
End;
PMProc:=CallWindowProc(oldPMProc,Window,Msg,wParam,lParam);
End;
Function GroupProc(Window:hWnd; Msg,wParam:Word; lParam:LongInt):Longint;
{This is the new window function for the group windows. It handles all
messages needed to draw the new "custom" group icons.
Returns the result of the default group window function.
Input: The standard window function parameters}
Const Labl:Array [0..255] of Char = '';
IconRec:TIconRec = (FileName:''; WindowText:''; Index:0);
Var DC:hDC;
PS:TPaintStruct;
MapMode:Integer;
Brush:hBrush;
Menu:hMenu;
Temp:Array [0..10] of Char;
Origin:TPoint;
Icon:hIcon;
Rect:TRect;
Begin
Case Msg of
wm_Paint: {If the group is minimized, then draw the new icon}
Begin
If IsIconic(Window) then
Begin
DC:=BeginPaint(Window,PS);
DrawIcon(DC,2,2,GetProp(Window,Icon_Section));
EndPaint(Window,PS);
GroupProc:=1;
End
else
GroupProc:=CallWindowProc(oldGroupProc,Window,Msg,wParam,lParam);
End;
wm_EraseBkGnd:
{Erase the background of the minimized group to match the rest
of the Program Manager workspace}
If IsIconic(Window) then
Begin
GetClipBox(wParam,Rect);
Brush:=CreateSolidBrush(GetSysColor(COLOR_APPWORKSPACE));
UnRealizeObject(Brush);
LongInt(Origin):=0;
ClientToScreen(GetParent(Window),Origin);
SetBrushOrg(wParam,Origin.X,Origin.Y);
Brush:=SelectObject(wParam,Brush);
PatBlt(wParam,Rect.Left,Rect.Top,
Rect.Right-Rect.Left,
Rect.Bottom-Rect.Top,PatCopy);
DeleteObject(SelectObject(wParam,Brush));
GroupProc:=1;
End
else
GroupProc:=CallWindowProc(oldGroupProc,Window,Msg,wParam,lParam);
wm_QueryDragIcon:
{The user is dragging a group icon. Return the handle to the new
icon so that the dragged icon displays properly.}
Begin
GroupProc:=GetProp(Window,Icon_Section);
End;
wm_SysCommand: {User selected a group menu command}
Case (wParam and $FFF0) of
cm_ChangeIcon: {Open "Change Icon" dialog box}
Begin
DialogBoxParam(hInstance,'CHANGE_ICON',Window,@Icon_Dialog,
Window);
GroupProc:=1;
End;
cm_UnloadProg: {Unload MyGroups}
Begin
If MessageBox(Window,'Are you sure you want to unload MyGroups?',
'Unload MyGroups',mb_IconQuestion or mb_YESNO) = id_Yes then
Begin
EnumWindows(@EnumProc,1);
InvalidateRect(0,Nil,True);
While GetModuleUsage(MyModule) > 1 do
FreeLibrary(MyModule);
{We can't call FreeLibrary for the last instance of the
module since the code won't be here for us to return
to! Instead we fix up the stack to return to the code
that called us and JUMP to FreeLibrary.}
Asm
MOV DX,[MyModule]
POP DI {Restore DI and SI}
POP SI
LEA SP,[BP-2] {Remove locals from stack}
POP DS {Restore DS and BP}
POP BP
DEC BP
POP AX {Save return address}
POP BX
ADD SP,$0A {Remove parameters from stack}
PUSH DX {Push module ID}
PUSH BX {Push return address}
PUSH AX
JMP FreeLibrary {Unload MyGroups}
End; {We never return from this}
End;
GroupProc:=1;
End;
else
GroupProc:=CallWindowProc(oldGroupProc,Window,Msg,wParam,lParam);
End;
wm_Create: {User is creating a new program group}
Begin
GroupProc:=CallWindowProc(oldGroupProc,Window,Msg,wParam,lParam);
SetProp(Window,Icon_Section,pmIcon);
SetProp(Window,Menu_Section,0);
End;
wm_InitMenu: {User is selecting the group system menu}
Begin
If GetProp(Window,Menu_Section) = 0 then
Begin
Menu:=GetSystemMenu(Window,False);
AppendMenu(Menu,mf_Separator,0,Nil);
AppendMenu(Menu,mf_String or mf_Enabled,cm_ChangeIcon,
'Change &Icon');
AppendMenu(Menu,mf_String or mf_Enabled,cm_UnloadProg,
'&Unload MyGroups');
SetProp(Window,Menu_Section,1);
End;
GroupProc:=CallWindowProc(oldGroupProc,Window,Msg,wParam,lParam);
End;
wm_Destroy: {User is deleting a program group}
Begin
Icon:=RemoveProp(Window,Icon_Section);
If Icon <> pmIcon then
Begin
DestroyIcon(Icon);
GetWindowText(Window,Labl,Sizeof(Labl));
WritePrivateProfileString(Icon_Section,Labl,Nil,Ini);
End;
GroupProc:=CallWindowProc(oldGroupProc,Window,Msg,wParam,lParam);
End;
wm_SetText: {User is changing the group description}
Begin
Icon:=GetProp(Window,Icon_Section);
If Icon <> pmIcon then
Begin
GetIconData(Window,IconRec);
WritePrivateProfileString(Icon_Section,IconRec.WindowText,
Nil,Ini);
StrCopy(IconRec.WindowText,PStr(lParam));
PutIconData(IconRec);
End;
GroupProc:=CallWindowProc(oldGroupProc,Window,Msg,wParam,lParam);
End;
else
GroupProc:=CallWindowProc(oldGroupProc,Window,Msg,wParam,lParam);
End;
End;
Procedure CheckIni;
{This procedure checks to see if there are any entries in MYGROUPS.INI
which do not have any matching program groups. If so, the user is
prompted to delete the entry.}
Var Msg:Array [0..255] of Char;
Procedure Warn(Item:PChar); Far;
Begin
StrCopy(Msg,'Warning: Group "');
StrCat(Msg,Item);
StrCat(Msg,'" not found.'^M'Delete entry in MYGROUPS.INI?');
If MessageBox(0,Msg,'MyGroups',mb_IconQuestion or mb_YesNo) = id_Yes then
WritePrivateProfileString(Icon_Section,Item,Nil,Ini);
End;
Begin
If Warn_Grp then Collection^.ForEach(@Warn);
Dispose(Collection,Done);
End;
Procedure Timer(Window:hWnd; Msg,idTimer:Word; dwTime:LongInt); Export;
{This timer is a fix for Windows 3.0. Since the RUN= line in WIN.INI
is processed before the groups are created (the order is reversed in
Windows 3.1) we need to periodically "poll" to see if we can now
subclass the groups.
Also, kill the copyright dialog if initialization took less than 2 seconds}
Begin
If idTimer = 1 then
If Window = CopyRight then
Begin {kill copyright}
KillTimer(Window,idTimer);
DestroyWindow(Window);
CopyRight:=0;
Exit;
End
else
else
If not DidSubClass then
Begin
EnumWindows(@EnumProc,0);
If DidSubClass then
Begin
KillTimer(Window,idTimer);
CheckIni;
End;
End;
End;
Var Result:Boolean;
PIni:PChar;
TickCount:LongInt;
PM_Mod:THandle;
{Initialization code.
1. Make sure we are not in Windows 3.0 real mode.
2. Unlock the data segment.
3. Display the copyright notice.
4. Get INI file settings
5. Find the Program Manager.
6. Subclass all the program groups.}
Begin
If (GetWinFlags and wf_PMODE) = 0 then
Begin
MessageBox(0,'This program cannot run in real mode','MyGroups',
mb_IconStop or mb_OK);
ExitCode:=0;
Exit;
End;
GlobalPageUnlock(DSeg);
GlobalRealloc(LOWORD(GlobalHandle(DSeg)),0,GMEM_MODIFY or GMEM_MOVEABLE);
{$IFNDEF VER70}
HeapLimit:=1024; {Enable subheap allocation for TPW 1.5}
{$ENDIF}
WinVer:=GetVersion;
CopyRight:=CreateDialogParam(hInstance,'CopyRight',0,@CopyRight_Dlg,0);
TickCount:=GetTickCount;
Warn_Icon:=Boolean(GetPrivateProfileInt(Warnings,WarnIcon,1,Ini));
Warn_Grp:=Boolean(GetPrivateProfileInt(Warnings,WarnGrp,1,Ini));
Str(Byte(Warn_Icon),Myself);
WritePrivateProfileString(Warnings,WarnIcon,Myself,Ini);
Str(Byte(Warn_Grp),Myself);
WritePrivateProfileString(Warnings,WarnGrp,Myself,Ini);
StrPCopy(Myself,ParamStr(0));
MyModule:=GetModuleHandle(Myself);
PM_Mod:=GetModuleHandle('PROGMAN');
If PM_Mod = 0 then
Begin
DestroyWindow(CopyRight);
MessageBox(0,'Cannot locate Program Manager','MyGroups',
mb_IconStop or mb_OK);
ExitCode:=0;
Exit;
End;
IniSize:=1000;
GetMem(IniGroups,IniSize);
While GetPrivateProfileString(Icon_Section,Nil,'',IniGroups,IniSize,Ini) =
IniSize-1 do
Begin
FreeMem(IniGroups,IniSize);
Inc(IniSize,500);
GetMem(IniGroups,IniSize);
End;
PIni:=IniGroups;
New(Collection,Init(30,10));
While PIni^ <> #0 do
Begin
Collection^.Insert(StrNew(PIni));
Inc(PIni,StrLen(PIni)+1);
End;
FreeMem(IniGroups,IniSize);
GetModuleFileName(PM_Mod,ProgMan,Sizeof(ProgMan));
EnumWindows(@EnumProc,0);
TickCount:=GetTickCount-TickCount;
If TickCount >= 2000 then
DestroyWindow(CopyRight)
else
SetTimer(CopyRight,1,2000-TickCount,@Timer);
If DidSubClass then
CheckIni
else
SetTimer(0,2,500,@Timer); {fix for Windows 3.0}
End.