home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Simtel MSDOS - Coast to Coast
/
simteldosarchivecoasttocoast.iso
/
pcmag
/
vol12n01.zip
/
GROUP.ZIP
/
GROUPMEN.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1992-09-25
|
11KB
|
336 lines
{$D-,L-,R-,S-,W-}
PROGRAM GroupMenu;
USES WinTypes, WinProcs, Strings, ShellApi, WinDos,
StdDlgs, GroupType, GroupFile,
{$IFDEF VER70}
ODialogs, OWindows, Objects;
{$Q-}
{$ELSE}
WObjects;
{$ENDIF}
{$D Copyright (c) 1992 by Neil J. Rubenking}
{$R GROUPMEN.RES}
{$I GROUPMEN.INC}
CONST
AppName : PChar = 'GroupMenu';
TYPE
TMyApplication = OBJECT(TApplication)
PROCEDURE InitMainWindow; virtual;
END;
PNStrCollection = ^TNStrCollection;
TNStrCollection = OBJECT(TStrCollection)
{Just like a TStrCollection, but strings aren't sorted}
FUNCTION Compare(Key1, Key2 : Pointer) : Integer; Virtual;
END;
PGroupMWindow = ^TGroupMWindow;
TGroupMWindow = OBJECT(TWindow)
Commands : PNStrCollection;
CONSTRUCTOR Init(AParent : PWindowsObject; AName : PChar);
PROCEDURE SetUpWindow; Virtual;
DESTRUCTOR Done; Virtual;
FUNCTION GetClassName : PChar; Virtual;
PROCEDURE GetWindowClass(var AWndClass: TWndClass); Virtual;
PROCEDURE wmCommand(VAR Msg : TMessage); Virtual
wm_First + wm_Command;
PROCEDURE JustMenu(Wid : Word);
END;
FUNCTION TNStrCollection.Compare(Key1, Key2 : Pointer) : Integer;
BEGIN Compare := -1; END;
{--------------------------------------------------}
{ TGroupMWindow's methods }
{--------------------------------------------------}
CONSTRUCTOR TGroupMWindow.Init(AParent : PWindowsObject;
AName : PChar);
CONST
Groupx : PChar = 'GROUP99';
VAR
N, Item : Word;
T : TGroupFile;
TID : TItemData;
SubH : hMenu;
Buff : ARRAY[0..80] OF Char;
HotBuff,
CmdBuff,
itemBuff : ARRAY[0..144] OF Char;
FUNCTION InsertMenuAlpha(Menu: HMenu; Flags, IDNewItem: Word;
NewItem: PChar): Bool;
{Insert the item into menu in alpha order}
VAR
Posn, NumItems : Integer;
found : Boolean;
mbuff : ARRAY[0..80] OF Char;
BEGIN
Posn := 0;
NumItems := GetMenuItemCount(Menu);
found := FALSE;
IF NumItems > 0 THEN
WHILE (Posn < NumItems) AND (NOT found) DO
BEGIN
GetMenuString(Menu, Posn, mbuff, 80, MF_BYPOSITION);
IF StrIComp(NewItem, mbuff) < 0 THEN found := TRUE
ELSE Inc(Posn);
END;
InsertMenuAlpha := InsertMenu(Menu, Posn, Flags, IDNewItem,
NewItem);
END;
BEGIN
TWindow.Init(AParent, AName);
New(Commands, Init(8, 8));
Attr.Menu := LoadMenu(hInstance, AppName);
FOR N := 1 TO 40 DO {max of 40 groups}
BEGIN
wvsprintf(Groupx, 'Group%u', N);
GetPrivateProfileString('Groups', Groupx, '', Buff, 80,
'PROGMAN.INI');
IF Buff[0] <> #0 THEN
BEGIN
{Buff holds FILENAME of Nth group}
T.Init(Buff);
IF T.GetStatus <> msg_Ok THEN
MessageBox(hWindow, T.GetStatStr(itemBuff, 144),
Buff, mb_Ok + mb_IconInformation)
ELSE
BEGIN
T.fpName(buff, 80); {buff now holds name of group}
SubH := CreateMenu;
FOR Item := 0 TO T.fcItems-1 DO
IF T.GetNthItem(Item, TID) THEN
BEGIN
T.PCharFmOffset(TID.pName, itembuff, 80);
IF T.GetItemTagHotStr(Item, Hotbuff, 80) THEN
BEGIN
StrLCat(itemBuff, '{', 144);
StrLCat(itemBuff, HotBuff, 144);
StrLCat(itemBuff, '}', 144);
END;
IF NOT T.GetItemTagDir(Item, cmdBuff+1, 144) THEN
StrCopy(cmdBuff, '*');
IF T.GetItemTagMin(Item) THEN cmdBuff[0] := 'm'
ELSE cmdBuff[0] := 'M';
StrLCat(cmdBuff, ' ', 144);
T.PCharFmOffset(TID.pCommand, StrEnd(Cmdbuff),
144-StrLen(CmdBuff));
{add program name to submenu, in order}
InsertMenuAlpha(SubH, MF_STRING +
MF_BYPOSITION, commands^.Count+cm_Progs,
itemBuff);
{add command info to collection}
commands^.Insert(StrNew(CmdBuff));
END;
{add submenu to main menu, in order}
InsertMenuAlpha(Attr.Menu, MF_POPUP + MF_BYPOSITION,
SubH, buff);
T.Done;
END;
END;
END;
END;
PROCEDURE TGroupMWindow.SetUpWindow;
BEGIN
TWindow.SetUpWindow;
JustMenu(GetSystemMetrics(sm_CXScreen));
END;
DESTRUCTOR TGroupMWindow.Done;
BEGIN
Dispose(Commands, Done);
TWindow.Done;
END;
FUNCTION TGroupMWindow.GetClassName;
BEGIN
GetClassName := AppName;
END;
PROCEDURE TGroupMWindow.GetWindowClass(VAR AWndClass :
TWndClass);
BEGIN
TWindow.GetWindowClass(AWndClass);
AWndClass.hIcon := LoadIcon(HInstance, AppName);
END;
PROCEDURE TGroupMWindow.wmCommand(VAR Msg : TMessage);
PROCEDURE ExecuteProgram(Num : Word);
{GRP file contains program name prefixed with *working*
directory (if specified). Actual directory containing
program is stored in tag data}
VAR
ProgDir : ARRAY[0..fsPathName] OF Char;
DefDir : ARRAY[0..fsDirectory] OF Char;
ProgName : ARRAY[0..fsFileName] OF Char;
ProgExt : ARRAY[0..fsExtension] OF Char;
CmdLine : ARRAY[0..127] OF Char;
P1, P2 : PChar;
ShowCmd : Integer;
BEGIN
P1 := commands^.At(Num);
IF P1[0] = 'm' THEN ShowCmd := sw_ShowMinimized
ELSE ShowCmd := sw_ShowNormal;
IF P1[1] = '*' THEN
BEGIN
ProgDir[0] := #0;
P2 := P1 + 3;
END
ELSE
BEGIN
P2 := StrScan(P1+1, ' ')+1;
StrLCopy(ProgDir, P1+1, P2-P1-2);
END;
FileSplit(P2, DefDir, ProgName, ProgExt);
StrCat(ProgDir, ProgName);
StrCat(ProgDir, ProgExt);
P1 := StrScan(P2, ' ');
IF P1 = NIL THEN CmdLine[0] := #0
ELSE StrCopy(CmdLine, P1+1);
IF ShellExecute(hWindow, NIL, ProgDir, CmdLine,
DefDir, ShowCmd) <= 32 THEN
MessageBox(hWindow, ProgDir, 'CANNOT EXECUTE',
mb_Ok + mb_IconStop);
END;
PROCEDURE FindFile;
CONST
Partl : ARRAY[0..80] OF Char = '';
VAR
MainB, SubB : ARRAY[0..80] OF Char;
fmt : ARRAY[0..1] OF PChar;
MainH, SubH : hMenu;
MsgLen,
MainN, SubN,
MainI, SubI : Word;
DidIt, Quit : Boolean;
MsgBuff : PChar;
BEGIN
IF Application^.ExecDialog(New(PInputDialog,
Init(@Self, 'Find program', 'Partial name',
partl, 80))) <> idOK THEN Exit;
MainH := GetMenu(hWindow);
MainN := GetMenuItemCount(MainH);
DidIt := FALSE;
Quit := FALSE;
MainI := 1;
fmt[0] := MainB;
fmt[1] := SubB;
WHILE (NOT (DidIt OR Quit)) AND (MainI < MainN) DO
BEGIN
GetMenuString(MainH, MainI, MainB, 80, MF_BYPOSITION);
SubH := GetSubMenu(MainH, MainI);
SubN := GetMenuItemCount(SubH);
SubI := 0;
WHILE (NOT (DidIt OR Quit)) AND (SubI < SubN) DO
BEGIN
GetMenuString(SubH, SubI, SubB, 80, MF_BYPOSITION);
IF StrLIComp(partl, SubB, StrLen(partl)) = 0 THEN
BEGIN
MsgLen := StrLen(MainB) + StrLen(SubB) + 20;
GetMem(MsgBuff, MsgLen);
wvsprintf(MsgBuff, 'Group: %s'#13'Program: %s', fmt);
CASE MessageBox(hWindow, MsgBuff,
'Execute program?', mb_YesNoCancel +
mb_IconQuestion) OF
id_Yes : BEGIN
DidIt := TRUE;
ExecuteProgram(GetMenuItemId(
SubH, SubI)-cm_Progs);
END;
id_No : ;
id_Cancel : Quit := TRUE;
END;
FreeMem(MsgBuff, MsgLen);
END;
Inc(SubI);
END;
Inc(MainI);
END;
IF NOT (DidIt OR Quit) THEN
MessageBox(hWindow, 'No more matching program names', Partl,
mb_Ok + mb_IconInformation);
END;
BEGIN
IF Msg.lParamLo = 0 THEN
BEGIN
CASE Msg.wParam OF
cm_FileFind : FindFile;
cm_About : Application^.ExecDialog(New(PDialog,
Init(@Self, 'GroupAbout')));
cm_AcrossTop : BEGIN
ShowWindow(hWindow, sw_Hide);
JustMenu(GetSystemMetrics(sm_CXScreen));
ShowWindow(hWindow, sw_ShowNormal);
END;
cm_LeftSide : BEGIN
ShowWindow(hWindow, sw_Hide);
JustMenu(0);
ShowWindow(hWindow, sw_ShowNormal);
END;
cm_Exit : TWindow.wmCommand(Msg);
ELSE ExecuteProgram(Msg.wParam-cm_Progs);
END;
END
ELSE TWindow.wmCommand(Msg);
END;
PROCEDURE TGroupMWindow.JustMenu(Wid : Word);
VAR
OrgH, Hig,
Hig1, MaxH : Word;
R : TRect;
BEGIN
{Size window so nothing but complete menu is shown}
Hig1 := GetSystemMetrics(sm_CYMenu)+1;
OrgH := GetSystemMetrics(sm_CYCaption) +
2*GetSystemMetrics(sm_CYFrame)-1;
Hig := OrgH;
MaxH := GetSystemMetrics(sm_CYScreen);
REPEAT
Inc(Hig, Hig1);
MoveWindow(hWindow, 0, 0, Wid, Hig, FALSE);
GetClientRect(hWindow, R);
IF Hig >= MaxH THEN
BEGIN
Inc(Wid, 48);
Hig := OrgH;
END;
UNTIL R.Bottom-R.Top > 0;
Dec(Hig, Hig1);
MoveWindow(hWindow, 0, 0, Wid, Hig, TRUE);
END;
{--------------------------------------------------}
{ TMyApplication's method implementations: }
{--------------------------------------------------}
PROCEDURE TMyApplication.InitMainWindow;
BEGIN
MainWindow := New(PGroupMWindow, Init(NIL, AppName));
END;
{--------------------------------------------------}
{ Main program: }
{--------------------------------------------------}
VAR
MyApp: TMyApplication;
PrevWnd : hWnd;
BEGIN
IF hPrevInst = 0 THEN
BEGIN
MyApp.Init(AppName);
MyApp.Run;
MyApp.Done;
END
ELSE
BEGIN
PrevWnd := FindWindow(AppName, AppName);
IF PrevWnd <> 0 THEN BringWindowToTop(PrevWnd);
END;
END.