VPF::Использование фонового рисунка в Memo

DYUMON

Дата 19.2.2007, 19:43 (ссылка)

(нет голосов)

Загрузка ...

Опытный

Профиль
Группа: Участник
Сообщений: 321
Регистрация: 17.6.2006
Где: Новосибирск

Репутация: нет
Всего: 3

Я хочу в memo в качестве фона вставить рисунок .Конечно бегущие зелёные строчки на черном фоне красиво. но мне хочется чтоб они бежали на фоне фота вселенной.

--------------------

Всех программистов надо посадить на целероны, что бы впредь головой думали что пишут.

Alexeis

Дата 19.2.2007, 20:37 (ссылка)

(нет голосов)

Загрузка ...

Амеба

Профиль
Группа: Админ
Сообщений: 11743
Регистрация: 12.10.2005
Где: Зеленоград

Репутация: 109
Всего: 459

Зря создавал тему. Вот тут почти такая же http://forum.vingrad.ru/index.php?showtopic=136301 и в самом верху раздела.

--------------------

Vit вечная память.

Обсуждение действий администрации форума производятся только в этом форуме

гениальность идеи состоит в том, что ее невозможно придумать

Sunvas

Дата 19.2.2007, 20:41 (ссылка)

(нет голосов)

Загрузка ...

Соль и сахар

Профиль
Группа: Участник
Сообщений: 3388
Регистрация: 12.3.2006
Где: Тосно

Репутация: 28
Всего: 89

Набросал. Можете критиковать. smile

Код


unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls;
      type
 TMemo = class(stdctrls.TMemo)
  private
    procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
protected
procedure Change; override;
    public
        function TopLine: Integer;    
    function VisibleLines: Integer;
  end;

  TForm1 = class(TForm)
    Memo1: TMemo;
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

function TMemo.TopLine: Integer;
begin
  Result := SendMessage(Self.Handle, EM_GETFIRSTVISIBLELINE, 0, 0);
end;

procedure TMemo.Change;    
begin
  Invalidate;
  inherited Change;
end;

function TMemo.VisibleLines: Integer;
begin
  Result := Height div (Abs(Self.Font.Height) + 2);
end;

procedure TMemo.WMPaint(var Message: TWMPaint);
var
  PS: TPaintStruct;
  DC: HDC;
  Canvas: TCanvas;
  i: Integer;
  X, Y: Integer;
  OldColor: TColor;
  Size: TSize;
  Max: Integer;
  s, Palabra, PrevWord: string;
begin
  DC := Message.DC;
  if DC = 0 then DC := BeginPaint(Handle, PS);
  Canvas := TCanvas.Create;
  try
    OldColor         := Font.Color;
    Canvas.Handle    := DC;
    Canvas.Font.Name := Font.Name;
    Canvas.Font.Size := Font.Size;
    with Canvas do
    begin
      Max := TopLine + VisibleLines;
      if Max > Pred(Lines.Count) then Max := Pred(Lines.Count);
      Brush.Color := Self.Color;
      FillRect(Self.ClientRect);
      brush.Style:=bsclear;
      Draw(0, 1, Application.Icon);
      Y := 1;
      for i := TopLine to Max do
      begin
        X := 2;
        s := Lines[i];
        TextOut(X, Y, s);
          GetTextExtentPoint32(DC, PChar(s), Length(s), Size);
          Inc(X, Size.cx);
          Font.Color := clBlack;
        Inc(Y, Size.cy);
        end;
    end;
  finally
    if Message.DC = 0 then EndPaint(Handle, PS);
  end;
  Canvas.Free;
  inherited;
end;
{$R *.dfm}

end.

--------------------

Воспитывая детей по своему образу и подобию, родители почему-то надеются, что они будут лучше их.

0LineGate

Дата 19.2.2007, 22:48 (ссылка)

(нет голосов)

Загрузка ...

Бывалый

Профиль
Группа: Участник
Сообщений: 176
Регистрация: 17.2.2007
Где: Россия, Тула

Репутация: 2
Всего: 2

2 Sunvas
Ееее! smile

Ит'c ворк! smile

Кул!

Респект и уважуха! smile

Yanis

Дата 20.2.2007, 12:26 (ссылка)

(нет голосов)

Загрузка ...

Эксперт

Профиль
Группа: Участник Клуба
Сообщений: 2937
Регистрация: 9.2.2004
Где: Москва

Репутация: 72
Всего: 111

Вроде без глюков...

Код

unit TransMem;

interface

uses
  SysUtils, Classes, Controls, StdCtrls, Windows, Messages, Forms;

type
  TCrackWinControl = class(TWinControl);

  TTransparentMemo = class(TMemo)
  private
    FAlignText: TAlignment;
    FTransparent: Boolean;
    FPainting: Boolean;
    procedure SetAlignText(Value: TAlignment);
    procedure SetTransparent(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;
  protected
    procedure RepaintWindow;
    procedure CreateParams(var Params: TCreateParams); override;
    procedure Change; override;
    procedure SetParent(AParent: TWinControl); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property AlignText: TAlignment read FAlignText write SetAlignText default taLeftJustify;
    property Transparent: Boolean read FTransparent write SetTransparent default False;
  end;

procedure Register;

implementation

const
 BorderRec: array[TBorderStyle] of Integer = (1, -1);

procedure Register;
begin
  RegisterComponents('Samples', [TTransparentMemo]);
end;

{ TTransparentMemo }

constructor TTransparentMemo.Create(AOwner: TComponent);
begin
 inherited Create(AOwner);
 FAlignText := taLeftJustify;
 FTransparent := False;
 FPainting := False;
end;

destructor TTransparentMemo.Destroy;
begin
 inherited Destroy;
end;

procedure TTransparentMemo.SetAlignText(Value: TAlignment);
begin
 if FAlignText <> Value then
   begin
    FAlignText := Value;
    RecreateWnd;
    Invalidate;
   end;
end;

procedure TTransparentMemo.SetTransparent(Value: Boolean);
begin
 if FTransparent <> Value then
   begin
    FTransparent := Value;
    Invalidate;
   end;
end;

procedure TTransparentMemo.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 := ClientOrigin;
       Windows.ScreenToClient(Parent.Handle, p);
       p.x := -p.x;
       p.y := -p.y;
       MoveWindowOrg(DC, p.x, p.y);
       SendMessage(Parent.Handle, $0014, DC, 0);
       TCrackWinControl(Parent).PaintControls(DC, nil);
       RestoreDC(DC, i);
      end;
   end else inherited;
end;

procedure TTransparentMemo.WMPaint(var Message: TWMPaint);
begin
 inherited;
 if FTransparent then
 if not FPainting then
 RepaintWindow;
end;

procedure TTransparentMemo.WMNCPaint(var Message: TMessage);
begin
 inherited;
end;

procedure TTransparentMemo.CNCtlColorEdit(var Message: TWMCtlColorEdit);
begin
 inherited;
 if FTransparent then
 SetBkMode(Message.ChildDC, 1);
end;

procedure TTransparentMemo.CNCtlColorStatic(var Message: TWMCtlColorStatic);
begin
 inherited;
 if FTransparent then
 SetBkMode(Message.ChildDC, 1);
end;

procedure TTransparentMemo.CMParentColorChanged(var Message: TMessage);
begin
 inherited;
 if FTransparent then
 Invalidate;
end;

procedure TTransparentMemo.WMSize(var Message: TWMSize);
begin
 inherited;
 Invalidate;
end;

procedure TTransparentMemo.WMMove(var Message: TWMMove);
begin
 inherited;
 Invalidate;
end;

procedure TTransparentMemo.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 TTransparentMemo.CreateParams(var Params: TCreateParams);
const
 Alignments: array [TAlignment] of DWord = (ES_LEFT, ES_RIGHT, ES_CENTER);
begin
 inherited CreateParams(Params);
 Params.Style := Params.Style or ES_MULTILINE or Alignments[FAlignText];
end;

procedure TTransparentMemo.Change;
begin
 RepaintWindow;
 inherited Change;
end;

procedure TTransparentMemo.SetParent(AParent: TWinControl);
begin
 inherited SetParent(AParent);
end;

end.

Это сообщение отредактировал(а) Yanis - 20.2.2007, 12:27

Присоединённый файл ( Кол-во скачиваний: 62 )

transmemo.JPG 44,17 Kb

--------------------

*щёлк*

MetalFan

Дата 20.2.2007, 12:35 (ссылка)

(нет голосов)

Загрузка ...

Аццкий Сотона

Профиль
Группа: Комодератор
Сообщений: 3815
Регистрация: 2.10.2006
Где: Moscow

Репутация: 62
Всего: 128

Цитата(Yanis @ 20.2.2007, 12:26

)

DC := CreateCompatibleDC(GetDC(Handle));
TmpBitmap := CreateCompatibleBitmap(GetDС(Handle), Succ(ClientWidth), Succ(ClientHeight));

вай-вай!
брать - берем, а отдавать кто будет??
а вот эта строка:

Цитата(Yanis @ 20.2.2007, 12:26

)

ReleaseDC(Handle, GetDC(Handle));

вообще странно выглядит...

Это сообщение отредактировал(а) MetalFan - 20.2.2007, 12:38

--------------------

There are always someone smarter than you...

Yanis

Дата 20.2.2007, 12:42 (ссылка)

(нет голосов)

Загрузка ...

Эксперт

Профиль
Группа: Участник Клуба
Сообщений: 2937
Регистрация: 9.2.2004
Где: Москва

Репутация: 72
Всего: 111

Цитата(MetalFan @ 20.2.2007, 13:35

)

вай-вай!

Код столетней давности. Откуда-то я его выдирал...
Но исправлять видимо придётся мне smile

Добавлено @ 12:48
MetalFan
Так, собственно, что именно не устраивает? smile

--------------------

*щёлк*

dumb

Дата 20.2.2007, 14:22 (ссылка)

(нет голосов)

Загрузка ...

sceloglauxalbifacies

Профиль
Группа: Экс. модератор
Сообщений: 2929
Регистрация: 16.6.2006

Репутация: 13
Всего: 158

Yanis,

Код


hDC := GetDC(Handle);
...
ReleaseDC(Handle, hDC);

Yanis

Дата 20.2.2007, 14:26 (ссылка)

(нет голосов)

Загрузка ...

Эксперт

Профиль
Группа: Участник Клуба
Сообщений: 2937
Регистрация: 9.2.2004
Где: Москва

Репутация: 72
Всего: 111

Цитата(dumb @ 20.2.2007, 15:22

)

hDC := GetDC(Handle);
...
ReleaseDC(Handle, hDC);

И что? DC какого-либо окна всегда одинаков и будет равен GetDC(Handle) (в контексте нашего потока). Не вижу смысла в его сохранении.

Добавлено @ 14:28
Я понимаю, что вы хотите, что бы я сделал так:

Код

procedure TTransparentMemo.RepaintWindow;
var
 DC, hMemDC: hDC;
 TmpBitmap, Bitmap: hBitmap;
begin
 if FTransparent then
   begin
    hMemDC := GetDC(Handle);
    FPainting := True;
    HideCaret(Handle);
    DC := CreateCompatibleDC(hMemDC);
    TmpBitmap := CreateCompatibleBitmap(hMemDC, Succ(ClientWidth), Succ(ClientHeight));
    Bitmap := SelectObject(DC, TmpBitmap);
    PaintTo(DC, 0, 0);
    BitBlt(hMemDC, BorderRec[BorderStyle], BorderRec[BorderStyle], ClientWidth, ClientHeight, DC, 1, 1, SRCCOPY);
    SelectObject(DC, Bitmap);
    DeleteDC(DC);
    ReleaseDC(Handle, hMemDC);
    DeleteObject(TmpBitmap);
    ShowCaret(Handle);
    FPainting := False;
   end;
end;

Только это ровным счётом ничего не меняет smile

--------------------

*щёлк*

Igor_thief

Дата 20.2.2007, 17:12 (ссылка)

(нет голосов)

Загрузка ...

Шустрый

Профиль
Группа: Участник
Сообщений: 112
Регистрация: 12.9.2006
Где: Украина

Репутация: нет
Всего: нет

Цитата(Sunvas @ 19.2.2007, 19:41)

Набросал. Можете критиковать. smile

Спасибо! Нашел для себя кое что интерессное в твоем коде.

Код можно было бы и почистить (есть переменные которые не используются). Также не обрабатывается выделение текста (некрасиво выглядит это дело когда текст выделен). Ну и скриншоты надо делать smile

Ну ты сам просил критиковать.

В любом случае - сапсибо! Молодец.

Yanis
Спасибо!

Это сообщение отредактировал(а) Igor_thief - 20.2.2007, 17:19

--------------------

В каждом из нас спит гений, и с каждым днем все крепче ...delphigeek.blogspot.com | www.iskomorokh.com

Sunvas

Дата 20.2.2007, 18:17 (ссылка)

(нет голосов)

Загрузка ...

Соль и сахар

Профиль
Группа: Участник
Сообщений: 3388
Регистрация: 12.3.2006
Где: Тосно

Репутация: 28
Всего: 89

Цитата(Igor_thief @ 20.2.2007, 17:12

)

Также не обрабатывается выделение текста (некрасиво выглядит это дело когда текст выделен).

А как оно выглядит? У меня нормально. Текст выделяется сплошной синей полосой.

Цитата(Igor_thief @ 20.2.2007, 17:12

)

Ну ты сам просил критиковать.

Уж как набросал. smile

--------------------

Воспитывая детей по своему образу и подобию, родители почему-то надеются, что они будут лучше их.

DYUMON

Дата 20.2.2007, 21:27 (ссылка)

(нет голосов)

Загрузка ...

Опытный

Профиль
Группа: Участник
Сообщений: 321
Регистрация: 17.6.2006
Где: Новосибирск

Репутация: нет
Всего: 3

Народ СПАСИБО но смущает одно но! У меня в самой программе кода меньше чем вы здесь накатали! smile

--------------------

Всех программистов надо посадить на целероны, что бы впредь головой думали что пишут.

Sunvas

Дата 20.2.2007, 21:46 (ссылка)

(голосов:1)

Загрузка ...

Соль и сахар

Профиль
Группа: Участник
Сообщений: 3388
Регистрация: 12.3.2006
Где: Тосно

Репутация: 28
Всего: 89

DYUMON, я же токо пример дал. А что ты там в своей программе использовал - дело целиком и полностью твое. Если хочешь - можешь поделиться, нет - ставь галочку "Вопрос решен".

--------------------

Воспитывая детей по своему образу и подобию, родители почему-то надеются, что они будут лучше их.

DYUMON

Дата 20.2.2007, 23:03 (ссылка)

(нет голосов)

Загрузка ...

Опытный

Профиль
Группа: Участник
Сообщений: 321
Регистрация: 17.6.2006
Где: Новосибирск

Репутация: нет
Всего: 3

Я не о том. Я о том что у меня в программе рабочего кода меньше . А здесь ты показал как лучше картинку в memo засунуть (за что отдельное спасибо ). Но для этого многовата будет этого кода.
я за минимализм. а не проще будет сделать в memo фон прозрачным а на задний фон картинку кинуть???

--------------------

Всех программистов надо посадить на целероны, что бы впредь головой думали что пишут.

Yanis

Дата 21.2.2007, 09:02 (ссылка)

(нет голосов)

Загрузка ...

Эксперт

Профиль
Группа: Участник Клуба
Сообщений: 2937
Регистрация: 9.2.2004
Где: Москва

Репутация: 72
Всего: 111

Цитата(DYUMON @ 21.2.2007, 00:03

)

я за минимализм. а не проще будет сделать в memo фон прозрачным а на задний фон картинку кинуть???

Это как раз мой вариант. Новый контрол, на основе TMemo, который умеет быть прозрачным.

--------------------

*щёлк*

Alexeis

Дата 21.2.2007, 10:45 (ссылка)

(нет голосов)

Загрузка ...

Амеба

Профиль
Группа: Админ
Сообщений: 11743
Регистрация: 12.10.2005
Где: Зеленоград

Репутация: 109
Всего: 459

Цитата(Yanis @ 21.2.2007, 09:02

)

Новый контрол, на основе TMemo, который умеет быть прозрачным.

Я протестил его в динамике. Бросил на фору компонент TShape, растянул его так чтобы часть его была под Memo, а часть выступала. Далее по таймеру менял его цвет. Следующим образом

Код


procedure TForm1.tmr1Timer(Sender: TObject);
begin
  shp1.Brush.Color := RGB(Random(256), Random(256), Random(256));
  shp1.Repaint;
  shp1.Refresh;
end;

В результате, все что было за пределами Мемо меняло цвет, а то что внутри не меняло, точнее меняло, но только после нажатия любой клавиши, а без этого нет. И еще, кнопка находящаяся под мемо оказалась также не видимой, точнее невидимой была только та часть которая была под мемо, все что выступало было видно.

--------------------

Sunvas

Дата 21.2.2007, 15:57 (ссылка)

(нет голосов)

Загрузка ...

Соль и сахар

Профиль
Группа: Участник
Сообщений: 3388
Регистрация: 12.3.2006
Где: Тосно

Репутация: 28
Всего: 89

Цитата(Alexeis @ 21.2.2007, 10:45

)

Это уже детали, не думаю что автору нужна настолько высокая функциональность. Ему всего-лишь надо сделать фон у Мемо.

--------------------

Воспитывая детей по своему образу и подобию, родители почему-то надеются, что они будут лучше их.

0 Пользователей читают эту тему (0 Гостей и 0 Скрытых Пользователей)
0 Пользователей:
« Предыдущая тема \| Delphi: Общие вопросы \| Следующая тема »