如何使memo实现垂直对齐(就像Label的Layout属性一样)?分不够可再加!谢谢!

Question

如题!请高帮忙!

Answer 1

用下列方法试试看，不过效果不是很理想。
  SendMessage(Memo1.Handle, EM_GETRECT, 0, Integer(@Rct));
  Inc(Rct.Top, 5); 数字自己定 
  SendMessage(Memo1.Handle, EM_SETRECT, 0, Integer(@Rct));

Answer 2

一時也不清楚, 你看看 TCustomLabel 的實現:
procedure TCustomLabel.Paint;
begin
    ....
    if FLayout <> tlTop then
    begin
      CalcRect := Rect;
      DoDrawText(CalcRect, DrawStyle or DT_CALCRECT);
      if FLayout = tlBottom then OffsetRect(Rect, 0, Height - CalcRect.Bottom)
      else OffsetRect(Rect, 0, (Height - CalcRect.Bottom) div 2);
    end;
    DoDrawText(Rect, DrawStyle);
  end;
end;

Answer 3

要重写个组件，直接继承Tmomo就可以了。记得OVERRIDE createparam,关键所在！

Answer 4

用这个试试:
  case FTextLayout of
    tlTop: YOffset := 0;
    tlCenter: YOffset := (ClientHeight - Canvas.TextHeight(Text)) div 2 + 1;
    tlBottom: YOffset := ClientHeight - Canvas.TextHeight(Text);
  else
    YOffset := 0;
  end;
  Rct:=Rect(0,0,ClientWidth,ClientHeight);
  Canvas.TextRect(Rct,0,YOffset,Text);

Answer 5

//要充分发挥想象力～～object Form1: TForm1
  Left = 192
  Top = 107
  Width = 283
  Height = 204
  Caption = 'Form1'
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  OldCreateOrder = False
  OnCreate = FormCreate
  PixelsPerInch = 96
  TextHeight = 13
  object Memo2: TMemo
    Left = 5
    Top = 4
    Width = 264
    Height = 161
    Enabled = False
    Lines.Strings = (
      'Memo2')
    TabOrder = 1
  end
  object Panel1: TPanel
    Left = 8
    Top = 8
    Width = 257
    Height = 153
    Cursor = crIBeam
    BevelOuter = bvNone
    Color = clWindow
    TabOrder = 0
    OnClick = Panel1Click
    object Memo1: TMemo
      Left = 5
      Top = 0
      Width = 196
      Height = 16
      BorderStyle = bsNone
      Ctl3D = False
      Lines.Strings = (
        'Memo1')
      ParentCtl3D = False
      TabOrder = 0
      WordWrap = False
      OnChange = Memo1Change
    end
  end
end
unit Unit1;interfaceuses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls;type
  TForm1 = class(TForm)
    Panel1: TPanel;
    Memo1: TMemo;
    Memo2: TMemo;
    procedure Memo1Change(Sender: TObject);
    procedure Panel1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;var
  Form1: TForm1;implementation{$R *.dfm}uses Math;procedure TForm1.Memo1Change(Sender: TObject);
var
  vLineCount: Integer;
begin
  if Memo1.Lines.Count <= 0 then
    vLineCount := 1
  else vLineCount := Memo1.Lines.Count +
    Ord(Pos(#13#10#0#0, Memo1.Lines.Text + #0#0) > 0);
  Memo1.Height := vLineCount * Canvas.TextHeight('|') + 10;
  Memo1.Top := (Memo1.Parent.Height - Memo1.Height) div 2;
end;procedure TForm1.Panel1Click(Sender: TObject);
begin
  if Memo1.CanFocus then Memo1.SetFocus;
end;procedure TForm1.FormCreate(Sender: TObject);
begin
  Memo1Change(Memo1);
  Memo1.Width := Panel1.ClientWidth - 10;
  Memo1.Text := 'A'#13#10'B';  Font.Name := '宋体';
  Font.Size := 9;
end;end.

Answer 6

//改进后的算法～～procedure SetMemoLayout(AMemo: TMemo; ALayout: Integer);
var
  vRect: TRect;
  vCanvas: TControlCanvas;
  vHeight: Integer;
  vLineCount: Integer;
begin
  if AMemo.Lines.Count <= 0 then
    vLineCount := 1
  else vLineCount := AMemo.Lines.Count +
    Ord(Pos(#13#10#0#0, AMemo.Lines.Text + #0#0) > 0);  vCanvas := TControlCanvas.Create;
  try
    vCanvas.Control := AMemo;
    vCanvas.Font.Assign(AMemo.Font);
    vHeight := vLineCount * vCanvas.TextHeight('|');
  finally
    vCanvas.Free;
  end;  vRect := AMemo.ClientRect;
  case ALayout of
    0: ; //tlTop
    1: vRect.Top := (AMemo.ClientHeight - vHeight) div 2; //tlCenter
    2: vRect.Top := AMemo.ClientHeight - vHeight; //tlBoottm
  else
  end;
  vRect.Bottom := vRect.Top + vHeight + 10;
  if (vRect.Top < AMemo.ClientRect.Top) or
    (vRect.Bottom > AMemo.ClientRect.Bottom) then
    vRect := AMemo.ClientRect;
  AMemo.Perform(EM_SETRECT, 0, Integer(@vRect));
end; { SetMemoLayout }procedure TForm1.RadioGroup1Click(Sender: TObject);
begin
  SetMemoLayout(Memo3, RadioGroup1.ItemIndex);
end;procedure TForm1.Memo3Change(Sender: TObject);
begin
  SetMemoLayout(TMemo(Sender), RadioGroup1.ItemIndex);
end;

Answer 7

以下是我自已在透明的TMemo中的TextLayou属性,可以实现靠上靠下居中功能,但是就是在设置TextLayout属性时候Memo却无法透明了,哪位高手帮我看一下啊?
unit UsrMemo;interfaceuses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, ComCtrls;type
  TCtrl = class(TWinControl);  TTextLayout = (tlTop, tlCenter, tlBottom);  TUsrMemo = class(TMemo)
  private
    FTransparent: Boolean; //透明
    FPainting: Boolean;
    FModiFlag:Boolean;   
    FCanvas:TCanvas;
    FTextLayout:TTextLayout; //靠上靠下居中
    procedure SetTransparent(Value: Boolean);
    procedure SetModiFlag(Value:Boolean);
    procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
    procedure WMNCPaint(var Message: TMessage); message WM_NCPAINT;
    procedure WMEraseBkGnd(var Message: TWMEraseBkGnd); message WM_ERASEBKGND;
    procedure CNCtlColorEdit(var Message: TWMCtlColorEdit); message CN_CTLCOLOREDIT;
    procedure CNCtlColorStatic(var Message: TWMCtlColorStatic); message CN_CTLCOLORSTATIC;
    procedure CMParentColorChanged(var Message: TMessage); message CM_PARENTCOLORCHANGED;
    procedure WMSize(var Message: TWMSize); message WM_SIZE;
    procedure WMMove(var Message: TWMMove); message WM_MOVE;
    function  GetTextLayout: TTextLayout;
    procedure SetTextLayout(Value: TTextLayout);
    procedure DrawText;
  protected
    procedure RepaintWindow;
    procedure Change; override;
    procedure SetParent(AParent: TWinControl); override;
    function GetMemoText: string; virtual;  //得到内容
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    property Canvas: TCanvas read FCanvas;
  published
    property Transparent: Boolean read FTransparent write SetTransparent default false;
    property ModiFlag:Boolean read FModiFlag write SetModiFlag default False;
    property TextLayout: TTextLayout read GetTextLayout write SetTextLayout default tlTop;
  end;procedure Register;
implementationconst
  BorderRec: array[TBorderStyle] of Integer = (1, -1);procedure Register;
begin
  RegisterComponents('EU', [TUsrMemo]);
end;function GetScreenClient(Control: TControl): TPoint;
var
  p: TPoint;
begin
  p := Control.ClientOrigin;
  ScreenToClient(Control.Parent.Handle, p);
  Result := p;
end;constructor TUsrMemo.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FTransparent := False;
  FPainting := false;
  FCanvas := TControlCanvas.Create;
  TControlCanvas(FCanvas).Control := Self;
end;destructor TUsrMemo.Destroy;
begin
  inherited Destroy;
end;procedure TUsrMemo.SetTransparent(Value: Boolean);
begin
  if FTransparent <> Value then
  begin
    FTransparent := Value;
    Invalidate;
  end;
end;procedure TUsrMemo.SetModiFlag(Value:Boolean);
begin
  if FModiFlag <> Value then
  begin
    FModiFlag :=Value;
    Invalidate;
  end;
end;procedure TUsrMemo.WMEraseBkGnd(var Message: TWMEraseBkGnd);
var
  DC: hDC;
  i: integer;
  p: TPoint;
begin
  if FTransparent then
  begin
    if Assigned(Parent) then
    begin
      DC := Message.DC;
      i := SaveDC(DC);  
      p := GetScreenClient(self);
      p.x := -p.x;
      p.y := -p.y;
      MoveWindowOrg(DC, p.x, p.y);
      SendMessage(Parent.Handle, $0014, DC, 0);
      TCtrl(Parent).PaintControls(DC, nil);
      RestoreDC(DC, i);
    end;
  end
  else
    inherited;
end;procedure TUsrMemo.WMPaint(var Message: TWMPaint);
begin
  inherited;
  if FTransparent then
    if not FPainting then
      RepaintWindow;
end;procedure TUsrMemo.WMNCPaint(var Message: TMessage);
begin
  inherited;
end;procedure TUsrMemo.CNCtlColorEdit(var Message: TWMCtlColorEdit);
begin
  inherited;
  if FTransparent then
    SetBkMode(Message.ChildDC, 1);
end;procedure TUsrMemo.CNCtlColorStatic(var Message: TWMCtlColorStatic);
begin
  inherited;
  if FTransparent then
    SetBkMode(Message.ChildDC, 1);
end;
procedure TUsrMemo.CMParentColorChanged(var Message: TMessage);
begin
  inherited;
  if FTransparent then
    Invalidate;
end;procedure TUsrMemo.WMSize(var Message: TWMSize);
begin
  inherited;
  Invalidate;
end;procedure TUsrMemo.WMMove(var Message: TWMMove);
begin
  inherited;
  Invalidate;
end;procedure TUsrMemo.RepaintWindow;
var
  DC: hDC;
  TmpBitmap, Bitmap: hBitmap;
begin
  if FTransparent then
  begin
    FPainting := true;
    HideCaret(Handle);
    DC := CreateCompatibleDC(GetDC(Handle));
    TmpBitmap := CreateCompatibleBitmap(GetDC(Handle), Succ(ClientWidth), Succ(ClientHeight));
    Bitmap := SelectObject(DC, TmpBitmap);
    PaintTo(DC, 0, 0);
    BitBlt(GetDC(Handle), BorderRec[BorderStyle], BorderRec[BorderStyle], ClientWidth, ClientHeight, DC, 1, 1,
      SRCCOPY);
    SelectObject(DC, Bitmap);
    DeleteDC(DC);
    ReleaseDC(Handle, GetDC(Handle));
    DeleteObject(TmpBitmap);
    ShowCaret(Handle);
    FPainting := false;
  end;
end;procedure TUsrMemo.Change;
begin
  RepaintWindow;
  inherited Change;
end;procedure TUsrMemo.SetParent(AParent: TWinControl);
begin
  inherited SetParent(AParent);
end;function TUsrMemo.GetTextLayout: TTextLayout;
begin
  Result := FTextLayout;
end;procedure TUsrMemo.SetTextLayout(Value:TTextLayout); //Layout属性
begin
  FTextLayout:=Value;
  DrawText;
end;function TUsrMemo.GetMemoText: string;
begin
  Result :=Trim(Text);
end;procedure TUsrMemo.DrawText;     //垂直对齐
var
  Rct: TRect;
  YOffset:integer;
  Text:string;
begin
  Text :=GetMemoText;
  case FTextLayout of
    tlTop: YOffset := 0;
    tlCenter: YOffset := (ClientHeight - Canvas.TextHeight(Text)) div 2 + 1;
    tlBottom: YOffset := ClientHeight - Canvas.TextHeight(Text);
  else
    YOffset := 0;
  end;
  Rct:=Rect(0,0,ClientWidth,ClientHeight);
  Canvas.TextRect(Rct,0,YOffset,Text);       
end;end.

Answer 8

自已再顶!
    memo的垂直对齐啊?高手在哪里啊?