QBasic & Borland Pascal & C/Delphi5.iso/Pascal/BPASCAL.700/D12/WINDEMOS.ZIP/WMENU.PAS

Pascal/Delphi Source File | 1992-10-01 | 4.6 KB | 178 lines

{************************************************}
{                                                }
{   Demo Program                                 }
{   Copyright (c) 1991 by Borland International  }
{                                                }
{************************************************}

program WMenu;

{$R WMenu}

uses WinProcs, WinTypes;

type
  TList = array[1..99] of String[17];

const
  ListCount:Word = 0;

var
  UserMenu: hMenu;
  List: TList;
  ListCounter: Word;
  MenuName:String[17];
  Window: hWnd;

function AboutProc(Dlg: hWnd; iMessage, wParam: Word; lParam: LongInt): Bool; Export;
  begin
    AboutProc:=false;
    case iMessage of
      WM_Create: AboutProc:=true;
      WM_Command: if (wParam = IDOK) or (wParam = IDCancel) then
            begin
              AboutProc:=true;
              EndDialog(Dlg, 0);
            end;
    end;
  end;

function CreateProc(Dlg: hWnd; iMessage, wParam:Word; lParam: LongInt): WordBool; export;
  var
    Style: Word;
    Name: String[17];
    Found: Boolean;
    I: Integer;
    DC: hDC;
    R: TRect;
  begin
      CreateProc:=False;
      case iMessage of
    WM_InitDialog: CreateProc:=true;
    WM_Command: case wParam of
              IDCancel: begin
                  EndDialog(Dlg, 0);
                  CreateProc:=true;
                end;
              104: begin
                 Name[0]:=Char(GetWindowText(GetDlgItem(Dlg, 103), @Name[1], 16));
                 Found:=false;
                 for I:=1 to ListCount do
                   if Name=List[I] then
                 begin
                   Found:=true;
                   DeleteMenu(UserMenu, I+300, MF_ByCommand);
                 end;
                  if MenuName=Name then
                begin
                  MenuName:='';
                  GetClientRect(Window, R);
                  InvalidateRect(Window, @R, true);
                end;
                  if Not found then
                MessageBox(Dlg, 'Item Not Found', 'Error', MB_OK)
                  else
                EndDialog(Dlg, 0);
               end;
              IDOK: begin
                  if SendMessage(GetDlgItem(Dlg, 101), BM_GetCheck, 0,0)=0 then
                Style:=MF_UnChecked
                  else
                Style:=MF_Checked;
                  if SendMessage(GetDlgItem(Dlg, 102), BM_GetCheck, 0,0)=0 then
                Style:=Style or MF_Enabled
                  else
                Style:=Style or MF_Grayed;
                  Name[0]:=Char(GetWindowText(GetDlgItem(Dlg, 103), @Name[1], 16));
                  Inc(ListCount);
                  if ListCount>99 then
                begin
                  MessageBox(Dlg, 'Too many menus', 'Error', MB_OK);
                  Exit;
                end;
                  List[ListCount]:=Name;
                  AppendMenu(UserMenu, Style or MF_String, ListCount+300, @Name[1]);
                  EndDialog(Dlg, 0);
                  CreateProc:=true;
                end;
             end;
      end;

  end;

function WindowProc(Wnd: hWnd; iMessage, wParam:Word; lParam: LongInt): LongInt; export;
  var
    ProcInst: Pointer;
    DC: hDC;
    PaintStruct: TPaintStruct;
    R: TRect;
  begin
    case iMessage of
      WM_Command: case WParam of
            100: begin
               ProcInst:=MakeProcInstance(@CreateProc, hInstance);
               DialogBox(hInstance, 'CreateDlg', Wnd, ProcInst);
               FreeProcInstance(ProcInst);
             end;
            106: begin
               ProcInst:=MakeProcInstance(@AboutProc, hInstance);
               DialogBox(hInstance, 'About', Wnd, ProcInst);
               FreeProcInstance(ProcInst);
             end;
            301..399: begin
                MenuName:=List[wParam-300];
                GetClientRect(Window, R);
                InvalidateRect(Window, @R, true);
                  end;

          else
            WindowProc:=DefWindowProc(Wnd, iMessage, wParam, lParam);
          end;
      WM_Paint: begin
          DC:=BeginPaint(Wnd, PaintStruct);
          TextOut(DC, 0, 0, @MenuName[1], Length(MenuName));
          EndPaint(Wnd, PaintStruct);
        end;
      WM_Destroy: PostQuitMessage(0);
    else
      WindowProc:=DefWindowProc(Wnd, iMessage, wParam, lParam);
    end;
  end;

procedure WinMain;
  var
    WndClas: TWndClass;
    Msg: TMsg;
  begin
    If hPrevInst = 0 then
      begin
    WndClas.Style := 0;
    WndClas.lpfnWndProc:= @WindowProc;
    WndClas.cbClsExtra := 0;
    WndClas.cbWndExtra := 0;
    WndClas.hInstance := HInstance;
    WndClas.hIcon := 0;
    WndClas.hCursor := LoadCursor(0, IDC_Arrow);
    WndClas.hbrBackground := GetStockObject(White_Brush);
    WndClas.lpszMenuName := 'Menu';
    WndClas.lpszClassName := 'GenWindow';
    if not RegisterClass(WndClas) then
      Halt;
      end;
    Window := CreateWindow('GenWindow', 'Menu Example', WS_OverLappedWindow,
             CW_UseDefault, 0, CW_UseDefault, 0, 0, 0, hInstance, nil);
    UpDateWindow(Window);
    UserMenu:=CreatePopUpMenu;
    InsertMenu(GetMenu(Window), 106, MF_ByCommand or MF_PopUp, UserMenu, 'User Define Menu');
    ShowWindow(Window,Sw_ShowNormal);
    while GetMessage(Msg, 0, 0, 0) do
      begin
    TranslateMessage(msg);
    DispatchMessage(msg);
      end;
  end;

begin
  WinMain;
end.