@karpov - narzekasz, że znajdujesz tylko opisy, a żadnego kodu, który by implementował przeciąganie i upuszczanie własnych, wirtualnych elementów, znajdujących się na jednym, ręcznie obsługiwanym komponencie; Napisałem więc prostą aplikację, która taką rzecz posiada; Kodu wyszło za dużo, aby wkleić go do posta, więc wrzucam tu same nagłówki, a cały projekt dorzucam w załączniku rectangles.zip
Wspomniane nagłówki:
type
TAreaPositionKind = (apkLeft, apkTop);
TAreaDimensionKind = (adkWidth, adkHeight);
type
TAreaPosition = array [TAreaPositionKind] of Integer;
TAreaDimensions = array [TAreaDimensionKind] of Integer;
type
TArea = record
Position: TAreaPosition;
Dimensions: TAreaDimensions;
end;
type
TRectangleObject = class;
type
TRectangleDragInfo = record
Dragging: Boolean;
RectangleObj: TRectangleObject;
CursorPos: TPoint;
Diff: TPoint;
end;
type
TRectangleObject = class(TObject)
private
FArea: TArea;
FColor: TColor;
private
function GetPosition(AKind: TAreaPositionKind): Integer;
function GetDimension(AKind: TAreaDimensionKind): Integer;
private
procedure SetPosition(AKind: TAreaPositionKind; APosition: Integer);
procedure SetDimension(AKind: TAreaDimensionKind; ADimension: Integer);
private
procedure SetColor(AColor: TColor);
public
constructor Create(AArea: TArea; AColor: TColor); overload;
constructor Create(ALeft, ATop, AWidth, AHeight: Integer; AColor: TColor); overload;
public
function ClipRect(): TRect;
public
property Left: Integer index apkLeft read GetPosition write SetPosition;
property Top: Integer index apkTop read GetPosition write SetPosition;
property Width: Integer index adkWidth read GetDimension write SetDimension;
property Height: Integer index adkHeight read GetDimension write SetDimension;
property Color: TColor read FColor write SetColor;
end;
type
TRectanglesList = class(TObject)
private
FList: TObjectList;
private
function GetItem(AIndex: Integer): TRectangleObject;
procedure SetItem(AIndex: Integer; ARectangleObject: TRectangleObject);
private
function GetItemsCount(): Integer;
public
constructor Create();
destructor Destroy(); override;
public
procedure Add(ARectangleObject: TRectangleObject);
procedure Delete(AIndex: Integer);
public
function RectangleAtPoint(APoint: TPoint): Integer;
public
property Items[AIndex: Integer]: TRectangleObject read GetItem write SetItem; default;
property ItemsCount: Integer read GetItemsCount;
end;
type
TPaintBox = class(ExtCtrls.TPaintBox)
private
FRectangles: TRectanglesList;
FDragInfo: TRectangleDragInfo;
protected
procedure WMLButtonDown(var AMessage: TLMLButtonDown); message LM_LBUTTONDOWN;
procedure WMLButtonUp(var AMessage: TLMLButtonUp); message LM_LBUTTONUP;
procedure WMMouseMove(var AMessage: TLMMouseMove); message LM_MOUSEMOVE;
protected
procedure Paint(); override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy(); override;
public
property Rectangles: TRectanglesList read FRectangles;
end;
type
TMainForm = class(TForm)
pbEditor: TPaintBox;
procedure FormCreate(Sender: TObject);
end;
Trochę się zagalopowałem, bo zachciało mi się klepania kodu metodą Bottom Up i zacząłem od podstaw - czyli od prymitywów jak typ TArea
, który można zastąpić typem TRect
; Ale mniejsza z tym - masz wszystko przedstawione; Teraz opiszę po kolei o co chodzi;
Typ TArea
zawiera informacje o położeniu obiektu oraz o jego wymiarach; Zawiera dwie indeksowane enumami macierze liczb, głównie po to, aby wygodnie było napisać akcesory i mutatory dla właściwości obiektu; Te macierze można zamienić po prostu na cztery zmienne, jednak przyczyni się to do spuchnięcia klasy obiektu;
Typ TRectangleDragInfo
zawiera informacje o przeciąganym obiekcie; Dragging
określa czy jakiś obiekt jest przeciągany i jeśli tak, w polu RectangleObj
znajduje się jego referencja; CursorPos
zawiera współrzędne kursora w oknie, a Diff
- te liczby zostają nadane po wciśnięciu LPM i przydają się do obliczeń podczas rysowania na ekranie; Oznaczają odległość w poziomie i pionie, pomiędzy lewym górnym rogiem obiektu a kursorem;
Typ TRectangleObject
zawiera informacje o pojedynczym obiekcie; Jego obszar typu TArea
przechowywany jest w polu FArea
, a kolor ramki w polu FColor
; Pozostała część klasy to konstruktory, destruktor, akcesory i mutatory oraz właściwości - służą do modyfikacji wartości pól oraz pośredniczą w dostępie do nich; W klasie znajduje się metoda ClipRect
- dokonuje ona translacji typu TArea
na TRect
;
Typ TRectanglesList
to wrapper na klasę TObjectList
- służy do przechowywania obiektów typu TRectangleObject
; Ma kilka metod, Add
i Delete
wiadomo do czego służą; RectangleAtPoint
zwraca indeks obiektu z listy, nad którym znajduje się punkt z argumentu; Obiekty sprawdza od końca, aby zachować Z-Order
; Ma też właściwość Items
, która umożliwia dostęp do konkretnego obiektu; Z własnych klas to tyle;
Edytorem jest komponent klasy TPaintBox
; Jak z nagłówka widać, do obsługi myszy nie użyłem jego zdarzeń OnMouseDown
, OnMouseMove
i OnMouseUp
; W zamian za to, skorzystałem z subclassingu i obsługę myszy wbudowałem w standardowy komponent; Dlaczego? Bo mogę bezpośrednio przechwytywać komunikaty, które zawierają m.in. współrzędne myszy w komponencie; Taki PaintBox
zawiera w sobie listę obiektów w polu FRectangles
oraz rekord z informacjami o przeciąganiu w polu FDragInfo
;
Teraz jak działa przeciąganie i upuszczanie:
- Po odebraniu komunikatu
LM_LBUTTONDOWN
sprawdzamy czy pod kursorem znajduje się obiekt, za pomocą metody RectangleAtPoint
; Jeśli jakiś znajduje się, uzupełniamy strukturę FDragInfo
; Pole Dragging
ustawiamy na True, bo rozpoczynamy przeciąganie, następnie do pola RectangleObj
wpisujemy referencję znalezionego obiektu (mamy jego indeks z poprzedniego kroku); Współrzędne kursora wpisujemy do pola CursorPos
; Różnicę współrzędnych kursora i lewego górnego rogu obiektu obliczamy prostym odejmowaniem i wpisujemy do pola Diff
; Ostatnim krokiem jest zmiana kursora na crDrag
i wywołanie metody Invalidate
, która wykona "bezpieczne" przemalowanie komponentu;
- Obsługa komunikatu
LM_MOUSEMOVE
wymaga sprawdzenia, czy obiekt w danej chwili jest przeciągany; Jeśli nie jest - nic nie robimy; Natomiast jeśli przeciągany jest obiekt, to wykonujemy dwa kroki - do pola CursorPos
wpisujemy aktualne współrzędne kursora, pobrane z parametru AMessage
oraz wywołujemy Invalidate
w celu przemalowania komponentu;
- Po odebraniu komunikatu
LM_LBUTTONUP
musimy sprawdzić, czy obiekt jest przesuwany (to ważne, bo kliknąć można na pusty obszar komponentu i nic się nie powinno dziać); Jeśli obiekt jest przeciągany, musimy to przeciąganie zakończyć; Aktualizujemy pozycję obiektu, wpisując nowe wartości do RectangleObj.Left
i RectangleObj.Top
, używając pól CursorPos
i Diff
; Dzięki temu obiekt można przesuwać o pojedynczy piksel, a samo przeciąganie jest zgodne z położeniem kursora - nic nie przeskakuje; Pozostałe kroki to wpisanie False do pola Dragging
, bo przeciąganie dobiegło końca, przywrócenie kursora oraz przemalowanie komponentu;
- Malowanie komponentu jest dość proste - najpierw wypełnienie tła kolorem białym, następnie namalowanie w pętli wszystkich obiektów (od pierwszego do ostatniego, aby ten o najwyższym indeksie był na samej górze); Ostatnim krokiem jest sprawdzenie, czy obiekt jest przeciągany i jeśli jest, obliczamy jego nowy obszar na podstawie informacji ze struktury
FDragInfo
oraz rysujemy standardową ramkę fokusa metodą DrawFocusRect
; Efekt jest dokładnie taki sam, jak w oknie eksploratora Windows, gdy pokazywanie zawartości podczas przeciągania jest wyłączone;
To w sumie tyle; Niestety kod pisałem na szybko, bo mało czasu miałem, więc niektóre elementy wymagają uzupełnienia; Na przykład metody TRectanglesList.Add
i TRectanglesList.Delete
powinny wywoływać Invalidate
; Wymaga też dodania kilku zabezpieczeń, np. przed przesunięciem obiektu poza formularz; Ale mniejsza o to - to kod testowy, nie produkcyjny; Do tego pisany na pałę :]
Jeżeli taki efekt przeciągania Cię nie satysfakcjonuje, bo wolałbyś aktualizowanie zawartości na bieżąco zamiast ramki fokusa, to kod trzeba będzie lekko zmodyfikować; W każdym razie sam kod działa na tyle szybko, że interfejs nie miga, mimo nieużywania podwójnego buforowania; Podejrzewam, że przesuwanie fragmentów obrazu 24-bitowego także będzie działać szybko;
No, to tyle; W razie czego pytaj, a postaram się coś poradzić.