rm_dsgctrls.pas

进销存·完整的·有数据库的·非常完整·只得参考

begin
  inherited Create(AOwner);
  FTrueTypeBMP := RMCreateBitmap('RM_TRUETYPE_FNT');
  FDeviceBMP := RMCreateBitmap('RM_DEVICE_FNT');
  FDevice := rmfdScreen;
  Style := csOwnerDrawVariable; //DropDownList;
  Sorted := True;
  DropDownCount := 18;
  Init;

  liFont := TFont.Create;
  try
	  liFont.Name := 'Arial';
  	liFont.Size := 16;
	  FFontHeight := RMCanvasHeight('a', liFont);
  finally
	  liFont.Free;
  end;  
end;

destructor TRMFontComboBox.Destroy;
begin
  FTrueTypeBMP.Free;
  FDeviceBMP.Free;
  inherited Destroy;
end;

procedure TRMFontComboBox.CreateWnd;
var
  OldFont: TFontName;
begin
  OldFont := FontName;
  inherited CreateWnd;
  FUpdate := True;
  try
    PopulateList;
    inherited Text := '';
    SetFontName(OldFont);
    Perform(CB_SETDROPPEDWIDTH, 240, 0);
  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.MeasureItem(Index: Integer; var Height: Integer);
begin
  if Index = -1 then
    Height := 15
  else
  begin
		Height := FFontHeight;
//    Canvas.Font.Name := Items[index];
//    Canvas.Font.Size := 16;
//    Height := GetItemHeight(Canvas.Font);
  end;
end;

procedure TRMFontComboBox.DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState);
var
  Bitmap: TBitmap;
  BmpWidth: Integer;
  s: string;
  h: Integer;
begin
  with Canvas do
  begin
    FillRect(Rect);
    BmpWidth := 15;
    if (Integer(Items.Objects[Index]) and TRUETYPE_FONTTYPE) <> 0 then
      Bitmap := FTrueTypeBMP
    else if (Integer(Items.Objects[Index]) and DEVICE_FONTTYPE) <> 0 then
      Bitmap := FDeviceBMP
    else
      Bitmap := nil;
    if Bitmap <> nil then
    begin
      BmpWidth := Bitmap.Width;
      BrushCopy(Bounds(Rect.Left + 2, (Rect.Top + Rect.Bottom - Bitmap.Height)
        div 2, Bitmap.Width, Bitmap.Height), Bitmap, Bounds(0, 0, Bitmap.Width,
        Bitmap.Height), Bitmap.TransparentColor);
    end;

    if (not DroppedDown){$IFDEF Delphi5} or (odComboBoxEdit in State){$ENDIF} then
    begin
      Font.Assign(Font);
    end
    else
    begin
      Font.Name := Items[index];
      Font.Size := 16;
    end;

    Rect.Left := Rect.Left + BmpWidth + 6;
    s := Items[index];
    h := TextHeight(s);
    TextOut(Rect.Left, Rect.Top + (Rect.Bottom - Rect.Top - h) div 2, s);
  end;
end;

procedure TRMFontComboBox.WMFontChange(var Message: TMessage);
begin
  inherited;
  Reset;
end;

procedure TRMFontComboBox.Change;
var
  I: Integer;
begin
  inherited Change;
  if Style <> csDropDownList then
  begin
    I := Items.IndexOf(inherited Text);
    if (I >= 0) and (I <> ItemIndex) then
    begin
      ItemIndex := I;
      DoChange;
    end;
  end;
end;

procedure TRMFontComboBox.Click;
begin
  inherited Click;
  DoChange;
end;

procedure TRMFontComboBox.DoChange;
begin
  if not (csReading in ComponentState) then
  begin
    if not FUpdate and Assigned(FOnChange) then
      FOnChange(Self);
  end;
end;

procedure TRMFontComboBox.Reset;
var
  SaveName: TFontName;
begin
  if HandleAllocated then
  begin
    FUpdate := True;
    try
      SaveName := FontName;
      PopulateList;
      FontName := SaveName;
    finally
      FUpdate := False;
      if FontName <> SaveName then
        DoChange;
    end;
  end;
end;

procedure TRMFontComboBox.CMFontChanged(var Message: TMessage);
begin
  inherited;
  Init;
end;

procedure TRMFontComboBox.CMFontChange(var Message: TMessage);
begin
  inherited;
  Reset;
end;

procedure TRMFontComboBox.Init;
begin
  if GetFontHeight(Font) > FTrueTypeBMP.Height then
    ItemHeight := GetFontHeight(Font)
  else
    ItemHeight := FTrueTypeBMP.Height + 1;
  RecreateWnd;
end;

{------------------------------------------------------------------------------}
{------------------------------------------------------------------------------}
{TRMTrackIcon}

constructor TRMTrackIcon.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  TrackBmp := TBitmap.create;
end;

destructor TRMTrackIcon.Destroy;
begin
  TrackBmp.Free;
  TrackBmp := nil;
  inherited Destroy;
end;

procedure TRMTrackIcon.Paint;
var
  TempRect: TRect;
begin
  Canvas.Lock;
  TempRect := Rect(0, 0, TrackBmp.Width, TrackBmp.Height);
  try
    Canvas.Brush.Style := bsClear;
    Canvas.BrushCopy(TempRect, TrackBmp, TempRect,
      TrackBmp.Canvas.Pixels[0, Height - 1]);
  finally
    Canvas.Unlock;
  end;
end;

procedure TRMTrackIcon.SetBitmapName(const Value: string);
begin
  if FBitmapName <> Value then
  begin
    FBitmapName := Value;
    if Value <> '' then
    begin
      TrackBmp.Handle := LoadBitmap(HInstance, PChar(BitmapName));
      Width := TrackBmp.Width;
      Height := TrackBmp.Height;
    end;
    invalidate;
  end
end;


{------------------------------------------------------------------------------}
{------------------------------------------------------------------------------}
{TRMRuler}
const
  rmTwipsPerInch = 1440;

constructor TRMRuler.Create(AOwner: TComponent);
var
  DC: HDC;
begin
  inherited Create(AOwner);
  Parent := TWinControl(AOwner);
  BevelInner := bvNone; //bvLowered;
  BevelOuter := bvNone;
  Caption := '';
  DC := GetDC(0);
  ScreenPixelsPerInch := GetDeviceCaps(DC, LOGPIXELSY);
  ReleaseDC(0, DC);

  FirstInd := TRMTrackIcon.Create(Self);
  with FirstInd do
  begin
    BitmapName := 'RM_RULERDOWN';
    Parent := Self;
    Left := 3; Top := 2;
//    SetBounds(3, 2, 16, 12);
    DragCursor := crArrow;
    OnMouseDown := OnRulerItemMouseDown;
    OnMouseMove := OnRulerItemMouseMove;
    OnMouseUp := OnFirstIndMouseUp;
  end;
  LeftInd := TRMTrackIcon.Create(Self);
  with LeftInd do
  begin
    BitmapName := 'RM_RULERUP';
    Parent := Self;
    Left := 3; Top := 12;
//    SetBounds(3, 12, 16, 12);
    DragCursor := crArrow;
    OnMouseDown := OnRulerItemMouseDown;
    OnMouseMove := OnRulerItemMouseMove;
    OnMouseUp := OnLeftIndMouseUp;
  end;
  RightInd := TRMTrackIcon.Create(Self);
  with RightInd do
  begin
    BitmapName := 'RM_RULERUP';
    Parent := Self;
    Left := 475; Top := 13;
//    SetBounds(475, 13, 15, 12);
    DragCursor := crArrow;
    OnMouseDown := OnRulerItemMouseDown;
    OnMouseMove := OnRulerItemMouseMove;
    OnMouseUp := OnRightIndMouseUp;
  end;
end;

procedure TRMRuler.Paint;
var
  i, j: integer;
  PageWidth: double;
  ScreenPixelsPerUnit: Double;
  liRect: TRect;
begin
  inherited Paint;
  ScreenPixelsPerUnit := ScreenPixelsPerInch;
  liRect := Rect(6, 4, Width - 6, Height - 4);
  with Canvas do
  begin
    Brush.Color := clWhite;
    FillRect(liRect);

    Pen.Color := clBtnShadow;
    MoveTo(liRect.Left - 1, liRect.Bottom);
    LineTo(liRect.Left - 1, liRect.Top);
    LineTo(liRect.Right + 1, liRect.Top);

    Pen.Color := clBlack;
    MoveTo(liRect.Left, liRect.Bottom);
    LineTo(liRect.Left, liRect.Top + 1);
    LineTo(liRect.Right + 1, liRect.Top + 1);

    Pen.Color := clBtnFace;
    MoveTo(liRect.Left - 1, liRect.Bottom);
    LineTo(liRect.Right + 1, liRect.Bottom);
    LineTo(liRect.Right + 1, liRect.Top);

    Pen.Color := clBtnHighlight;
    MoveTo(liRect.Left - 1, liRect.Bottom + 1);
    LineTo(liRect.Right + 2, liRect.Bottom + 1);
    LineTo(liRect.Right + 2, liRect.Top);

    PageWidth := (RichEdit.Width - 12) / ScreenPixelsPerUnit;
    for i := 0 to trunc(pageWidth) + 1 do
    begin
      if (i >= PageWidth) then
        continue;
      if i > 0 then
        TextOut(Trunc(liRect.Left + i * ScreenPixelsPerUnit - TextWidth(inttostr(i)) div 2),
          liRect.Top + 3, inttostr(i));
      for j := 1 to 3 do
      begin
        Pen.color := clBlack;
        if (i + j / 4 >= PageWidth) then
          Continue;

        if (j = 4 div 2) then
        begin
          MoveTo(liRect.Left + Trunc((i + (j / 4)) * ScreenPixelsPerUnit), liRect.Top + 7);
          LineTo(liRect.Left + Trunc((i + (j / 4)) * ScreenPixelsPerUnit), liRect.Bottom - 5);
        end
        else
        begin
          MoveTo(liRect.Left + Trunc((i + (j / 4)) * ScreenPixelsPerUnit), liRect.Top + 8);
          LineTo(liRect.Left + Trunc((i + (j / 4)) * ScreenPixelsPerUnit), liRect.Bottom - 7);
        end
      end
    end;
  end;
end;

procedure TRMRuler.DrawLine;
var
  P: TPoint;
begin
  FLineVisible := not FLineVisible;
  P := Point(0, 0);
  Inc(P.X, FLineOfs);
  with P, RichEdit do
  begin
    MoveToEx(FLineDC, X, Y, nil);
    LineTo(FLineDC, X, Y + ClientHeight);
  end;
end;

procedure TRMRuler.CalcLineOffset(Control: TControl);
var
  P: TPoint;
begin
  with Control do
    P := ClientToScreen(Point(0, 0));
  P := RichEdit.ScreenToClient(P);
  FLineOfs := P.X + FDragOfs;
end;