Imagine a canvas that is tile filed both horizontally and vertically by using a single bitmap, for example:
The above is achieved with the following:
procedure TForm1.PaintBox1Paint(Sender: TObject);
var
X, Y: Integer;
begin
Y := 0;
while Y < PaintBox1.Height do
begin
X := 0;
while X < PaintBox1.Width do
begin
PaintBox1.Canvas.Draw(X, Y, Image1.Picture.Bitmap);
Inc(X, Image1.Picture.Bitmap.Width);
end;
Inc(Y, Image1.Picture.Bitmap.Height);
end;
PaintBox1.Canvas.Brush.Style := bsClear;
PaintBox1.Canvas.Rectangle(PaintBox1.ClientRect);
end;
Now what I would like to do is extend the above to allow a horizontal and vertical offset to simulate the effect that the tiled images are been wrapped / scrolled when using a scrollbar etc.
The idea is that when changing the horizontal offset for example, the tiled images would move to the left, and from the right you should see the tiled images appear as if they have been wrapped around from one side of the paintbox to the other.
I have managed to make a test project that does work how I want it to and it looks like this:
I have written this test project in Lazarus but it can be easily adapted to test in Delphi.
Below is the lfm:
object Form1: TForm1
Left = 0
Height = 625
Top = 0
Width = 782
Caption = 'Form1'
ClientHeight = 625
ClientWidth = 782
OnCreate = FormCreate
Position = poScreenCenter
Visible = False
object Label1: TLabel
Left = 25
Height = 15
Top = 16
Width = 40
Caption = 'Regular'
ParentColor = False
end
object Label2: TLabel
Left = 361
Height = 15
Top = 16
Width = 32
Caption = 'Offset'
ParentColor = False
end
object PaintBox1: TPaintBox
Left = 24
Height = 320
Top = 40
Width = 320
OnPaint = PaintBox1Paint
end
object PaintBox2: TPaintBox
Left = 361
Height = 320
Top = 40
Width = 320
OnPaint = PaintBox2Paint
end
object Image1: TImage
Left = 25
Height = 48
Top = 544
Width = 48
AutoSize = True
Picture.Data = {
1754506F727461626C654E6574776F726B47726170686963830A000089504E47
0D0A1A0A0000000D49484452000000300000003008060000005702F98700000A
4A494441546881CD997F8C5C5515C73FF7BE376F66F6C77477DBEDF677A9A4EC
A2056D34223110C0468A091122CA822151227FD45F31C400898A1AF803635249
C4F40F883424842A46A28480A6828AD820581A1A4B7F125AFBBBDBFD313BBB33
F3DEBBF7F8C77D333B3F763B3BBB267A9297B9F7BD7BDF3BDF7BCEF99E73EF28
6B85FF3779FA6F87552E1B749C199B5AD1BF24BB6A595766C5D989D286209559
7DEDE0C0536BBABCFD95B17E3B2FDEF1EA81A67B294FD3DB95E1CCD8147DDD19
B2299F53A385BA766F57864CCAE3E4C5C9A4ED7366AC90EEEDCAF4766782DEF1
E9F2DABECEF4FA251DE9354664DD47D72D5DDFD3915E7DFDE0409FA7BDDE13E3
9167BC6E56F7A4F8F99F8E8EFEE4F3830B03B0EDA60FCF7BECCE378EA4D3BE74
A53CBDD2F7D4EAEE6CB06AC3F225EB7B3A830D3D1DE9B557ADED5D9ECB0403D9
C0EBCBFA9E4EA73CB452D5F916383C1272AE10D19DF1185A11E06B087CDD5DFB
9D455B402BB57A656FE7A6E9305ED7D795599FCB066B7DAD567D7AE3C09A8EC0
1FE84CFB5D595FA73C4FE36BDDF21BB1B11CBA18727E322697F5D9D89F21E529
26C398D800A06AC72FCA023B5E3D70E5351B07760F2ECFADCA066DBDAA49CAB1
E5E048999129434FD667E34016AD15B115E248304E798CAD9FB7600B182BEC3B
7C7ACBBDD75DB12A9D5A9CF28747CABC3F1AD2DF9D62437F06AD15A1018C54D7
5B002B601703A0D102F71E3A65622BA4012B8ECD2A7EDCD89F4BF265C39EE3D3
5CB7B19B5814A111748D923A21C9C8088803B160004FECFE57B56DAC45A49982
6DC3BD5A20B5CF1C30E1743E647434C4A228C782566044A8C5AD05E20454BC18
0B7C73CB47EAFA5F3D7C7ADE736B95B722942343680CE3D365AC80566E7545EA
A3546B88C4B1921230A67E81DA02B0FD9577AB6D6305D31851F304321DC64C96
62AC588C1504B7B2612C68A5D015040AB475734293805C8C05EEDF7A755DFF9E
C7E76F818A9423C3443122328257C3AAD60AC68255159723F955587131E06B17
D70B06F0D88BEFD47DB0D1DF5B8915A16CDCAAD78940642116E7264ACD28AA11
626BB1C9F3C64FB605E0A15B37D7F5EFDEFE52132BB40651C32452B927C406A2
58507AC68534CEF7232358014F2F320F3CF2C2DBD5B6B182B582D026824651EE
8AAD10092833E3429E5208E2005820E5D86FC1007E70FB27EAFA77FEF445C0AD
A01569C9F9738958B7C2462C4A5442A52E1E8C08C6385A350667920503F8F59B
D5B61167815A69E6F9D65289E3589C825AD5D854C0183BE3F7162C8BA0D147BE
744D5DFF8EC77E37E7D8762C22022282A904A9024F25F4190B2A798FD2B2381A
7DE8B93DD5B6313661A2B9C737B2945899357B4342A346B02AA14E208A6DF20E
97A151AAC9EAEDD1E85DD7D6F56F7BF4B7ED4CAF4A158476E5851117A871A29C
46B008C68ACBCA0AC4B81831F122007C67E75FAB6DC742ED67E27A20954692D9
AD73178B101B41251CA7948B95624928858B00F0F857AEAFEBDFFAE3E7EB154A
5650E9F6D8C8E27283490A1E93B88ED60A57F281AF61AC685D55BA5000DF78EA
B56A3B36B6EAFF56A4AA7C2D905A309264EE590F11923A3F322E464CB20F5022
E86AB6538C4C5A6431007EF1B51BEBFAB73CFCAB96736416852BC1ED55EA4EE5
4A89C8D494E82E763149069E2C19268BA66143D92680FB76ECAEB68DB5583393
C0CC0232B2B5E2283451BE1C591433855C8585B5C085494B1C0BB2181A7D72DB
96BAFECDDF7B6E469959E8713E794029B058F2C53809DC99FB5A293C0DF992E5
623E464410594429B1FE96EF73ED673E45269D228A0DC658EB8AB339B87D9664
168B5437305AE1AC6884C8B8CD8A02D06ED545095614A74663577E57227AA100
8EBFFC685DFFEB4FBE96F55B304EFD4EACFE5939364C873146847CD1602D7404
9A5264B1CA31CF48DE30316550B878688CA9B600745D7E3B9B6EDECAE0D0FAA0
A73B7BC34D9B2FDB96CB386B342B3EE3CBB5A20144988A0C2282D230D09FE6D8
C922FDFD198C5862EB363BE3D3C2D9F188DAB85ED4A6BE70EC05001E78F6EF3B
1EB8EDE3F72EEB4C530C63A7989A51BC1644ED3370543915C6D5673D198FCBFB
04A533BCF77E910FADCD622C144A8673E33171ECE2412A001A10B43E2AAB91DC
E09D74ACDD4AAE33BD6959679AA97254A7EC5C759115088D5BF562546F2DAD14
EB7B35FDD910C4920934A39311A74762A2A46C90A45C1769DE925DD202B9A1E1
CADAE9E4523A9551B1B1552D5A9DFF44D6129A9903806CCAC35A4B313255C0B1
71C561A11873763CE2C2B841254B2BB8F32057A54AEB723A515A250A7BC9AF9F
B415A044A4C972B540625B29D06C93C9D3BE46A91446C4056BA57E568A722894
CA33AB5ED1B576D12F99077243C3C12C4AD7025180B2B61E8015B752715290B5
FACFC1D7CA156D8DE576E2268DF3DD30690D00C8004183D2F500C422222AB696
E9C49FE7FB274945E1B9868B50BF00CD8717D816892C063A80748DF28D16C088
780B51FC929204A8A599EBA5F29CA6186E02504C940D12103E33F15005803496
540B50B83A36711D35D39E6BBE4053355AE7CBF983BB042800A3409800C92457
BA72999A18A89C48D45EF31191E6EDA85857ACD958DC65672E1171ABE8296F4E
003520A680F3403E1993AEBD444455EAFB76E552B59324C02AE7123A2927B482
52D916CF8D44E70BA5DC91DA39B3E681FCC15D921B1A9E06C68125407715AC63
8AB612E07C4245092804AD04CF8352D9469313F18589317B267F313E519AB4A3
D1B41D11237F6C09209114D00FF430C34C00182B2D62A0B5C2E07242E06BBA02
0FA5C3383F194FC8D9E8C2FE7D8523A5097B269AB679890981349A69A578E6FC
1F361F9D2F00838B8718E8023C944A08A11E403BE7A356045F2B966483E89DE3
178FEE3D7AF6CD7FEE3FFAC67B47CC581C5EF9C5E51BFDA9890FC273CA531E0A
8D56392C23589E3EB77BF389C6F7CD09207F70579C1B1A3E0D9481CB811538AB
48CAF702CFF7E6AD7C39B64C14C3786CAAFCBE15D9F3EEF191BF3CB5F3E57746
3E387E6AFAC29982298E84C1B22D9B7AAFB8120C018AC0E51B9D41CC49A4BC53
791D67677BF7256BA1FCC15D06389F1B1A0E7114BB1E48BDBDEFD89E939FFBD8
CA8EB4DF618CAD9EE7D42A3C3E5D666C3A3C3A5628BD558CCC6B22F20F84431B
57F694BEFDD94DDCBFF56ABA37DE91D17ED0E9752F4DEB742A4070078BC662F1
324878CCE45F797A6CDF8FC6E7D251CD3719E5868633C05A609D9898CE156BB2
7D6B56AD7BE287F7FCEC86C115C1DE13A38C4E95FF9D9F2EBF558CCC9F813780
C33837444408523E5D81CF7DDFDA4EE1F471941F68208B943C2FF7C9C1DCDA2D
DF5D7A592E3CF1D6545EA474C0E45FDA69CBFBA6505D2031F943CD0769F30690
80F070F1A0252A174C794AAEBAF50B776FFBF28D03FD4B3A5EBF38593C70597F
777EAEF97D9D6936ADEA6D7EA7943C2F77CDD5DDABB73C3875569F4315F69AC2
CBCF8EEF7FACDC4AA776FFE035C004804AA5F15369F63DBFF3991D08BF7C7898
8B93458E8F14005795766752F47406F474A4E9C906746553FC7EDF09EEB9EB41
C41A929AD9803248398F8895F0D4EBA6F4C26FB0E32637345CF7F1FCC15D4D0A
B565814BC98542893313457AB201B96C8A9E6CD0D6FCDCE0B0EF77AE5A3ABA77
FBB976E6FDD700FCAFE43F765B2B40A722D3C30000000049454E44AE426082
}
Visible = False
end
object Label3: TLabel
Left = 645
Height = 15
Top = 376
Width = 36
Alignment = taRightJustify
AutoSize = False
Caption = '0'
ParentColor = False
end
object ScrollBar1: TScrollBar
Left = 361
Height = 17
Top = 374
Width = 273
Max = 5000
PageSize = 0
TabOrder = 0
OnChange = ScrollBar1Change
end
object ScrollBar2: TScrollBar
Left = 696
Height = 320
Top = 40
Width = 17
Kind = sbVertical
Max = 5000
PageSize = 0
TabOrder = 1
OnChange = ScrollBar2Change
end
object Label4: TLabel
Left = 720
Height = 15
Top = 40
Width = 34
Caption = 'Label4'
ParentColor = False
end
end
and the source
unit Unit1;
{$mode delphi}
interface
uses
Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls,
ExtCtrls;
{ TForm1 }
type
TForm1 = class(TForm)
Image1: TImage;
Label1: TLabel;
Label2: TLabel;
Label3: TLabel;
Label4: TLabel;
PaintBox1: TPaintBox;
PaintBox2: TPaintBox;
ScrollBar1: TScrollBar;
ScrollBar2: TScrollBar;
procedure FormCreate(Sender: TObject);
procedure PaintBox1Paint(Sender: TObject);
procedure PaintBox2Paint(Sender: TObject);
procedure ScrollBar1Change(Sender: TObject);
procedure ScrollBar2Change(Sender: TObject);
private
FOffsetX: Integer;
FOffsetY: Integer;
public
{ public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.lfm}
{ TForm1 }
procedure TForm1.FormCreate(Sender: TObject);
begin
FOffsetX := 0;
FOffsetY := 0;
end;
procedure TForm1.PaintBox1Paint(Sender: TObject);
var
X, Y: Integer;
begin
Y := 0;
while Y < PaintBox1.Height do
begin
X := 0;
while X < PaintBox1.Width do
begin
PaintBox1.Canvas.Draw(X, Y, Image1.Picture.Bitmap);
Inc(X, Image1.Picture.Bitmap.Width);
end;
Inc(Y, Image1.Picture.Bitmap.Height);
end;
PaintBox1.Canvas.Brush.Style := bsClear;
PaintBox1.Canvas.Rectangle(PaintBox1.ClientRect);
end;
// needs improvement
procedure TForm1.PaintBox2Paint(Sender: TObject);
var
X, Y: Integer;
begin
Y := -FOffsetY;
while Y < PaintBox2.Height do
begin
X := -FOffsetX;
while X < PaintBox2.Width do
begin
PaintBox2.Canvas.Draw(X, Y, Image1.Picture.Bitmap);
Inc(X, Image1.Picture.Bitmap.Width);
end;
Inc(Y, Image1.Picture.Bitmap.Height);
end;
PaintBox2.Canvas.Brush.Style := bsClear;
PaintBox2.Canvas.Rectangle(PaintBox2.ClientRect);
end;
procedure TForm1.ScrollBar1Change(Sender: TObject);
begin
FOffsetX := ScrollBar1.Position;
Label3.Caption := IntToStr(FOffsetX);
PaintBox2.Invalidate;
end;
procedure TForm1.ScrollBar2Change(Sender: TObject);
begin
FOffsetY := ScrollBar2.Position;
Label4.Caption := IntToStr(FOffsetY);
PaintBox2.Invalidate;
end;
end.
My question is how can I improve my existing code and whether or not there is a better way of doing this, I may have over complicated the task?
For small offsets the paintbox paints quite fast but with larger offsets such as 5000 (what I am currently testing with) the scrolling becomes rather slow and I wonder if I have missed out something obvious?
There is no need to draw all of the bitmaps that are not visible. For any given width/height of bitmap (let's call it the "tile"), you only need to start/finish drawing at most 1 tile width or height beyond the edge of your canvas.
i.e. calculate the first visible tile and starting painting with that.
The illustration above tries to show what I mean... only the green tiles are in the visible area (shaded blue) so even if the offset includes those that are shown red, there is no point painting them.
Windows (the OS) will clip these anyway, but you are still spending time iterating over those not-visible tiles, which is why your larger offsets result in degraded performance... you are spending time counting up through the "invisible" space, before reaching the tiles that you actually need to paint.
Calculating the "origin" at which to start painting is simple arithmetic and doesn't require loop iterations. Instead of initialising Y and X to your absolute offsets, set them to the first multiple of the height/width of the tile from that offset, using a simple mod operation:
Y := -FOffsetY mod Image1.Height;
X := -FOffseXY mod Image1.Width;
Or similar
Jerry's observation w.r.t using an offscreen bitmap and then blitting into your control will also optimise the actual painting.
Related
In a 32-bit VCL Application in Windows 10 in Delphi 11 Alexandria, I select a ListItem in the OwnerDrawn TListView.OnDrawItem event handler and I want the ENTIRE UNINTERRUPTED row to be selected. Unfortunately, not the entire row gets selected, but only the caption-text portion of the row gets selected:
This is what I need to achieve:
This is the code of the form-unit:
unit Unit1;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.ComCtrls, Vcl.StdCtrls;
type
TForm1 = class(TForm)
ListView1: TListView;
Edit1: TEdit;
procedure ListView1DrawItem(Sender: TCustomListView; Item: TListItem; Rect: TRect; State: TOwnerDrawState);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
//uses
//CodeSiteLogging,
//Generics.Collections,
//System.StrUtils,
//Vcl.Themes;
{$R *.dfm}
procedure TForm1.ListView1DrawItem(Sender: TCustomListView; Item: TListItem; Rect: TRect; State: TOwnerDrawState);
const
Alignments: array[TAlignment] of TTextFormats = (tfLeft, tfRight, tfCenter);
procedure SetCanvasColors(const aBrushColor, aFontColor: TColor);
begin
(Sender as TListView).Canvas.Brush.Color := aBrushColor;
(Sender as TListView).Canvas.Font.Color := aFontColor;
end;
begin
if not Assigned(Item) then EXIT;
var SelectionColor := clYellow;
if Edit1.Text = '' then
begin
/// Draw normal Item Columns:
var LV := Sender as TListView;
LV.Canvas.Brush.Style := bsSolid;
LV.Canvas.FillRect(Rect);
var x1 := 0;
var x2 := 0;
var RR := Rect;
var SS: string;
LV.Canvas.Brush.Style := bsClear;
for var i := 0 to 1 do
begin
Inc(x2, LV.Columns[i].Width);
RR.Left := x1;
RR.Right := x2;
if i = 0 then
SS := Item.Caption
else
begin
SS := Item.SubItems[i - 1];
end;
SS := #32 + SS;
if ([odSelected, odHotLight] * State <> []) then
SetCanvasColors(SelectionColor, clWindowText)
else
SetCanvasColors(clWindow, clWindowText);
LV.Canvas.TextRect(RR, SS, [tfSingleLine, Alignments[LV.Columns[i].Alignment], tfVerticalCenter]);
x1 := x2;
end;
end;
// code removed that is not relevant for this question...
end;
end.
And this is the code of the form DFM file:
object Form1: TForm1
Left = 0
Top = 0
Caption = 'Form1'
ClientHeight = 191
ClientWidth = 545
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -13
Font.Name = 'Segoe UI'
Font.Style = []
Position = poScreenCenter
PixelsPerInch = 96
TextHeight = 17
object ListView1: TListView
Tag = -1
Left = 0
Top = 25
Width = 545
Height = 166
Align = alClient
Columns = <
item
AutoSize = True
end
item
Width = 100
end>
Items.ItemData = {
05CA0100000400000000000000FFFFFFFFFFFFFFFF01000000FFFFFFFF000000
001654006F006D00200068006100720076006500730074006500640020003300
20006100700070006C00650073000566007200750069007400E09FD791000000
00FFFFFFFFFFFFFFFF01000000FFFFFFFF00000000194A006500720072007900
200069006E0068006500720069007400650064002000350020006F0072006100
6E006700650073000566007200750069007400D0BFD79100000000FFFFFFFFFF
FFFFFF01000000FFFFFFFF000000002454006800650020006200610062007900
2000680061007300200065006100740065006E00200073006F006D0065002000
7300740072006100770062006500720072006900650073000566007200750069
00740068D2D79100000000FFFFFFFFFFFFFFFF01000000FFFFFFFF000000003D
530061006C006C0079002000770061006E0074007300200074006F0020006200
61006B006500200061002000630061006B006500200077006900740068002000
660069007600650020006100700070006C0065007300200061006E0064002000
7400680072006500650020006F00720061006E0067006500730004630061006B
00650060F0D791FFFFFFFFFFFFFFFF}
OwnerDraw = True
ReadOnly = True
RowSelect = True
TabOrder = 0
ViewStyle = vsReport
OnDrawItem = ListView1DrawItem
end
object Edit1: TEdit
AlignWithMargins = True
Left = 33
Top = 0
Width = 479
Height = 25
Margins.Left = 33
Margins.Top = 0
Margins.Right = 33
Margins.Bottom = 0
Align = alTop
TabOrder = 1
Visible = False
end
end
The issue seems to be that you partly think about declarative programming, when in fact Delphi is entirely imperative.
If you want the background to be a single, blue rectangle, you have to write a code of line that draws a single, blue rectangle.
Since you want this to be the background, on top of which the text should be printed, you need to put this line before the text-drawing commands.
Here's a simple example:
Create a new VCL app and add a TListView to the main form. As always, set DoubleBuffered to True. In this case, I set Align = alClient, in which case you are aesthetically obliged to also set Border = bsNone.
Add columns and data.
Then, to make it owner drawn, set OwnerDraw = True.
Then add the following OnDrawItem handler:
procedure TForm1.ListView1DrawItem(Sender: TCustomListView; Item: TListItem;
Rect: TRect; State: TOwnerDrawState);
begin
if Sender <> ListView1 then
Exit;
// Draw the background
if odSelected in State then
begin
ListView1.Canvas.Brush.Color := clHighlight;
ListView1.Canvas.Font.Color := clHighlightText;
end
else
begin
ListView1.Canvas.Brush.Color := clWindow;
ListView1.Canvas.Font.Color := clWindowtext;
end;
ListView1.Canvas.FillRect(Rect);
// Draw each column
var x := 0;
for var i := 0 to ListView1.Columns.Count - 1 do
begin
var S := '';
if i = 0 then
S := Item.Caption
else
S := Item.SubItems[i - 1];
S := #32 + S; // padding happens to equal width of a single space
var W := ListView1.Columns[i].Width;
var R := TRect.Create(x, Rect.Top, x + W, Rect.Bottom);
ListView1.Canvas.TextRect(R, S, [tfSingleLine, tfVerticalCenter, tfEndEllipsis]);
Inc(x, W);
end;
end;
Result:
Please note that this simple example has a serious bug, since it doesn't support a non-zero position of the horizontal scroll bar. This can be fixed very easily, almost trivially. (How?)
In addition, in a real scenario, you would also implement the focus rectangle and the mouse hover effect.
I have a form with at TListBox that I populate in the onCreate event, where I also set the selected item. I want the List Box to have the selected item in view when the form shows, so I tried firing the ScrollToItem method. This does not work. I also tried putting it in OnShow and OnActivate events, but it still does not work. Is there a way to get this to work?
Here is a sample program that illustrates the problem:
`type
TForm5 = class(TForm)
ListBox1: TListBox;
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form5: TForm5;
implementation
{$R *.fmx}
procedure TForm5.FormCreate(Sender: TObject);
var
i: Integer;
lbi: TListBoxItem;
begin
for i := 1 to 50 do
begin
lbi := TListBoxItem.Create(ListBox1);
lbi.Text := 'item ' + inttostr(i);
ListBox1.AddObject( lbi );
end;
ListBox1.itemindex := ListBox1.items.indexof('item 48');
ListBox1.ScrollToItem(ListBox1.Selected);
end;
end.`
and the FMX file:
`object Form5: TForm5
Left = 0
Top = 0
Caption = 'Form5'
ClientHeight = 480
ClientWidth = 640
FormFactor.Width = 320
FormFactor.Height = 480
FormFactor.Devices = [Desktop]
OnCreate = FormCreate
DesignerMasterStyle = 0
object ListBox1: TListBox
Position.X = 224.000000000000000000
Position.Y = 144.000000000000000000
TabOrder = 1
DisableFocusEffect = True
DefaultItemStyles.ItemStyle = ''
DefaultItemStyles.GroupHeaderStyle = ''
DefaultItemStyles.GroupFooterStyle = ''
Viewport.Width = 196.000000000000000000
Viewport.Height = 196.000000000000000000
end
end`
TListBox has a property ViewportPosition: TPointF that sets the scrollbars. Add the following line after you set ListBox1.ItemIndex:
ListBox1.ViewportPosition := PointF(0.0, ListBox1.itemindex * ListBox1.ItemHeight);
The previous assumes that all items have the same height (TListBox1.ItemHeight set in Object Inspector or in code earlier). Your FMX file doesn't reflect this, so you may want to add it, otherwise the scrolling will not take place.
You might want to set individual height for the items. In that case you must traverse all items up to the one you want to be selected and sum their heights to get the Y term for the ViewportPosition.
I'm using the DrawTextRotatedB function from Josef Ċ vejk's excellent answer to the question How to draw text in a canvas vertical + horizontal with Delphi 10.2
to draw text vertically on a TPanel (full code below, Win 32 program).
This is done in a message handler (message WM_DRAWTEXT). The PostMessage call is in the FormResize (which in the real program does a lot more).
Issue:
FormResize is called from FormShow, all relevant code is executed, but the vertical text does not show.
If I then resize the form, the same code gets executed again and it is visible.
How can this be, and how to fix it?
Structure view of form components (drawing on PnlLeftLeft):
Full test code below. Note that this logs to a text file specified by the cLogFileName constant at the top. This log contains (initial resize + one subsequent resize).
FormShow start
FormShow end
FormResize start
PostMessage left sent
FormResize end
RedrawMessage left: test text
(X,Y): (51,284)
RedrawMessage ends
FormResize start
PostMessage left sent
FormResize end
RedrawMessage left: test text
(X,Y): (51,285)
RedrawMessage ends
uFrmTest.Pas
unit uFrmTest;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.Imaging.pngimage, Vcl.ExtCtrls, System.UITypes;
const
WM_DRAWTEXT = WM_USER + 100;
cLogFileName = 'd:\temp\log.lst';
type
TFrmTest = class(TForm)
PnlClient: TPanel;
PnlLeft: TPanel;
PnlRight: TPanel;
PnlLeftLeft: TPanel;
procedure FormShow(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormResize(Sender: TObject);
private
FTextFile: TextFile; // Debugging do cLogFileName
procedure RedrawMessage(var Msg: TMessage); message WM_DRAWTEXT;
public
end;
var
FrmTest: TFrmTest;
implementation
{$R *.dfm}
procedure DrawTextRotated(ACanvas: TCanvas; Angle, X, Y: Integer; AText: String);
// DrawTextRotatedB from https://stackoverflow.com/a/52923681/512728
var
Escapement: Integer;
LogFont: TLogFont;
NewFontHandle: HFONT;
OldFontHandle: HFONT;
begin
if not Assigned(ACanvas) then
Exit;
// Get handle of font and prepare escapement
GetObject(ACanvas.Font.Handle, SizeOf(LogFont), #LogFont);
while Angle > 360 do Angle := Angle - 360;
while Angle < -360 do Angle := Angle + 360;
Escapement := Angle * 10;
// We must initialise all fields of the record structure
LogFont.lfWidth := 0;
LogFont.lfHeight := ACanvas.Font.Height;
LogFont.lfEscapement := Escapement;
LogFont.lfOrientation := 0;
if fsBold in ACanvas.Font.Style then
LogFont.lfWeight := FW_BOLD
else
LogFont.lfWeight := FW_NORMAL;
LogFont.lfItalic := Byte(fsItalic in ACanvas.Font.Style);
LogFont.lfUnderline := Byte(fsUnderline in ACanvas.Font.Style);
LogFont.lfStrikeOut := Byte(fsStrikeOut in ACanvas.Font.Style);
LogFont.lfCharSet := ACanvas.Font.Charset;
LogFont.lfOutPrecision := OUT_DEFAULT_PRECIS;
LogFont.lfClipPrecision := CLIP_DEFAULT_PRECIS;
LogFont.lfQuality := DEFAULT_QUALITY;
LogFont.lfPitchAndFamily := DEFAULT_PITCH;
StrPCopy(LogFont.lfFaceName, ACanvas.Font.Name);
// Create new font with rotation
NewFontHandle := CreateFontIndirect(LogFont);
try
// Select the new font into the canvas
OldFontHandle := SelectObject(ACanvas.Handle, NewFontHandle);
try
// Output result
ACanvas.Brush.Style := VCL.Graphics.bsClear;
try
ACanvas.TextOut(X, Y, AText);
finally
ACanvas.Brush.Style := VCL.Graphics.bsSolid;
end;
finally
// Restore font handle
NewFontHandle := SelectObject(ACanvas.Handle, OldFontHandle);
end;
finally
// Delete the deselected font object
DeleteObject(NewFontHandle);
end;
end;
procedure TFrmTest.FormCreate(Sender: TObject);
begin
AssignFile(FTextFile,cLogFileName);
Rewrite(FTextFile);
end;
procedure TFrmTest.FormDestroy(Sender: TObject);
begin
CloseFile(FTextFile);
end;
procedure TFrmTest.FormResize(Sender: TObject);
begin
WriteLn(FTextFile,'FormResize start');
PostMessage(Handle,WM_DRAWTEXT,0,0);
WriteLn(FTextFile,'PostMessage left sent');
WriteLn(FTextFile,'FormResize end');
end;
procedure TFrmTest.FormShow(Sender: TObject);
begin
WriteLn(FTextFile,'FormShow start');
WriteLn(FTextFile,'FormShow end');
end;
type
THackPanel = class(TPanel);
procedure TFrmTest.RedrawMessage(var Msg: TMessage);
const cLeftVertText = 'test text';
var lHorDrawOffset, lVertDrawOffset: Integer;
begin
WriteLn(FTextFile,'RedrawMessage left: ' + cLeftVertText);
THackPanel(PnlLeftLeft).Canvas.Font := PnlLeftLeft.Font;
lVertDrawOffset := (PnlLeftLeft.Height - THackPanel(PnlLeftLeft).Canvas.TextHeight(cLeftVertText)) DIV 2;
lHorDrawOffset := (PnlLeftLeft.Width - THackPanel(PnlLeftLeft).Canvas.TextWidth(cLeftVertText)) DIV 2;
DrawTextRotated(THackPanel(PnlLeftLeft).Canvas , 90, lHorDrawOffset, lVertDrawOffset, cLeftVertText);
WriteLn(FTextFile,Format('(X,Y): (%d,%d)',[lHorDrawOffset,lVertDrawOffset]));
WriteLn(FTextFile,'RedrawMessage ends');
WriteLn(FTextFile,'');
end;
end.
uFrmTest.dfm
object FrmTest: TFrmTest
Left = 0
Top = 0
Caption = 'FrmTest'
ClientHeight = 592
ClientWidth = 905
Color = clWhite
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Tahoma'
Font.Style = []
OldCreateOrder = False
OnCreate = FormCreate
OnDestroy = FormDestroy
OnResize = FormResize
OnShow = FormShow
PixelsPerInch = 96
TextHeight = 13
object PnlClient: TPanel
Left = 0
Top = 0
Width = 905
Height = 592
Align = alClient
BevelOuter = bvNone
ParentColor = True
TabOrder = 0
ExplicitLeft = 88
ExplicitTop = 8
object PnlLeft: TPanel
AlignWithMargins = True
Left = 20
Top = 10
Width = 367
Height = 582
Margins.Left = 20
Margins.Top = 10
Margins.Right = 20
Margins.Bottom = 0
Align = alLeft
BevelOuter = bvNone
ParentColor = True
TabOrder = 0
object PnlLeftLeft: TPanel
Tag = -20
Left = 0
Top = 0
Width = 145
Height = 582
Align = alLeft
BevelOuter = bvNone
ParentColor = True
TabOrder = 0
end
end
object PnlRight: TPanel
AlignWithMargins = True
Left = 427
Top = 10
Width = 458
Height = 582
Margins.Left = 20
Margins.Top = 10
Margins.Right = 20
Margins.Bottom = 0
Align = alClient
BevelOuter = bvNone
TabOrder = 1
end
end
end
I have form (Height = 500) and TVertScrollBox on it (align set to TAlignLayout.Client and range is 5000px). I wrote simple method, which show position of mouse when I click on scroll box.
procedure TformMain.VertScrollBox1MouseDown(Sender: TObject;
Button: TMouseButton; Shift: TShiftState; X, Y: Single);
begin
ShowMessage(FloatToStr(X) + ' ' + FloatToStr(Y));
end;
When the scroll bar is on top and I click on top of the scroll box, Y in message is 0. That's right. But when I scroll down to the half and click on top of the scroll box, Y in message is 0, too (not 2500). How can I get the position relative to scroll box?
This is my FMX code for TForm and TVertScrollBox:
object formMain: TformMain
Left = 0
Top = 0
BorderIcons = [biSystemMenu, biMinimize]
BorderStyle = Single
Caption = 'Gear Studio 1.0'
ClientHeight = 600
ClientWidth = 450
Position = DesktopCenter
StyleBook = StyleBookPanel
FormFactor.Width = 320
FormFactor.Height = 480
FormFactor.Devices = [Desktop]
OnCreate = FormCreate
OnCloseQuery = FormCloseQuery
DesignerMasterStyle = 0
object VertScrollBox1: TVertScrollBox
Align = Client
Size.Width = 450.000000000000000000
Size.Height = 576.000000000000000000
Size.PlatformDefault = False
StyleLookup = 'VertScrollBox1Style1'
TabOrder = 1
OnMouseDown = VertScrollBox1MouseDown
Viewport.Width = 450.000000000000000000
Viewport.Height = 576.000000000000000000
end
...
...
end
That's how I am adding panels:
SetLength(MyItems, i+1);
MyItems[i] := TItem.Create(i);
with MyItems[i] do begin
...
end;
constructor TItem.Create(number: integer);
var
ThisItem: TItem;
begin
inherited Create(nil);
ThisItem := Self;
with ThisItem do begin
if number = -1 then begin
... //not important
end;
end else if number > 0 then begin
Width := 370;
Height := 35;
...
end;
Position.X := 10;
Parent := formMain.VertScrollBox1;
PopupMenu := formMain.PopupMenu1;
OnDblClick := DblClick;
OnMouseEnter := MouseEnter;
OnMouseLeave := MouseLeave;
end;
end;
MyItems is dynamical array of TItem (it is normal TPanel with added some properties).
You need to add VertScrollBox1.ViewportPosition.Y property to get the absolute coordinate.
ShowMessage(FloatToStr(X) + ' ' + FloatToStr(VertScrollBox1.ViewportPosition.Y+Y));
shows correct result.
I have two string lists that I'm working with. One that has a list of keywords, and then another that has a list of negative keywords. I want to be able to search through the list and pick out the list items that do not contain the negative keyword and output to a third keyword list. I was using the AnsiPos function but that found the negative keywords if they were part of a word, vs full word.
Any suggestions on a relatively easy way to do this? Speed is not that important, but would be nice.
Example of what I'm looking to do:
Keyword List:
Cat
Catfish
Fish Sticks
Dog Food
Negative Keyword List:
Fish
Returned Values Wanted:
Cat
Catfish
Dog Food
This is what I've got so far.. which does not work. I used information from: Is There An Efficient Whole Word Search Function in Delphi?
function ExistWordInString(aString: PAnsichar; aSearchString: string;
aSearchOptions: TStringSearchOptions): Boolean;
var
Size : Integer;
begin
Size := StrLen(aString);
result := SearchBuf(aString, Size, 0, 0, aSearchString, aSearchOptions) <> nil;
end;
procedure TForm2.Button1Click(Sender: TObject);
var
i, j, index: integer;
s: string;
stl: tstringlist;
begin
stl := TStringList.Create;
stl.Text := listbox1.Items.Text;
for I := 0 to stl.Count - 1 do
begin
for j := 0 to listbox2.Count - 1 do
begin
if not ExistWordInString(PAnsiChar(listbox2.Items.Strings[j]),
listbox1.Items.Strings[i], [soWholeWord, soDown])
then
listbox3.Items.Append(stl.Strings[i]);
end;
end;
end;
If spaces are the only word delimiter you need to worry about, then you can do a whole word match using AnsiPos by adding a space before and after both the keyword and the negative keyword, ie
AnsiPos(' '+SubStr+' ', ' '+Str+' ')
You'd need a loop to check every entry from the negative keyword list.
this sample code works like a charm (using Delphi 7):
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, StrUtils;
type
TForm1 = class(TForm)
Button1: TButton;
ListBox1: TListBox;
ListBox2: TListBox;
ListBox3: TListBox;
procedure Button1Click(Sender: TObject);
private
function ExistWordInString(aString, aSearchString:string;aSearchOptions: TStringSearchOptions): Boolean;
public
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.Button1Click(Sender: TObject);
var
i,k: integer;
begin
for k:= 0 to ListBox2.Count -1 do
for i:= 0 to ListBox1.Count - 1 do
begin
if not ExistWordInString(ListBox1.Items[i], ListBox2.Items[k],[soWholeWord,soDown]) then
ListBox3.Items.Append(ListBox1.Items[i]);
end;
end;
function TForm1.ExistWordInString(aString, aSearchString: string; aSearchOptions: TStringSearchOptions): Boolean;
var
Size : Integer;
begin
Size:=Length(aString);
Result := SearchBuf(PChar(aString), Size, 0, 0, aSearchString, aSearchOptions)<>nil;
end;
end.
and here's the form:
object Form1: TForm1
Left = 1008
Top = 398
Width = 411
Height = 294
Caption = 'Form1'
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Tahoma'
Font.Style = []
OldCreateOrder = False
PixelsPerInch = 96
TextHeight = 13
object Button1: TButton
Left = 320
Top = 8
Width = 75
Height = 25
Caption = 'Button1'
TabOrder = 0
OnClick = Button1Click
end
object ListBox1: TListBox
Left = 8
Top = 8
Width = 177
Height = 97
ItemHeight = 13
Items.Strings = (
'Cat '
'Catfish'
'Fish Sticks'
'Dog Food')
TabOrder = 1
end
object ListBox2: TListBox
Left = 192
Top = 8
Width = 121
Height = 97
ItemHeight = 13
Items.Strings = (
'Fish')
TabOrder = 2
end
object ListBox3: TListBox
Left = 8
Top = 112
Width = 305
Height = 137
ItemHeight = 13
TabOrder = 3
end
end
hope this helps.
Reinhard :-)
I think I figured it out. Use stringlist.find('fish',index);
I didn't figure it out. .find did not work.
-Brad
You can use the SearchBuf function (see the pastacool's answer) IF you are not interested in other characters except A..Z / Unicode.
If you have an Unicode Delphi (D2009 or D2010) then you must use TCharacter.IsLetterOrDigit(aString: string; aIndex: integer): boolean; from the Character unit. A simple example for you to get the idea:
procedure TForm7.btn1Click(Sender: TObject);
var
bMatches: boolean;
begin
with rgx1 do //custom component - disregard it
begin
RegEx:=edtTextToFind.Text; //text to find
Subject:=mmoResult.Text; //text in which to search
if Match then //aha! found it!
begin
bMatches:=True;
if chkWholeWord.Checked then //be attentive from here!! - I think that's self explaining...
begin
if MatchedExpressionOffset>1 then
bMatches:=not TCharacter.IsLetterOrDigit(Subject, MatchedExpressionOffset-1);
if bMatches and (MatchedExpressionOffset+MatchedExpressionLength<=Length(Subject)) then
bMatches:=not TCharacter.IsLetterOrDigit(Subject, MatchedExpressionOffset+MatchedExpressionLength);
end;
if bMatches then //select it in the memo
begin
mmoResult.SelStart:=MatchedExpressionOffset-1;
mmoResult.SelLength:=MatchedExpressionLength;
mmoResult.SetFocus;
end
else
ShowMessage('Text not found!');
end
else
ShowMessage('Text not found!');
end;
end;
Change your function to read:
function ExistWordInString(aString:PAnsichar;
aSearchString:string;
aSearchOptions: TStringSearchOptions): Boolean;
var
b : boolean;
begin
if soWholeWord in aSearchOptions then
b := Pos(' '+Uppercase(aSearchString)+' ',' '+UpperCase(aString)+' ') > 0;
else
b := Pos(UpperCase(aSearchString),UpperCase(aString)) > 0;
Result := b;
end;
If your using Delphi 2009/2010 then change it from Pos to AnsiPos. My assumption here is that soWholeWord means that the match "Fish" would match "Fish Sticks" but not "catfish".