jvmenus.pas

East make Tray Icon in delphi

            IntersectClipRect(Canvas.Handle, Left, Top, Right, Bottom);
          DrawItem(Item, rcItem, State);
          Canvas.Handle := 0;
        finally
          RestoreDC(hDC, SaveIndex);
        end;
      finally
        Canvas.Free;
      end;
    end;
  end;
end;

procedure TJvMainMenu.WMMeasureItem(var Msg: TWMMeasureItem);
var
  Item: TMenuItem;
  SaveIndex: Integer;
  DC: HDC;
begin
  with Msg.MeasureItemStruct^ do
  begin
    Item := FindItem(itemID, fkCommand);
    if Assigned(Item) then
    begin
      DC := GetWindowDC(0);
      try
        FCanvas := TControlCanvas.Create;
        try
          SaveIndex := SaveDC(DC);
          try
            FCanvas.Handle := DC;
            FCanvas.Font := Screen.MenuFont;
            if Item.Default then
              Canvas.Font.Style := Canvas.Font.Style + [fsBold];
            GetActiveItemPainter.Menu := Self;
            GetActiveItemPainter.Measure(Item, Integer(itemWidth), Integer(itemHeight));
            //MeasureItem(Item, Integer(itemWidth), Integer(itemHeight));
          finally
            FCanvas.Handle := 0;
            RestoreDC(DC, SaveIndex);
          end;
        finally
          Canvas.Free;
        end;
      finally
        ReleaseDC(DC, 0);
      end;
    end;
  end;
end;

procedure TJvMainMenu.WMMenuSelect(var Msg: TWMMenuSelect);
var
  MenuItem: TMenuItem;
  FindKind: TFindItemKind;
  MenuID: Integer;
begin
  if FCursor <> crDefault then
    with Msg do
    begin
      FindKind := fkCommand;
      if MenuFlag and MF_POPUP <> 0 then
      begin
        FindKind := fkHandle;
        MenuID := GetSubMenu(Menu, IDItem);
      end
      else
        MenuID := IDItem;
      MenuItem := TMenuItem(FindItem(MenuID, FindKind));
      if (MenuItem <> nil) and (IsItemPopup(MenuItem) or (MenuItem.Count = 0)) and
        (MenuFlag and MF_HILITE <> 0) then
        SetCursor(Screen.Cursors[FCursor])
      else
        SetCursor(Screen.Cursors[crDefault]);
    end;
end;

procedure TJvMainMenu.SetItemPainter(const Value: TJvCustomMenuItemPainter);
begin
  if Value <> FItemPainter then
  begin
    // Remove menu from current item painter
    if FItemPainter <> nil then
      FItemPainter.Menu := nil;

    // set value and if not nil, setup the painter correctly
    FItemPainter := Value;
    if FItemPainter <> nil then
    begin
      Style := msItemPainter;
      FItemPainter.FreeNotification(Self);
      FItemPainter.Menu := Self;
    end
    else
      Style := msStandard;
    Refresh;
  end;
end;

function TJvMainMenu.GetActiveItemPainter: TJvCustomMenuItemPainter;
begin
  if (Style = msItemPainter) and (ItemPainter <> nil) then
    Result := ItemPainter
  else
    Result := FStyleItemPainter;
end;

//=== { TJvPopupList } =======================================================

type
  TJvPopupList = class(TList)
  private
    procedure WndProc(var Message: TMessage);
  public
    Window: HWND;
    procedure Add(Popup: TPopupMenu);
    procedure Remove(Popup: TPopupMenu);
  end;

var
  PopupList: TJvPopupList = nil;

procedure TJvPopupList.WndProc(var Message: TMessage);
var
  I: Integer;
  MenuItem: TMenuItem;
  FindKind: TFindItemKind;
  ContextID: Integer;
  Handled: Boolean;
begin
  try
    case Message.Msg of
      WM_MEASUREITEM, WM_DRAWITEM:
        for I := 0 to Count - 1 do
        begin
          Handled := False;
          TJvPopupMenu(Items[I]).WndMessage(nil, Message, Handled);
          if Handled then
            Exit;
        end;
      WM_COMMAND:
        for I := 0 to Count - 1 do
          if TJvPopupMenu(Items[I]).DispatchCommand(Message.WParam) then
            Exit;
      WM_INITMENUPOPUP:
        for I := 0 to Count - 1 do
          with TWMInitMenuPopup(Message) do
            if TJvPopupMenu(Items[I]).DispatchPopup(MenuPopup) then
              Exit;
      WM_MENUSELECT:
        with TWMMenuSelect(Message) do
        begin
          FindKind := fkCommand;
          if MenuFlag and MF_POPUP <> 0 then
          begin
            FindKind := fkHandle;
            ContextID := GetSubMenu(Menu, IDItem);
          end
          else
            ContextID := IDItem;
          for I := 0 to Count - 1 do
          begin
            MenuItem := TJvPopupMenu(Items[I]).FindItem(ContextID, FindKind);
            if MenuItem <> nil then
            begin
              Application.Hint := MenuItem.Hint;
              with TJvPopupMenu(Items[I]) do
                if FCursor <> crDefault then
                  if (MenuFlag and MF_HILITE <> 0) then
                    SetCursor(Screen.Cursors[FCursor])
                  else
                    SetCursor(Screen.Cursors[crDefault]);
              Exit;
            end;
          end;
          Application.Hint := '';
        end;
      WM_MENUCHAR:
        for I := 0 to Count - 1 do
          with TJvPopupMenu(Items[I]) do
            if (Handle = HMenu(Message.LParam)) or
              (FindItem(Message.LParam, fkHandle) <> nil) then
            begin
              ProcessMenuChar(TWMMenuChar(Message));
              Exit;
            end;
      WM_HELP:
        with PHelpInfo(Message.LParam)^ do
        begin
          for I := 0 to Count - 1 do
            if TJvPopupMenu(Items[I]).Handle = hItemHandle then
            begin
              ContextID := TMenu(Items[I]).GetHelpContext(iCtrlID, True);
              if ContextID = 0 then
                ContextID := TMenu(Items[I]).GetHelpContext(hItemHandle, False);
              if Screen.ActiveForm = nil then
                Exit;
              if (biHelp in Screen.ActiveForm.BorderIcons) then
                Application.HelpCommand(HELP_CONTEXTPOPUP, ContextID)
              else
                Application.HelpContext(ContextID);
              Exit;
            end;
        end;
    end;
    with Message do
      Result := DefWindowProc(Window, Msg, WParam, LParam);
  except
    Application.HandleException(Self);
  end;
end;

procedure TJvPopupList.Add(Popup: TPopupMenu);
begin
  if Count = 0 then
    Window := AllocateHWnd(WndProc);
  inherited Add(Popup);
end;

procedure TJvPopupList.Remove(Popup: TPopupMenu);
begin
  inherited Remove(Popup);
  if Count = 0 then
    DeallocateHWnd(Window);
end;

//=== { TJvPopupMenu } =======================================================

constructor TJvPopupMenu.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  if PopupList = nil then
    PopupList := TJvPopupList.Create;
  FStyle := msStandard;
  FStyleItemPainter := CreateMenuItemPainterFromStyle(FStyle, Self);
  FCursor := crDefault;
  FImageMargin := TJvImageMargin.Create;
  FImageSize := TJvMenuImageSize.Create;
  PopupList.Add(Self);
  FImageChangeLink := TChangeLink.Create;
  FImageChangeLink.OnChange := ImageListChange;
  FDisabledImageChangeLink := TChangeLink.Create;
  FDisabledImageChangeLink.OnChange := DisabledImageListChange;
  FHotImageChangeLink := TChangeLink.Create;
  FHotImageChangeLink.OnChange := HotImageListChange;
  FPopupPoint := Point(-1, -1);

  // Set default values that are not 0
  FTextVAlignment := vaMiddle;
end;

destructor TJvPopupMenu.Destroy;
begin
  FImageChangeLink.Free;
  FDisabledImageChangeLink.Free;
  FHotImageChangeLink.Free;
  FImageMargin.Free;
  FImageSize.Free;
  FStyleItemPainter.Free;

  // This test is only False if finalization is called before destroy.
  // An example of this happening is when using TJvAppInstances
  if Assigned(PopupList) then
    PopupList.Remove(Self);

  inherited Destroy;
end;

procedure TJvPopupMenu.Loaded;
begin
  inherited Loaded;
  if IsOwnerDrawMenu then
    RefreshMenu(True);
end;

function TJvPopupMenu.GetCanvas: TCanvas;
begin
  Result := FCanvas;
end;

procedure TJvPopupMenu.Notification(AComponent: TComponent; Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);
  if Operation = opRemove then
  begin
    if AComponent = FImages then
      SetImages(nil);
    if AComponent = FDisabledImages then
      SetDisabledImages(nil);
    if AComponent = FHotImages then
      SetHotImages(nil);
    if AComponent = FItemPainter then
      ItemPainter := nil;
  end;
end;

procedure TJvPopupMenu.ImageListChange(Sender: TObject);
begin
  if Sender = FImages then
    RefreshMenu(IsOwnerDrawMenu);
end;

procedure TJvPopupMenu.SetImages(Value: TImageList);
var
  OldOwnerDraw: Boolean;
begin
  OldOwnerDraw := IsOwnerDrawMenu;
  if FImages <> nil then
    FImages.UnregisterChanges(FImageChangeLink);
  FImages := Value;
  if Value <> nil then
  begin
    FImages.RegisterChanges(FImageChangeLink);
    FImages.FreeNotification(Self);
  end;
  if IsOwnerDrawMenu <> OldOwnerDraw then
    RefreshMenu(not OldOwnerDraw);
end;

procedure TJvPopupMenu.DisabledImageListChange(Sender: TObject);
begin
  if Sender = FDisabledImages then
    RefreshMenu(IsOwnerDrawMenu);
end;

procedure TJvPopupMenu.SetDisabledImages(Value: TImageList);
var
  OldOwnerDraw: Boolean;
begin
  OldOwnerDraw := IsOwnerDrawMenu;
  if FDisabledImages <> nil then
    FDisabledImages.UnregisterChanges(FDisabledImageChangeLink);
  FDisabledImages := Value;
  if Value <> nil then
  begin
    FDisabledImages.RegisterChanges(FDisabledImageChangeLink);
    FDisabledImages.FreeNotification(Self);
  end;
  if IsOwnerDrawMenu <> OldOwnerDraw then
    RefreshMenu(not OldOwnerDraw);
end;

procedure TJvPopupMenu.HotImageListChange(Sender: TObject);
begin
  if Sender = FHotImages then
    RefreshMenu(IsOwnerDrawMenu);
end;

procedure TJvPopupMenu.SetHotImages(Value: TImageList);
var
  OldOwnerDraw: Boolean;
begin
  OldOwnerDraw := IsOwnerDrawMenu;
  if FHotImages <> nil then
    FImages.UnregisterChanges(FHotImageChangeLink);
  FHotImages := Value;
  if Value <> nil then
  begin
    FHotImages.RegisterChanges(FHotImageChangeLink);
    FHotImages.FreeNotification(Self);
  end;
  if IsOwnerDrawMenu <> OldOwnerDraw then
    RefreshMenu(not OldOwnerDraw);
end;

function FindPopupControl(const Pos: TPoint): TControl;
var
  Window: TWinControl;
begin
  Result := nil;
  Window := FindVCLWindow(Pos);
  if Window <> nil then
  begin
    Result := Window.ControlAtPos(Pos, False);
    if Result = nil then
      Result := Window;
  end;
end;

procedure TJvPopupMenu.SetBiDiModeFromPopupControl;
var
  AControl: TControl;
begin
  if not SysLocale.MiddleEast then
    Exit;