我需要将滚动添加到组件 - TCustomControl - 但无法使其正常工作。
问题是
- 当我点击滚动条时，它们会消失，除非地图更大并且可以滚动，否则永远不会回来。
- 当我按下/向上箭头或向左/向右箭头时似乎没有正确滚动。
- 拖动滚动标签时不会平滑滚动。
以下是完整的代码，随时可以安装。要测试你只需要创建按钮或一些触发器来增加Hexmap.Columns和Hexmap.Rows。
unit HexMap;
interface
uses
SysUtils,WinTypes,WinProcs,Messages,Classes,IniFiles,vcl.Graphics,vcl.Controls,
vcl.Menus,vcl.Forms,vcl.StdCtrls,vcl.ExtCtrls,System.Types;
type TPointType = (ptRowCol,ptXY); {used in the convertcoords function}
type
THexMap = Class(TCustomControl)
private
FHexColumns:Integer; { Number of columns in the map }
FHexRows :Integer; { Number of rows in the map }
FHexRadius :Integer; { The radius of one hexagon }
Rise :Integer;
FHexShowLabels:Boolean;
FHex3d :Boolean;
FHexColor :TColor;
FLineColor :TColor;
FBackColor :TColor;
FHexMapName:String;
FTStarting :Integer;
TempMap :TBitMap; {used as a drawing surface, before sending to control}
FOffset :TPoint; // X = Horizontal scrollbar position. Y = Vertical scrollbar position.
//scrollbars
procedure WMVScroll(var msg: TWMSCROLL); message WM_VSCROLL;
procedure WMHScroll(var msg: TWMSCROLL); message WM_HSCROLL;
procedure WMGetDlgCode(var msg: TWMGetDlgCode); message WM_GETDLGCODE;
procedure HandleScrollbar(var msg: TWMSCROLL; bar: Integer);
//end
function ClientToMap(X : integer; Y : integer) : TPoint; overload;
function ClientToMap(Pt : TPoint) : TPoint; overload;
function MapToClient(Pt : TPoint) : TPoint;
Function FindRange(Bpoint:TPoint;EPoint:TPoint):Integer;
procedure SetHexColumns(value :Integer);
procedure SetHexRows(Value : Integer);
procedure SetHexRadius(Value : Integer);
procedure SetHexShowLabels(Value :Boolean);
Procedure SetHex3d(Value : Boolean);
Procedure SetHexColor(Value : TColor);
Procedure SetLineColor(Value : TColor);
Procedure SetBackColor(Value : TColor);
Procedure SetTotalStartingLocations(Value : Integer);
procedure MakeSolidMap;
procedure DrawSolidHex(Target:TCanvas; {Canvas to draw hex on }
FillStyle : TBrushStyle;{How to fill hex }
FillColor : TColor; {What color to fill hex }
LineStyle : TPenStyle; {What kind of lines }
LineColor : TColor; {What Color for lines }
x,y,Radius: Integer; {Position and size of hex}
button : boolean); {Hex looks like button? }
procedure DrawSolidHexImage(Target:TCanvas; {Canvas to draw hex on }
FillStyle : TBrushStyle;{How to fill hex }
FillColor : TColor; {What color to fill hex }
FillImage : vcl.Graphics.TBitMap; {What image to fill hex }
LineStyle : TPenStyle; {What kind of lines }
LineColor : TColor; {What Color for lines }
x,y,Radius: Integer; {Position and size of hex}
button : boolean); {Hex looks like button? }
procedure DrawhexOutline(Target:TCanvas;
Linestyle : TPenStyle;{What kind of line }
LineColor : TColor; {What color for lines }
x,y,radius: integer; {Position and size }
button : boolean); {Hex looks like button? }
Protected
{scroll bars}
procedure CreateParams(var params: TCreateParams); override;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
{end}
function ConvertCoords(point:TPoint;pointType:TPointType):TPoint;
Public
constructor Create(AOwner: TComponent); Override;
destructor destroy; OverRide;
Function RangeInHexes(BPoint,EPoint :TPoint) :Integer;
procedure PaintAHex(HexColorWanted :TColor; HexPatternWanted: TBrushStyle; MapLocation: System.Types.TPoint);
Procedure ImageAHex(ImageWanted:vcl.Graphics.TBitMap;HexPatternWanted:TBrushStyle;MapLocation:System.Types.Tpoint);
Procedure StartPosition(Text :string; Position:TPoint);
procedure SaveHexMap(Name : string);
procedure LoadHexMap(Name : string);
Procedure WndProc(var Message: TMessage); override;
function XYtoRowCol(pt : TPoint) : TPoint;
Published
property HexColumns: Integer read FHexColumns write SetHexColumns;
property HexRows: Integer read FHexRows write SetHexRows;
Property HexRadius: Integer read FHexRadius write SetHexRadius;
property HexShowLabels: Boolean read FHexShowLabels Write SetHexShowLabels;
property Hex3d: Boolean read FHex3d write SetHex3d;
Property HexColor : TColor read FHexColor write SetHexColor;
Property LineColor : TColor read FLineColor write SetLineColor;
Property BackColor : TColor read FBackColor write SetBackColor;
Property StartingLocations : Integer read FTStarting write SetTotalStartingLocations;
{inherited properties}
property Align;
property Visible;
property Enabled;
property font;
property DragCursor;
property DragMode;
property OnDragDrop;
property OnDragOver;
property OnEndDrag;
property OnMouseDown;
property OnMouseMove;
property onMouseUp;
property OnClick;
property OnDblClick;
property PopupMenu;
End;
Procedure Register;
implementation
uses
Windows;
const
DEFAULT_MAP_WIDTH = 300;
DEFAULT_MAP_HEIGHT = 250;
{create scroll bars}
procedure Thexmap.CreateParams(var params: TCreateParams);
begin
inherited;
params.Style := params.Style or WS_VSCROLL or WS_HSCROLL;
end;
procedure THexMap.HandleScrollbar(var msg: TWMSCROLL; bar: Integer);
var
si: TScrollInfo;
MaxOffset : TPoint;
begin
msg.result := 0;
si.cbSize := Sizeof(TscrollInfo);
si.fMask := SIF_ALL;
GetScrollInfo(Handle, bar, si);
if TempMap.Width > ClientWidth then
MaxOffset.X := TempMap.Width - ClientWidth
else
MaxOffset.X := 0;
if TempMap.Height > ClientHeight then
MaxOffset.Y := TempMap.Height - ClientHeight
else
MaxOffset.Y := 0;
if FOffset.X < 0 then
FOffset.X := 0
else
if FOffset.X > MaxOffset.X then
FOffset.X := MaxOffset.X;
if FOffset.Y < 0 then
FOffset.Y := 0
else
if FOffset.Y > MaxOffset.Y then
FOffset.Y := MaxOffset.Y;
Refresh;
if bar = SB_HORZ then
begin
si.nPos := FOffset.X;
si.nMin := 0;
si.nMax := MaxOffset.X;
end
else
begin
si.nPos := FOffset.Y;
si.nMin := 0;
si.nMax := MaxOffset.Y;
end;
if si.nPos < si.nMin then
si.nPos := si.nMin;
if si.nPos > si.nMax then
si.nPos := si.nMax;
SetScrollInfo(Handle, bar, si, true);
end;
procedure THexmap.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
inherited;
if (Button = mbLeft) and CanFocus and not Focused then
SetFocus;
end;
procedure Thexmap.WMGetDlgCode(var msg: TWMGetDlgCode);
begin
msg.result := DLGC_WANTARROWS;
end;
procedure Thexmap.WMHScroll(var msg: TWMSCROLL);
begin
case msg.ScrollCode of
SB_LEFT : FOffset.X := 0;
SB_PAGELEFT : FOffset.X := FOffset.X - ClientHeight;
SB_LINELEFT : FOffset.X := FOffset.X - FHexRadius;
SB_LINERIGHT : FOffset.X := FOffset.X + FHexRadius;
SB_PAGERIGHT : FOffset.X := FOffset.X + ClientHeight;
SB_RIGHT : FOffset.X := MAXINT;
SB_THUMBTRACK : FOffset.X := MAXINT;
SB_THUMBPOSITION : FOffset.X := MAXINT;
SB_ENDSCROLL : Exit;
end;
HandleScrollbar(msg, SB_HORZ);
end;
procedure Thexmap.WMVScroll(var msg: TWMSCROLL);
begin
case msg.ScrollCode of
SB_TOP : FOffset.Y := 0;
SB_PAGEUP : FOffset.Y := FOffset.Y - ClientHeight;
SB_LINEUP : FOffset.Y := FOffset.Y - FHexRadius;
SB_LINEDOWN : FOffset.Y := FOffset.Y + FHexRadius;
SB_PAGEDOWN : FOffset.Y := FOffset.Y + ClientHeight;
SB_BOTTOM : FOffset.Y := MAXINT;
SB_THUMBTRACK : FOffset.Y := MAXINT;
SB_THUMBPOSITION : FOffset.Y := MAXINT;
SB_ENDSCROLL : Exit;
end;
HandleScrollbar(msg, SB_VERT);
end;
{end scroll bars..}
Constructor THexMap.Create(AOwner: Tcomponent);
begin
inherited Create(AOwner);
Width := DEFAULT_MAP_WIDTH;
Height := DEFAULT_MAP_HEIGHT;
tempMap := vcl.Graphics.TBitMap.Create; {prepare the offscreen temp map};
{ Set intial property values for component }
FHexColumns := 8;
FHexRows := 5;
FHexRadius := 30;
FHex3d := True;
FHexColor := clGray;
FBackColor := clTeal;
FLineColor := clBlack;
FHexMapName := 'Default';
rise := round(sqrt(sqr(FHexRadius)-sqr(FHexRadius/2)));
FOffset := point(0,0);
//create map
MakeSolidMap;
end;
destructor ThexMap.Destroy;
begin
TempMap.Free;
inherited Destroy;
end;
Procedure THexMap.MakeSolidMap;
var
p0 : TPoint;
looprow,Loopcol : integer;
begin
TempMap.width := ((HexColumns-1) * round((1.5 * HexRadius))) + (2 * hexRadius);
TempMap.height := ((HexRows) * (2 * rise)) + rise;
With TempMap.Canvas do
begin
{set Background color}
brush.Color := BackColor;
fillrect(rect(0,0,TempMap.Width,TempMap.Height));
{draw Hex's left to right / top to bottom}
for looprow := 1 to HexRows do
begin
for loopcol := 1 to HexColumns do
begin
{compute center coords}
p0 := ConvertCoords(Point(LoopCol,LoopRow),ptROWCOL);
{draw the hex}
DrawSolidHex(TempMap.Canvas,bsSolid,hexColor,psSolid,LineColor,P0.X,p0.Y,hexRadius,hex3d);
end;
end;
end;
end;
function THexMap.MapToClient(Pt: TPoint): TPoint;
begin
Result.X := pt.X - FOffset.X;
Result.Y := pt.Y - FOffset.Y;
end;
procedure THexMap.PaintAHex(HexColorWanted: TColor; HexPatternWanted: TBrushStyle; MapLocation: System.Types.TPoint);
var
p0:Tpoint;
begin
with TempMap.canvas do
p0 := convertcoords(Point(MapLocation.X,MapLocation.Y),ptROWCOL);
drawsolidhex(tempmap.Canvas,HexPatternWanted,HexColorWanted,psSolid,LineColor,p0.X,p0.Y,Hexradius,hex3d);
MakeSolidMap;
Invalidate;
end;
Procedure THexMap.ImageAHex(ImageWanted: vcl.Graphics.TBitmap; HexPatternWanted: TBrushStyle; MapLocation: System.Types.TPoint);
var
p0 :Tpoint;
begin
with TempMap.Canvas do
p0:= convertcoords(point(MapLocation.X,MapLocation.Y),ptROWCOL);
drawSolidHexImage(tempmap.Canvas,HexPatternWanted,StringToColor('clGray'),ImageWanted,psSolid,LineColor,p0.X,p0.Y,hexradius,hex3d);
end;
procedure THexMap.DrawSolidHex(Target: TCanvas;
FillStyle: TBrushStyle;
FillColor: TColor;
LineStyle: TPenStyle;
LineColor: TColor;
x,y,Radius:Integer;
button: Boolean);
var
p0,p1,p2,p3,p4,p5,p6:TPoint;
begin
p0 := Point(x,y);
{compute each point based on hex center}
p1.X := p0.X - round(Radius /2);
p1.Y := p0.Y - rise;
p2.X := p0.X + round(Radius/2);
p2.Y := p1.Y;
p3.X := p0.X + Radius;
p3.Y := p0.Y;
p4.X := p2.X;
p4.Y := p0.Y + rise;
p5.X := p1.X;
p5.Y := p4.Y;
p6.X := p0.X - Radius;
p6.Y := p0.Y;
{set color / style of lines}
target.Pen.Color := LineColor;
target.Pen.Style := LineStyle;
{set color / style of hex}
target.Brush.Color := FillColor;
Target.Brush.Style := FillStyle;
{draw the hex}
target.Polygon([p1,p2,p3,p4,p5,p6]);
{if desired, draw the boarder for the hex}
if button = true then
begin
with target do
begin
pen.Mode :=pmCopy;
pen.Color :=clWhite;
moveto(p5.X+1,p5.Y-1);
lineto(p6.X+1,p6.Y);
lineto(p1.X+1,p1.Y+1);
lineto(p2.X-1,p2.Y+1);
pen.Color :=clBlack;
lineto(p3.X-1,p3.Y);
lineto(p4.X-1,p4.Y-1);
lineto(p5.X+1,p5.Y-1);
end;
end;
end;
procedure THexMap.DrawSolidHexImage(Target: TCanvas;
FillStyle: TBrushStyle;
FillColor: TCOlor;
FillImage: vcl.Graphics.TBitMap;
LineStyle: TPenStyle;
LineColor: TColor;
x,y,Radius:Integer;
button: Boolean);
var
HexCentre,p1,p2,p3,p4,p5,p6:TPoint;
HexCorners : array [1..6] of TPoint;
HexRgn : HRGN;
R : TRect;
begin
HexCentre := Point(x,y);
{compute each point based on hex center}
HexCorners[1].X := HexCentre.X - round(Radius /2);
HexCorners[1].Y := HexCentre.Y - rise;
HexCorners[2].X := HexCentre.X + round(Radius/2);
HexCorners[2].Y := HexCorners[1].Y;
HexCorners[3].X := HexCentre.X + Radius;
HexCorners[3].Y := HexCentre.Y;
HexCorners[4].X := HexCorners[2].X;
HexCorners[4].Y := HexCentre.Y + rise;
HexCorners[5].X := HexCorners[1].X;
HexCorners[5].Y := HexCorners[4].Y;
HexCorners[6].X := HexCentre.X - Radius;
HexCorners[6].Y := HexCentre.Y;
{set color / style of lines}
target.Pen.Color := LineColor;
target.pen.Style := LineStyle;
{set color / style of hex}
target.Brush.Color := FillColor;
Target.Brush.Style := FillStyle;
Target.Brush.Bitmap:= FillImage;
{draw the hex}
target.Polygon(HexCorners);
{if desired, draw the boarder for the hex}
if button = true then
begin
with target do
begin
pen.Mode :=pmCopy;
pen.Color :=clWhite;
moveto(HexCorners[5].X+1,HexCorners[5].Y-1);
lineto(HexCorners[6].X+1,HexCorners[6].Y);
lineto(HexCorners[1].X+1,HexCorners[1].Y+1);
lineto(HexCorners[2].X-1,HexCorners[2].Y+1);
pen.Color :=clBlack;
lineto(HexCorners[3].X-1,HexCorners[3].Y);
lineto(HexCorners[4].X-1,HexCorners[4].Y-1);
lineto(HexCorners[5].X+1,HexCorners[5].Y-1);
end;
end;
CreatePolygonRgn(HexCorners,6,WINDING);
try
R.Left := HexCorners[6].X;
R.Top := HexCorners[1].Y;
R.Right := HexCorners[3].X;
R.Bottom := HexCorners[4].Y;
InvalidateRect(self.Handle, R, FALSE);
finally
DeleteObject(HexRgn);
end;
Refresh;
end;
procedure THexMap.DrawhexOutline(Target: TCanvas;
Linestyle: TPenStyle;
LineColor: TColor;
x,y,radius: Integer;
button: Boolean);
var
p0,p1,p2,p3,p4,p5,p6:TPoint;
begin
p0 := Point(x,y);
{compute each point based on hex center}
p1.X := p0.X - round(Radius /2);
p1.Y := p0.Y - rise;
p2.X := p0.X + round(Radius/2);
p2.Y := p1.Y;
p3.X := p0.X + Radius;
p3.Y := p0.Y;
p4.X := p2.X;
p4.Y := p0.Y + rise;
p5.X := p1.X;
p5.Y := p4.Y;
p6.X := p0.X - Radius;
p6.Y := p0.Y;
{Set Color / Style of lines}
Target.Pen.Color := lineColor;
Target.Pen.Style := LineStyle;
{Draw the hex}
Target.Polyline([p1,p2,p3,p4,p5,p6]);
{If Desired, draw the boarders for the hex}
if button = true then
begin
with target do
begin
pen.Mode :=pmCopy;
pen.Color :=clWhite;
moveto(p5.X+1,p5.Y-1);
lineto(p6.X+1,p6.Y);
lineto(p1.X+1,p1.Y+1);
lineto(p2.X-1,p2.Y+1);
pen.Color :=clBlack;
lineto(p3.X-1,p3.Y);
lineto(p4.X-1,p4.Y-1);
lineto(p5.X+1,p5.Y-1);
end;
end;
end;
procedure THexMap.SaveHexMap(Name: string);
begin
//unknown GM
end;
procedure THexMap.LoadHexMap(Name: string);
begin
//unknown GM
end;
procedure THexMap.StartPosition(Text: string; Position: TPoint);
var
HexText : string;
p0 : TPoint;
begin
With TempMap.Canvas do
begin
HexText := Text;
p0 := Convertcoords(Point(Position.X,Position.Y),ptROWCOL);
TextOut(p0.X - (Trunc(TextWidth(HexText) / 2)), p0.Y - (TextHeight(HexText)), HexText);
end;
Invalidate;
end;
procedure THexMap.WndProc(var Message: TMessage);
const
DISCARD_CURRENT_ORIGIN = nil;
var
R : TRect;
PS : PAINTSTRUCT;
begin
if Message.Msg = WM_PAINT then
begin
if GetUpdateRect( Handle, nil, false ) then
begin
BeginPaint( Handle, PS );
try
R := PS.rcPaint;
bitblt(Canvas.Handle, R.Left, R.Top, R.Width, R.Height, TempMap.Canvas.Handle, R.Left+FOffset.X, R.Top+FOffset.Y, SRCCOPY);
finally
EndPaint( Handle, PS );
end;
end
else
inherited;
end
else
inherited;
end;
function THexMap.XYtoRowCol(pt: TPoint): TPoint;
begin
Result := self.ConvertCoords(ClienttoMap(Pt),ptXY)
end;
Function THexMap.FindRange(Bpoint: TPoint; EPoint: TPoint) : Integer;
var
Delta : TPoint;
begin
Delta.X := abs(EPoint.X - BPoint.X);
Delta.Y := abs(EPoint.Y - BPoint.Y);
if Delta.Y > (Delta.X div 2) then
Result := Delta.X + (Delta.Y - (Delta.X div 2))
else
Result := Delta.X;
end;
function THexMap.ClientToMap(X, Y: integer): TPoint;
begin
Result.X := X + FOffset.X;
Result.Y := Y + FOffset.Y;
end;
function THexMap.ClientToMap(Pt: TPoint): TPoint;
begin
Result := ClientToMap(Pt.X,Pt.Y);
end;
function THexMap.ConvertCoords(point: TPoint; pointType: TPointType):Tpoint;
var
temp :TPoint;
begin
case pointtype of
ptXY: {Convert from x/y to Row/col}
begin
temp.X := round( (point.X + (HexRadius/2) ) / (1.5 * HexRadius));
if odd(Temp.X) then
temp.Y := round ( (point.Y + rise) / (rise*2))
else
temp.Y := round (point.Y / (2*rise));
{Ensure row / col is good}
if (temp.X <1) or (temp.Y < 1) then
begin
temp.X :=0;
temp.Y :=0;
end
else if (temp.Y > HexRows) or (Temp.X > hexColumns) then
begin
temp.X :=0;
temp.Y :=0;
end;
ConvertCoords := temp;
end;
ptRowCol: {converts Row/Col to X/Y}
begin
if point.X=1 then
temp.X:= hexRadius
else
temp.X := hexRadius+(point.X-1) * (Round(1.5 * Hexradius));
if odd(Point.X) then
if point.y =1 then
temp.Y:=rise
else
temp.Y := rise+(point.Y-1) * (2*rise)
else
temp.Y := (point.Y * (2*rise));
ConvertCoords := Temp;
end;
end;
end;
function THexMap.RangeInHexes(BPoint: TPoint; EPoint: TPoint):Integer;
var
dx, tdx, tempdx: integer;
dy: integer;
dist: integer;
begin
{if its in the same column or row}
if (Epoint.X-Bpoint.X = 0) or (EPoint.y - BPoint.Y =0) then
begin
dx:=Epoint.X-BPoint.X;
dy:=Epoint.Y-Bpoint.Y;
dist:=abs(dx)+abs(dy);
end
else
begin {not in same row or column}
dist:=findrangeD(Bpoint,Epoint);
end;
RangeInHexesD := dist;
end;
Procedure THexMap.SetHexcolumns(Value:Integer);
begin
if Value <> FHexColumns then
FHexColumns := Value;
makesolidMap;
Invalidate;
end;
Procedure THexMap.SetHexRows(Value:Integer);
begin
if Value <> FHexRows then
FHexRows := Value;
makeSolidMap;
Invalidate;
end;
procedure THexMap.SetHexRadius(Value:Integer);
begin
if Value <> FHexRadius then
begin
FHexRadius := Value;
if Odd(FHexRadius) then
inc(FHexRadius); {Even values work better..}
{Compute new rise}
rise:=round( Sqrt( Sqr(FHexRadius) - sqr(FHexRadius/2)));
end;
MakeSolidMap;
Invalidate;
end;
procedure THexMap.SetHexShowLabels(Value:Boolean);
begin
if Value <> FHexShowLabels then
begin
FHexShowLabels := Value;
makeSolidMap;
Invalidate;
end;
end;
procedure THexMap.SetHex3d(Value:Boolean);
begin
if Value <> FHex3d then
begin
FHex3d := Value;
makeSolidMap;
Invalidate;
end;
end;
Procedure THexMap.SetHexColor(Value: TColor);
begin
if Value <> FHexColor then
begin
FHexColor := Value;
makeSolidMap;
Invalidate;
end;
end;
Procedure THexMap.SetLineColor(Value:TColor);
begin
if Value <> FLineColor then
begin
FLineColor := Value;
makeSolidMap;
Invalidate;
end;
end;
Procedure THexMap.SetBackColor(Value:TColor);
begin
if Value <> FBackColor then
begin
FBackColor := Value;
makeSolidMap;
Invalidate;
end;
end;
procedure THexMap.SetTotalStartingLocations(Value: Integer);
begin
if Value <> FTStarting then
FTStarting := value;
end;
procedure Register;
begin
RegisterComponents('Game',[THexMap]);
end;
end.
答案 0 :(得分：2)
为了平滑滚动，您必须在WMHScroll / WMVScroll中执行此操作：
SB_THUMBTRACK:
FOffset.Y := msg.Pos;
SB_THUMBPOSITION:
FOffset.Y := msg.Pos;
如果只更新hexrow或hexcolumns的数量，滚动条不会自动更新。您必须调用SetScrollInfo / ShowScrollbar。
您需要手动在HandleScrollbar中显示或隐藏滚动条。
ShowScrollBar(Handle, SB_VERT, MaxOffset.Y > 0);
ShowScrollBar(Handle, SB_HORZ, MaxOffset.X > 0);
您还应该设置ScrollInfo.nPageAmount。
请查看单元Vcl.CategoryButtons中的TCategoryButtons。这是实现自己的滚动条的一个很好的例子。 TCategoryButtons派生自TCustomControl。搜索＆＃34;滚动＆＃34;在这个单元中，你应该知道你需要做什么。