xpmenu.pas

以前写的一个利用P2P 技术的一个通讯的例子。里面用到了 DBISAM 、INDY 控件。

               B.Width := TextRect.Right - TextRect.Left;
               B.Height := TextRect.Bottom - TextRect.Top;
               BRect := Rect(0, 0, B.Width, B.Height);

               B.Canvas.Brush.Color := ACanvas.Brush.Color;
               B.Canvas.FillRect(BRect);
               B.Canvas.Font.color := DefColor;

               DrawtextEx(B.Canvas.Handle,
                  PChar(txt),
                  Length(txt),
                  BRect, TextFormat + DT_VCENTER, nil);
               ACanvas.CopyRect(TextRect, B.Canvas, BRect);
               B.Free;
               exit;
            end;

      end;

   if (TopMenu and Selected) then
      if FUseSystemColors then
         DefColor := TopMenuFontColor(ACanvas, FFIconBackColor);

   ACanvas.Font.color := DefColor; // will not affect Buttons

   TextRect.Top := TextRect.Top +
      ((TextRect.Bottom - TextRect.Top) - ACanvas.TextHeight('W')) div 2;

   SetBkMode(ACanvas.Handle, TRANSPARENT);

   if Default and Enabled then
      begin

         Inc(TextRect.Left, 1);
         ACanvas.Font.color := GetShadeColor(ACanvas,
            ACanvas.Pixels[TextRect.Left, TextRect.Top], 30);
         DrawtextEx(ACanvas.Handle,
            PChar(txt),
            Length(txt),
            TextRect, TextFormat, nil);
         Dec(TextRect.Left, 1);

         Inc(TextRect.Top, 2);
         Inc(TextRect.Left, 1);
         Inc(TextRect.Right, 1);

         ACanvas.Font.color := GetShadeColor(ACanvas,
            ACanvas.Pixels[TextRect.Left, TextRect.Top], 30);
         DrawtextEx(ACanvas.Handle,
            PChar(txt),
            Length(txt),
            TextRect, TextFormat, nil);

         Dec(TextRect.Top, 1);
         Dec(TextRect.Left, 1);
         Dec(TextRect.Right, 1);

         ACanvas.Font.color := GetShadeColor(ACanvas,
            ACanvas.Pixels[TextRect.Left, TextRect.Top], 40);
         DrawtextEx(ACanvas.Handle,
            PChar(txt),
            Length(txt),
            TextRect, TextFormat, nil);

         Inc(TextRect.Left, 1);
         Inc(TextRect.Right, 1);

         ACanvas.Font.color := GetShadeColor(ACanvas,
            ACanvas.Pixels[TextRect.Left, TextRect.Top], 60);
         DrawtextEx(ACanvas.Handle,
            PChar(txt),
            Length(txt),
            TextRect, TextFormat, nil);

         Dec(TextRect.Left, 1);
         Dec(TextRect.Right, 1);
         Dec(TextRect.Top, 1);

         ACanvas.Font.color := DefColor;
      end;

   DrawtextEx(ACanvas.Handle,
      PChar(txt),
      Length(txt),
      TextRect, TextFormat, nil);

   txt := ShortCutText + ' ';

   if not Is16Bit then
      ACanvas.Font.color := DefColor
   else
      ACanvas.Font.color := GetShadeColor(ACanvas, DefColor, -40);

   if IsRightToLeft then
      begin
         Inc(TextRect.Left, 10);
         TextFormat := DT_LEFT
      end
   else
      begin
         Dec(TextRect.Right, 10);
         TextFormat := DT_RIGHT;
      end;

   DrawtextEx(ACanvas.Handle,
      PChar(txt),
      Length(txt),
      TextRect, TextFormat, nil);

end;

procedure TXPMenu.DrawIcon(Sender: TObject; ACanvas: TCanvas; B: TBitmap;
   IconRect: Trect; Hot, Selected, Enabled, Checked, FTopMenu,
   IsRightToLeft: boolean);
var
   DefColor: TColor;
   X, Y: integer;
begin

   if (B <> nil) and (B.Width > 0) then
      begin
         X := IconRect.Left;
         Y := IconRect.Top + 1;

         if (Sender is TMenuItem) then
            begin
               inc(Y, 2);
               if FIconWidth > B.Width then
                  X := X + ((FIconWidth - B.Width) div 2) - 1
               else
                  begin
                     if IsRightToLeft then
                        X := IconRect.Right - b.Width - 2
                     else
                        X := IconRect.Left + 2;
                  end;
            end;

         if FTopMenu then
            begin
               if IsRightToLeft then
                  X := IconRect.Right - b.Width - 5
               else
                  X := IconRect.Left + 1;
            end;

         if (Hot) and (not FTopMenu) and (Enabled) and (not Checked) then
            if not Selected then
               begin
                  dec(X, 1);
                  dec(Y, 1);
               end;

         if (not Hot) and (Enabled) and (not Checked) then
            if Is16Bit then
               DimBitmap(B, FDimLevel {30});

         if not Enabled then
            begin
               GrayBitmap(B, FGrayLevel);
               DimBitmap(B, 40);
            end;

         if (Hot) and (Enabled) and (not Checked) then
            begin
               if (Is16Bit) and (not UseSystemColors) and (Sender is TToolButton) then
                  DefColor := NewColor(ACanvas, FSelectColor, 68)
               else
                  DefColor := FFSelectColor;

               DefColor := GetShadeColor(ACanvas, DefColor, 50);
               DrawBitmapShadow(B, ACanvas, X + 2, Y + 2, DefColor);
            end;

         B.Transparent := true;
         ACanvas.Draw(X, Y, B);
      end;

end;

function TXPMenu.TopMenuFontColor(ACanvas: TCanvas; Color: TColor): TColor;
var
   r, g, b, avg: integer;
begin

   Color := ColorToRGB(Color);
   r := Color and $000000FF;
   g := (Color and $0000FF00) shr 8;
   b := (Color and $00FF0000) shr 16;

   Avg := (r + b) div 2;

   if (Avg > 150) or (g > 200) then
      Result := FFont.Color
   else
      Result := NewColor(ACanvas, Color, 90);

end;

procedure TXPMenu.SetActive(const Value: boolean);
begin
   if Value = FActive then exit;

   FActive := Value;
   if FActive then
      InitItems(FForm, true, true)
   else
      InitItems(FForm, false, true);

   // if (FForm <> nil) and (TForm(FForm).Menu <> nil) then
   Windows.DrawMenuBar(FForm.Handle);
end;

procedure TXPMenu.SetAutoDetect(const Value: boolean);
begin
   FAutoDetect := Value;
end;

procedure TXPMenu.SetForm(const Value: TScrollingWinControl);
var
   Hold: boolean;
begin
   if Value <> FForm then
      begin
         Hold := Active;
         Active := false;
         FForm := Value;
         if Hold then
            Active := True;
      end;
end;

procedure TXPMenu.SetFont(const Value: TFont);
begin
   FFont.Assign(Value);
   Windows.DrawMenuBar(FForm.Handle);

end;

procedure TXPMenu.SetColor(const Value: TColor);
begin
   FColor := Value;
end;

procedure TXPMenu.SetIconBackColor(const Value: TColor);
begin
   FIconBackColor := Value;
end;

procedure TXPMenu.SetMenuBarColor(const Value: TColor);
begin
   FMenuBarColor := Value;
   Windows.DrawMenuBar(FForm.Handle);
end;

procedure TXPMenu.SetCheckedColor(const Value: TColor);
begin
   FCheckedColor := Value;
end;

procedure TXPMenu.SetSeparatorColor(const Value: TColor);
begin
   FSeparatorColor := Value;
end;

procedure TXPMenu.SetSelectBorderColor(const Value: TColor);
begin
   FSelectBorderColor := Value;
end;

procedure TXPMenu.SetSelectColor(const Value: TColor);
begin
   FSelectColor := Value;
end;

procedure TXPMenu.SetDisabledColor(const Value: TColor);
begin
   FDisabledColor := Value;
end;

procedure TXPMenu.SetSelectFontColor(const Value: TColor);
begin
   FSelectFontColor := Value;
end;

procedure TXPMenu.SetIconWidth(const Value: integer);
begin
   FIconWidth := Value;
end;

procedure TXPMenu.SetDrawSelect(const Value: boolean);
begin
   FDrawSelect := Value;
end;

procedure TXPMenu.SetOverrideOwnerDraw(const Value: boolean);
begin
   FOverrideOwnerDraw := Value;
   if FActive then
      Active := True;
end;

procedure TXPMenu.SetUseSystemColors(const Value: boolean);
begin
   FUseSystemColors := Value;
   Windows.DrawMenuBar(FForm.Handle);
end;

procedure TXPMenu.SetGradient(const Value: boolean);
begin
   FGradient := Value;
end;

procedure TXPMenu.SetFlatMenu(const Value: boolean);
begin
   FFlatMenu := Value;
end;

procedure TXPMenu.SetXPContainers(const Value: TXPContainers);
begin
   if Value <> FXPContainers then
      begin
         if FActive then
            begin
               FActive := false;
               InitItems(FForm, false, true);
               FActive := true;
               FXPContainers := Value;
               InitItems(FForm, true, true);
            end;
      end;
   FXPContainers := Value;

end;

procedure TXPMenu.SetXPControls(const Value: TXPControls);
begin
   if Value <> FXPControls then
      begin
         if FActive then
            begin
               FActive := false;
               InitItems(FForm, false, true);
               FActive := true;
               FXPControls := Value;
               InitItems(FForm, true, true);
            end;
      end;
   FXPControls := Value;

end;

procedure GetSystemMenuFont(Font: TFont);
var
   FNonCLientMetrics: TNonCLientMetrics;
begin
   FNonCLientMetrics.cbSize := Sizeof(TNonCLientMetrics);
   if SystemParametersInfo(SPI_GETNONCLIENTMETRICS, 0, @FNonCLientMetrics, 0) then
      begin
         Font.Handle := CreateFontIndirect(FNonCLientMetrics.lfMenuFont);
         Font.Color := clMenuText;

         //if Font.Name = 'MS Sans Serif' then
         //begin
         //  Font.Name := 'Tahoma';
         //  Font.Charset := DEFAULT_CHARSET;
         //end;

      end;
end;

procedure TXPMenu.DrawGradient(ACanvas: TCanvas; ARect: TRect;
   IsRightToLeft: boolean);
var
   i: integer;
   v: integer;
   FRect: TRect;
begin

   fRect := ARect;
   V := 0;
   if IsRightToLeft then
      begin
         fRect.Left := fRect.Right - 1;
         for i := ARect.Right downto ARect.Left do
            begin
               if (fRect.Left < ARect.Right)
                  and (fRect.Left > ARect.Right - FIconWidth + 5) then
                  inc(v, 3)
               else
                  inc(v, 1);

               if v > 96 then v := 96;
               ACanvas.Brush.Color := NewColor(ACanvas, FFIconBackColor, v);
               ACanvas.FillRect(fRect);

               fRect.Left := fRect.Left - 1;
               fRect.Right := fRect.Left - 1;
            end;
      end
   else
      begin
         fRect.Right := fRect.Left + 1;
         for i := ARect.Left to ARect.Right do
            begin
               i