Własny komponent - Kalendarz (transparent)

Witam!
Piszę własny kalendarz oparty na TCustomGrid kalendarz w pełni działa ale zacząłem pisać Transparent dla niego i mi całkiem nie wychodzi :/
Próbowałem kilku sposobów i nic, szukałem i nic nie znalazłem :/
Chcę mieć obrazek pod kalendarzem cos jak KalendarzXP
Prosze Was o pomoc! Może znacie jakiś sposób :)
Pozdrawiam i udostępniam kod mojego komponentu:

unit KoloSoft;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, ComCtrls, Grids;

type
  TDayOfWeek = 0..6;

  TKSCalendar = class(TCustomGrid)
  private
    FColorNie: TColor;
    FColorNieBool: Boolean;
    FDate: TDateTime;
    FMonthOffset: Integer;
    FOnChange: TNotifyEvent;
    FPainting: Boolean;	
    FReadOnly: Boolean;
    FStartOfWeek: TDayOfWeek;
    FTransparent: Boolean;	
    FUpdating: Boolean;
    FUseCurrentDate: Boolean;
    function GetCellText(ACol, ARow: Integer): string;
    function GetDateElement(Index: Integer): Integer;
    procedure SetCalendarDate(Value: TDateTime);
    procedure SetDateElement(Index: Integer; Value: Integer);
    procedure SetStartOfWeek(Value: TDayOfWeek);
    procedure SetUseCurrentDate(Value: Boolean);	
    function StoreCalendarDate: Boolean;
    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;	
  protected
    procedure RepaintWindow;
    procedure Change; dynamic;
    procedure ChangeMonth(Delta: Integer);
    procedure Click; override;
    function DaysPerMonth(AYear, AMonth: Integer): Integer; virtual;
    function DaysThisMonth: Integer; virtual;
    procedure DrawCell(ACol, ARow: Longint; ARect: TRect; AState: TGridDrawState); override;
    function IsLeapYear(AYear: Integer): Boolean; virtual;
    function SelectCell(ACol, ARow: Longint): Boolean; override;
    procedure WMSize(var Message: TWMSize); message WM_SIZE;
  public
    constructor Create(AOwner: TComponent); override;
    property CalendarDate: TDateTime  read FDate write SetCalendarDate stored StoreCalendarDate;
    property CellText[ACol, ARow: Integer]: string read GetCellText;
    procedure NextMonth;
    procedure NextYear;
    procedure PrevMonth;
    procedure PrevYear;
    procedure UpdateCalendar; virtual;
  published
    property Align;
    property Anchors;
    property BorderStyle;
    property Color;
    property ColorNie:TColor read FColorNie write FColorNie default clBlack;
    property Constraints;
    property Ctl3D;
    property Day: Integer index 3  read GetDateElement write SetDateElement stored False;
    property DragCursor;
    property DragKind;
    property DragMode;
    property Enabled;
    property FixedColor;
    property FixedCols;
    property Font;
    property GridLineWidth;
    property Month: Integer index 2  read GetDateElement write SetDateElement stored False;
    property Options; 
    property ParentColor;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ReadOnly: Boolean read FReadOnly write FReadOnly default False;
    property RowCount;
    property ShowHint;
    property StartOfWeek: TDayOfWeek read FStartOfWeek write SetStartOfWeek;
    property TabOrder;
    property TabStop;
    property UseCurrentDate: Boolean read FUseCurrentDate write SetUseCurrentDate default True;
    property ColorNieBool: boolean read FColorNieBool write FColorNieBool default FALSE;
    property Transparent: Boolean read FTransparent write SetTransparent default false;	
    property Visible;
    property Year: Integer index 1  read GetDateElement write SetDateElement stored False;
    property OnClick;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDock;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnStartDock;
    property OnStartDrag;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('KoloSoft Components', [TKSCalendar]);
end;

constructor TKSCalendar.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  { defaults }
  FUseCurrentDate := True;
  BorderStyle := bsNone;
  ColorNieBool := FALSE;
  FixedCols := 0;
  FixedRows := 1;
  Height := 97;
  Width:= 147;
  ColCount := 7;
  RowCount := 7;
  ScrollBars := ssNone;
  StartOfWeek := 1;
  Options := Options - [goRangeSelect] + [goDrawFocusSelected];
  FDate := Date;
  FTransparent := false;
  FPainting := false;   
  UpdateCalendar;
end;

procedure TKSCalendar.Change;
begin
  if Assigned(FOnChange) then FOnChange(Self);
   RepaintWindow;
 Change;
end;

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

procedure TKSCalendar.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 TKSCalendar.WMPaint(var Message: TWMPaint);
begin
 inherited;
 if FTransparent then
 if not FPainting then
 RepaintWindow;
end;

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

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

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

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

procedure TKSCalendar.Click;
var
  TheCellText: string;
begin
  inherited Click;
  TheCellText := CellText[Col, Row];
  if TheCellText <> '' then Day := StrToInt(TheCellText);
end;

procedure TKSCalendar.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;

function TKSCalendar.IsLeapYear(AYear: Integer): Boolean;
begin
  Result := (AYear mod 4 = 0) and ((AYear mod 100 <> 0) or (AYear mod 400 = 0));
end;

function TKSCalendar.DaysPerMonth(AYear, AMonth: Integer): Integer;
const
  DaysInMonth: array[1..12] of Integer = (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31);
begin
  Result := DaysInMonth[AMonth];
  if (AMonth = 2) and IsLeapYear(AYear) then Inc(Result); { leap-year Feb is special }
end;

function TKSCalendar.DaysThisMonth: Integer;
begin
  Result := DaysPerMonth(Year, Month);
end;

procedure TKSCalendar.DrawCell(ACol, ARow: Longint; ARect: TRect; AState: TGridDrawState);
var
  TheText: string;
begin
  TheText := CellText[ACol, ARow];
  with ARect, Canvas do
    TextRect(ARect, Left + (Right - Left - TextWidth(TheText)) div 2,
      Top + (Bottom - Top - TextHeight(TheText)) div 2, TheText);
end;

function TKSCalendar.GetCellText(ACol, ARow: Integer): string;
var
  DayNum: Integer;
begin
  if ARow = 0 then
    Result := ShortDayNames[(StartOfWeek + ACol) mod 7 + 1]
  else
  begin
    DayNum := FMonthOffset + ACol + (ARow - 1) * 7;
    if (DayNum < 1) or (DayNum > DaysThisMonth) then Result := ''
    else Result := IntToStr(DayNum);
  end;
end;

function TKSCalendar.SelectCell(ACol, ARow: Longint): Boolean;
begin
  if ((not FUpdating) and FReadOnly) or (CellText[ACol, ARow] = '') then
    Result := False
  else Result := inherited SelectCell(ACol, ARow);
end;

procedure TKSCalendar.SetCalendarDate(Value: TDateTime);
begin
  FDate := Value;
  UpdateCalendar;
  Change;
end;

function TKSCalendar.StoreCalendarDate: Boolean;
begin
  Result := not FUseCurrentDate;
end;

function TKSCalendar.GetDateElement(Index: Integer): Integer;
var
  AYear, AMonth, ADay: Word;
begin
  DecodeDate(FDate, AYear, AMonth, ADay);
  case Index of
    1: Result := AYear;
    2: Result := AMonth;
    3: Result := ADay;
    else Result := -1;
  end;
end;

procedure TKSCalendar.SetDateElement(Index: Integer; Value: Integer);
var
  AYear, AMonth, ADay: Word;
begin
  if Value > 0 then
  begin
    DecodeDate(FDate, AYear, AMonth, ADay);
    case Index of
      1: if AYear <> Value then AYear := Value else Exit;
      2: if (Value <= 12) and (Value <> AMonth) then AMonth := Value else Exit;
      3: if (Value <= DaysThisMonth) and (Value <> ADay) then ADay := Value else Exit;
      else Exit;
    end;
    FDate := EncodeDate(AYear, AMonth, ADay);
    FUseCurrentDate := False;
    UpdateCalendar;
    Change;
  end;
end;

procedure TKSCalendar.SetStartOfWeek(Value: TDayOfWeek);
begin
  if Value <> FStartOfWeek then
  begin
    FStartOfWeek := Value;
    UpdateCalendar;
  end;
end;

procedure TKSCalendar.SetUseCurrentDate(Value: Boolean);
begin
  if Value <> FUseCurrentDate then
  begin
    FUseCurrentDate := Value;
    if Value then
    begin
      FDate := Date;
      UpdateCalendar;
    end;
  end;
end;

procedure TKSCalendar.ChangeMonth(Delta: Integer);
var
  AYear, AMonth, ADay: Word;
  NewDate: TDateTime;
  CurDay: Integer;
begin
  DecodeDate(FDate, AYear, AMonth, ADay);
  CurDay := ADay;
  if Delta > 0 then ADay := DaysPerMonth(AYear, AMonth)
  else ADay := 1;
  NewDate := EncodeDate(AYear, AMonth, ADay);
  NewDate := NewDate + Delta;
  DecodeDate(NewDate, AYear, AMonth, ADay);
  if DaysPerMonth(AYear, AMonth) > CurDay then ADay := CurDay
  else ADay := DaysPerMonth(AYear, AMonth);
  CalendarDate := EncodeDate(AYear, AMonth, ADay);
end;

procedure TKSCalendar.PrevMonth;
begin
  ChangeMonth(-1);
end;

procedure TKSCalendar.NextMonth;
begin
  ChangeMonth(1);
end;

procedure TKSCalendar.NextYear;
begin
  if IsLeapYear(Year) and (Month = 2) and (Day = 29) then Day := 28;
  Year := Year + 1;
end;

procedure TKSCalendar.PrevYear;
begin
  if IsLeapYear(Year) and (Month = 2) and (Day = 29) then Day := 28;
  Year := Year - 1;
end;

procedure TKSCalendar.UpdateCalendar;
var
  AYear, AMonth, ADay: Word;
  FirstDate: TDateTime;
begin
  FUpdating := True;
  try
    DecodeDate(FDate, AYear, AMonth, ADay);
    FirstDate := EncodeDate(AYear, AMonth, 1);
    FMonthOffset := 2 - ((DayOfWeek(FirstDate) - StartOfWeek + 7) mod 7); { day of week for 1st of month }
    if FMonthOffset = 2 then FMonthOffset := -5;
    MoveColRow((ADay - FMonthOffset) mod 7, (ADay - FMonthOffset) div 7 + 1,
      False, False);
    Invalidate;
  finally
    FUpdating := False;
  end;
end;

procedure TKSCalendar.WMSize(var Message: TWMSize);
var
  GridLines: Integer;
begin
  GridLines := 6 * GridLineWidth;
  DefaultColWidth := (Message.Width - GridLines) div 7;
  DefaultRowHeight := (Message.Height - GridLines) div 7;
end;

end.

Pomoze ktos koledze w potrzebie ?

djkolo napisał(a)

Pomoze ktos koledze w potrzebie ?

Nie wiem, jak Ci pomóc, ostatnio sam pisałem kalendarz, ale nie używałem transparenta.
W prawdzie nie przyglądałem się za bardzo Twojemu kodowi, więc pewnie nie powiem nic odkrywczego.
W OnDrawCell odrysowujesz to w obrębie komórki, co jest pod Twoim komponentem, a na koniec rysujesz na nim napis.

Poza tym czepie się IsLeapYear. Po co przepisywać coś, co już jest w DateUtils? ;)

A pomógłby mi ktoś pomóc w tym OnDrawCell?
Każdą komórkę muszę wypełnić tym co jest pod Kalendarzem?
Jak to zrobić? Nie mam zielonego pojęcia.
Dodam że obrazek nie jest o jednolitym kolorze, jest w formacie *.png
Dodam też że kalendarz nie będzie przesuwany po obrazku co nam ułatwi sprawę,
bo nie będzie trzeba odświeżać komórek.
Największy problem dla mnie stanowi to że nie wiem jak umieścić w komórce X tego co jest pod nią, nie chcę całego pliku *.png dać do komórki bo to by był brak efektu.

Jeszcze raz proszę o pomoc i z góry pozdrawiam!
P.S
Za pomoc w rozwiązaniu problemu jestem w stanie przelać małą kwotę na parę piwek :)

djkolo napisał(a)

A pomógłby mi ktoś pomóc w tym OnDrawCell?

Takie rzeczy robisz, a nie znasz OnDrawCell? :P

Popatrz w helpie, jakie parametry ma OnDrawCell.
Masz m.in. ACol i ARow, czyli konkretną komórkę, która aktualnie jest rysowana.

OnDrawCell jest wywoływane dla KAŻDEJ komórki podczas rysowania. Nawet dla komórek które są fixed.
Tak więc musisz o tym pamiętać.
Z PNG będzie dość spory problem, bo nie wiem, czy Delphi w ogóle obsługuje PNG.

Ale algorytm wygląda mniej więcej tak:

Weź left i top komórki. Masz punkt jakiś. Ten punkt jest względem całego grida zdaje się, a nie komórki(ale to musisz się upewnić) - tak więc ogromny plus.

Następnie musisz wiedzieć jak wielka jest ta komórka.
Czyli znać jej długość i wysokość(to wszystko powinno być w przekazanym w parametrze TRect).

I teraz pobierasz piksel rysunku, który odpowiada pikselowi twojej komórki i rysujesz go w komórce.

Tak to wygląda mniej więcej.

Być może jest prostszy sposób, tzn. po prostu odrysować wszystkie piksele w metodzie Paint.
Ale nie wiem, które będzie lepsze.

Największy problem dla mnie stanowi to że nie wiem jak umieścić w komórce X tego co jest pod nią, nie chcę całego pliku *.png dać do komórki bo to by był brak efektu.

No, jak już powiedziałem, robisz to piksel po pikselu :)

Tylko, no... z png możesz mieć ogromne problemy, bo nie wiem, czy i jak Delphi to obsługuje, więc pewnie musiałbyś mieć jakąś klasę, która je ładnie obsłuży.
Najlepiej będzie testować to na zwykłej bitmapie, a dopiero potem, jak będzie już działało myśleć o png.

do png jest specjalny unit - pngimage, tylko trzeba poszukać, bo o niego trudno.

PNG mi sie samo zainstalowało przy instalacji komponentów "Omega 0.93".
Z *.png nie mam problemu w programach,
Spisuje sie bardzo dobrze, mało zajmuje, za to bitmapy bardzo dużo.
W razie "W" mogę komuś podesłać :)
Nie znam sie na OnDrawCell, zawszę próbowałem szukać innego rozwiązania niż rysowanie po komponencie, mam nie ufność do kompilatora jak i do swoich aplikacji przykład (if Button.Enabled then) ja dodaje np (=True) bo co wtedy jak program pomysli inaczej? Jestem tak przyzwyczajony :), ale to nie ten temat.

Szukałem zastępczego komponentu, nie znalazłem, ale znalazłem za to kod oparty na DBGrids

procedure TForm1.DBGrid1DrawDataCell(Sender: TObject; const Rect: TRect;
Field: TField; State: TGridDrawState);
var
Text: string;
Rct: TRect;
begin
Text := Field.AsString;
Rct:= Rect;

BitBlt(DBGrid1.Canvas.handle,
Rct.left,
Rct.top,
Rct.right - Rct.left,
Rct.bottom - Rct.top,
Image1.Canvas.Handle,
Rct.left + DBGrid1.Left + Panel1.Left,
Rct.Top + DBGrid1.Top + Panel1.Top,
SRCCOPY);

SetBkModE(DBGrid1.Canvas.Handle, TRANSPARENT);
DBGrid1.Canvas.Font.Style := [fsBold];
DrawtextEx(DBGrid1.Canvas.Handle,
PChar(Text),
Length(Text),
Rct,
DT_WORDBREAK,
nil);
end;

procedure TForm1.Panel1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
ReleaseCapture;
Panel1.Perform(WM_SYSCOMMAND, $F012, SC_MOVE);
Application.ProcessMessages ;

BitBlt(GetDc(Panel1.Handle),
0,
0,
Panel1.Width,
Panel1.Height,
Image1.Canvas.Handle ,
Panel1.Left, Panel1.Top,
SRCAND);

DBGrid1.refresh;
end; 

Jednak u mnie nie może znaleźć TField
Możesz to sprawdzić u siebie?
Dodam że to jest z przesówaniem komponentu po formie..

[EDIT]
Spróbuje coś wykompinować używając tego kodu..
Będę korzystał ze zwykłego Grida, pozniej sobie do do komponentu wrzucę (jeżeli coś wymyślimy :)), ponieważ nie umieściłem OnDrawCell jest tylko DrawCell w kodzie , ale nie będę co chwile kompilował komponentu by sprawdzić czy działa.

[EDIT2]
Pierwszy błąd (wymagana bitmapa)
(Jednak zaczniemy na bitmapach, z czasem dojdzie sie do PNG)
Błąd w linijce
BitBlt(DrawGrid1.Canvas.handle,
[EDIT3]
Rozwiązałem swój problem :)
ale jak z jednego problemu tworzy się następny,
transparent juz dziala, ale muszę udoskonalić kod, bo:

• obrazek jest przesunięty (za bardzo w lewo i do gory)
• maly problem z wyświetlaniem tekstu
  Z tym już sobię chyba poradzę :)
  Dzięki Wam chłopaki za pomoc!

djkolo napisał(a)

komponencie, mam nie ufność do kompilatora jak i do swoich aplikacji przykład (if Button.Enabled then) ja dodaje np (=True) bo co wtedy jak program pomysli inaczej? Jestem tak przyzwyczajony :)

Też byłem, ale po co se utrudniać robotę? To jest zwykła logika synu.
Kiedyś też stosowałem dla zwrócenia rezultatu wszędzie ify zamiast np:

result:=((a>0) or (b>5));

:)

Jednak u mnie nie może znaleźć TField
Możesz to sprawdzić u siebie?

Nie mogę, bo to jasne.
TField jest związany z bazami danych, a więc m.in. z komponentem DBGrid.

TField będzie w pewnym sensie odpowiednikiem ACol.

ponieważ nie umieściłem OnDrawCell jest tylko DrawCell w kodzie , ale nie będę co chwile kompilował komponentu by sprawdzić czy działa.

Człowieku, wiesz jak działają komponenty, jak się je pisze itd? ;)
Najpierw może poczytaj więcej na ten temat.

Po pierwsze DrawCell, to jest metoda, która wywołuje zdarzenie OnDrawCell. Musisz ją przesłonić w swoim komponencie, ale oczywiście nie zapominaj o inherited.

Poza tym, żeby sprawdzić, czy komponent działa nie ma innej możliwości, jak zrobić to w testowym projekcie.
Chociaż, nie, przepraszam. Można jakoś testować komponent bez instalowania go, ale nie wiem jak to zrobić. Musiałbyś poszukać.

transparent juz dziala, ale muszę udoskonalić kod, bo:

• obrazek jest przesunięty (za bardzo w lewo i do gory)

Bo pewnie rysujesz od punktu (0,0) grida. A powinieneś pominąć komórki, które są fixed(Szare)

Wiem ze TField jest zwiazany z DB, :)
ale mam cos nie tak bo jak mialem DBGrid na formie samo
to nie chciało mi sie skompilować.

Z komponentem chodzilo mi o to ze nie chce go teraz modyfikować,
najpierw udoskonale kod a pozniej sie tym zajmę :)
od punktu 0,0 mi zle wyswietla zrobiłem tak i jest dobrze

. . .
  BitBlt(DrawGrid1.Canvas.handle,
         Rct.left,
         Rct.top,
         Rct.right - Rct.left,
         Rct.bottom - Rct.top,
         Image1.Canvas.Handle,
         Rct.left + DrawGrid1.Left - 8,
         Rct.Top + DrawGrid1.Top - 8,
         SRCCOPY);
. . .

Rozwiązałem problem z *.png, mogę już z tego korzystać, był dosyć prosty

var
PNG: TPNGObject;
begin
PNG := TPNGObject.Create;
try
PNG.LoadFromFile('C:\skin.png');
PNG.AssignTo(Image1.Picture.Bitmap);
finally
PNG.Free;
end;