GCW Games & More & Wacky Windows Companion/gcw.iso/win/util/mygroups/mygroups.pas

Pascal/Delphi Source File | 1994-06-29 | 37.8 KB | 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.