rm_common.pas

来自「report machine 2.3 功能强大」· PAS 代码 · 共 2,143 行 · 第 1/4 页

             // This check is necessary to be sure that combo is created, not
             // RECREATED (somehow CM_RECREATEWND does not work)
          SetWindowLong(FListHandle, GWL_WNDPROC, Longint(FDefListProc));
          FDefListProc := nil;
          FChildHandle := Message.lParam;
        end
        else
        begin
             // WM_Create is the only event I found where I can get the ListBox handle.
             // The fact that combo box usually creates more then 1 handle complicates the
             // things, so I have to have the FChildHandle to resolve it later (in CreateWnd).
          if FChildHandle = 0 then
            FChildHandle := Message.lParam
          else
            FListHandle := Message.lParam;
        end;
      end;
    WM_WINDOWPOSCHANGING:
      MoveWindow(EditHandle, 3 + FEditOffset, 3, Width - FButtonWidth - 7 - FEditOffset,
        Height - 6, True);
  end;
  inherited;
end;

procedure TRMCustomComboBox.WMPaint(var Message: TWMPaint);
var
  PS, PSE: TPaintStruct;
begin
  BeginPaint(Handle, PS);
  try
    if Enabled then
    begin
      DrawImage(PS.HDC, ItemIndex, Rect(3, 3, FEditOffset + 3, Height - 3));
      if GetSolidBorder then
      begin
        PaintBorder(PS.HDC, True);
        if DroppedDown then
          PaintButton(2)
        else
          PaintButton(1);
      end else
      begin
        PaintBorder(PS.HDC, False);
        PaintButton(0);
      end;
    end else
    begin
      BeginPaint(EditHandle, PSE);
      try
        PaintDisabled;
      finally
        EndPaint(EditHandle, PSE);
      end;
    end;
  finally
    EndPaint(Handle, PS);
  end;
  Message.Result := 0;
end;

procedure TRMCustomComboBox.DrawImage(DC: HDC; Index: Integer; R: TRect);
begin
  if FEditOffset > 0 then
    FillRect(DC, R, GetSysColorBrush(COLOR_WINDOW));
end;

procedure TRMCustomComboBox.ComboWndProc(var Message: TMessage; ComboWnd: HWnd;
  ComboProc: Pointer);
var
  DC: HDC;
begin
  inherited;
  if (ComboWnd = EditHandle) then
    case Message.Msg of
      WM_SETFOCUS:
        begin
          DC := GetWindowDC(Handle);
          PaintBorder(DC, True);
          PaintButton(1);
          ReleaseDC(Handle, DC);
        end;
      WM_KILLFOCUS:
        begin
          DC := GetWindowDC(Handle);
          PaintBorder(DC, False);
          PaintButton(0);
          ReleaseDC(Handle, DC);
        end;
    end;
end;

procedure TRMCustomComboBox.CNCommand(var Message: TWMCommand);
begin
  inherited;
  if (Message.NotifyCode in [CBN_CLOSEUP]) then
    PaintButton(1);
end;

procedure TRMCustomComboBox.PaintBorder(DC: HDC; const SolidBorder: Boolean);
var
  R: TRect;
  BtnFaceBrush, WindowBrush: HBRUSH;
begin
  BtnFaceBrush := GetSysColorBrush(COLOR_BTNFACE);
  WindowBrush := GetSysColorBrush(COLOR_WINDOW);
  GetWindowRect(Handle, R);
  OffsetRect(R, -R.Left, -R.Top);
  InflateRect(R, -1, -1);
  FrameRect(DC, R, BtnFaceBrush);
  InflateRect(R, -1, -1);
  R.Right := R.Right - FButtonWidth - 1;
  FrameRect(DC, R, WindowBrush);
  if SolidBorder then
  begin
    GetWindowRect(Handle, R);
    OffsetRect(R, -R.Left, -R.Top);
    DrawEdge(DC, R, BDR_SUNKENOUTER, BF_RECT);
  end else
  begin
    GetWindowRect(Handle, R);
    OffsetRect(R, -R.Left, -R.Top);
    FrameRect(DC, R, BtnFaceBrush);
  end;
end;

procedure TRMCustomComboBox.PaintButtonGlyph(DC: HDC; x: Integer; y: Integer);
var
  Pen, SavePen: HPEN;
begin
  Pen := CreatePen(PS_SOLID, 1, ColorToRGB(clBlack));
  SavePen := SelectObject(DC, Pen);
  MoveToEx(DC, x, y, nil);
  LineTo(DC, x + 5, y);
  MoveToEx(DC, x + 1, y + 1, nil);
  LineTo(DC, x + 4, y + 1);
  MoveToEx(DC, x + 2, y + 2, nil);
  LineTo(DC, x + 3, y + 2);
  SelectObject(DC, SavePen);
  DeleteObject(Pen);
end;


procedure TRMCustomComboBox.PaintButton(bnStyle: Integer);
var
  R: TRect;
  DC: HDC;
  Brush, SaveBrush: HBRUSH;
  X, Y: Integer;
  Pen, SavePen: HPEN;
  WindowBrush: HBRUSH;
begin
  WindowBrush := GetSysColorBrush(COLOR_WINDOW);
  DC := GetWindowDC(Handle);
  SetRect(R, Width - FButtonWidth - 2, 2, Width - 2, Height - 2);
  Brush := CreateSolidBrush(GetSysColor(COLOR_BTNFACE));
  SaveBrush := SelectObject(DC, Brush);
  FillRect(DC, R, Brush);
  SelectObject(DC, SaveBrush);
  DeleteObject(Brush);
  X := Trunc(FButtonWidth / 2) + Width - FButtonWidth - 4;
  Y := Trunc((Height - 4) / 2) + 1;
  if bnStyle = 0 then //No 3D border
  begin
    FrameRect(DC, R, WindowBrush);
    GetWindowRect(Handle, R);
    OffsetRect(R, -R.Left, -R.Top);
    InflateRect(R, -FButtonWidth - 3, -2);
    Pen := CreatePen(PS_SOLID, 1, ColorToRGB(clWindow));
    SavePen := SelectObject(DC, Pen);
    MoveToEx(DC, R.Right, R.Top, nil);
    LineTo(DC, R.Right, R.Bottom);
    SelectObject(DC, SavePen);
    DeleteObject(Pen);
    PaintButtonGlyph(DC, X, Y);
  end;
  if bnStyle = 1 then //3D up border
  begin
    DrawEdge(DC, R, BDR_RAISEDINNER, BF_RECT);
    GetWindowRect(Handle, R);
    OffsetRect(R, -R.Left, -R.Top);
    InflateRect(R, -FButtonWidth - 3, -1);
    Pen := CreatePen(PS_SOLID, 1, ColorToRGB(clBtnFace));
    SavePen := SelectObject(DC, Pen);
    MoveToEx(DC, R.Right, R.Top, nil);
    LineTo(DC, R.Right, R.Bottom);
    SelectObject(DC, SavePen);
    DeleteObject(Pen);
    PaintButtonGlyph(DC, X, Y);
  end;
  if bnStyle = 2 then //3D down border
  begin
    DrawEdge(DC, R, BDR_SUNKENOUTER, BF_RECT);
    GetWindowRect(Handle, R);
    OffsetRect(R, -R.Left, -R.Top);
    InflateRect(R, -FButtonWidth - 3, -1);
    Pen := CreatePen(PS_SOLID, 1, ColorToRGB(clBtnFace));
    SavePen := SelectObject(DC, Pen);
    MoveToEx(DC, R.Right, R.Top, nil);
    LineTo(DC, R.Right, R.Bottom);
    SelectObject(DC, SavePen);
    DeleteObject(Pen);
    PaintButtonGlyph(DC, X + 1, Y + 1);
  end;
  ReleaseDC(Handle, DC);
end;

procedure TRMCustomComboBox.PaintDisabled;
var
  R: TRect;
  Brush, SaveBrush: HBRUSH;
  DC: HDC;
  WindowBrush: HBRUSH;
begin
  WindowBrush := GetSysColorBrush(COLOR_WINDOW);
  DC := GetWindowDC(Handle);
  Brush := CreateSolidBrush(GetSysColor(COLOR_BTNFACE));
  SaveBrush := SelectObject(DC, Brush);
  FillRect(DC, ClientRect, Brush);
  SelectObject(DC, SaveBrush);
  DeleteObject(Brush);
  R := ClientRect;
  InflateRect(R, -2, -2);
  FrameRect(DC, R, WindowBrush);
  PaintButtonGlyph(DC, Trunc(FButtonWidth / 2) + Width - FButtonWidth - 4,
    Trunc((Height - 4) / 2) + 1);
  ReleaseDC(Handle, DC);
end;

procedure TRMCustomComboBox.CMEnabledChanged(var Msg: TMessage);
begin
  inherited;
  Invalidate;
end;

procedure TRMCustomComboBox.CMMouseEnter(var Message: TMessage);
var
  DC: HDC;
begin
  inherited;
  msMouseInControl := True;
  if Enabled and not (GetFocus = EditHandle) and not DroppedDown then
  begin
    DC := GetWindowDC(Handle);
    PaintBorder(DC, True);
    PaintButton(1);
    ReleaseDC(Handle, DC);
  end;
end;

procedure TRMCustomComboBox.CMMouseLeave(var Message: TMessage);
var
  DC: HDC;
begin
  inherited;
  msMouseInControl := False;
  if Enabled and not (GetFocus = EditHandle) and not DroppedDown then
  begin
    DC := GetWindowDC(Handle);
    PaintBorder(DC, False);
    PaintButton(0);
    ReleaseDC(Handle, DC);
  end;
end;

function TRMCustomComboBox.GetSolidBorder: Boolean;
begin
  Result := ((csDesigning in ComponentState)) or
    (DroppedDown or (GetFocus = EditHandle) or msMouseInControl);
end;

function TRMCustomComboBox.GetListHeight: Integer;
begin
  Result := ItemHeight * Min(DropDownCount, Items.Count) + 4;
  if (DropDownCount <= 0) or (Items.Count = 0) then
    Result := ItemHeight + 4;
end;

procedure TRMCustomComboBox.CMFontChanged(var Message: TMessage);
begin
  inherited;
  ItemHeight := GetFontHeight(Font);
  RecreateWnd;
end;

{------------------------------------------------------------------------------}
{------------------------------------------------------------------------------}
{TRMFontPreview}

constructor TRMFontPreview.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Width := 200;
  Height := 50;
  Visible := False;
  Parent := AOwner as TWinControl;

  FPanel := TPanel.Create(Self);
  with FPanel do
  begin
    Parent := Self;
    Color := clWindow;
    Ctl3D := False;
    ParentCtl3D := False;
    BorderStyle := bsSingle;
    BevelInner := bvNone;
    BevelOuter := bvNone;
    Font.Color := clWindowText;
    Font.Size := 20;
    Align := alClient;
  end;
end;

destructor TRMFontPreview.Destroy;
begin
  FPanel.Free;
  FPanel := nil;
  inherited Destroy;
end;

procedure TRMFontPreview.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  with Params do
  begin
    Style := WS_POPUP or WS_CLIPCHILDREN;
    ExStyle := WS_EX_TOOLWINDOW;
    WindowClass.Style := WindowClass.Style or CS_SAVEBITS;
  end;
end;

{------------------------------------------------------------------------------}
{------------------------------------------------------------------------------}
{TRMFontComboBox}

const
  WRITABLE_FONTTYPE = 256;

function IsValidFont(Box: TRMFontComboBox; LogFont: TLogFont;
  FontType: Integer): Boolean;
begin
  Result := True;
  if (rmfoAnsiOnly in Box.Options) then
    Result := Result and (LogFont.lfCharSet = ANSI_CHARSET);
  if (rmfoTrueTypeOnly in Box.Options) then
    Result := Result and (FontType and TRUETYPE_FONTTYPE = TRUETYPE_FONTTYPE);
  if (rmfoFixedPitchOnly in Box.Options) then
    Result := Result and (LogFont.lfPitchAndFamily and FIXED_PITCH = FIXED_PITCH);
  if (rmfoOEMFontsOnly in Box.Options) then
    Result := Result and (LogFont.lfCharSet = OEM_CHARSET);
  if (rmfoNoOEMFonts in Box.Options) then
    Result := Result and (LogFont.lfCharSet <> OEM_CHARSET);
  if (rmfoNoSymbolFonts in Box.Options) then
    Result := Result and (LogFont.lfCharSet <> SYMBOL_CHARSET);
  if (rmfoScalableOnly in Box.Options) then
    Result := Result and (FontType and RASTER_FONTTYPE = 0);
end;

function EnumFontsProc(var EnumLogFont: TEnumLogFont;
  var TextMetric: TNewTextMetric; FontType: Integer; Data: LPARAM): Integer;
  export; stdcall;
var
  FaceName: string;
begin
  FaceName := StrPas(EnumLogFont.elfLogFont.lfFaceName);
  with TRMFontComboBox(Data) do
    if (Items.IndexOf(FaceName) < 0) and
      IsValidFont(TRMFontComboBox(Data), EnumLogFont.elfLogFont, FontType) then
    begin
      if EnumLogFont.elfLogFont.lfCharSet <> SYMBOL_CHARSET then
        FontType := FontType or WRITABLE_FONTTYPE;
      Items.AddObject(FaceName, TObject(FontType));
    end;
  Result := 1;
end;

constructor TRMFontComboBox.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  if not (csDesigning in ComponentState) then
    FRMFontViewForm := TRMFontPreview.Create(Self);
  FTrueTypeBMP := RMCreateBitmap('RM_TRUETYPE_FNT');
  FDeviceBMP := RMCreateBitmap('RM_DEVICE_FNT');
  FDevice := rmfdScreen;
  Sorted := True;
  DropDownCount := 12;
  Init;
end;

destructor TRMFontComboBox.Destroy;
begin
  FTrueTypeBMP.Free;
  FDeviceBMP.Free;
  if not (csDesigning in ComponentState) then
    FRMFontViewForm.Destroy;
  inherited Destroy;
end;

procedure TRMFontComboBox.CreateWnd;
var
  OldFont: TFontName;
begin
  OldFont := FontName;
  inherited CreateWnd;
  FUpdate := True;
  try
    PopulateList;
    inherited Text := '';
    SetFontName(OldFont);
  finally
    FUpdate := False;
  end;
  if AnsiCompareText(FontName, OldFont) <> 0 then DoChange;
end;

procedure TRMFontComboBox.PopulateList;
var
  DC: HDC;
begin
  if not HandleAllocated then Exit;
  Items.BeginUpdate;
  try
    Clear;
    DC := GetDC(0);
    try
      if (FDevice = rmfdScreen) or (FDevice = rmfdBoth) then
        EnumFontFamilies(DC, nil, @EnumFontsProc, Longint(Self));
      if (FDevice = rmfdPrinter) or (FDevice = rmfdBoth) then
      begin
        try
          EnumFontFamilies(Printer.Handle, nil, @EnumFontsProc, Longint(Self));
        except
        end;
      end;
    finally
      ReleaseDC(0, DC);
    end;
  finally
    Items.EndUpdate;
  end;
end;

procedure TRMFontComboBox.SetFontName(const NewFontName: TFontName);
var
  Item: Integer;
begin
  if FontName <> NewFontName then
  begin
    if not (csLoading in ComponentState) then
    begin
      HandleNeeded;
      for Item := 0 to Items.Count - 1 do
      begin
        if AnsiCompareText(Items[Item], NewFontName) = 0 then
        begin
          ItemIndex := Item;
          DoChange;
          Exit;
        end;
      end;
      if Style = csDropDownList then
        ItemIndex := -1
      else
        inherited Text := NewFontName;
    end
    else
      inherited Text := NewFontName;
    DoChange;
  end;
end;

function TRMFontComboBox.GetFontName: TFontName;
begin
  Result := inherited Text;
end;

function TRMFontComboBox.GetTrueTypeOnly: Boolean;
begin
  Result := rmfoTrueTypeOnly in FOptions;
end;

procedure TRMFontComboBox.SetOptions(Value: TFontListOptions);
begin
  if Value <> Options then
  begin
    FOptions := Value;
    Reset;
  end;
end;

procedure TRMFontComboBox.SetTrueTypeOnly(Value: Boolean);
begin
  if Value <> TrueTypeOnly then
  begin
    if Value then
      FOptions := FOptions + [rmfoTrueTypeOnly]
    else
      FOptions := FOptions - [rmfoTrueTypeOnly];
    Reset;
  end;
end;

procedure TRMFontComboBox.SetDevice(Value: TFontDevice);
begin
  if Value <> FDevice then
  begin
    FDevice := Value;
    Reset;
  end;
end;

procedure TRMFontComboBox.SetUseFonts(Value: Boolean);
begin
  if Value <> FUseFonts then
  begin
    FUseFonts := Value;
    Invalidate;
  end;
end;

procedure TRMFontComboBox.DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState);
var
  Bitmap: TBitmap;
  BmpWidth: Integer;
  Text: array[0..255] of Char;
begin
  if FUseFonts and (Integer(Items.Objects[Index]) and WRITABLE_FONTTYPE <> 0) then
  begin
    if odSelected in State then
    begin
      FRMFontViewForm.FPanel.Caption := self.Items[index];
      FRMFontViewForm.FPanel.Font.Name := self.Items[index];
    end;
  end;

  with Canvas do
  begin