TMemoの垂直スクロールバー自動表示 (ID:19456)

名前

ホームページ(ブログ、Twitterなど)のURL (省略可)

本文

うはっ。出遅れた…
既に不要かとは思いますが、コンポーネント作成しました。
この方法ですとグレースクロールバーがほぼ出ません。
WMCharで２バイトチェックしてないのはご愛嬌で。

unit MemoEx;

interface
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls,
  StdCtrls, imm;

type
  TMemoEx = class(TCustomMemo)
  private
    { Private 宣言 }
    siIMEWCharCount:integer;
    siLineHeight   :integer;
    siStopFlag     :boolean;
    procedure siCheckLineHeight;
    procedure siScrollBarsAutoShow(CharCode:Word);
    procedure CMFontChanged(var Msg: TMessage);     message CM_FONTCHANGED;
    procedure WMChar(var Msg: TWMChar);             message WM_CHAR;
    procedure WMImeComposition(var Msg : TMessage); message WM_IME_COMPOSITION;
    procedure WMSize      (var Msg: TWMSize);       message WM_SIZE;
  protected
    procedure KeyUp   (var Key:Word; Shift:TShiftState); override;
  public
    { Public 宣言 }
    constructor Create(AOwner: TComponent); override;
  end;

implementation

{ TMemoEx }

procedure TMemoEx.CMFontChanged(var Msg: TMessage);
begin
  inherited;
  siCheckLineHeight;
end;

constructor TMemoEx.Create(AOwner: TComponent);
begin
  inherited;
  siIMEWCharCount :=0;
  siLineHeight    :=0;
  siCheckLineHeight;
end;

procedure TMemoEx.KeyUp(var Key: Word; Shift: TShiftState);
begin
  inherited;
  siStopFlag:=True;
  case key of
    //本当は他の方法で実装したいけどVK_DELETEがここでしか検出できなかった。
    VK_DELETE:siScrollBarsAutoShow(8);
  end;
  siStopFlag:=False;

end;

procedure TMemoEx.siCheckLineHeight;
var bufBMP:TBitmap;
begin
  //手抜き
  bufBmp:=TBitmap.Create;
  bufBmp.Canvas.Font.Assign(Font);
  siLineHeight:=bufBmp.Canvas.TextHeight('H');
  bufBmp.Free;
end;

procedure TMemoEx.siScrollBarsAutoShow(CharCode:Word);
var
  xPos,i   : Integer;
  LCount : Integer;
begin
  case CharCode of
    13:LCount:=Lines.Count+1;
    else begin
      if (Lines.Text<>'') and (Lines.Text[Length(Lines.Text)-1]=#13) then
        LCount:=Lines.Count+1
        else
        LCount:=Lines.Count;
    end;
  end;
    //+1は微調整 原因不明 orz
    if ((siLineHeight * LCount +1) >= ClientHeight) and
       (ScrollBars = ssNone) then
    begin
      xPos       := SelStart;
      ScrollBars := ssVertical;
      SelStart   := xPos;
      for i:=0 to Lines.Count-1 do
      Perform(EM_SCROLL, SB_VERT, Lines.Count);
      //SendMessage(Handle, EM_SCROLL, SB_LINEDOWN, Lines.Count);
    end
    else
    //+1は微調整 原因不明 orz
    if ((siLineHeight * LCount +1) < ClientHeight)
      and (ScrollBars = ssVertical) then
    begin
      xPos := SelStart;
      ScrollBars := ssNone;
      SelStart   := xPos;
    end;

end;

procedure TMemoEx.WMChar(var Msg: TWMChar);
begin
  inherited;

if siIMEWCharCount>0 then
  begin
    dec(siIMEWCharCount);
    exit;
  end else begin
    siStopFlag:=True;
    siScrollBarsAutoShow(Msg.CharCode);
    siStopFlag:=False;
  end;
end;

procedure TMemoEx.WMImeComposition(var Msg: TMessage);
var
  IMC               : HIMC;
begin
 inherited;

if Msg.lParam and GCS_RESULTSTR <> 0 then
 begin
   IMC := ImmGetContext(Handle);
   if IMC <> 0 then
     siIMEWCharCount:= ImmGetCompositionStringW(IMC, GCS_RESULTSTR, nil, 0) div
                         SizeOf(WideChar) -1;
   ImmReleaseContext(Handle, IMC);
 end;

end;

procedure TMemoEx.WMSize(var Msg: TWMSize);
begin
  inherited;
  if siStopFlag=True then exit;
  siStopFlag:=True;
  siScrollBarsAutoShow(0);
  siStopFlag:=False;
end;

end.

←解決時は質問者本人がここをチェックしてください。

戻る