من از کد زیر برای ساخت منوهای اصلی در بالای صفحه استفاده میکنم
با این کد میشه به منوها رنگ و فونت داد همچنین میتونم Height رو در قسمت Popup ها تغییر بدم
اما میخوام Height در قسمت بالای صفحه رو نیز بتونم تغییر بدم
در عکس ضمیمه مشخص کردم.
اگر ممکنه راهنمایی بفرمائید.
procedure TDmLocal.FillMenuMain(Menu:TMenu;ObjectID:Integer; Event:TNotifyEvent;ShowMenuType:TShowMenuType=SmAu to);
var
VFlag: Integer;
i,RC:integer;
NewNote:TMenuItem;
MenuType:string;
begin
MainWidth:=0;
CountNote:=0;
Menu.Items.Clear;
case ShowMenuType of
SmAuto:
if Menu is TPopupMenu then
MenuType:='0'
else
MenuType:='1';
SmPopMenu:
MenuType:='0';
SmMainMenu:
MenuType:='1';
end;
QryProcedure.SQL.Clear;
ImageIndex:=0;
QryProcedure.ExecSQL('SELECT * FROM MenuDesignOrder Where MenuType='+MenuType+' And '+'ObjectID= '+IntToStr(ObjectID)+' Order BY MenuOrder');
if QryProcedure.RecordCount<>0 then
begin
HiddenToolBar;
Rc:=QryProcedure.RecordCount-1;
SetLength(ANoteMain,Rc+1);
for i:=0 to Rc do
begin
ANoteMain[i].Caption:=QryProcedure.FieldByName('MenuCaption'). AsString;
ANoteMain[i].MenuCode:=QryProcedure.FieldByName('MenuCode').As Integer;
ANoteMain[i].ParentCode:=QryProcedure.FieldByName('ParentCode' ).AsInteger;
ANoteMain[i].ShortCut:=QryProcedure.FieldByName('ShortCut').As String;
ANoteMain[i].ImageIndex:=QryProcedure.FieldByName('MenuImage') .AsInteger;
ANoteMain[i].FontName:=QryProcedure.FieldByName('MenuFont').As String;
ANoteMain[i].FontSize:=QryProcedure.FieldByName('MenuFontSize' ).AsInteger;
ANoteMain[i].Color:=QryProcedure.FieldByName('MenuColor').AsIn teger;
if ANoteMain[i].ImageIndex = 0 then
ANoteMain[i].ImageIndex := -1;
ANoteMain[i].Hint:=QryProcedure.FieldByName('MenuHint').AsStri ng;
ANoteMain[i].Shakhes:=QryProcedure.FieldByName('MenuShakhes'). AsInteger;
if ANoteMain[i].Shakhes<>0 then
begin
Inc(ImageIndex);
VFlag:=1;
CreateToolBar(ImageIndex,ANoteMain[i],Event);
end;
QryProcedure.Next;
end;
if VFlag=1 then
FrmMain.CoolBar.Visible:=True;
for i:=Rc downto 0 do
begin
if ANoteMain[i].ParentCode=0 then
begin
NewNote:=TMenuItem.Create(menu);
NewNote.Caption:= ANoteMain[i].Caption;
if ANoteMain[i].Name = '' then
NewNote.Name :=ANoteMain[i].Name
else
NewNote.Name :='Mnu'+IntToStr(ANoteMain[i].MenuCode);
NewNote.ImageIndex := ANoteMain[i].ImageIndex;
NewNote.Tag:=ANoteMain[i].MenuCode;
NewNote.OnClick:=Event;
NewNote.OnDrawItem:=MenuDrawItemMain;
NewNote.OnMeasureItem:=MenuMeasureItemMain;
NewNote.ShortCut:=TextToShortCut(ANoteMain[i].ShortCut);
NewNote.Hint:=ANoteMain[i].Hint;
Menu.Items.Add(NewNote);
Child(Event,Menu,ANoteMain,rc,NewNote,ANoteMain[i].MenuCode);
end;
end;
end;
end;
procedure TDmLocal.MenuDrawItemMain(Sender: TObject; ACanvas: TCanvas; ARect: TRect;
Selected: Boolean);
var Str:string;
Item:TMenuItem;
Color:TColor;
I:Integer;
TWidth,SWidth,EWidth: Integer;
begin
Item :=(Sender as TMenuItem);
Str:=Item.Caption+' '+ShortCutToText(Item.ShortCut);
if (Item.Tag <> 0)then
begin
for I := Low(ANoteMain) to High(ANoteMain) do
begin
if ANoteMain[i].MenuCode = Item.Tag then
begin
if ANoteMain[i].FontName <> '' then
ACanvas.Font.Name:=ANoteMain[i].FontName;
ACanvas.Font.Size:=ANoteMain[i].FontSize;
if ANoteMain[i].color <> 0 then
Color := ANoteMain[i].color;
if ACanvas.Font.Size = 0 then
ACanvas.Font.Size := 9;
break;
end;
end;
end
else
begin
ACanvas.Font.Name:='Tahoma';
ACanvas.Font.Size:=9;
end;
FrmMain.LblCanvas.Font:=ACanvas.Font;
FrmMain.LblCanvas.Caption:=Item.Caption;
TWidth:=FrmMain.LblCanvas.Canvas.TextWidth(FrmMain .LblCanvas.Caption);
FrmMain.LblCanvas.Caption:=ShortCutToText(Item.Sho rtCut);
SWidth:=FrmMain.LblCanvas.Canvas.TextWidth(FrmMain .LblCanvas.Caption);
TWidth:=MainWidth-(TWidth+SWidth);
FrmMain.LblCanvas.Caption:=' ';
EWidth:=FrmMain.LblCanvas.Canvas.TextWidth(FrmMain .LblCanvas.Caption);
TWidth:=(TWidth-35) div EWidth;
Str:=Item.Caption+LeftStr(' ',TWidth)+ShortCutToText(Item.ShortCut);
if Selected then
begin
ACanvas.Pen.Color := clBlue;
ACanvas.Brush.Color:=clSkyBlue;
ACanvas.Rectangle(ARect);
if Alignment='LeftToRight' then
begin
if (Item.GetParentComponent is TMainMenu) then
ARect.Left := ARect.Left + 5
else
ARect.Left := ARect.Left + 35;
end
else
begin
if (Item.GetParentComponent is TMainMenu) then
ARect.Right := ARect.Right - 5
else
ARect.Right := ARect.Right - 35;
end;
ACanvas.Font.Color := clBlack;
end
else
begin
ACanvas.Brush.Color:=clWhite;
ACanvas.Pen.Color := clWhite;
ACanvas.Rectangle(ARect);
if Alignment='LeftToRight' then
begin
if not(Item.GetParentComponent is TMainMenu) then
ARect.Left := ARect.Left + 30;
end
else
begin
if not(Item.GetParentComponent is TMainMenu) then
ARect.Right := ARect.Right - 30;
end;
ACanvas.Pen.Color := clBtnFace;
if Color = 0 then
ACanvas.Brush.Color:=clBtnFace
else
ACanvas.Brush.Color:=Color;
ACanvas.Rectangle(ARect);
if Alignment='LeftToRight' then
ARect.Left := ARect.Left + 5
else
ARect.Right := ARect.Right - 5;
end;
if Item.Caption <> '-' then
begin
if Alignment='LeftToRight' then
begin
ARect.Right:=MainWidth;
FrmMain.SmallIcon.Draw(ACanvas,ARect.Left - 30 ,ARect.top + 3 ,Item.ImageIndex)
end
else
FrmMain.SmallIcon.Draw(ACanvas,ARect.Right + 12 ,ARect.top + 3 ,Item.ImageIndex);
DrawText(ACanvas.Handle, PChar(Str), -1, ARect, DT_RIGHT or DT_VCENTER or DT_SINGLELINE or DT_NOCLIP);
end
else
begin
ACanvas.Brush.Color := clSilver;
ARect.Top := ARect.Top + 2;
ACanvas.Rectangle(ARect);
ARect.Bottom := ARect.Bottom - 2;
ACanvas.Rectangle(ARect);
end;
end;
procedure TDmLocal.MenuMeasureItemMain(Sender: TObject; ACanvas: TCanvas;
var Width, Height: Integer);
begin
if (Sender as TMenuItem).Tag <> 0 then
begin
if (Sender as TMenuItem).Caption <> '-' then
Height := ACanvas.TextHeight((Sender as TMenuItem).Caption)+18
else
Height := 5;
Width := 400;
end;
end;
پاسخ با نقل قول
