Стартовый пул
This commit is contained in:
12
bgracontrols/.github/FUNDING.yml
vendored
Normal file
12
bgracontrols/.github/FUNDING.yml
vendored
Normal file
@@ -0,0 +1,12 @@
|
||||
# These are supported funding model platforms
|
||||
|
||||
github: # Replace with up to 4 GitHub Sponsors-enabled usernames e.g., [user1, user2]
|
||||
patreon: # Replace with a single Patreon username
|
||||
open_collective: # Replace with a single Open Collective username
|
||||
ko_fi: # Replace with a single Ko-fi username
|
||||
tidelift: # Replace with a single Tidelift platform-name/package-name e.g., npm/babel
|
||||
community_bridge: # Replace with a single Community Bridge project-name e.g., cloud-foundry
|
||||
liberapay: # Replace with a single Liberapay username
|
||||
issuehunt: # Replace with a single IssueHunt username
|
||||
otechie: # Replace with a single Otechie username
|
||||
custom: ['https://sourceforge.net/p/lazpaint/donate/?source=navbar'] # Replace with up to 4 custom sponsorship URLs e.g., ['link1', 'link2']
|
||||
21
bgracontrols/.gitignore
vendored
Normal file
21
bgracontrols/.gitignore
vendored
Normal file
@@ -0,0 +1,21 @@
|
||||
*.bak
|
||||
*.dbg
|
||||
*.exe
|
||||
*.lps
|
||||
backup/*
|
||||
backup
|
||||
lib
|
||||
debug
|
||||
*.res
|
||||
*.lrt
|
||||
*.o
|
||||
*.ppu
|
||||
*.or
|
||||
*.compiled
|
||||
*Thumbs.db
|
||||
*.app/*
|
||||
*.dSYM
|
||||
test/test_bccombobox/test_bccombobox
|
||||
!images/bgracontrols_images.res
|
||||
|
||||
.DS_Store
|
||||
2631
bgracontrols/BCExpandPanels.pas
Normal file
2631
bgracontrols/BCExpandPanels.pas
Normal file
File diff suppressed because it is too large
Load Diff
65
bgracontrols/BCExpandPanels.txt
Normal file
65
bgracontrols/BCExpandPanels.txt
Normal file
@@ -0,0 +1,65 @@
|
||||
// ExpandPanels Version 3.0
|
||||
|
||||
2024-01-31 MaxM: First port from original code in BGRAControls (formally Ver. 3.0)
|
||||
|
||||
// ExpandPanels Version 2.2
|
||||
|
||||
30-06-2016 MaxM :
|
||||
Added Button.Style as bbsLineTop,bbsLineBottom,bbsLineDoubleTop,bbsLineDoubleBottom
|
||||
Fixed Some Paint Coordinate position of Button elements and Lines
|
||||
|
||||
21-06-2016 MaxM :
|
||||
Added Button.GlyphKind (default to gkArrows)
|
||||
Added gkClose (EXP_PANEL_CLOSE.png),
|
||||
gkMinMax (EXP_PANEL_MIN_*.png, EXP_PANEL_MAX_*.png) Glyphs
|
||||
Added TExpandPanels properties ButtonGlyphLayout,ButtonGlyphKind,ButtonStyle,ButtonTextLayout,ButtonTabWidth
|
||||
|
||||
15-06-2016 MaxM :
|
||||
Added Button.Style as bbsLine and bbsLineDouble
|
||||
|
||||
09-06-2016 MaxM :
|
||||
Completed Painting of Button.Style as bbsTab
|
||||
|
||||
05-2016 MaxM :
|
||||
Added Owner Draw of Panel so we can Draw Rounded Borders and don't draw Borders when Collapsed
|
||||
Added Style property on Button (bbsButton, bbsTab) (bbsTab paint is incomplete do not use)
|
||||
Deleted BevenInner/Outer redefinition no more needed because now we draw the borders
|
||||
Changed using of writeln with debugln because strange exceptions under Windows
|
||||
Moved TMyRollOut.Loaded Code to CreateWnd because on RunTime creation is never Called
|
||||
Fixed More OnCollapsed events
|
||||
Fixed PositionButton is called only after Loaded is complete
|
||||
Updated Copyright and Created separeted txt files
|
||||
Added development test with only one panel (to simplify my life)
|
||||
|
||||
// ExpandPanels Version 2.1
|
||||
|
||||
23-07-2015 MaxM :
|
||||
Added Owner Draw of Button so we can Draw Vertically when ButtonPosition is akLeft or akRight
|
||||
Added Glyphs Support (Automatically Loaded from Resources or User Passed)
|
||||
Solved Bugs About BevelOuter and Starting in Collapsed State
|
||||
Moved Colors inside Button
|
||||
|
||||
// TO-DO:
|
||||
|
||||
- MaxM:
|
||||
|
||||
Fix User components have 2 Pixels visible over the Button when Button Position
|
||||
is akRight and is Collapsed SEE PROJECT1 DEVELOPMENT - ONLY ADDED IN TExpandPanels?
|
||||
Fix Shadows incoerence when Button.Style is bbsTab, the Panel attached side may not have borders.
|
||||
|
||||
|
||||
- Alex
|
||||
|
||||
simplyfy everything with verctor addition and scalar multiplication (orthogonal basis vectors... and so on)
|
||||
if horizonatal and vertical would be described by a unity vector, I could calculate if a certain operation should be performed
|
||||
and I could just multiply the basis vector with an operation to get a delta movement (or none)
|
||||
|
||||
|
||||
|
||||
Known Bugs:
|
||||
|
||||
- the TExpandPanels lacks a arrange on bottom and right
|
||||
|
||||
- (Solved?) Button.Color Setted to clBtnFace at DesignTime -> Color = clSkyBlue in RunTime
|
||||
(is not Loaded because is The inherited Default Color of TCustomSpeedButton)
|
||||
|
||||
165
bgracontrols/COPYING.LGPL.txt
Normal file
165
bgracontrols/COPYING.LGPL.txt
Normal file
@@ -0,0 +1,165 @@
|
||||
GNU LESSER GENERAL PUBLIC LICENSE
|
||||
Version 3, 29 June 2007
|
||||
|
||||
Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>
|
||||
Everyone is permitted to copy and distribute verbatim copies
|
||||
of this license document, but changing it is not allowed.
|
||||
|
||||
|
||||
This version of the GNU Lesser General Public License incorporates
|
||||
the terms and conditions of version 3 of the GNU General Public
|
||||
License, supplemented by the additional permissions listed below.
|
||||
|
||||
0. Additional Definitions.
|
||||
|
||||
As used herein, "this License" refers to version 3 of the GNU Lesser
|
||||
General Public License, and the "GNU GPL" refers to version 3 of the GNU
|
||||
General Public License.
|
||||
|
||||
"The Library" refers to a covered work governed by this License,
|
||||
other than an Application or a Combined Work as defined below.
|
||||
|
||||
An "Application" is any work that makes use of an interface provided
|
||||
by the Library, but which is not otherwise based on the Library.
|
||||
Defining a subclass of a class defined by the Library is deemed a mode
|
||||
of using an interface provided by the Library.
|
||||
|
||||
A "Combined Work" is a work produced by combining or linking an
|
||||
Application with the Library. The particular version of the Library
|
||||
with which the Combined Work was made is also called the "Linked
|
||||
Version".
|
||||
|
||||
The "Minimal Corresponding Source" for a Combined Work means the
|
||||
Corresponding Source for the Combined Work, excluding any source code
|
||||
for portions of the Combined Work that, considered in isolation, are
|
||||
based on the Application, and not on the Linked Version.
|
||||
|
||||
The "Corresponding Application Code" for a Combined Work means the
|
||||
object code and/or source code for the Application, including any data
|
||||
and utility programs needed for reproducing the Combined Work from the
|
||||
Application, but excluding the System Libraries of the Combined Work.
|
||||
|
||||
1. Exception to Section 3 of the GNU GPL.
|
||||
|
||||
You may convey a covered work under sections 3 and 4 of this License
|
||||
without being bound by section 3 of the GNU GPL.
|
||||
|
||||
2. Conveying Modified Versions.
|
||||
|
||||
If you modify a copy of the Library, and, in your modifications, a
|
||||
facility refers to a function or data to be supplied by an Application
|
||||
that uses the facility (other than as an argument passed when the
|
||||
facility is invoked), then you may convey a copy of the modified
|
||||
version:
|
||||
|
||||
a) under this License, provided that you make a good faith effort to
|
||||
ensure that, in the event an Application does not supply the
|
||||
function or data, the facility still operates, and performs
|
||||
whatever part of its purpose remains meaningful, or
|
||||
|
||||
b) under the GNU GPL, with none of the additional permissions of
|
||||
this License applicable to that copy.
|
||||
|
||||
3. Object Code Incorporating Material from Library Header Files.
|
||||
|
||||
The object code form of an Application may incorporate material from
|
||||
a header file that is part of the Library. You may convey such object
|
||||
code under terms of your choice, provided that, if the incorporated
|
||||
material is not limited to numerical parameters, data structure
|
||||
layouts and accessors, or small macros, inline functions and templates
|
||||
(ten or fewer lines in length), you do both of the following:
|
||||
|
||||
a) Give prominent notice with each copy of the object code that the
|
||||
Library is used in it and that the Library and its use are
|
||||
covered by this License.
|
||||
|
||||
b) Accompany the object code with a copy of the GNU GPL and this license
|
||||
document.
|
||||
|
||||
4. Combined Works.
|
||||
|
||||
You may convey a Combined Work under terms of your choice that,
|
||||
taken together, effectively do not restrict modification of the
|
||||
portions of the Library contained in the Combined Work and reverse
|
||||
engineering for debugging such modifications, if you also do each of
|
||||
the following:
|
||||
|
||||
a) Give prominent notice with each copy of the Combined Work that
|
||||
the Library is used in it and that the Library and its use are
|
||||
covered by this License.
|
||||
|
||||
b) Accompany the Combined Work with a copy of the GNU GPL and this license
|
||||
document.
|
||||
|
||||
c) For a Combined Work that displays copyright notices during
|
||||
execution, include the copyright notice for the Library among
|
||||
these notices, as well as a reference directing the user to the
|
||||
copies of the GNU GPL and this license document.
|
||||
|
||||
d) Do one of the following:
|
||||
|
||||
0) Convey the Minimal Corresponding Source under the terms of this
|
||||
License, and the Corresponding Application Code in a form
|
||||
suitable for, and under terms that permit, the user to
|
||||
recombine or relink the Application with a modified version of
|
||||
the Linked Version to produce a modified Combined Work, in the
|
||||
manner specified by section 6 of the GNU GPL for conveying
|
||||
Corresponding Source.
|
||||
|
||||
1) Use a suitable shared library mechanism for linking with the
|
||||
Library. A suitable mechanism is one that (a) uses at run time
|
||||
a copy of the Library already present on the user's computer
|
||||
system, and (b) will operate properly with a modified version
|
||||
of the Library that is interface-compatible with the Linked
|
||||
Version.
|
||||
|
||||
e) Provide Installation Information, but only if you would otherwise
|
||||
be required to provide such information under section 6 of the
|
||||
GNU GPL, and only to the extent that such information is
|
||||
necessary to install and execute a modified version of the
|
||||
Combined Work produced by recombining or relinking the
|
||||
Application with a modified version of the Linked Version. (If
|
||||
you use option 4d0, the Installation Information must accompany
|
||||
the Minimal Corresponding Source and Corresponding Application
|
||||
Code. If you use option 4d1, you must provide the Installation
|
||||
Information in the manner specified by section 6 of the GNU GPL
|
||||
for conveying Corresponding Source.)
|
||||
|
||||
5. Combined Libraries.
|
||||
|
||||
You may place library facilities that are a work based on the
|
||||
Library side by side in a single library together with other library
|
||||
facilities that are not Applications and are not covered by this
|
||||
License, and convey such a combined library under terms of your
|
||||
choice, if you do both of the following:
|
||||
|
||||
a) Accompany the combined library with a copy of the same work based
|
||||
on the Library, uncombined with any other library facilities,
|
||||
conveyed under the terms of this License.
|
||||
|
||||
b) Give prominent notice with the combined library that part of it
|
||||
is a work based on the Library, and explaining where to find the
|
||||
accompanying uncombined form of the same work.
|
||||
|
||||
6. Revised Versions of the GNU Lesser General Public License.
|
||||
|
||||
The Free Software Foundation may publish revised and/or new versions
|
||||
of the GNU Lesser General Public License from time to time. Such new
|
||||
versions will be similar in spirit to the present version, but may
|
||||
differ in detail to address new problems or concerns.
|
||||
|
||||
Each version is given a distinguishing version number. If the
|
||||
Library as you received it specifies that a certain numbered version
|
||||
of the GNU Lesser General Public License "or any later version"
|
||||
applies to it, you have the option of following the terms and
|
||||
conditions either of that published version or of any later version
|
||||
published by the Free Software Foundation. If the Library as you
|
||||
received it does not specify a version number of the GNU Lesser
|
||||
General Public License, you may choose any version of the GNU Lesser
|
||||
General Public License ever published by the Free Software Foundation.
|
||||
|
||||
If the Library as you received it specifies that a proxy can decide
|
||||
whether future versions of the GNU Lesser General Public License shall
|
||||
apply, that proxy's public statement of acceptance of any version is
|
||||
permanent authorization for you to choose that version for the
|
||||
Library.
|
||||
24
bgracontrols/COPYING.modifiedLGPL.txt
Normal file
24
bgracontrols/COPYING.modifiedLGPL.txt
Normal file
@@ -0,0 +1,24 @@
|
||||
This is the file COPYING.modifiedLGPL, it applies to all units of the
|
||||
BGRABitmap library.
|
||||
|
||||
These files are distributed under the GNU Lesser General Public License
|
||||
(see the file COPYING.LGPL) with the following modification:
|
||||
|
||||
As a special exception, the copyright holders of this library give you
|
||||
permission to link this library with independent modules to produce an
|
||||
executable, regardless of the license terms of these independent modules,
|
||||
and to copy and distribute the resulting executable under terms of your choice,
|
||||
provided that you also meet, for each linked independent module, the terms
|
||||
and conditions of the license of that module. An independent module is a
|
||||
module which is not derived from or based on this library. If you modify this
|
||||
library, you may extend this exception to your version of the library, but
|
||||
you are not obligated to do so. If you do not wish to do so, delete this
|
||||
exception statement from your version.
|
||||
|
||||
|
||||
If you didn't receive a copy of the file COPYING.LGPL, contact:
|
||||
Free Software Foundation, Inc.,
|
||||
675 Mass Ave
|
||||
Cambridge, MA 02139
|
||||
USA
|
||||
|
||||
35
bgracontrols/Makefile
Normal file
35
bgracontrols/Makefile
Normal file
@@ -0,0 +1,35 @@
|
||||
ifeq ($(OS),Windows_NT) # true for Windows_NT or later
|
||||
COPY := winmake\copyfile
|
||||
REMOVE := winmake\remove
|
||||
REMOVEDIR := winmake\removedir
|
||||
THEN := &
|
||||
RUN :=
|
||||
else
|
||||
COPY := cp
|
||||
REMOVE := rm -f
|
||||
REMOVEDIR := rm -rf
|
||||
THEN := ;
|
||||
RUN := ./
|
||||
RUN := $(strip $(RUN))
|
||||
endif
|
||||
|
||||
all: compile
|
||||
|
||||
install: not_installable
|
||||
uninstall: not_installable
|
||||
|
||||
not_installable:
|
||||
echo "The library cannot be installed on the system but statically linked to another Lazarus package or application."
|
||||
|
||||
clean: clean_bgracontrols
|
||||
|
||||
clean_bgracontrols:
|
||||
$(REMOVEDIR) "lib"
|
||||
$(REMOVEDIR) "backup"
|
||||
|
||||
compile: BGRAControls
|
||||
lazbuild:
|
||||
#lazbuild will determine what to recompile
|
||||
BGRAControls: lazbuild bgracontrols.lpk
|
||||
lazbuild bgracontrols.lpk
|
||||
|
||||
304
bgracontrols/README.md
Normal file
304
bgracontrols/README.md
Normal file
@@ -0,0 +1,304 @@
|
||||
# BGRA Controls
|
||||
|
||||
BGRA Controls is a set of graphical UI elements that you can use with Lazarus LCL applications.
|
||||
|
||||
|
||||
|
||||
### Support Us
|
||||
|
||||
If you like BGRAControls please [support @circular17 with PayPal](https://sourceforge.net/p/lazpaint/donate/?source=navbar).
|
||||
|
||||
### Installing
|
||||
|
||||
Use the Online Package Manager to get BGRABitmap and BGRAControls.
|
||||
|
||||
Notice that you must check only the packages "bgrabitmappack.lpk" and "bgracontrols.lpk" in the Online Package Manager. The other packages are optional and may need third party packages / libraries to work (OpenGL and PascalScript).
|
||||
|
||||
### Optional Components
|
||||
|
||||
Since v4.4 the components TBCDefaultThemeManager, TBCKeyboard and TBCNumericKeyboard are not installed by default to allow Linux users to get a seamless installation with the Online Package Manager not installing third party stuff. If you want these components turn on the "Register unit" in the package options for each file (bcdefaulthememanager.pas, bckeyboard.pas, bcnumerickeyboard.pas) then compile and rebuild Lazarus. On Linux you need to install libxtst-dev and libgl-dev first.
|
||||
|
||||
### Screenshots macOS 64 Cocoa
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
### TBCButton
|
||||
|
||||
A button control that can be styled through properties for each state like StateClicked, StateHover, StateNormal with settings like gradients, border and text with shadows. You can assign an already made style through the property AssignStyle.
|
||||
|
||||
Author: Dibo.
|
||||
|
||||
### TBCButtonFocus
|
||||
|
||||
Like TBCButton but it supports focus like normal TButton.
|
||||
|
||||
Author: Dibo.
|
||||
|
||||
### TBCGameGrid
|
||||
|
||||
A grid with custom width and height of items and any number of horizontal and vertical cells that can be drawn with BGRABitmap directly with the OnRenderControl event.
|
||||
|
||||
Author: Lainz.
|
||||
|
||||
### TBCImageButton
|
||||
|
||||
A button control that can be styled with one image file, containing the drawing for each state Normal, Hovered, Active and Disabled. It supports 9-slice scaling feature. It supports a nice fading animation that can be turned on.
|
||||
|
||||
Author: Lainz.
|
||||
|
||||
### TBCXButton
|
||||
|
||||
A button control that can be styled by code with the OnRenderControl event. Or even better create your own child control inheriting from this class.
|
||||
|
||||
Author: Lainz.
|
||||
|
||||
### TBCLabel
|
||||
|
||||
A label control that can be styled through properties, it supports shadow, custom borders and background.
|
||||
|
||||
Author: Dibo.
|
||||
|
||||
### TBCMaterialDesignButton
|
||||
|
||||
A button control that has an animation effect according to Google Material Design guidelines. It supports custom color for background and for the circle animation, also you can customize the shadow.
|
||||
|
||||
Author: Lainz.
|
||||
|
||||
### TBCMDButton
|
||||
|
||||
A button control like TBCMaterialDesignButton, without shadow, but with more capabilities.
|
||||
|
||||
Author: Lainz. Contributions by Fritz.
|
||||
|
||||
### TBCPanel
|
||||
|
||||
A panel control that can be styled through properties. You can assign an already made style through the property AssignStyle.
|
||||
|
||||
Author: Dibo.
|
||||
|
||||
### TBCRadialProgressBar
|
||||
|
||||
A progress bar with radial style. You can set the color and text properties as you like.
|
||||
|
||||
Author: Lainz.
|
||||
|
||||
### TBCSVGButton
|
||||
|
||||
Button made with SVG images for each state. Based on the SVG Viewer.
|
||||
|
||||
Author: Josh.
|
||||
|
||||
### TBCSVGViewer
|
||||
|
||||
SVG viewer with several options.
|
||||
|
||||
Author: Lainz, Circular.
|
||||
|
||||
### TBCToolBar
|
||||
|
||||
A TToolBar with an event OnRedraw to paint it using BGRABitmap. It supports also the default OnPaintButton to customize the buttons drawing. By default it comes with a Windows 7 like explorer toolbar style.
|
||||
|
||||
Author: Lainz.
|
||||
|
||||
### TBCTrackBarUpdown
|
||||
|
||||
A control to input numeric values with works like a trackbar and a spinedit both in one control.
|
||||
|
||||
Author: Circular.
|
||||
|
||||
### TBGRAFlashProgressBar
|
||||
|
||||
A progress bar with a default style inspired in the old Flash Player Setup for Windows progress dialog. You can change the color property to have different styles and also you can use the event OnRedraw to paint custom styles on it like text or override the entire default drawing.
|
||||
|
||||
Author: Circular.
|
||||
|
||||
### TBGRAGraphicControl
|
||||
|
||||
Is like a paintbox. You can draw with transparency with this control using the OnRedraw event.
|
||||
|
||||
Author: Circular.
|
||||
|
||||
### TBGRAImageList
|
||||
|
||||
An image list that supports alpha in all supported platforms.
|
||||
|
||||
Author: Dibo.
|
||||
|
||||
### TBGRAImageManipulation
|
||||
|
||||
A tool to manipulate pictures, see the demo that shows all the capability that comes with it.
|
||||
|
||||
Author: Emerson Cavalcanti.
|
||||
|
||||
### TBGRAKnob
|
||||
|
||||
A knob that can be styled through properties.
|
||||
|
||||
Author: Circular.
|
||||
|
||||
### TBGRAResizeSpeedButton
|
||||
|
||||
A speed button that can resize the glyph to fit in the entire control.
|
||||
|
||||
Author: Fox (helix2001).
|
||||
|
||||
### TBGRAShape
|
||||
|
||||
A control with configurable shapes like polygon and ellipse that can be filled with gradients and can have custom borders and many other visual settings.
|
||||
|
||||
Author: Circular.
|
||||
|
||||
### TBGRASpeedButton
|
||||
|
||||
A speed button that in GTK and GTK2 provides BGRABitmap powered transparency to the glyph.
|
||||
|
||||
Author: Dibo.
|
||||
|
||||
### TBGRASpriteAnimation
|
||||
|
||||
A component that can be used as image viewer or animation viewer, supports the loading of gif files.
|
||||
|
||||
Author: Lainz.
|
||||
|
||||
### TBGRAVirtualScreen
|
||||
|
||||
Is like a panel. You can draw this control using the OnRedraw event.
|
||||
|
||||
Author: Circular.
|
||||
|
||||
### TBCNumericKeyboard
|
||||
|
||||
A panel with numeric buttons to store the input in a string. Then you can use the events to edit it to fit your needs and assign to other controls that value.
|
||||
|
||||
Author: Lainz.
|
||||
|
||||
### TBCRealNumericKeyboard
|
||||
|
||||
A panel with numeric buttons to do the real input of the keys on keyboard. What you type is sent to the focused control directly.
|
||||
|
||||
Author: Lainz. Esvignolo.
|
||||
|
||||
### TBCDefaultThemeManager
|
||||
|
||||
A component to style all the selected buttons in a form with the need to style only a single button. Can be used entirely with code.
|
||||
|
||||
Author: Lainz.
|
||||
|
||||
### TDTAnalogClock
|
||||
|
||||
A clock.
|
||||
|
||||
Author: Digeo.
|
||||
|
||||
### TDTAnalogGaugue
|
||||
|
||||
A gauge.
|
||||
|
||||
Author: Digeo.
|
||||
|
||||
### TDTThemedClock
|
||||
|
||||
Another clock.
|
||||
|
||||
Author: Digeo.
|
||||
|
||||
### TDTThemedGauge
|
||||
|
||||
Another gauge.
|
||||
|
||||
Author: Digeo.
|
||||
|
||||
### TPSImport_BGRAPascalScript
|
||||
|
||||
A component to load BGRABitmap pascal script utilities.
|
||||
|
||||
Author: Lainz, Circular.
|
||||
|
||||
# BGRA Custom Drawn
|
||||
BGRA Custom Drawn is a set of controls inherited from Custom Drawn. These come with a default dark style that is like Photoshop.
|
||||
|
||||
Author: Lainz.
|
||||
|
||||
### TBCDButton
|
||||
|
||||
A button control that is styled with TBGRADrawer.
|
||||
|
||||
### TBCDEdit
|
||||
|
||||
An edit control that is styled with TBGRADrawer.
|
||||
|
||||
### TBCDStaticText
|
||||
|
||||
A label control that is styled with TBGRADrawer.
|
||||
|
||||
### TBCDProgressBar
|
||||
|
||||
A progress bar control that is styled with TBGRADrawer.
|
||||
|
||||
### TBCDSpinEdit
|
||||
|
||||
A spin edit control that is styled with TBGRADrawer.
|
||||
|
||||
### TBCDCheckBox
|
||||
|
||||
A check box control that is styled with TBGRADrawer.
|
||||
|
||||
### TBCRadioButton
|
||||
|
||||
A radio button that is styled with TBGRADrawer.
|
||||
|
||||
### TBCDPanel
|
||||
|
||||
A panel control that is styled in its own Paint event.
|
||||
|
||||
# Sample code
|
||||
|
||||
BGRA Controls comes with nice demos to show how to use the stuff and extra things you can use in your own projects.
|
||||
|
||||
Contributors: Lainz, Circular, Fred vS, Coasting and others.
|
||||
|
||||
### Pascal Script Library
|
||||
|
||||
Putting BGRABitmap methods into a .dll with c#, java and pascal headers.
|
||||
|
||||
### BGRA Ribbon Custom
|
||||
|
||||
How to create a fully themed window using the controls to achieve a Ribbon like application.
|
||||
|
||||
### Tests
|
||||
|
||||
There are test for analog controls (clock and gauge), BC prefixed controls, BGRA prefixed controls, BGRA Custom Drawn controls, how to use Pascal Script and BGRABitmap, bgrascript or how to create your own scripting solution with BGRABitmap.
|
||||
|
||||
### Tests Extra
|
||||
|
||||
These are extra tests like how to use fading effect, an fpGUI theme, games like maze and puzzle, how we created the material design animation, pix2svg or how to convert a small picture to svg using hexagons, rectangles and ellipses, plugins or how to load .dlls and use into a TBGRAVirtualScreen, rain effect, shadow effect, 9-slice-scaling with Custom Drawn or how to theme with bitmaps an application to look like Windows themes and 9-slice-scaling with charts.
|
||||
|
||||
# Another units
|
||||
|
||||
These units come with BGRA Controls and contains more functionality that is sometimes used with the controls, sometimes not but are usefull in some way. Some are listed here, others you can see linked directly with any control like bcrtti, bcstylesform, bctools, bctypes.
|
||||
|
||||
Author: Dibo.
|
||||
|
||||
### BCEffect
|
||||
|
||||
Fading effect with BGRABitmap.
|
||||
|
||||
Author: Lainz, Circular.
|
||||
|
||||
### BCFilters
|
||||
|
||||
A set of pixel filters to use with BGRABitmap.
|
||||
|
||||
Author: Lainz.
|
||||
|
||||
### BGRAScript
|
||||
|
||||
Scripting with BGRABitmap, see test project.
|
||||
|
||||
Author: Lainz.
|
||||
8
bgracontrols/_config.yml
Normal file
8
bgracontrols/_config.yml
Normal file
@@ -0,0 +1,8 @@
|
||||
title: BGRA Controls
|
||||
description:
|
||||
google_analytics:
|
||||
show_downloads: false
|
||||
theme: jekyll-theme-cayman
|
||||
|
||||
gems:
|
||||
- jekyll-mentions
|
||||
399
bgracontrols/atshapelinebgra.pas
Normal file
399
bgracontrols/atshapelinebgra.pas
Normal file
@@ -0,0 +1,399 @@
|
||||
// SPDX-License-Identifier: LGPL-3.0-linking-exception
|
||||
{ATShapeLine is a component which paints line (directions: left-right, up-down, diagonals), with or without arrows at both sides. Line width is option. Line color and arrow color are options. It is Lazarus port of Delphi component TLine (renamed since TLine id is busy with TAChart).
|
||||
|
||||
Original author: Gon Perez-Jimenez (Spain, 2002)
|
||||
Ported to Lazarus by: Alexey Torgashin (Russia)
|
||||
|
||||
- I redone get/set of canvas.pen and canvas.brush: do it only inside Paint, before it was all accross the code, in getters, setters, etc. This gives crashes of IDE on changing props in Linux.
|
||||
- I added any linewidth for any direction with arrow1=true and arrow2=true.
|
||||
- I converted demo to Laz using ide converter.
|
||||
- Icon added to component-pallette to 'Misc'.
|
||||
|
||||
For BGRAControls by: Lainz
|
||||
|
||||
- Using BGRABitmap antialiased drawing (2020-09-09)
|
||||
|
||||
Lazarus: 1.6+}
|
||||
|
||||
unit atshapelinebgra;
|
||||
|
||||
interface
|
||||
|
||||
{$mode delphi}
|
||||
|
||||
uses
|
||||
Graphics, SysUtils, Classes, Controls;
|
||||
|
||||
type
|
||||
TShapeLineDirection = (drLeftRight, drUpDown, drTopLeftBottomRight, drTopRightBottomLeft);
|
||||
|
||||
{ TShapeLineBGRA }
|
||||
|
||||
TShapeLineBGRA = class(TGraphicControl)
|
||||
private
|
||||
{ Private declarations }
|
||||
FLineDir: TShapeLineDirection;
|
||||
FArrow1: Boolean;
|
||||
FArrow2: Boolean;
|
||||
FArrowFactor: Integer;
|
||||
FLineWidth: integer;
|
||||
FLineColor: TColor;
|
||||
FArrowColor: TColor;
|
||||
|
||||
procedure SetArrowColor(AValue: TColor);
|
||||
procedure SetLineColor(AValue: TColor);
|
||||
procedure SetLineDir(AValue: TShapeLineDirection);
|
||||
procedure SetArrow1(Value: Boolean);
|
||||
procedure SetArrow2(Value: Boolean);
|
||||
procedure SetArrowFactor(Value: integer);
|
||||
procedure SetLineWidth(AValue: Integer);
|
||||
protected
|
||||
{ Protected declarations }
|
||||
procedure Paint; override;
|
||||
public
|
||||
{ Public declarations }
|
||||
constructor Create(AOwner: TComponent); override;
|
||||
destructor Destroy; override;
|
||||
published
|
||||
{ Published declarations }
|
||||
property DragCursor;
|
||||
property DragKind;
|
||||
property DragMode;
|
||||
property Align;
|
||||
property Anchors;
|
||||
property BorderSpacing;
|
||||
property ParentShowHint;
|
||||
property Hint;
|
||||
property ShowHint;
|
||||
property Visible;
|
||||
property PopupMenu;
|
||||
property Direction: TShapeLineDirection read FLineDir write SetLineDir default drLeftRight;
|
||||
property LineColor: TColor read FLineColor write SetLineColor;
|
||||
property ArrowColor: TColor read FArrowColor write SetArrowColor;
|
||||
property LineWidth: Integer read FLineWidth write SetLineWidth;
|
||||
property Arrow1: Boolean read FArrow1 write SetArrow1 default False;
|
||||
property Arrow2: Boolean read FArrow2 write SetArrow2 default False;
|
||||
property ArrowFactor: Integer read FArrowFactor write SetArrowFactor default 8;
|
||||
property OnDragDrop;
|
||||
property OnDragOver;
|
||||
property OnEndDrag;
|
||||
property OnEndDock;
|
||||
property OnMouseDown;
|
||||
property OnMouseMove;
|
||||
property OnMouseUp;
|
||||
property OnClick;
|
||||
property OnDblClick;
|
||||
end;
|
||||
|
||||
procedure Register;
|
||||
|
||||
implementation
|
||||
|
||||
uses Math, BGRABitmap, BGRABitmapTypes;
|
||||
|
||||
procedure Register;
|
||||
begin
|
||||
RegisterComponents('BGRA Controls', [TShapeLineBGRA]);
|
||||
end;
|
||||
|
||||
{ TShapeLineBGRA }
|
||||
|
||||
constructor TShapeLineBGRA.Create(AOwner: TComponent);
|
||||
begin
|
||||
inherited Create(AOwner);
|
||||
ControlStyle := ControlStyle + [csReplicatable];
|
||||
Width:=110;
|
||||
Height:=30;
|
||||
FArrow1:=false;
|
||||
FArrow2:=false;
|
||||
FArrowFactor:=8;
|
||||
FArrowColor:=clBlack;
|
||||
FLineColor:=clBlack;
|
||||
FLineWidth:=1;
|
||||
FLineDir:=drLeftRight;
|
||||
end;
|
||||
|
||||
destructor TShapeLineBGRA.Destroy;
|
||||
begin
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
procedure TShapeLineBGRA.SetArrowFactor(Value: integer);
|
||||
begin
|
||||
if Value <> FArrowFactor then begin
|
||||
FArrowFactor := Value;
|
||||
Invalidate;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TShapeLineBGRA.SetArrow1(Value: Boolean);
|
||||
begin
|
||||
if Value <> FArrow1 then begin
|
||||
FArrow1 := Value;
|
||||
Invalidate;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TShapeLineBGRA.SetArrow2(Value: Boolean);
|
||||
begin
|
||||
if Value <> FArrow2 then begin
|
||||
FArrow2 := Value;
|
||||
Invalidate;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TShapeLineBGRA.SetLineWidth(AValue: Integer);
|
||||
begin
|
||||
if AValue <> FLineWidth then
|
||||
begin
|
||||
FLineWidth := AValue;
|
||||
Invalidate;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TShapeLineBGRA.SetLineColor(AValue: TColor);
|
||||
begin
|
||||
if AValue <> FLineColor then
|
||||
begin
|
||||
FLineColor := AValue;
|
||||
Invalidate;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TShapeLineBGRA.SetArrowColor(AValue: TColor);
|
||||
begin
|
||||
if AValue <> FArrowColor then
|
||||
begin
|
||||
FArrowColor := AValue;
|
||||
Invalidate;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TShapeLineBGRA.SetLineDir(AValue: TShapeLineDirection);
|
||||
begin
|
||||
if AValue <> FLineDir then
|
||||
begin
|
||||
FLineDir := AValue;
|
||||
Invalidate;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TShapeLineBGRA.Paint;
|
||||
var
|
||||
start: Integer;
|
||||
p1,p2,p3: TPoint;
|
||||
H0,W0,H,W: Integer;
|
||||
Alfa: double;
|
||||
bgra: TBGRABitmap;
|
||||
begin
|
||||
inherited;
|
||||
|
||||
bgra := TBGRABitmap.Create(Canvas.Width, Canvas.Height, BGRAPixelTransparent);
|
||||
bgra.CanvasBGRA.Pen.Color:= FLineColor;
|
||||
bgra.CanvasBGRA.Brush.Color:=FArrowColor;
|
||||
bgra.CanvasBGRA.Pen.Width:=FLineWidth;
|
||||
|
||||
case FLineDir of
|
||||
drLeftRight:
|
||||
begin
|
||||
start := (Height - FLineWidth) div 2;
|
||||
bgra.CanvasBGRA.Pen.Width:= FLineWidth;
|
||||
bgra.CanvasBGRA.MoveTo(IfThen(FArrow1, FArrowFactor), start);
|
||||
bgra.CanvasBGRA.LineTo(Width-IfThen(FArrow2, FArrowFactor), Start);
|
||||
bgra.CanvasBGRA.Pen.Width:= 1;
|
||||
|
||||
if FArrow1 then begin
|
||||
//Flecha hacia izquierda
|
||||
p1:=Point(0,start);
|
||||
p2:=Point(FArrowFactor,Start-FArrowFactor);
|
||||
p3:=Point(FArrowFactor,Start+FArrowFactor);
|
||||
bgra.CanvasBGRA.Polygon([p1,p2,p3]);
|
||||
end;
|
||||
|
||||
if FArrow2 then begin
|
||||
//Flecha hacia derecha
|
||||
p1:=Point(Width-1, Start);
|
||||
p2:=Point(Width-(FArrowFactor+1),Start-FArrowFactor);
|
||||
p3:=Point(Width-(FArrowFactor+1),Start+FArrowFactor);
|
||||
bgra.CanvasBGRA.Polygon([p1,p2,p3]);
|
||||
end;
|
||||
end;
|
||||
|
||||
drUpDown:
|
||||
begin
|
||||
start := (Width - FLineWidth) div 2;
|
||||
bgra.CanvasBGRA.Pen.Width:= FLineWidth;
|
||||
bgra.CanvasBGRA.MoveTo(start, IfThen(FArrow1, FArrowFactor));
|
||||
bgra.CanvasBGRA.LineTo(start, Height-IfThen(FArrow2, FArrowFactor));
|
||||
bgra.CanvasBGRA.Pen.Width:= 1;
|
||||
|
||||
if FArrow1 then begin
|
||||
//Flecha hacia arriba
|
||||
p1:=Point(start,0);
|
||||
p2:=Point(Start-FArrowFactor,FArrowFactor);
|
||||
p3:=Point(Start+FArrowFactor,FArrowFactor);
|
||||
bgra.CanvasBGRA.Polygon([p1,p2,p3]);
|
||||
end;
|
||||
|
||||
if FArrow2 then begin
|
||||
//Flecha hacia abajo
|
||||
p1:=Point(start,Height-1);
|
||||
p2:=Point(Start-FArrowFactor,Height-(FArrowFactor+1));
|
||||
p3:=Point(Start+FArrowFactor,Height-(FArrowFactor+1));
|
||||
bgra.CanvasBGRA.Polygon([p1,p2,p3]);
|
||||
end;
|
||||
end;
|
||||
|
||||
drTopLeftBottomRight:
|
||||
begin
|
||||
Alfa:= arctan2(Height, Width);
|
||||
bgra.CanvasBGRA.Pen.Width:= FLineWidth;
|
||||
bgra.CanvasBGRA.MoveTo(
|
||||
IfThen(FArrow1, Trunc(FArrowFactor*cos(Alfa))),
|
||||
IfThen(FArrow1, Trunc(FArrowFactor*sin(Alfa)))
|
||||
);
|
||||
bgra.CanvasBGRA.LineTo(
|
||||
Width-IfThen(FArrow2, Trunc(FArrowFactor*cos(Alfa))),
|
||||
Height-IfThen(FArrow2, Trunc(FArrowFactor*sin(Alfa)))
|
||||
);
|
||||
bgra.CanvasBGRA.Pen.Width:= 1;
|
||||
|
||||
if FArrow1 and(Width>0)then begin
|
||||
//Flecha hacia arriba
|
||||
H0:=Round((FArrowFactor+1)*Sin(Alfa));
|
||||
W0:=Round((FArrowFactor+1)*Cos(Alfa));
|
||||
|
||||
p1:=Point(0,0);
|
||||
W:=Round(W0+(FArrowFactor*Cos((Pi/2)-Alfa)));
|
||||
H:=Round(H0-(FArrowFactor*Sin((Pi/2)-Alfa)));
|
||||
|
||||
if H<0 then H:=0;
|
||||
if W<0 then W:=0;
|
||||
|
||||
p2:=Point(W,H);
|
||||
|
||||
W:=Round(W0-(FArrowFactor*Cos((Pi/2)-Alfa)));
|
||||
H:=Round(H0+(FArrowFactor*Sin((Pi/2)-Alfa)));
|
||||
|
||||
if H<0 then H:=0;
|
||||
if W<0 then W:=0;
|
||||
|
||||
p3:=Point(W,H);
|
||||
|
||||
bgra.CanvasBGRA.Polygon([p1,p2,p3]);
|
||||
end;
|
||||
|
||||
|
||||
if FArrow2 and(Width>0)then begin
|
||||
//Flecha hacia abajo
|
||||
H0:=Round((FArrowFactor+1)*Sin(Alfa));
|
||||
W0:=Round((FArrowFactor+1)*Cos(Alfa));
|
||||
|
||||
p1:=Point(Width-1, Height-1);
|
||||
|
||||
W:=Round(W0-(FArrowFactor*Cos((Pi/2)-Alfa)));
|
||||
H:=Round(H0+(FArrowFactor*Sin((Pi/2)-Alfa)));
|
||||
|
||||
W:=Width-W-1;
|
||||
H:=Height-H-1;
|
||||
|
||||
if H>=Height then H:=Height-1;
|
||||
if W>=Width then W:=Width-1;
|
||||
|
||||
p2:=Point(W,H);
|
||||
|
||||
W:=Round(W0+(FArrowFactor*Cos((Pi/2)-Alfa)));
|
||||
H:=Round(H0-(FArrowFactor*Sin((Pi/2)-Alfa)));
|
||||
|
||||
W:=Width-W-1;
|
||||
H:=Height-H-1;
|
||||
|
||||
if H>=Height then H:=Height-1;
|
||||
if W>=Width then W:=Width-1;
|
||||
|
||||
p3:=Point(W,H);
|
||||
|
||||
bgra.CanvasBGRA.Polygon([p1,p2,p3]);
|
||||
end;
|
||||
|
||||
end;
|
||||
|
||||
drTopRightBottomLeft:
|
||||
begin
|
||||
Alfa:= arctan2(Height, Width);
|
||||
bgra.CanvasBGRA.Pen.Width:= FLineWidth;
|
||||
bgra.CanvasBGRA.MoveTo(
|
||||
Width-IfThen(FArrow1, Trunc(FArrowFactor*cos(Alfa))),
|
||||
IfThen(FArrow1, Trunc(FArrowFactor*sin(Alfa)))
|
||||
);
|
||||
bgra.CanvasBGRA.LineTo(
|
||||
IfThen(FArrow2, Trunc(FArrowFactor*cos(Alfa))),
|
||||
Height-IfThen(FArrow2, Trunc(FArrowFactor*sin(Alfa)))
|
||||
);
|
||||
bgra.CanvasBGRA.Pen.Width:= 1;
|
||||
|
||||
if FArrow1 and(Width>0)then begin
|
||||
H0:=Round((FArrowFactor+1)*Sin(Alfa));
|
||||
W0:=Round((FArrowFactor+1)*Cos(Alfa));
|
||||
|
||||
p1:=Point(Width-1,0);
|
||||
|
||||
W:=Round(W0+(FArrowFactor*Cos((Pi/2)-Alfa)));
|
||||
H:=Round(H0-(FArrowFactor*Sin((Pi/2)-Alfa)));
|
||||
|
||||
W:=Width-W-1;
|
||||
|
||||
if H<0 then H:=0;
|
||||
if W>=Width then W:=Width-1;
|
||||
|
||||
p2:=Point(W,H);
|
||||
|
||||
W:=Round(W0-(FArrowFactor*Cos((Pi/2)-Alfa)));
|
||||
H:=Round(H0+(FArrowFactor*Sin((Pi/2)-Alfa)));
|
||||
|
||||
W:=Width-W-1;
|
||||
|
||||
if H<0 then H:=0;
|
||||
if W>=Width then W:=Width-1;
|
||||
|
||||
p3:=Point(W,H);
|
||||
|
||||
bgra.CanvasBGRA.Polygon([p1,p2,p3]);
|
||||
end;
|
||||
|
||||
if FArrow2 and(Width>0)then begin
|
||||
H0:=Round((FArrowFactor+1)*Sin(Alfa));
|
||||
W0:=Round((FArrowFactor+1)*Cos(Alfa));
|
||||
|
||||
p1:=Point(0, Height-1);
|
||||
|
||||
W:=Round(W0-(FArrowFactor*Cos((Pi/2)-Alfa)));
|
||||
H:=Round(H0+(FArrowFactor*Sin((Pi/2)-Alfa)));
|
||||
|
||||
H:=Height-H-1;
|
||||
|
||||
if H>=Height then H:=Height-1;
|
||||
if W<0 then W:=0;
|
||||
|
||||
p2:=Point(W,H);
|
||||
|
||||
W:=Round(W0+(FArrowFactor*Cos((Pi/2)-Alfa)));
|
||||
H:=Round(H0-(FArrowFactor*Sin((Pi/2)-Alfa)));
|
||||
|
||||
H:=Height-H-1;
|
||||
|
||||
if H>=Height then H:=Height-1;
|
||||
if W<0 then W:=0;
|
||||
|
||||
p3:=Point(W,H);
|
||||
|
||||
bgra.CanvasBGRA.Polygon([p1,p2,p3]);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
bgra.Draw(Canvas, 0, 0, False);
|
||||
bgra.Free;
|
||||
end;
|
||||
|
||||
end.
|
||||
1837
bgracontrols/bcbasectrls.pas
Normal file
1837
bgracontrols/bcbasectrls.pas
Normal file
File diff suppressed because it is too large
Load Diff
72
bgracontrols/bcbrightandcontrast.pas
Normal file
72
bgracontrols/bcbrightandcontrast.pas
Normal file
@@ -0,0 +1,72 @@
|
||||
// SPDX-License-Identifier: LGPL-3.0-linking-exception
|
||||
{******************************* CONTRIBUTOR(S) ******************************
|
||||
- Edivando S. Santos Brasil | mailedivando@gmail.com
|
||||
(Compatibility with delphi VCL 11/2018)
|
||||
|
||||
***************************** END CONTRIBUTOR(S) *****************************}
|
||||
|
||||
unit BCBrightAndContrast;
|
||||
|
||||
{ Unit contributed by esvignolo }
|
||||
|
||||
{$I bgracontrols.inc}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils, Graphics,{$IFDEF FPC}LCLType{$ELSE}Types, BGRAGraphics, GraphType, FPImage{$ENDIF};
|
||||
|
||||
function Bright(aColor: TColor; BrightPercent: byte): TColor;
|
||||
function GetContrastColor(ABGColor: TColor): TColor;
|
||||
|
||||
implementation
|
||||
|
||||
function Bright(aColor: TColor; BrightPercent: byte): TColor;
|
||||
var
|
||||
r, g, b: byte;
|
||||
begin
|
||||
aColor := ColorToRGB(aColor);
|
||||
r := Red(aColor);
|
||||
g := Green(aColor);
|
||||
b := Blue(aColor);
|
||||
{muldiv (255-r, BrightPercent, 100); - color value in percentage,
|
||||
By which it is necessary to increase initial color (integer)}
|
||||
r := r + muldiv(255 - r, BrightPercent, 100);
|
||||
g := g + muldiv(255 - g, BrightPercent, 100);
|
||||
b := b + muldiv(255 - b, BrightPercent, 100);
|
||||
Result := RGBToColor(r, g, b);
|
||||
end;
|
||||
|
||||
function GetContrastColor(ABGColor: TColor): TColor;
|
||||
var
|
||||
ADouble: double;
|
||||
R, G, B: byte;
|
||||
begin
|
||||
if ABGColor <= 0 then
|
||||
begin
|
||||
Result := clWhite;
|
||||
Exit; // *** EXIT RIGHT HERE ***
|
||||
end;
|
||||
|
||||
if ABGColor = clWhite then
|
||||
begin
|
||||
Result := clBlack;
|
||||
Exit; // *** EXIT RIGHT HERE ***
|
||||
end;
|
||||
|
||||
// Get RGB from Color
|
||||
R := Red(ABGColor);
|
||||
G := Green(ABGColor);
|
||||
B := Blue(ABGColor);
|
||||
|
||||
// Counting the perceptive luminance - human eye favors green color...
|
||||
ADouble := 1 - (0.299 * R + 0.587 * G + 0.114 * B) / 255;
|
||||
|
||||
if (ADouble < 0.5) then
|
||||
Result := clBlack // bright colors - black font
|
||||
else
|
||||
Result := clWhite; // dark colors - white font
|
||||
end;
|
||||
|
||||
end.
|
||||
|
||||
2119
bgracontrols/bcbutton.pas
Normal file
2119
bgracontrols/bcbutton.pas
Normal file
File diff suppressed because it is too large
Load Diff
1918
bgracontrols/bcbuttonfocus.pas
Normal file
1918
bgracontrols/bcbuttonfocus.pas
Normal file
File diff suppressed because it is too large
Load Diff
796
bgracontrols/bccheckcombobox.pas
Normal file
796
bgracontrols/bccheckcombobox.pas
Normal file
@@ -0,0 +1,796 @@
|
||||
unit BCCheckComboBox;
|
||||
|
||||
{$mode delphi}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
{$ifdef WINDOWS}Windows,{$endif} Classes, SysUtils, LResources, Forms, Controls, ExtCtrls, Graphics, Dialogs, BCButton,
|
||||
StdCtrls, BCTypes, BCBaseCtrls, BGRABitmap, BGRABitmapTypes, LMessages, LCLType,
|
||||
CheckLst, BGRATheme;
|
||||
|
||||
type
|
||||
|
||||
{ TBCCheckComboBox }
|
||||
|
||||
TBCCheckComboBox = class(TBCStyleCustomControl)
|
||||
private
|
||||
FButton: TBCButton;
|
||||
FCanvasScaleMode: TBCCanvasScaleMode;
|
||||
FDropDownBorderSize: integer;
|
||||
FDropDownCount: integer;
|
||||
FDropDownColor: TColor;
|
||||
FDropDownFontColor: TColor;
|
||||
FDropDownFontHighlight: TColor;
|
||||
FDropDownHighlight: TColor;
|
||||
FFocusBorderColor: TColor;
|
||||
FFocusBorderOpacity: byte;
|
||||
FItems: TStringList;
|
||||
FItemIndex: integer;
|
||||
FForm: TForm;
|
||||
FFormHideDate: TDateTime;
|
||||
FHoverItem: integer;
|
||||
FItemHeight: integer;
|
||||
FListBox: TCheckListBox;
|
||||
FDropDownBorderColor: TColor;
|
||||
FOnDrawItem: TDrawItemEvent;
|
||||
FOnDrawSelectedItem: TOnAfterRenderBCButton;
|
||||
FOnChange: TNotifyEvent;
|
||||
FOnDropDown: TNotifyEvent;
|
||||
FDrawingDropDown: boolean;
|
||||
FTimerCheckFormHide: TTimer;
|
||||
FQueryFormHide: boolean;
|
||||
procedure ButtonClick(Sender: TObject);
|
||||
procedure DrawCheckBox(aCaption: string; State: TBGRAThemeButtonState;
|
||||
aFocused: boolean; Checked: boolean; ARect: TRect;
|
||||
ASurface: TBGRAThemeSurface);
|
||||
procedure FormDeactivate(Sender: TObject);
|
||||
procedure FormHide(Sender: TObject);
|
||||
function GetArrowFlip: boolean;
|
||||
function GetCaption: String;
|
||||
function GetComboCanvas: TCanvas;
|
||||
function GetArrowSize: integer;
|
||||
function GetArrowWidth: integer;
|
||||
function GetGlobalOpacity: byte;
|
||||
function GetItemText: string;
|
||||
function GetDropDownColor: TColor;
|
||||
function GetItemIndex: integer;
|
||||
function GetItems: TStrings;
|
||||
function GetMemoryUsage: TBCButtonMemoryUsage;
|
||||
function GetOnDrawSelectedItem: TOnAfterRenderBCButton;
|
||||
function GetRounding: TBCRounding;
|
||||
function GetStateClicked: TBCButtonState;
|
||||
function GetStateHover: TBCButtonState;
|
||||
function GetStateNormal: TBCButtonState;
|
||||
function GetStaticButton: boolean;
|
||||
procedure ListBoxKeyDown(Sender: TObject; var Key: Word; {%H-}Shift: TShiftState
|
||||
);
|
||||
procedure ListBoxMouseUp({%H-}Sender: TObject; {%H-}Button: TMouseButton;
|
||||
{%H-}Shift: TShiftState; {%H-}X, {%H-}Y: Integer);
|
||||
procedure ListBoxMouseLeave(Sender: TObject);
|
||||
procedure ListBoxMouseMove(Sender: TObject; {%H-}Shift: TShiftState; X,
|
||||
Y: Integer);
|
||||
procedure ListBoxSelectionChange(Sender: TObject; {%H-}User: boolean);
|
||||
procedure ListBoxDrawItem(Control: TWinControl; Index: Integer;
|
||||
ARect: TRect; State: TOwnerDrawState);
|
||||
procedure OnAfterRenderButton(Sender: TObject; const ABGRA: TBGRABitmap;
|
||||
AState: TBCButtonState; ARect: TRect);
|
||||
procedure OnTimerCheckFormHide(Sender: TObject);
|
||||
procedure SetArrowFlip(AValue: boolean);
|
||||
procedure SetArrowSize(AValue: integer);
|
||||
procedure SetArrowWidth(AValue: integer);
|
||||
procedure SetCanvasScaleMode(AValue: TBCCanvasScaleMode);
|
||||
procedure SetCaption(AValue: String);
|
||||
procedure SetDropDownColor(AValue: TColor);
|
||||
procedure SetGlobalOpacity(AValue: byte);
|
||||
procedure SetItemIndex(AValue: integer);
|
||||
procedure SetItems(AValue: TStrings);
|
||||
procedure SetMemoryUsage(AValue: TBCButtonMemoryUsage);
|
||||
procedure SetOnDrawSelectedItem(AValue: TOnAfterRenderBCButton);
|
||||
procedure SetRounding(AValue: TBCRounding);
|
||||
procedure SetStateClicked(AValue: TBCButtonState);
|
||||
procedure SetStateHover(AValue: TBCButtonState);
|
||||
procedure SetStateNormal(AValue: TBCButtonState);
|
||||
procedure SetStaticButton(AValue: boolean);
|
||||
protected
|
||||
function GetStyleExtension: String; override;
|
||||
procedure WMSetFocus(var {%H-}Message: {$IFDEF FPC}TLMSetFocus{$ELSE}TWMSetFocus{$ENDIF}); message {$IFDEF FPC}LM_SETFOCUS{$ELSE}WM_SETFOCUS{$ENDIF};
|
||||
procedure WMKillFocus(var Message: {$IFDEF FPC}TLMKillFocus{$ELSE}TWMKillFocus{$ENDIF}); message {$IFDEF FPC}LM_KILLFOCUS{$ELSE}WM_KILLFOCUS{$ENDIF};
|
||||
procedure UpdateFocus(AFocused: boolean);
|
||||
procedure KeyDown(var Key: Word; {%H-}Shift: TShiftState); override;
|
||||
procedure UTF8KeyPress(var UTF8Key: TUTF8Char); override;
|
||||
procedure CreateForm;
|
||||
procedure FreeForm;
|
||||
function GetListBox: TCheckListBox;
|
||||
procedure UpdateButtonCanvasScaleMode;
|
||||
public
|
||||
constructor Create(AOwner: TComponent); override;
|
||||
destructor Destroy; override;
|
||||
{ Assign the properties from Source to this instance }
|
||||
procedure Assign(Source: TPersistent); override;
|
||||
procedure Clear;
|
||||
property HoverItem: integer read FHoverItem;
|
||||
property Button: TBCButton read FButton write FButton;
|
||||
property ListBox: TCheckListBox read GetListBox;
|
||||
property Text: string read GetItemText;
|
||||
published
|
||||
property Anchors;
|
||||
property Canvas: TCanvas read GetComboCanvas;
|
||||
property CanvasScaleMode: TBCCanvasScaleMode read FCanvasScaleMode write SetCanvasScaleMode default csmAuto;
|
||||
property Caption: String read GetCaption write SetCaption;
|
||||
property Items: TStrings read GetItems write SetItems;
|
||||
property ItemIndex: integer read GetItemIndex write SetItemIndex;
|
||||
property ItemHeight: integer read FItemHeight write FItemHeight default 0;
|
||||
property ArrowSize: integer read GetArrowSize write SetArrowSize;
|
||||
property ArrowWidth: integer read GetArrowWidth write SetArrowWidth;
|
||||
property ArrowFlip: boolean read GetArrowFlip write SetArrowFlip default false;
|
||||
property FocusBorderColor: TColor read FFocusBorderColor write FFocusBorderColor default clBlack;
|
||||
property FocusBorderOpacity: byte read FFocusBorderOpacity write FFocusBorderOpacity default 255;
|
||||
property DropDownBorderColor: TColor read FDropDownBorderColor write FDropDownBorderColor default clWindowText;
|
||||
property DropDownBorderSize: integer read FDropDownBorderSize write FDropDownBorderSize default 1;
|
||||
property DropDownColor: TColor read GetDropDownColor write SetDropDownColor default clWindow;
|
||||
property DropDownFontColor: TColor read FDropDownFontColor write FDropDownFontColor default clWindowText;
|
||||
property DropDownCount: integer read FDropDownCount write FDropDownCount default 8;
|
||||
property DropDownHighlight: TColor read FDropDownHighlight write FDropDownHighlight default clHighlight;
|
||||
property DropDownFontHighlight: TColor read FDropDownFontHighlight write FDropDownFontHighlight default clHighlightText;
|
||||
property GlobalOpacity: byte read GetGlobalOpacity write SetGlobalOpacity;
|
||||
property MemoryUsage: TBCButtonMemoryUsage read GetMemoryUsage write SetMemoryUsage;
|
||||
property Rounding: TBCRounding read GetRounding write SetRounding;
|
||||
property StateClicked: TBCButtonState read GetStateClicked write SetStateClicked;
|
||||
property StateHover: TBCButtonState read GetStateHover write SetStateHover;
|
||||
property StateNormal: TBCButtonState read GetStateNormal write SetStateNormal;
|
||||
property StaticButton: boolean read GetStaticButton write SetStaticButton;
|
||||
property OnDropDown: TNotifyEvent read FOnDropDown write FOnDropDown;
|
||||
property OnDrawItem: TDrawItemEvent read FOnDrawItem write FOnDrawItem;
|
||||
property OnDrawSelectedItem: TOnAfterRenderBCButton read GetOnDrawSelectedItem write SetOnDrawSelectedItem;
|
||||
property OnChange: TNotifyEvent read FOnChange write FOnChange;
|
||||
property TabStop;
|
||||
property TabOrder;
|
||||
end;
|
||||
|
||||
procedure Register;
|
||||
|
||||
implementation
|
||||
|
||||
uses math, PropEdits, BGRAText;
|
||||
|
||||
procedure Register;
|
||||
begin
|
||||
RegisterComponents('BGRA Controls', [TBCCheckComboBox]);
|
||||
end;
|
||||
|
||||
{ TBCCheckComboBox }
|
||||
|
||||
procedure TBCCheckComboBox.ButtonClick(Sender: TObject);
|
||||
const MinDelayReopen = 500/(1000*60*60*24);
|
||||
var
|
||||
p: TPoint;
|
||||
h: Integer;
|
||||
s: TSize;
|
||||
begin
|
||||
{$IFDEF DARWIN}
|
||||
if Assigned(FForm) and not FForm.Visible then FreeForm;
|
||||
{$ENDIF}
|
||||
|
||||
CreateForm;
|
||||
|
||||
if FForm.Visible then
|
||||
FForm.Visible := false
|
||||
else
|
||||
if Now > FFormHideDate+MinDelayReopen then
|
||||
begin
|
||||
p := ControlToScreen(Point(FButton.Left, FButton.Top + FButton.Height));
|
||||
FForm.Left := p.X;
|
||||
FForm.Top := p.Y;
|
||||
FForm.Color := FDropDownBorderColor;
|
||||
FListBox.Font.Name := Button.StateNormal.FontEx.Name;
|
||||
FListBox.Font.Style := Button.StateNormal.FontEx.Style;
|
||||
FListBox.Font.Height := FontEmHeightSign*Button.StateNormal.FontEx.Height;
|
||||
self.Canvas.Font.Assign(FListBox.Font);
|
||||
if Assigned(FOnDrawItem) and (FItemHeight <> 0) then
|
||||
h := FItemHeight else h := self.Canvas.GetTextHeight('Hg');
|
||||
{$IFDEF WINDOWS}inc(h,6);{$ENDIF}
|
||||
FListBox.ItemHeight := h;
|
||||
{$IFDEF LINUX}inc(h,6);{$ENDIF}
|
||||
{$IFDEF DARWIN}inc(h,2);{$ENDIF}
|
||||
s := TSize.Create(FButton.Width, h*min(Items.Count, FDropDownCount) + 2*FDropDownBorderSize);
|
||||
FForm.ClientWidth := s.cx;
|
||||
FForm.ClientHeight := s.cy;
|
||||
FListBox.SetBounds(FDropDownBorderSize,FDropDownBorderSize,
|
||||
s.cx - 2*FDropDownBorderSize,
|
||||
s.cy - 2*FDropDownBorderSize);
|
||||
if FForm.Top + FForm.Height > Screen.WorkAreaTop + Screen.WorkAreaHeight then
|
||||
FForm.Top := FForm.Top - FForm.Height - Self.Height;
|
||||
if Assigned(FOnDropDown) then FOnDropDown(self);
|
||||
FForm.Visible := True;
|
||||
if FListBox.CanSetFocus then
|
||||
FListBox.SetFocus;
|
||||
FTimerCheckFormHide.Enabled:= true;
|
||||
FQueryFormHide := false;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TBCCheckComboBox.FormDeactivate(Sender: TObject);
|
||||
begin
|
||||
FQueryFormHide := true;
|
||||
end;
|
||||
|
||||
procedure TBCCheckComboBox.FormHide(Sender: TObject);
|
||||
begin
|
||||
FFormHideDate := Now;
|
||||
end;
|
||||
|
||||
function TBCCheckComboBox.GetArrowFlip: boolean;
|
||||
begin
|
||||
result := Button.FlipArrow;
|
||||
end;
|
||||
|
||||
function TBCCheckComboBox.GetCaption: String;
|
||||
begin
|
||||
Result := Button.Caption;
|
||||
end;
|
||||
|
||||
function TBCCheckComboBox.GetComboCanvas: TCanvas;
|
||||
begin
|
||||
if FDrawingDropDown then
|
||||
result := ListBox.Canvas
|
||||
else
|
||||
result := inherited Canvas;
|
||||
end;
|
||||
|
||||
function TBCCheckComboBox.GetArrowSize: integer;
|
||||
begin
|
||||
result := Button.DropDownArrowSize;
|
||||
end;
|
||||
|
||||
function TBCCheckComboBox.GetArrowWidth: integer;
|
||||
begin
|
||||
result := Button.DropDownWidth;
|
||||
end;
|
||||
|
||||
function TBCCheckComboBox.GetGlobalOpacity: byte;
|
||||
begin
|
||||
result := Button.GlobalOpacity;
|
||||
end;
|
||||
|
||||
function TBCCheckComboBox.GetItemText: string;
|
||||
begin
|
||||
if ItemIndex<>-1 then
|
||||
result := Items[ItemIndex]
|
||||
else
|
||||
result := '';
|
||||
end;
|
||||
|
||||
function TBCCheckComboBox.GetDropDownColor: TColor;
|
||||
begin
|
||||
if Assigned(FListBox) then
|
||||
result := FListBox.Color
|
||||
else result := FDropDownColor;
|
||||
end;
|
||||
|
||||
function TBCCheckComboBox.GetItemIndex: integer;
|
||||
begin
|
||||
if Assigned(FListBox) then
|
||||
result := FListBox.ItemIndex
|
||||
else
|
||||
begin
|
||||
if FItemIndex >= Items.Count then
|
||||
FItemIndex := -1;
|
||||
result := FItemIndex;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TBCCheckComboBox.GetItems: TStrings;
|
||||
begin
|
||||
if Assigned(FListBox) then
|
||||
Result := FListBox.Items
|
||||
else Result := FItems;
|
||||
end;
|
||||
|
||||
function TBCCheckComboBox.GetMemoryUsage: TBCButtonMemoryUsage;
|
||||
begin
|
||||
result := Button.MemoryUsage;
|
||||
end;
|
||||
|
||||
function TBCCheckComboBox.GetOnDrawSelectedItem: TOnAfterRenderBCButton;
|
||||
begin
|
||||
result := FOnDrawSelectedItem;
|
||||
end;
|
||||
|
||||
function TBCCheckComboBox.GetRounding: TBCRounding;
|
||||
begin
|
||||
result := Button.Rounding;
|
||||
end;
|
||||
|
||||
function TBCCheckComboBox.GetStateClicked: TBCButtonState;
|
||||
begin
|
||||
result := Button.StateClicked;
|
||||
end;
|
||||
|
||||
function TBCCheckComboBox.GetStateHover: TBCButtonState;
|
||||
begin
|
||||
result := Button.StateHover;
|
||||
end;
|
||||
|
||||
function TBCCheckComboBox.GetStateNormal: TBCButtonState;
|
||||
begin
|
||||
result := Button.StateNormal;
|
||||
end;
|
||||
|
||||
function TBCCheckComboBox.GetStaticButton: boolean;
|
||||
begin
|
||||
result := Button.StaticButton;
|
||||
end;
|
||||
|
||||
procedure TBCCheckComboBox.ListBoxKeyDown(Sender: TObject; var Key: Word;
|
||||
Shift: TShiftState);
|
||||
begin
|
||||
if (Key = VK_RETURN) or (Key = VK_ESCAPE) then
|
||||
begin
|
||||
ButtonClick(nil);
|
||||
Key := 0;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TBCCheckComboBox.ListBoxMouseUp(Sender: TObject; Button: TMouseButton;
|
||||
Shift: TShiftState; X, Y: Integer);
|
||||
begin
|
||||
FQueryFormHide := true;
|
||||
end;
|
||||
|
||||
procedure TBCCheckComboBox.ListBoxMouseLeave(Sender: TObject);
|
||||
begin
|
||||
FHoverItem := -1;
|
||||
FListBox.Repaint;
|
||||
end;
|
||||
|
||||
procedure TBCCheckComboBox.ListBoxMouseMove(Sender: TObject; Shift: TShiftState; X,
|
||||
Y: Integer);
|
||||
var
|
||||
TempItem: integer;
|
||||
begin
|
||||
TempItem := FListBox.ItemAtPos(Point(x, y), True);
|
||||
|
||||
if TempItem <> FHoverItem then
|
||||
begin
|
||||
FHoverItem := TempItem;
|
||||
if (FHoverItem<>-1) and ([ssLeft,ssRight]*Shift <> []) then
|
||||
FListBox.ItemIndex := FHoverItem;
|
||||
FListBox.Repaint;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TBCCheckComboBox.ListBoxSelectionChange(Sender: TObject; User: boolean);
|
||||
begin
|
||||
Button.Caption := GetItemText;
|
||||
if User and Assigned(FOnChange) then FOnChange(self);
|
||||
end;
|
||||
|
||||
procedure TBCCheckComboBox.ListBoxDrawItem(Control: TWinControl; Index: Integer;
|
||||
ARect: TRect; State: TOwnerDrawState);
|
||||
var
|
||||
surface: TBGRAThemeSurface;
|
||||
parentForm: TCustomForm;
|
||||
lclDPI: Integer;
|
||||
begin
|
||||
parentForm := GetParentForm(Control, False);
|
||||
if Assigned(parentForm) then
|
||||
lclDPI := parentForm.PixelsPerInch
|
||||
else lclDPI := Screen.PixelsPerInch;
|
||||
surface := TBGRAThemeSurface.Create(ARect, TCheckListBox(Control).Canvas, Control.GetCanvasScaleFactor, lclDPI);
|
||||
try
|
||||
DrawCheckBox(TCheckListBox(Control).Items[Index], btbsNormal, False, TCheckListBox(Control).Checked[Index], ARect, surface);
|
||||
finally
|
||||
surface.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TBCCheckComboBox.DrawCheckBox(aCaption: string; State: TBGRAThemeButtonState;
|
||||
aFocused: boolean; Checked: boolean; ARect: TRect; ASurface: TBGRAThemeSurface
|
||||
);
|
||||
var
|
||||
Style: TTextStyle;
|
||||
aColor: TBGRAPixel;
|
||||
aleft, atop, aright, abottom: integer;
|
||||
penWidth: single;
|
||||
begin
|
||||
with ASurface do
|
||||
begin
|
||||
DestCanvas.Font.Color := clBlack;
|
||||
case State of
|
||||
btbsHover: aColor := BGRA(0, 120, 215);
|
||||
btbsActive: aColor := BGRA(0, 84, 153);
|
||||
btbsDisabled:
|
||||
begin
|
||||
DestCanvas.Font.Color := clGray;
|
||||
aColor := BGRA(204, 204, 204);
|
||||
end;
|
||||
else {btbsNormal}
|
||||
aColor := BGRABlack;
|
||||
end;
|
||||
|
||||
Bitmap.Fill(BGRAWhite);
|
||||
BitmapRect := ARect;
|
||||
penWidth := ASurface.ScaleForBitmap(10) / 10;
|
||||
aleft := round(penWidth);
|
||||
aright := Bitmap.Height-round(penWidth);
|
||||
atop := round(penWidth);
|
||||
abottom := Bitmap.Height-round(penWidth);
|
||||
Bitmap.RectangleAntialias(aleft-0.5+penWidth/2, atop-0.5+penWidth/2,
|
||||
aright-0.5-penWidth/2, abottom-0.5-penWidth/2,
|
||||
aColor, penWidth);
|
||||
aleft := round(penWidth*2);
|
||||
aright := Bitmap.Height-round(penWidth*2);
|
||||
atop := round(penWidth*2);
|
||||
abottom := Bitmap.Height-round(penWidth*2);
|
||||
if Checked then
|
||||
Bitmap.DrawPolyLineAntialias(Bitmap.ComputeBezierSpline(
|
||||
[BezierCurve(pointF(aleft + 2, atop + 3), PointF((aleft + aright - 1) / 2, abottom - 3)),
|
||||
BezierCurve(PointF((aleft + aright - 1) / 2, abottom - 3), PointF(
|
||||
(aleft + aright - 1) / 2, (atop * 2 + abottom - 1) / 3), PointF(aright - 2, atop))]),
|
||||
Color, penWidth*1.5);
|
||||
DrawBitmap;
|
||||
|
||||
if aCaption <> '' then
|
||||
begin
|
||||
fillchar(Style, sizeof(Style), 0);
|
||||
Style.Alignment := taLeftJustify;
|
||||
Style.Layout := tlCenter;
|
||||
Style.Wordbreak := True;
|
||||
DestCanvas.TextRect(ARect,
|
||||
ARect.Height, 0, aCaption, Style);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TBCCheckComboBox.OnAfterRenderButton(Sender: TObject;
|
||||
const ABGRA: TBGRABitmap; AState: TBCButtonState; ARect: TRect);
|
||||
var
|
||||
focusMargin: integer;
|
||||
begin
|
||||
if Assigned(FOnDrawSelectedItem) then
|
||||
FOnDrawSelectedItem(self, ABGRA, AState, ARect);
|
||||
if Focused then
|
||||
begin
|
||||
focusMargin := round(2 * Button.CanvasScale);
|
||||
ABGRA.RectangleAntialias(ARect.Left + focusMargin, ARect.Top + focusMargin,
|
||||
ARect.Right - focusMargin - 1, ARect.Bottom - focusMargin - 1,
|
||||
ColorToBGRA(FocusBorderColor, FocusBorderOpacity),
|
||||
Button.CanvasScale);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TBCCheckComboBox.OnTimerCheckFormHide(Sender: TObject);
|
||||
{$ifdef WINDOWS}
|
||||
function IsDropDownOnTop: boolean;
|
||||
begin
|
||||
result := Assigned(FForm) and (GetForegroundWindow = FForm.Handle);
|
||||
end;
|
||||
{$endif}
|
||||
|
||||
begin
|
||||
if Assigned(FForm) and FForm.Visible and
|
||||
({$IFDEF DARWIN}not FForm.Active or {$ENDIF}
|
||||
{$IFDEF WINDOWS}not IsDropDownOnTop or{$ENDIF}
|
||||
FQueryFormHide) then
|
||||
begin
|
||||
FForm.Visible := false;
|
||||
FQueryFormHide := false;
|
||||
FTimerCheckFormHide.Enabled := false;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TBCCheckComboBox.SetArrowFlip(AValue: boolean);
|
||||
begin
|
||||
Button.FlipArrow:= AValue;
|
||||
end;
|
||||
|
||||
procedure TBCCheckComboBox.SetArrowSize(AValue: integer);
|
||||
begin
|
||||
Button.DropDownArrowSize:= AValue;
|
||||
end;
|
||||
|
||||
procedure TBCCheckComboBox.SetArrowWidth(AValue: integer);
|
||||
begin
|
||||
Button.DropDownWidth:= AValue;
|
||||
end;
|
||||
|
||||
procedure TBCCheckComboBox.SetCanvasScaleMode(AValue: TBCCanvasScaleMode);
|
||||
begin
|
||||
if FCanvasScaleMode=AValue then Exit;
|
||||
FCanvasScaleMode:=AValue;
|
||||
UpdateButtonCanvasScaleMode;
|
||||
end;
|
||||
|
||||
procedure TBCCheckComboBox.SetCaption(AValue: String);
|
||||
begin
|
||||
Button.Caption := AValue;
|
||||
end;
|
||||
|
||||
procedure TBCCheckComboBox.SetDropDownColor(AValue: TColor);
|
||||
begin
|
||||
if Assigned(FListBox) then
|
||||
FListBox.Color := AValue
|
||||
else FDropDownColor:= AValue;
|
||||
end;
|
||||
|
||||
procedure TBCCheckComboBox.SetGlobalOpacity(AValue: byte);
|
||||
begin
|
||||
Button.GlobalOpacity := AValue;
|
||||
end;
|
||||
|
||||
procedure TBCCheckComboBox.SetItemIndex(AValue: integer);
|
||||
begin
|
||||
if Assigned(FListBox) then
|
||||
FListBox.ItemIndex := AValue
|
||||
else
|
||||
begin
|
||||
if AValue <> FItemIndex then
|
||||
begin
|
||||
FItemIndex := AValue;
|
||||
Button.Caption := GetItemText;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TBCCheckComboBox.SetItems(AValue: TStrings);
|
||||
begin
|
||||
if Assigned(FListBox) then
|
||||
FListBox.Items.Assign(AValue)
|
||||
else FItems.Assign(AValue);
|
||||
end;
|
||||
|
||||
procedure TBCCheckComboBox.SetMemoryUsage(AValue: TBCButtonMemoryUsage);
|
||||
begin
|
||||
Button.MemoryUsage := AValue;
|
||||
end;
|
||||
|
||||
procedure TBCCheckComboBox.SetOnDrawSelectedItem(AValue: TOnAfterRenderBCButton);
|
||||
begin
|
||||
if @FOnDrawSelectedItem = @AValue then Exit;
|
||||
FOnDrawSelectedItem:= AValue;
|
||||
FButton.ShowCaption := not Assigned(AValue);
|
||||
UpdateButtonCanvasScaleMode;
|
||||
end;
|
||||
|
||||
procedure TBCCheckComboBox.SetRounding(AValue: TBCRounding);
|
||||
begin
|
||||
Button.Rounding := AValue;
|
||||
end;
|
||||
|
||||
procedure TBCCheckComboBox.SetStateClicked(AValue: TBCButtonState);
|
||||
begin
|
||||
Button.StateClicked := AValue;
|
||||
end;
|
||||
|
||||
procedure TBCCheckComboBox.SetStateHover(AValue: TBCButtonState);
|
||||
begin
|
||||
Button.StateHover := AValue;
|
||||
end;
|
||||
|
||||
procedure TBCCheckComboBox.SetStateNormal(AValue: TBCButtonState);
|
||||
begin
|
||||
Button.StateNormal := AValue;
|
||||
end;
|
||||
|
||||
procedure TBCCheckComboBox.SetStaticButton(AValue: boolean);
|
||||
begin
|
||||
Button.StaticButton:= AValue;
|
||||
end;
|
||||
|
||||
function TBCCheckComboBox.GetStyleExtension: String;
|
||||
begin
|
||||
result := 'bccombo';
|
||||
end;
|
||||
|
||||
procedure TBCCheckComboBox.WMSetFocus(var Message: TLMSetFocus);
|
||||
begin
|
||||
UpdateFocus(True);
|
||||
end;
|
||||
|
||||
procedure TBCCheckComboBox.WMKillFocus(var Message: TLMKillFocus);
|
||||
begin
|
||||
if Message.FocusedWnd <> Handle then
|
||||
UpdateFocus(False);
|
||||
end;
|
||||
|
||||
procedure TBCCheckComboBox.UpdateFocus(AFocused: boolean);
|
||||
var
|
||||
lForm: TCustomForm;
|
||||
oldCaption: string;
|
||||
begin
|
||||
lForm := GetParentForm(Self);
|
||||
if lForm = nil then
|
||||
exit;
|
||||
|
||||
{$IFDEF FPC}//#
|
||||
if AFocused then
|
||||
ActiveDefaultControlChanged(lForm.ActiveControl)
|
||||
else
|
||||
ActiveDefaultControlChanged(nil);
|
||||
{$ENDIF}
|
||||
|
||||
oldCaption := FButton.Caption;
|
||||
FButton.Caption := FButton.Caption + '1';
|
||||
FButton.Caption := oldCaption;
|
||||
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBCCheckComboBox.KeyDown(var Key: Word; Shift: TShiftState);
|
||||
begin
|
||||
if Key = VK_RETURN then
|
||||
begin
|
||||
ButtonClick(nil);
|
||||
Key := 0;
|
||||
end
|
||||
else if Key = VK_DOWN then
|
||||
begin
|
||||
if ItemIndex + 1 < Items.Count then
|
||||
begin
|
||||
ItemIndex := ItemIndex + 1;
|
||||
Button.Caption := GetItemText;
|
||||
if Assigned(FOnChange) then
|
||||
FOnChange(Self);
|
||||
end;
|
||||
Key := 0;
|
||||
end
|
||||
else if Key = VK_UP then
|
||||
begin
|
||||
if ItemIndex - 1 >= 0 then
|
||||
begin
|
||||
ItemIndex := ItemIndex - 1;
|
||||
Button.Caption := GetItemText;
|
||||
if Assigned(FOnChange) then
|
||||
FOnChange(Self);
|
||||
end;
|
||||
Key := 0;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TBCCheckComboBox.UTF8KeyPress(var UTF8Key: TUTF8Char);
|
||||
var
|
||||
i: integer;
|
||||
begin
|
||||
for i:=0 to Items.Count-1 do
|
||||
begin
|
||||
if (Items[i] <> '') and Items[i].ToLower.StartsWith(LowerCase(UTF8Key)) then
|
||||
begin
|
||||
if ItemIndex <> i then
|
||||
begin
|
||||
ItemIndex := i;
|
||||
Button.Caption := GetItemText;
|
||||
if Assigned(FOnChange) then
|
||||
FOnChange(Self);
|
||||
break;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TBCCheckComboBox.CreateForm;
|
||||
begin
|
||||
if FForm = nil then
|
||||
begin
|
||||
FForm := TForm.Create(Self);
|
||||
FForm.Visible := False;
|
||||
FForm.ShowInTaskBar:= stNever;
|
||||
FForm.BorderStyle := bsNone;
|
||||
FForm.OnDeactivate:= FormDeactivate;
|
||||
FForm.OnHide:=FormHide;
|
||||
FForm.FormStyle := fsStayOnTop;
|
||||
end;
|
||||
|
||||
if FListBox = nil then
|
||||
begin
|
||||
FListBox := TCheckListBox.Create(self);
|
||||
FListBox.Parent := FForm;
|
||||
FListBox.BorderStyle := bsNone;
|
||||
//FListBox.OnSelectionChange := ListBoxSelectionChange;
|
||||
FListBox.OnMouseLeave:=ListBoxMouseLeave;
|
||||
FListBox.OnMouseMove:=ListBoxMouseMove;
|
||||
//FListBox.OnMouseUp:= ListBoxMouseUp;
|
||||
FListBox.Style := lbOwnerDrawFixed;
|
||||
FListBox.OnDrawItem:= ListBoxDrawItem;
|
||||
FListBox.Options := []; // do not draw focus rect
|
||||
FListBox.OnKeyDown:=ListBoxKeyDown;
|
||||
if Assigned(FItems) then
|
||||
begin
|
||||
FListBox.Items.Assign(FItems);
|
||||
FreeAndNil(FItems);
|
||||
end;
|
||||
FListBox.ItemIndex := FItemIndex;
|
||||
FListBox.Color := FDropDownColor;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TBCCheckComboBox.FreeForm;
|
||||
begin
|
||||
if Assigned(FListBox) then
|
||||
begin
|
||||
if FListBox.LCLRefCount > 0 then exit;
|
||||
if FItems = nil then
|
||||
FItems := TStringList.Create;
|
||||
FItems.Assign(FListBox.Items);
|
||||
FItemIndex := FListBox.ItemIndex;
|
||||
FDropDownColor:= FListBox.Color;
|
||||
FreeAndNil(FListBox);
|
||||
end;
|
||||
FreeAndNil(FForm);
|
||||
end;
|
||||
|
||||
function TBCCheckComboBox.GetListBox: TCheckListBox;
|
||||
begin
|
||||
CreateForm;
|
||||
result := FListBox;
|
||||
end;
|
||||
|
||||
procedure TBCCheckComboBox.UpdateButtonCanvasScaleMode;
|
||||
begin
|
||||
if (CanvasScaleMode = csmFullResolution) or
|
||||
((CanvasScaleMode = csmAuto) and not Assigned(FOnDrawSelectedItem)) then
|
||||
FButton.CanvasScaleMode:= csmFullResolution
|
||||
else FButton.CanvasScaleMode:= csmScaleBitmap;
|
||||
end;
|
||||
|
||||
constructor TBCCheckComboBox.Create(AOwner: TComponent);
|
||||
begin
|
||||
inherited Create(AOwner);
|
||||
FButton := TBCButton.Create(Self);
|
||||
FButton.Align := alClient;
|
||||
FButton.Parent := Self;
|
||||
FButton.OnClick := ButtonClick;
|
||||
FButton.DropDownArrow := True;
|
||||
FButton.OnAfterRenderBCButton := OnAfterRenderButton;
|
||||
UpdateButtonCanvasScaleMode;
|
||||
|
||||
FItems := TStringList.Create;
|
||||
FHoverItem := -1;
|
||||
FItemIndex := -1;
|
||||
|
||||
DropDownBorderSize := 1;
|
||||
DropDownColor := clWindow;
|
||||
DropDownBorderColor := clWindowText;
|
||||
DropDownCount := 8;
|
||||
DropDownFontColor := clWindowText;
|
||||
DropDownHighlight := clHighlight;
|
||||
DropDownFontHighlight := clHighlightText;
|
||||
|
||||
FTimerCheckFormHide := TTimer.Create(self);
|
||||
FTimerCheckFormHide.Interval:= 30;
|
||||
FTimerCheckFormHide.OnTimer:= OnTimerCheckFormHide;
|
||||
end;
|
||||
|
||||
destructor TBCCheckComboBox.Destroy;
|
||||
begin
|
||||
FreeAndNil(FItems);
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
procedure TBCCheckComboBox.Assign(Source: TPersistent);
|
||||
var
|
||||
src: TBCCheckComboBox;
|
||||
begin
|
||||
if Source is TBCCheckComboBox then
|
||||
begin
|
||||
src := TBCCheckComboBox(Source);
|
||||
Button.Assign(src.Button);
|
||||
Items.Assign(src.Items);
|
||||
ItemIndex := src.ItemIndex;
|
||||
DropDownBorderColor := src.DropDownBorderColor;
|
||||
DropDownBorderSize := src.DropDownBorderSize;
|
||||
DropDownColor := src.DropDownColor;
|
||||
DropDownFontColor := src.DropDownFontColor;
|
||||
DropDownCount := src.DropDownCount;
|
||||
DropDownHighlight := src.DropDownHighlight;
|
||||
DropDownFontHighlight := src.DropDownFontHighlight;
|
||||
end else
|
||||
inherited Assign(Source);
|
||||
end;
|
||||
|
||||
procedure TBCCheckComboBox.Clear;
|
||||
begin
|
||||
Items.Clear;
|
||||
end;
|
||||
|
||||
end.
|
||||
740
bgracontrols/bccombobox.pas
Normal file
740
bgracontrols/bccombobox.pas
Normal file
@@ -0,0 +1,740 @@
|
||||
// SPDX-License-Identifier: LGPL-3.0-linking-exception
|
||||
unit BCComboBox;
|
||||
|
||||
{$mode delphi}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
{$ifdef WINDOWS}Windows,{$endif} Classes, SysUtils, LResources, Forms, Controls, ExtCtrls, Graphics, Dialogs, BCButton,
|
||||
StdCtrls, BCTypes, BCBaseCtrls, BGRABitmap, BGRABitmapTypes, LMessages, LCLType;
|
||||
|
||||
type
|
||||
|
||||
{ TBCComboBox }
|
||||
|
||||
TBCComboBox = class(TBCStyleCustomControl)
|
||||
private
|
||||
FButton: TBCButton;
|
||||
FCanvasScaleMode: TBCCanvasScaleMode;
|
||||
FDropDownBorderSize: integer;
|
||||
FDropDownCount: integer;
|
||||
FDropDownColor: TColor;
|
||||
FDropDownFontColor: TColor;
|
||||
FDropDownFontHighlight: TColor;
|
||||
FDropDownHighlight: TColor;
|
||||
FFocusBorderColor: TColor;
|
||||
FFocusBorderOpacity: byte;
|
||||
FItems: TStringList;
|
||||
FItemIndex: integer;
|
||||
FForm: TForm;
|
||||
FFormHideDate: TDateTime;
|
||||
FHoverItem: integer;
|
||||
FItemHeight: integer;
|
||||
FListBox: TListBox;
|
||||
FDropDownBorderColor: TColor;
|
||||
FOnDrawItem: TDrawItemEvent;
|
||||
FOnDrawSelectedItem: TOnAfterRenderBCButton;
|
||||
FOnChange: TNotifyEvent;
|
||||
FOnDropDown: TNotifyEvent;
|
||||
FDrawingDropDown: boolean;
|
||||
FTimerCheckFormHide: TTimer;
|
||||
FQueryFormHide: boolean;
|
||||
procedure ButtonClick(Sender: TObject);
|
||||
procedure FormDeactivate(Sender: TObject);
|
||||
procedure FormHide(Sender: TObject);
|
||||
function GetArrowFlip: boolean;
|
||||
function GetComboCanvas: TCanvas;
|
||||
function GetArrowSize: integer;
|
||||
function GetArrowWidth: integer;
|
||||
function GetGlobalOpacity: byte;
|
||||
function GetItemText: string;
|
||||
function GetDropDownColor: TColor;
|
||||
function GetItemIndex: integer;
|
||||
function GetItems: TStrings;
|
||||
function GetMemoryUsage: TBCButtonMemoryUsage;
|
||||
function GetOnDrawSelectedItem: TOnAfterRenderBCButton;
|
||||
function GetRounding: TBCRounding;
|
||||
function GetStateClicked: TBCButtonState;
|
||||
function GetStateHover: TBCButtonState;
|
||||
function GetStateNormal: TBCButtonState;
|
||||
function GetStaticButton: boolean;
|
||||
procedure ListBoxKeyDown(Sender: TObject; var Key: Word; {%H-}Shift: TShiftState
|
||||
);
|
||||
procedure ListBoxMouseUp({%H-}Sender: TObject; {%H-}Button: TMouseButton;
|
||||
{%H-}Shift: TShiftState; {%H-}X, {%H-}Y: Integer);
|
||||
procedure ListBoxMouseLeave(Sender: TObject);
|
||||
procedure ListBoxMouseMove(Sender: TObject; {%H-}Shift: TShiftState; X,
|
||||
Y: Integer);
|
||||
procedure ListBoxSelectionChange(Sender: TObject; {%H-}User: boolean);
|
||||
procedure ListBoxDrawItem(Control: TWinControl; Index: Integer;
|
||||
ARect: TRect; State: TOwnerDrawState);
|
||||
procedure OnAfterRenderButton(Sender: TObject; const ABGRA: TBGRABitmap;
|
||||
AState: TBCButtonState; ARect: TRect);
|
||||
procedure OnTimerCheckFormHide(Sender: TObject);
|
||||
procedure SetArrowFlip(AValue: boolean);
|
||||
procedure SetArrowSize(AValue: integer);
|
||||
procedure SetArrowWidth(AValue: integer);
|
||||
procedure SetCanvasScaleMode(AValue: TBCCanvasScaleMode);
|
||||
procedure SetDropDownColor(AValue: TColor);
|
||||
procedure SetGlobalOpacity(AValue: byte);
|
||||
procedure SetItemIndex(AValue: integer);
|
||||
procedure SetItems(AValue: TStrings);
|
||||
procedure SetMemoryUsage(AValue: TBCButtonMemoryUsage);
|
||||
procedure SetOnDrawSelectedItem(AValue: TOnAfterRenderBCButton);
|
||||
procedure SetRounding(AValue: TBCRounding);
|
||||
procedure SetStateClicked(AValue: TBCButtonState);
|
||||
procedure SetStateHover(AValue: TBCButtonState);
|
||||
procedure SetStateNormal(AValue: TBCButtonState);
|
||||
procedure SetStaticButton(AValue: boolean);
|
||||
protected
|
||||
function GetStyleExtension: String; override;
|
||||
procedure WMSetFocus(var {%H-}Message: {$IFDEF FPC}TLMSetFocus{$ELSE}TWMSetFocus{$ENDIF}); message {$IFDEF FPC}LM_SETFOCUS{$ELSE}WM_SETFOCUS{$ENDIF};
|
||||
procedure WMKillFocus(var Message: {$IFDEF FPC}TLMKillFocus{$ELSE}TWMKillFocus{$ENDIF}); message {$IFDEF FPC}LM_KILLFOCUS{$ELSE}WM_KILLFOCUS{$ENDIF};
|
||||
procedure UpdateFocus(AFocused: boolean);
|
||||
procedure KeyDown(var Key: Word; {%H-}Shift: TShiftState); override;
|
||||
procedure UTF8KeyPress(var UTF8Key: TUTF8Char); override;
|
||||
procedure CreateForm;
|
||||
procedure FreeForm;
|
||||
function GetListBox: TListBox;
|
||||
procedure UpdateButtonCanvasScaleMode;
|
||||
public
|
||||
constructor Create(AOwner: TComponent); override;
|
||||
destructor Destroy; override;
|
||||
{ Assign the properties from Source to this instance }
|
||||
procedure Assign(Source: TPersistent); override;
|
||||
procedure Clear;
|
||||
property HoverItem: integer read FHoverItem;
|
||||
property Button: TBCButton read FButton write FButton;
|
||||
property ListBox: TListBox read GetListBox;
|
||||
property Text: string read GetItemText;
|
||||
published
|
||||
property Anchors;
|
||||
property Canvas: TCanvas read GetComboCanvas;
|
||||
property CanvasScaleMode: TBCCanvasScaleMode read FCanvasScaleMode write SetCanvasScaleMode default csmAuto;
|
||||
property Items: TStrings read GetItems write SetItems;
|
||||
property ItemIndex: integer read GetItemIndex write SetItemIndex;
|
||||
property ItemHeight: integer read FItemHeight write FItemHeight default 0;
|
||||
property ArrowSize: integer read GetArrowSize write SetArrowSize;
|
||||
property ArrowWidth: integer read GetArrowWidth write SetArrowWidth;
|
||||
property ArrowFlip: boolean read GetArrowFlip write SetArrowFlip default false;
|
||||
property FocusBorderColor: TColor read FFocusBorderColor write FFocusBorderColor default clBlack;
|
||||
property FocusBorderOpacity: byte read FFocusBorderOpacity write FFocusBorderOpacity default 255;
|
||||
property DropDownBorderColor: TColor read FDropDownBorderColor write FDropDownBorderColor default clWindowText;
|
||||
property DropDownBorderSize: integer read FDropDownBorderSize write FDropDownBorderSize default 1;
|
||||
property DropDownColor: TColor read GetDropDownColor write SetDropDownColor default clWindow;
|
||||
property DropDownFontColor: TColor read FDropDownFontColor write FDropDownFontColor default clWindowText;
|
||||
property DropDownCount: integer read FDropDownCount write FDropDownCount default 8;
|
||||
property DropDownHighlight: TColor read FDropDownHighlight write FDropDownHighlight default clHighlight;
|
||||
property DropDownFontHighlight: TColor read FDropDownFontHighlight write FDropDownFontHighlight default clHighlightText;
|
||||
property GlobalOpacity: byte read GetGlobalOpacity write SetGlobalOpacity;
|
||||
property MemoryUsage: TBCButtonMemoryUsage read GetMemoryUsage write SetMemoryUsage;
|
||||
property Rounding: TBCRounding read GetRounding write SetRounding;
|
||||
property StateClicked: TBCButtonState read GetStateClicked write SetStateClicked;
|
||||
property StateHover: TBCButtonState read GetStateHover write SetStateHover;
|
||||
property StateNormal: TBCButtonState read GetStateNormal write SetStateNormal;
|
||||
property StaticButton: boolean read GetStaticButton write SetStaticButton;
|
||||
property OnDropDown: TNotifyEvent read FOnDropDown write FOnDropDown;
|
||||
property OnDrawItem: TDrawItemEvent read FOnDrawItem write FOnDrawItem;
|
||||
property OnDrawSelectedItem: TOnAfterRenderBCButton read GetOnDrawSelectedItem write SetOnDrawSelectedItem;
|
||||
property OnChange: TNotifyEvent read FOnChange write FOnChange;
|
||||
property TabStop;
|
||||
property TabOrder;
|
||||
end;
|
||||
|
||||
procedure Register;
|
||||
|
||||
implementation
|
||||
|
||||
uses math, PropEdits, BGRAText;
|
||||
|
||||
procedure Register;
|
||||
begin
|
||||
RegisterComponents('BGRA Controls', [TBCComboBox]);
|
||||
end;
|
||||
|
||||
{ TBCComboBox }
|
||||
|
||||
procedure TBCComboBox.ButtonClick(Sender: TObject);
|
||||
const MinDelayReopen = 500/(1000*60*60*24);
|
||||
var
|
||||
p: TPoint;
|
||||
h: Integer;
|
||||
s: TSize;
|
||||
begin
|
||||
{$IFDEF DARWIN}
|
||||
if Assigned(FForm) and not FForm.Visible then FreeForm;
|
||||
{$ENDIF}
|
||||
|
||||
CreateForm;
|
||||
|
||||
if FForm.Visible then
|
||||
FForm.Visible := false
|
||||
else
|
||||
if Now > FFormHideDate+MinDelayReopen then
|
||||
begin
|
||||
p := ControlToScreen(Point(FButton.Left, FButton.Top + FButton.Height));
|
||||
FForm.Left := p.X;
|
||||
FForm.Top := p.Y;
|
||||
FForm.Color := FDropDownBorderColor;
|
||||
FListBox.Font.Name := Button.StateNormal.FontEx.Name;
|
||||
FListBox.Font.Style := Button.StateNormal.FontEx.Style;
|
||||
FListBox.Font.Height := FontEmHeightSign*Button.StateNormal.FontEx.Height;
|
||||
self.Canvas.Font.Assign(FListBox.Font);
|
||||
if Assigned(FOnDrawItem) and (FItemHeight <> 0) then
|
||||
h := FItemHeight else h := self.Canvas.GetTextHeight('Hg');
|
||||
{$IFDEF WINDOWS}inc(h,6);{$ENDIF}
|
||||
FListBox.ItemHeight := h;
|
||||
{$IFDEF LINUX}inc(h,6);{$ENDIF}
|
||||
{$IFDEF DARWIN}inc(h,2);{$ENDIF}
|
||||
s := TSize.Create(FButton.Width, h*min(Items.Count, FDropDownCount) + 2*FDropDownBorderSize);
|
||||
FForm.ClientWidth := s.cx;
|
||||
FForm.ClientHeight := s.cy;
|
||||
FListBox.SetBounds(FDropDownBorderSize,FDropDownBorderSize,
|
||||
s.cx - 2*FDropDownBorderSize,
|
||||
s.cy - 2*FDropDownBorderSize);
|
||||
if FForm.Top + FForm.Height > Screen.WorkAreaTop + Screen.WorkAreaHeight then
|
||||
FForm.Top := FForm.Top - FForm.Height - Self.Height;
|
||||
if Assigned(FOnDropDown) then FOnDropDown(self);
|
||||
FForm.Visible := True;
|
||||
if FListBox.CanSetFocus then
|
||||
FListBox.SetFocus;
|
||||
FTimerCheckFormHide.Enabled:= true;
|
||||
FQueryFormHide := false;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TBCComboBox.FormDeactivate(Sender: TObject);
|
||||
begin
|
||||
FQueryFormHide := true;
|
||||
end;
|
||||
|
||||
procedure TBCComboBox.FormHide(Sender: TObject);
|
||||
begin
|
||||
FFormHideDate := Now;
|
||||
end;
|
||||
|
||||
function TBCComboBox.GetArrowFlip: boolean;
|
||||
begin
|
||||
result := Button.FlipArrow;
|
||||
end;
|
||||
|
||||
function TBCComboBox.GetComboCanvas: TCanvas;
|
||||
begin
|
||||
if FDrawingDropDown then
|
||||
result := ListBox.Canvas
|
||||
else
|
||||
result := inherited Canvas;
|
||||
end;
|
||||
|
||||
function TBCComboBox.GetArrowSize: integer;
|
||||
begin
|
||||
result := Button.DropDownArrowSize;
|
||||
end;
|
||||
|
||||
function TBCComboBox.GetArrowWidth: integer;
|
||||
begin
|
||||
result := Button.DropDownWidth;
|
||||
end;
|
||||
|
||||
function TBCComboBox.GetGlobalOpacity: byte;
|
||||
begin
|
||||
result := Button.GlobalOpacity;
|
||||
end;
|
||||
|
||||
function TBCComboBox.GetItemText: string;
|
||||
begin
|
||||
if ItemIndex<>-1 then
|
||||
result := Items[ItemIndex]
|
||||
else
|
||||
result := '';
|
||||
end;
|
||||
|
||||
function TBCComboBox.GetDropDownColor: TColor;
|
||||
begin
|
||||
if Assigned(FListBox) then
|
||||
result := FListBox.Color
|
||||
else result := FDropDownColor;
|
||||
end;
|
||||
|
||||
function TBCComboBox.GetItemIndex: integer;
|
||||
begin
|
||||
if Assigned(FListBox) then
|
||||
result := FListBox.ItemIndex
|
||||
else
|
||||
begin
|
||||
if FItemIndex >= Items.Count then
|
||||
FItemIndex := -1;
|
||||
result := FItemIndex;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TBCComboBox.GetItems: TStrings;
|
||||
begin
|
||||
if Assigned(FListBox) then
|
||||
Result := FListBox.Items
|
||||
else Result := FItems;
|
||||
end;
|
||||
|
||||
function TBCComboBox.GetMemoryUsage: TBCButtonMemoryUsage;
|
||||
begin
|
||||
result := Button.MemoryUsage;
|
||||
end;
|
||||
|
||||
function TBCComboBox.GetOnDrawSelectedItem: TOnAfterRenderBCButton;
|
||||
begin
|
||||
result := FOnDrawSelectedItem;
|
||||
end;
|
||||
|
||||
function TBCComboBox.GetRounding: TBCRounding;
|
||||
begin
|
||||
result := Button.Rounding;
|
||||
end;
|
||||
|
||||
function TBCComboBox.GetStateClicked: TBCButtonState;
|
||||
begin
|
||||
result := Button.StateClicked;
|
||||
end;
|
||||
|
||||
function TBCComboBox.GetStateHover: TBCButtonState;
|
||||
begin
|
||||
result := Button.StateHover;
|
||||
end;
|
||||
|
||||
function TBCComboBox.GetStateNormal: TBCButtonState;
|
||||
begin
|
||||
result := Button.StateNormal;
|
||||
end;
|
||||
|
||||
function TBCComboBox.GetStaticButton: boolean;
|
||||
begin
|
||||
result := Button.StaticButton;
|
||||
end;
|
||||
|
||||
procedure TBCComboBox.ListBoxKeyDown(Sender: TObject; var Key: Word;
|
||||
Shift: TShiftState);
|
||||
begin
|
||||
if (Key = VK_RETURN) or (Key = VK_ESCAPE) then
|
||||
begin
|
||||
ButtonClick(nil);
|
||||
Key := 0;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TBCComboBox.ListBoxMouseUp(Sender: TObject; Button: TMouseButton;
|
||||
Shift: TShiftState; X, Y: Integer);
|
||||
begin
|
||||
FQueryFormHide := true;
|
||||
end;
|
||||
|
||||
procedure TBCComboBox.ListBoxMouseLeave(Sender: TObject);
|
||||
begin
|
||||
FHoverItem := -1;
|
||||
FListBox.Repaint;
|
||||
end;
|
||||
|
||||
procedure TBCComboBox.ListBoxMouseMove(Sender: TObject; Shift: TShiftState; X,
|
||||
Y: Integer);
|
||||
var
|
||||
TempItem: integer;
|
||||
begin
|
||||
TempItem := FListBox.ItemAtPos(Point(x, y), True);
|
||||
|
||||
if TempItem <> FHoverItem then
|
||||
begin
|
||||
FHoverItem := TempItem;
|
||||
if (FHoverItem<>-1) and ([ssLeft,ssRight]*Shift <> []) then
|
||||
FListBox.ItemIndex := FHoverItem;
|
||||
FListBox.Repaint;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TBCComboBox.ListBoxSelectionChange(Sender: TObject; User: boolean);
|
||||
begin
|
||||
Button.Caption := GetItemText;
|
||||
if User and Assigned(FOnChange) then FOnChange(self);
|
||||
end;
|
||||
|
||||
procedure TBCComboBox.ListBoxDrawItem(Control: TWinControl; Index: Integer;
|
||||
ARect: TRect; State: TOwnerDrawState);
|
||||
var
|
||||
aCanvas: TCanvas;
|
||||
begin
|
||||
if Assigned(FOnDrawItem) then
|
||||
begin
|
||||
FDrawingDropDown := true;
|
||||
Exclude(State, odSelected);
|
||||
if Index = HoverItem then Include(State, odSelected);
|
||||
if Index = ItemIndex then Include(State, odChecked);
|
||||
try
|
||||
FOnDrawItem(Control, Index, ARect, State);
|
||||
finally
|
||||
FDrawingDropDown := false;
|
||||
end;
|
||||
exit;
|
||||
end;
|
||||
|
||||
aCanvas := TListBox(Control).Canvas;
|
||||
if Index = HoverItem then
|
||||
begin
|
||||
aCanvas.Brush.Color := DropDownHighlight;
|
||||
aCanvas.Font.Color := DropDownFontHighlight;
|
||||
end
|
||||
else
|
||||
begin
|
||||
aCanvas.Brush.Color := DropDownColor;
|
||||
aCanvas.Font.Color := DropDownFontColor;
|
||||
end;
|
||||
aCanvas.Pen.Style := psClear;
|
||||
aCanvas.FillRect(ARect);
|
||||
aCanvas.TextRect(ARect, ARect.Left+4, ARect.Top +
|
||||
(ARect.Height - aCanvas.GetTextHeight(Items[Index])) div 2,
|
||||
Items[Index]);
|
||||
end;
|
||||
|
||||
procedure TBCComboBox.OnAfterRenderButton(Sender: TObject;
|
||||
const ABGRA: TBGRABitmap; AState: TBCButtonState; ARect: TRect);
|
||||
var
|
||||
focusMargin: integer;
|
||||
begin
|
||||
if Assigned(FOnDrawSelectedItem) then
|
||||
FOnDrawSelectedItem(self, ABGRA, AState, ARect);
|
||||
if Focused then
|
||||
begin
|
||||
focusMargin := round(2 * Button.CanvasScale);
|
||||
ABGRA.RectangleAntialias(ARect.Left + focusMargin, ARect.Top + focusMargin,
|
||||
ARect.Right - focusMargin - 1, ARect.Bottom - focusMargin - 1,
|
||||
ColorToBGRA(FocusBorderColor, FocusBorderOpacity),
|
||||
Button.CanvasScale);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TBCComboBox.OnTimerCheckFormHide(Sender: TObject);
|
||||
{$ifdef WINDOWS}
|
||||
function IsDropDownOnTop: boolean;
|
||||
begin
|
||||
result := Assigned(FForm) and (GetForegroundWindow = FForm.Handle);
|
||||
end;
|
||||
{$endif}
|
||||
|
||||
begin
|
||||
if Assigned(FForm) and FForm.Visible and
|
||||
({$IFDEF DARWIN}not FForm.Active or {$ENDIF}
|
||||
{$IFDEF WINDOWS}not IsDropDownOnTop or{$ENDIF}
|
||||
FQueryFormHide) then
|
||||
begin
|
||||
FForm.Visible := false;
|
||||
FQueryFormHide := false;
|
||||
FTimerCheckFormHide.Enabled := false;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TBCComboBox.SetArrowFlip(AValue: boolean);
|
||||
begin
|
||||
Button.FlipArrow:= AValue;
|
||||
end;
|
||||
|
||||
procedure TBCComboBox.SetArrowSize(AValue: integer);
|
||||
begin
|
||||
Button.DropDownArrowSize:= AValue;
|
||||
end;
|
||||
|
||||
procedure TBCComboBox.SetArrowWidth(AValue: integer);
|
||||
begin
|
||||
Button.DropDownWidth:= AValue;
|
||||
end;
|
||||
|
||||
procedure TBCComboBox.SetCanvasScaleMode(AValue: TBCCanvasScaleMode);
|
||||
begin
|
||||
if FCanvasScaleMode=AValue then Exit;
|
||||
FCanvasScaleMode:=AValue;
|
||||
UpdateButtonCanvasScaleMode;
|
||||
end;
|
||||
|
||||
procedure TBCComboBox.SetDropDownColor(AValue: TColor);
|
||||
begin
|
||||
if Assigned(FListBox) then
|
||||
FListBox.Color := AValue
|
||||
else FDropDownColor:= AValue;
|
||||
end;
|
||||
|
||||
procedure TBCComboBox.SetGlobalOpacity(AValue: byte);
|
||||
begin
|
||||
Button.GlobalOpacity := AValue;
|
||||
end;
|
||||
|
||||
procedure TBCComboBox.SetItemIndex(AValue: integer);
|
||||
begin
|
||||
if Assigned(FListBox) then
|
||||
FListBox.ItemIndex := AValue
|
||||
else
|
||||
begin
|
||||
if AValue <> FItemIndex then
|
||||
begin
|
||||
FItemIndex := AValue;
|
||||
Button.Caption := GetItemText;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TBCComboBox.SetItems(AValue: TStrings);
|
||||
begin
|
||||
if Assigned(FListBox) then
|
||||
FListBox.Items.Assign(AValue)
|
||||
else FItems.Assign(AValue);
|
||||
end;
|
||||
|
||||
procedure TBCComboBox.SetMemoryUsage(AValue: TBCButtonMemoryUsage);
|
||||
begin
|
||||
Button.MemoryUsage := AValue;
|
||||
end;
|
||||
|
||||
procedure TBCComboBox.SetOnDrawSelectedItem(AValue: TOnAfterRenderBCButton);
|
||||
begin
|
||||
if @FOnDrawSelectedItem = @AValue then Exit;
|
||||
FOnDrawSelectedItem:= AValue;
|
||||
FButton.ShowCaption := not Assigned(AValue);
|
||||
UpdateButtonCanvasScaleMode;
|
||||
end;
|
||||
|
||||
procedure TBCComboBox.SetRounding(AValue: TBCRounding);
|
||||
begin
|
||||
Button.Rounding := AValue;
|
||||
end;
|
||||
|
||||
procedure TBCComboBox.SetStateClicked(AValue: TBCButtonState);
|
||||
begin
|
||||
Button.StateClicked := AValue;
|
||||
end;
|
||||
|
||||
procedure TBCComboBox.SetStateHover(AValue: TBCButtonState);
|
||||
begin
|
||||
Button.StateHover := AValue;
|
||||
end;
|
||||
|
||||
procedure TBCComboBox.SetStateNormal(AValue: TBCButtonState);
|
||||
begin
|
||||
Button.StateNormal := AValue;
|
||||
end;
|
||||
|
||||
procedure TBCComboBox.SetStaticButton(AValue: boolean);
|
||||
begin
|
||||
Button.StaticButton:= AValue;
|
||||
end;
|
||||
|
||||
function TBCComboBox.GetStyleExtension: String;
|
||||
begin
|
||||
result := 'bccombo';
|
||||
end;
|
||||
|
||||
procedure TBCComboBox.WMSetFocus(var Message: TLMSetFocus);
|
||||
begin
|
||||
UpdateFocus(True);
|
||||
end;
|
||||
|
||||
procedure TBCComboBox.WMKillFocus(var Message: TLMKillFocus);
|
||||
begin
|
||||
if Message.FocusedWnd <> Handle then
|
||||
UpdateFocus(False);
|
||||
end;
|
||||
|
||||
procedure TBCComboBox.UpdateFocus(AFocused: boolean);
|
||||
var
|
||||
lForm: TCustomForm;
|
||||
oldCaption: string;
|
||||
begin
|
||||
lForm := GetParentForm(Self);
|
||||
if lForm = nil then
|
||||
exit;
|
||||
|
||||
{$IFDEF FPC}//#
|
||||
if AFocused then
|
||||
ActiveDefaultControlChanged(lForm.ActiveControl)
|
||||
else
|
||||
ActiveDefaultControlChanged(nil);
|
||||
{$ENDIF}
|
||||
|
||||
oldCaption := FButton.Caption;
|
||||
FButton.Caption := FButton.Caption + '1';
|
||||
FButton.Caption := oldCaption;
|
||||
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBCComboBox.KeyDown(var Key: Word; Shift: TShiftState);
|
||||
begin
|
||||
if Key = VK_RETURN then
|
||||
begin
|
||||
ButtonClick(nil);
|
||||
Key := 0;
|
||||
end
|
||||
else if Key = VK_DOWN then
|
||||
begin
|
||||
if ItemIndex + 1 < Items.Count then
|
||||
begin
|
||||
ItemIndex := ItemIndex + 1;
|
||||
Button.Caption := GetItemText;
|
||||
if Assigned(FOnChange) then
|
||||
FOnChange(Self);
|
||||
end;
|
||||
Key := 0;
|
||||
end
|
||||
else if Key = VK_UP then
|
||||
begin
|
||||
if ItemIndex - 1 >= 0 then
|
||||
begin
|
||||
ItemIndex := ItemIndex - 1;
|
||||
Button.Caption := GetItemText;
|
||||
if Assigned(FOnChange) then
|
||||
FOnChange(Self);
|
||||
end;
|
||||
Key := 0;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TBCComboBox.UTF8KeyPress(var UTF8Key: TUTF8Char);
|
||||
var
|
||||
i: integer;
|
||||
begin
|
||||
for i:=0 to Items.Count-1 do
|
||||
begin
|
||||
if (Items[i] <> '') and Items[i].ToLower.StartsWith(LowerCase(UTF8Key)) then
|
||||
begin
|
||||
if ItemIndex <> i then
|
||||
begin
|
||||
ItemIndex := i;
|
||||
Button.Caption := GetItemText;
|
||||
if Assigned(FOnChange) then
|
||||
FOnChange(Self);
|
||||
break;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TBCComboBox.CreateForm;
|
||||
begin
|
||||
if FForm = nil then
|
||||
begin
|
||||
FForm := TForm.Create(Self);
|
||||
FForm.Visible := False;
|
||||
FForm.ShowInTaskBar:= stNever;
|
||||
FForm.BorderStyle := bsNone;
|
||||
FForm.OnDeactivate:= FormDeactivate;
|
||||
FForm.OnHide:=FormHide;
|
||||
FForm.FormStyle := fsStayOnTop;
|
||||
end;
|
||||
|
||||
if FListBox = nil then
|
||||
begin
|
||||
FListBox := TListBox.Create(self);
|
||||
FListBox.Parent := FForm;
|
||||
FListBox.BorderStyle := bsNone;
|
||||
FListBox.OnSelectionChange := ListBoxSelectionChange;
|
||||
FListBox.OnMouseLeave:=ListBoxMouseLeave;
|
||||
FListBox.OnMouseMove:=ListBoxMouseMove;
|
||||
FListBox.OnMouseUp:= ListBoxMouseUp;
|
||||
FListBox.Style := lbOwnerDrawFixed;
|
||||
FListBox.OnDrawItem:= ListBoxDrawItem;
|
||||
FListBox.Options := []; // do not draw focus rect
|
||||
FListBox.OnKeyDown:=ListBoxKeyDown;
|
||||
if Assigned(FItems) then
|
||||
begin
|
||||
FListBox.Items.Assign(FItems);
|
||||
FreeAndNil(FItems);
|
||||
end;
|
||||
FListBox.ItemIndex := FItemIndex;
|
||||
FListBox.Color := FDropDownColor;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TBCComboBox.FreeForm;
|
||||
begin
|
||||
if Assigned(FListBox) then
|
||||
begin
|
||||
if FListBox.LCLRefCount > 0 then exit;
|
||||
if FItems = nil then
|
||||
FItems := TStringList.Create;
|
||||
FItems.Assign(FListBox.Items);
|
||||
FItemIndex := FListBox.ItemIndex;
|
||||
FDropDownColor:= FListBox.Color;
|
||||
FreeAndNil(FListBox);
|
||||
end;
|
||||
FreeAndNil(FForm);
|
||||
end;
|
||||
|
||||
function TBCComboBox.GetListBox: TListBox;
|
||||
begin
|
||||
CreateForm;
|
||||
result := FListBox;
|
||||
end;
|
||||
|
||||
procedure TBCComboBox.UpdateButtonCanvasScaleMode;
|
||||
begin
|
||||
if (CanvasScaleMode = csmFullResolution) or
|
||||
((CanvasScaleMode = csmAuto) and not Assigned(FOnDrawSelectedItem)) then
|
||||
FButton.CanvasScaleMode:= csmFullResolution
|
||||
else FButton.CanvasScaleMode:= csmScaleBitmap;
|
||||
end;
|
||||
|
||||
constructor TBCComboBox.Create(AOwner: TComponent);
|
||||
begin
|
||||
inherited Create(AOwner);
|
||||
FButton := TBCButton.Create(Self);
|
||||
FButton.Align := alClient;
|
||||
FButton.Parent := Self;
|
||||
FButton.OnClick := ButtonClick;
|
||||
FButton.DropDownArrow := True;
|
||||
FButton.OnAfterRenderBCButton := OnAfterRenderButton;
|
||||
UpdateButtonCanvasScaleMode;
|
||||
|
||||
FItems := TStringList.Create;
|
||||
FHoverItem := -1;
|
||||
FItemIndex := -1;
|
||||
|
||||
DropDownBorderSize := 1;
|
||||
DropDownColor := clWindow;
|
||||
DropDownBorderColor := clWindowText;
|
||||
DropDownCount := 8;
|
||||
DropDownFontColor := clWindowText;
|
||||
DropDownHighlight := clHighlight;
|
||||
DropDownFontHighlight := clHighlightText;
|
||||
|
||||
FTimerCheckFormHide := TTimer.Create(self);
|
||||
FTimerCheckFormHide.Interval:= 30;
|
||||
FTimerCheckFormHide.OnTimer:= OnTimerCheckFormHide;
|
||||
end;
|
||||
|
||||
destructor TBCComboBox.Destroy;
|
||||
begin
|
||||
FreeAndNil(FItems);
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
procedure TBCComboBox.Assign(Source: TPersistent);
|
||||
var
|
||||
src: TBCComboBox;
|
||||
begin
|
||||
if Source is TBCComboBox then
|
||||
begin
|
||||
src := TBCComboBox(Source);
|
||||
Button.Assign(src.Button);
|
||||
Items.Assign(src.Items);
|
||||
ItemIndex := src.ItemIndex;
|
||||
DropDownBorderColor := src.DropDownBorderColor;
|
||||
DropDownBorderSize := src.DropDownBorderSize;
|
||||
DropDownColor := src.DropDownColor;
|
||||
DropDownFontColor := src.DropDownFontColor;
|
||||
DropDownCount := src.DropDownCount;
|
||||
DropDownHighlight := src.DropDownHighlight;
|
||||
DropDownFontHighlight := src.DropDownFontHighlight;
|
||||
end else
|
||||
inherited Assign(Source);
|
||||
end;
|
||||
|
||||
procedure TBCComboBox.Clear;
|
||||
begin
|
||||
Items.Clear;
|
||||
end;
|
||||
|
||||
end.
|
||||
260
bgracontrols/bcdefaultthememanager.pas
Normal file
260
bgracontrols/bcdefaultthememanager.pas
Normal file
@@ -0,0 +1,260 @@
|
||||
// SPDX-License-Identifier: LGPL-3.0-linking-exception
|
||||
{******************************* CONTRIBUTOR(S) ******************************
|
||||
- Edivando S. Santos Brasil | mailedivando@gmail.com
|
||||
(Compatibility with delphi VCL 11/2018)
|
||||
|
||||
***************************** END CONTRIBUTOR(S) *****************************}
|
||||
unit BCDefaultThemeManager;
|
||||
|
||||
{$I bgracontrols.inc}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils, {$IFDEF FPC}LResources, CustomDrawnDrawers,{$ENDIF}
|
||||
Forms, Controls, Graphics, Dialogs,
|
||||
{$IFNDEF FPC}BGRAGraphics, GraphType, FPImage, {$ENDIF}
|
||||
BCButton, BCButtonFocus, BCNumericKeyboard, BCThemeManager,
|
||||
BCSamples, {$IFDEF FPC}BGRACustomDrawn,{$ENDIF} BCKeyboard;
|
||||
|
||||
type
|
||||
|
||||
{ TBCDefaultThemeManager }
|
||||
|
||||
TBCDefaultThemeManager = class(TBCThemeManager)
|
||||
private
|
||||
FBCStyle: TBCSampleStyle;
|
||||
FButton: TBCButton;
|
||||
FButtonFocus: TBCButtonFocus;
|
||||
FCDStyle: TCDDrawStyle;
|
||||
procedure SetFBCStyle(AValue: TBCSampleStyle);
|
||||
procedure SetFButton(AValue: TBCButton);
|
||||
procedure SetFButtonFocus(AValue: TBCButtonFocus);
|
||||
procedure SetFCDStyle(AValue: TCDDrawStyle);
|
||||
protected
|
||||
|
||||
public
|
||||
constructor Create(AOwner: TComponent); override;
|
||||
destructor Destroy; override;
|
||||
public
|
||||
procedure Apply(AControl: TWinControl); override;
|
||||
procedure Apply(); override;
|
||||
published
|
||||
property Button: TBCButton read FButton write SetFButton;
|
||||
property ButtonFocus: TBCButtonFocus read FButtonFocus write SetFButtonFocus;
|
||||
property BCStyle: TBCSampleStyle read FBCStyle write SetFBCStyle;
|
||||
property CDStyle: TCDDrawStyle read FCDStyle write SetFCDStyle;
|
||||
end;
|
||||
|
||||
{$IFDEF FPC}procedure Register;{$ENDIF}
|
||||
|
||||
implementation
|
||||
|
||||
{$IFDEF FPC}procedure Register;
|
||||
begin
|
||||
RegisterComponents('BGRA Controls', [TBCDefaultThemeManager]);
|
||||
end;
|
||||
{$ENDIF}
|
||||
|
||||
{ TBCDefaultThemeManager }
|
||||
|
||||
procedure TBCDefaultThemeManager.SetFButton(AValue: TBCButton);
|
||||
begin
|
||||
if FButton = AValue then
|
||||
Exit;
|
||||
FButton := AValue;
|
||||
end;
|
||||
|
||||
procedure TBCDefaultThemeManager.SetFBCStyle(AValue: TBCSampleStyle);
|
||||
begin
|
||||
if FBCStyle = AValue then
|
||||
Exit;
|
||||
FBCStyle := AValue;
|
||||
end;
|
||||
|
||||
procedure TBCDefaultThemeManager.SetFButtonFocus(AValue: TBCButtonFocus);
|
||||
begin
|
||||
if FButtonFocus = AValue then
|
||||
Exit;
|
||||
FButtonFocus := AValue;
|
||||
end;
|
||||
|
||||
procedure TBCDefaultThemeManager.SetFCDStyle(AValue: TCDDrawStyle);
|
||||
begin
|
||||
if FCDStyle = AValue then
|
||||
Exit;
|
||||
FCDStyle := AValue;
|
||||
end;
|
||||
|
||||
constructor TBCDefaultThemeManager.Create(AOwner: TComponent);
|
||||
begin
|
||||
inherited Create(AOwner);
|
||||
FBCStyle := ssDefault;
|
||||
FCDStyle := dsDefault;
|
||||
end;
|
||||
|
||||
destructor TBCDefaultThemeManager.Destroy;
|
||||
begin
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
procedure TBCDefaultThemeManager.Apply(AControl: TWinControl);
|
||||
var
|
||||
i: integer;
|
||||
removeTempButton: boolean;
|
||||
removeTempButtonFocus: boolean;
|
||||
tempButton: TBCButton;
|
||||
tempButtonFocus: TBCButtonFocus;
|
||||
begin
|
||||
removeTempButton := False;
|
||||
removeTempButtonFocus := False;
|
||||
|
||||
if (Assigned(FButton)) and (FBCStyle = ssDefault) then
|
||||
tempButton := FButton
|
||||
else
|
||||
begin
|
||||
tempButton := TBCButton.Create(Self);
|
||||
tempButton.Name := 'BCDefaultThemeManager_tempButton';
|
||||
removeTempButton := True;
|
||||
StyleButtonsSample(tempButton, FBCStyle);
|
||||
end;
|
||||
|
||||
if (Assigned(FButton)) and (FBCStyle = ssDefault) then
|
||||
tempButtonFocus := FButtonFocus
|
||||
else
|
||||
begin
|
||||
tempButtonFocus := TBCButtonFocus.Create(Self);
|
||||
tempButtonFocus.Name := 'BCDefaultThemeManager_tempButtonFocus';
|
||||
removeTempButtonFocus := True;
|
||||
StyleButtonsFocusSample(tempButtonFocus, FBCStyle);
|
||||
end;
|
||||
|
||||
{ Controls }
|
||||
for i := 0 to AControl.ControlCount - 1 do
|
||||
begin
|
||||
{ BCButton }
|
||||
if (AControl.Controls[i] is TBCButton) then
|
||||
with TBCButton(AControl.Controls[i]) do
|
||||
if (Assigned(ThemeManager)) and
|
||||
(TBCDefaultThemeManager(ThemeManager).Name = Self.Name) and
|
||||
(tempButton.Name <> AControl.Controls[i].Name) then
|
||||
begin
|
||||
Assign(tempButton);
|
||||
end;
|
||||
{ BCButtonFocus }
|
||||
if (AControl.Controls[i] is TBCButtonFocus) then
|
||||
with TBCButtonFocus(AControl.Controls[i]) do
|
||||
if (Assigned(ThemeManager)) and
|
||||
(TBCDefaultThemeManager(ThemeManager).Name = Self.Name) then
|
||||
begin
|
||||
Assign(tempButtonFocus);
|
||||
end;
|
||||
{ Custom Drawn }
|
||||
if (AControl.Controls[i] is TBCDButton) then
|
||||
with TBCDButton(AControl.Controls[i]) do
|
||||
if (Assigned(ThemeManager)) and
|
||||
(TBCDefaultThemeManager(ThemeManager).Name = Self.Name) and
|
||||
(tempButtonFocus.Name <> AControl.Controls[i].Name) then
|
||||
begin
|
||||
DrawStyle := CDStyle;
|
||||
end;
|
||||
if (AControl.Controls[i] is TBCDEdit) then
|
||||
with TBCDEdit(AControl.Controls[i]) do
|
||||
if (Assigned(ThemeManager)) and
|
||||
(TBCDefaultThemeManager(ThemeManager).Name = Self.Name) and
|
||||
(tempButtonFocus.Name <> AControl.Controls[i].Name) then
|
||||
begin
|
||||
DrawStyle := CDStyle;
|
||||
end;
|
||||
if (AControl.Controls[i] is TBCDStaticText) then
|
||||
with TBCDStaticText(AControl.Controls[i]) do
|
||||
if (Assigned(ThemeManager)) and
|
||||
(TBCDefaultThemeManager(ThemeManager).Name = Self.Name) and
|
||||
(tempButtonFocus.Name <> AControl.Controls[i].Name) then
|
||||
begin
|
||||
DrawStyle := CDStyle;
|
||||
end;
|
||||
if (AControl.Controls[i] is TBCDProgressBar) then
|
||||
with TBCDProgressBar(AControl.Controls[i]) do
|
||||
if (Assigned(ThemeManager)) and
|
||||
(TBCDefaultThemeManager(ThemeManager).Name = Self.Name) and
|
||||
(tempButtonFocus.Name <> AControl.Controls[i].Name) then
|
||||
begin
|
||||
DrawStyle := CDStyle;
|
||||
end;
|
||||
if (AControl.Controls[i] is TBCDSpinEdit) then
|
||||
with TBCDSpinEdit(AControl.Controls[i]) do
|
||||
if (Assigned(ThemeManager)) and
|
||||
(TBCDefaultThemeManager(ThemeManager).Name = Self.Name) and
|
||||
(tempButtonFocus.Name <> AControl.Controls[i].Name) then
|
||||
begin
|
||||
DrawStyle := CDStyle;
|
||||
end;
|
||||
if (AControl.Controls[i] is TBCDCheckBox) then
|
||||
with TBCDCheckBox(AControl.Controls[i]) do
|
||||
if (Assigned(ThemeManager)) and
|
||||
(TBCDefaultThemeManager(ThemeManager).Name = Self.Name) and
|
||||
(tempButtonFocus.Name <> AControl.Controls[i].Name) then
|
||||
begin
|
||||
DrawStyle := CDStyle;
|
||||
end;
|
||||
if (AControl.Controls[i] is TBCDRadioButton) then
|
||||
with TBCDRadioButton(AControl.Controls[i]) do
|
||||
if (Assigned(ThemeManager)) and
|
||||
(TBCDefaultThemeManager(ThemeManager).Name = Self.Name) and
|
||||
(tempButtonFocus.Name <> AControl.Controls[i].Name) then
|
||||
begin
|
||||
DrawStyle := CDStyle;
|
||||
end;
|
||||
end;
|
||||
{ Components }
|
||||
for i := 0 to AControl.ComponentCount - 1 do
|
||||
begin
|
||||
{ BCNumericKeyboard }
|
||||
if (AControl.Components[i] is TBCNumericKeyboard) then
|
||||
with TBCNumericKeyboard(AControl.Components[i]) do
|
||||
if (Assigned(ThemeManager)) and
|
||||
(TBCDefaultThemeManager(ThemeManager).Name = Self.Name) and
|
||||
(tempButton.Name <> TBCNumericKeyboard(AControl.Components[i]).ButtonStyle.Name) then
|
||||
begin
|
||||
ButtonStyle.Assign(tempButton);
|
||||
UpdateButtonStyle;
|
||||
end;
|
||||
{ BCRealNumericKeyboard }
|
||||
if (AControl.Components[i] is TBCRealNumericKeyboard) then
|
||||
with TBCRealNumericKeyboard(AControl.Components[i]) do
|
||||
if (Assigned(ThemeManager)) and
|
||||
(TBCDefaultThemeManager(ThemeManager).Name = Self.Name) and
|
||||
(tempButton.Name <> TBCRealNumericKeyboard(AControl.Components[i]).ButtonStyle.Name) then
|
||||
begin
|
||||
ButtonStyle.Assign(tempButton);
|
||||
UpdateButtonStyle;
|
||||
end;
|
||||
{ BCKeyboard }
|
||||
if (AControl.Components[i] is TBCKeyboard) then
|
||||
with TBCKeyboard(AControl.Components[i]) do
|
||||
if (Assigned(ThemeManager)) and
|
||||
(TBCDefaultThemeManager(ThemeManager).Name = Self.Name) and
|
||||
(tempButton.Name <> TBCKeyboard(AControl.Components[i]).ButtonStyle.Name) then
|
||||
begin
|
||||
ButtonStyle.Assign(tempButton);
|
||||
UpdateButtonStyle;
|
||||
end;
|
||||
end;
|
||||
|
||||
if removeTempButton then
|
||||
tempButton.Free;
|
||||
|
||||
if removeTempButtonFocus then
|
||||
tempButtonFocus.Free;
|
||||
end;
|
||||
|
||||
procedure TBCDefaultThemeManager.Apply;
|
||||
begin
|
||||
if Self.Owner is TWinControl then
|
||||
Apply(Self.Owner as TWinControl)
|
||||
else
|
||||
raise Exception.Create('The parent is not TWinControl descendant.');
|
||||
end;
|
||||
|
||||
end.
|
||||
227
bgracontrols/bceffect.pas
Normal file
227
bgracontrols/bceffect.pas
Normal file
@@ -0,0 +1,227 @@
|
||||
// SPDX-License-Identifier: LGPL-3.0-linking-exception
|
||||
{
|
||||
Created by BGRA Controls Team
|
||||
Dibo, Circular, lainz (007) and contributors.
|
||||
For detailed information see readme.txt
|
||||
|
||||
Site: https://sourceforge.net/p/bgra-controls/
|
||||
Wiki: http://wiki.lazarus.freepascal.org/BGRAControls
|
||||
Forum: http://forum.lazarus.freepascal.org/index.php/board,46.0.html
|
||||
}
|
||||
{******************************* CONTRIBUTOR(S) ******************************
|
||||
- Edivando S. Santos Brasil | mailedivando@gmail.com
|
||||
(Compatibility with delphi VCL 11/2018)
|
||||
|
||||
***************************** END CONTRIBUTOR(S) *****************************}
|
||||
unit BCEffect;
|
||||
|
||||
{$I bgracontrols.inc}
|
||||
{$IFDEF FPC}
|
||||
{$modeswitch advancedrecords}
|
||||
{$ENDIF}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils, {$IFDEF FPC}LCLProc, LazUTF8, {$ELSE}Types, BGRAGraphics, GraphType, FPImage, {$ENDIF} BGRABitmapTypes;
|
||||
|
||||
{-- Fading --}
|
||||
|
||||
type
|
||||
TFadingMode = (fmSuspended, fmFadeIn, fmFadeOut, fmFadeInCycle, fmFadeOutCycle, fmFadeInOut, fmFadeOutIn);
|
||||
|
||||
const
|
||||
FadingModeStr: array[TFadingMode] of string = ('Suspended', 'Fade In', 'Fade Out', 'Fade In Cycle','Fade Out Cycle', 'Fade In Out', 'Fade Out In');
|
||||
|
||||
function StrToTFadingMode(const s: ansistring): TFadingMode;
|
||||
procedure FadingModeStrList(s: TStrings);
|
||||
|
||||
type
|
||||
|
||||
{ TFading }
|
||||
|
||||
TFading = record
|
||||
private
|
||||
FAlpha: byte;
|
||||
FMode: TFadingMode;
|
||||
FAlphaStep: byte;
|
||||
FDuration: integer;
|
||||
FPrevDate: TDateTime;
|
||||
FElapsedMsAccumulator: integer;
|
||||
public
|
||||
procedure SetFAlpha(AValue: byte);
|
||||
procedure SetFMode(AValue: TFadingMode);
|
||||
procedure SetFAlphaStep(AValue: byte);
|
||||
procedure SetFDuration(AValue: integer);
|
||||
public
|
||||
function Execute(AStepCount: integer= 1): byte; // execute and return new alpha
|
||||
function Reset: byte; // reset and return new alpha
|
||||
procedure PutImage(ADestination: TBGRACustomBitmap; AX,AY: integer; ASource: TBGRACustomBitmap);
|
||||
procedure FillRect(ADestination: TBGRACustomBitmap; ARect: TRect; AColor: TBGRAPixel);
|
||||
public
|
||||
property Alpha: byte read FAlpha write SetFAlpha;
|
||||
property Mode: TFadingMode read FMode write SetFMode;
|
||||
property Step: byte read FAlphaStep write SetFAlphaStep;
|
||||
property Duration: integer read FDuration write SetFDuration;
|
||||
end;
|
||||
|
||||
{-- Fading --}
|
||||
|
||||
implementation
|
||||
|
||||
{-- Fading --}
|
||||
|
||||
function StrToTFadingMode(const s: ansistring): TFadingMode;
|
||||
var
|
||||
fm: TFadingMode;
|
||||
ls: ansistring;
|
||||
begin
|
||||
ls := {$IFDEF FPC}UTF8LowerCase{$ELSE}LowerCase{$ENDIF}(s);
|
||||
for fm := low(TFadingMode) to high(TFadingMode) do
|
||||
if ls = {$IFDEF FPC}UTF8LowerCase{$ELSE}LowerCase{$ENDIF}(FadingModeStr[fm]) then
|
||||
begin
|
||||
Result := fm;
|
||||
break;
|
||||
end;
|
||||
Result := fm;
|
||||
end;
|
||||
|
||||
procedure FadingModeStrList(s: TStrings);
|
||||
var
|
||||
fm: TFadingMode;
|
||||
begin
|
||||
for fm := low(TFadingMode) to high(TFadingMode) do
|
||||
s.Add(FadingModeStr[fm]);
|
||||
end;
|
||||
|
||||
{ TFading }
|
||||
|
||||
procedure TFading.SetFAlpha(AValue: byte);
|
||||
begin
|
||||
if FAlpha = AValue then
|
||||
Exit;
|
||||
FAlpha := AValue;
|
||||
end;
|
||||
|
||||
procedure TFading.SetFMode(AValue: TFadingMode);
|
||||
begin
|
||||
if FMode = AValue then
|
||||
Exit;
|
||||
FMode := AValue;
|
||||
FPrevDate:= 0;
|
||||
end;
|
||||
|
||||
procedure TFading.SetFAlphaStep(AValue: byte);
|
||||
begin
|
||||
if FAlphaStep = AValue then
|
||||
Exit
|
||||
else
|
||||
FAlphaStep := AValue;
|
||||
end;
|
||||
|
||||
procedure TFading.SetFDuration(AValue: integer);
|
||||
begin
|
||||
FDuration:= AValue;
|
||||
end;
|
||||
|
||||
function TFading.Execute(AStepCount: integer= 1): byte;
|
||||
var curDate: TDateTime;
|
||||
alphaStep: byte;
|
||||
timeGrain: integer;
|
||||
begin
|
||||
if FAlphaStep <= 0 then
|
||||
alphaStep := 1
|
||||
else
|
||||
alphaStep := FAlphaStep;
|
||||
|
||||
if FDuration > 0 then
|
||||
begin
|
||||
curDate := Now;
|
||||
if FPrevDate = 0 then
|
||||
begin
|
||||
FPrevDate := curDate;
|
||||
FElapsedMsAccumulator := 0;
|
||||
result := FAlpha;
|
||||
exit;
|
||||
end;
|
||||
|
||||
inc(FElapsedMsAccumulator, round((curDate-FPrevDate)*(24*60*60*1000)) );
|
||||
timeGrain := round(FDuration*alphaStep/255);
|
||||
if timeGrain <= 0 then timeGrain := 1;
|
||||
AStepCount := FElapsedMsAccumulator div timeGrain;
|
||||
FElapsedMsAccumulator:= FElapsedMsAccumulator mod timeGrain;
|
||||
FPrevDate := curDate;
|
||||
end;
|
||||
|
||||
if AStepCount < 0 then AStepCount := 0
|
||||
else if AStepCount > 255 then AStepCount := 255;
|
||||
|
||||
case FMode of
|
||||
fmFadeIn, fmFadeInOut, fmFadeInCycle:
|
||||
begin
|
||||
if (FAlpha = 255) and (FMode = fmFadeInCycle) then
|
||||
FAlpha := 0
|
||||
else
|
||||
if FAlpha + alphaStep*AStepCount >= 255 then
|
||||
begin
|
||||
FAlpha := 255;
|
||||
if FMode = fmFadeInOut then
|
||||
FMode := fmFadeOutIn
|
||||
else if FMode <> fmFadeInCycle then
|
||||
FMode := fmSuspended;
|
||||
end
|
||||
else
|
||||
FAlpha := FAlpha + (alphaStep*AStepCount);
|
||||
end;
|
||||
fmFadeOut,fmFadeOutIn, fmFadeOutCycle:
|
||||
begin
|
||||
if (FAlpha = 0) and (FMode = fmFadeOutCycle) then
|
||||
FAlpha := 255
|
||||
else
|
||||
if FAlpha - alphaStep*AStepCount <= 0 then
|
||||
begin
|
||||
FAlpha := 0;
|
||||
if FMode = fmFadeOutIn then
|
||||
FMode := fmFadeInOut
|
||||
else if FMode <> fmFadeOutCycle then
|
||||
FMode := fmSuspended;
|
||||
end
|
||||
else
|
||||
FAlpha := FAlpha - (alphaStep*AStepCount);
|
||||
end;
|
||||
end;
|
||||
|
||||
Result := FAlpha;
|
||||
end;
|
||||
|
||||
function TFading.Reset: byte;
|
||||
begin
|
||||
case FMode of
|
||||
fmFadeIn, fmFadeInOut:
|
||||
begin
|
||||
FAlpha := 0;
|
||||
end;
|
||||
fmFadeOut,fmFadeOutIn:
|
||||
begin
|
||||
FAlpha := 255;
|
||||
end;
|
||||
end;
|
||||
Result := FAlpha;
|
||||
FPrevDate := 0;
|
||||
end;
|
||||
|
||||
procedure TFading.PutImage(ADestination: TBGRACustomBitmap; AX, AY: integer;
|
||||
ASource: TBGRACustomBitmap);
|
||||
begin
|
||||
ADestination.PutImage(AX,AY,ASource,dmDrawWithTransparency,Alpha);
|
||||
end;
|
||||
|
||||
procedure TFading.FillRect(ADestination: TBGRACustomBitmap; ARect: TRect;
|
||||
AColor: TBGRAPixel);
|
||||
begin
|
||||
ADestination.FillRect(ARect, BGRA(AColor.red,AColor.green,AColor.blue,AColor.alpha*Alpha div 255),dmDrawWithTransparency);
|
||||
end;
|
||||
|
||||
{-- Fading --}
|
||||
|
||||
end.
|
||||
1551
bgracontrols/bcfilters.pas
Normal file
1551
bgracontrols/bcfilters.pas
Normal file
File diff suppressed because it is too large
Load Diff
252
bgracontrols/bcfluentprogressring.pas
Normal file
252
bgracontrols/bcfluentprogressring.pas
Normal file
@@ -0,0 +1,252 @@
|
||||
{
|
||||
2024 by hedgehog
|
||||
}
|
||||
|
||||
unit BCFluentProgressRing;
|
||||
|
||||
{$mode ObjFPC}{$H+}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils, Controls, Graphics, ExtCtrls,
|
||||
BGRAGraphicControl, BGRABitmapTypes;
|
||||
|
||||
type
|
||||
|
||||
{ TBCFluentProgressRing }
|
||||
|
||||
TBCFluentProgressRing = class(TBGRAGraphicControl)
|
||||
private
|
||||
FPeriod: Int64;
|
||||
FIndeterminate: boolean;
|
||||
FStartTickCount: QWord;
|
||||
FAnimationTime: Int64;
|
||||
FTimer: TTimer;
|
||||
FMaxValue: integer;
|
||||
FMinValue: integer;
|
||||
FValue: integer;
|
||||
FLineColor: TColor;
|
||||
FLineBkgColor: TColor;
|
||||
FLineWidth: integer;
|
||||
|
||||
procedure SetIndeterminate(AValue: boolean);
|
||||
procedure SetLineBkgColor(AValue: TColor);
|
||||
procedure SetLineColor(AValue: TColor);
|
||||
procedure SetMaxValue(AValue: integer);
|
||||
procedure SetMinValue(AValue: integer);
|
||||
procedure SetValue(AValue: integer);
|
||||
procedure SetLineWidth(AValue: integer);
|
||||
protected
|
||||
procedure SetEnabled(Value: Boolean); override;
|
||||
procedure SetVisible(Value: Boolean); override;
|
||||
procedure RedrawBitmapContent; override;
|
||||
|
||||
procedure TimerEvent({%H-}Sender: TObject);
|
||||
procedure TimerStart({%H-}Sender: TObject);
|
||||
public
|
||||
constructor Create(AOwner: TComponent); override;
|
||||
published
|
||||
property MinValue: integer read FMinValue write SetMinValue default 0;
|
||||
property MaxValue: integer read FMaxValue write SetMaxValue default 100;
|
||||
property Value: integer read FValue write SetValue default 0;
|
||||
property LineColor: TColor read FLineColor write SetLineColor default
|
||||
TColor($009E5A00);
|
||||
property LineBkgColor: TColor read FLineBkgColor write SetLineBkgColor default
|
||||
TColor($00D3D3D3);
|
||||
property LineWidth: integer read FLineWidth write SetLineWidth default 0;
|
||||
property Indeterminate: boolean read FIndeterminate write SetIndeterminate default false;
|
||||
end;
|
||||
|
||||
procedure Register;
|
||||
|
||||
implementation
|
||||
|
||||
procedure Register;
|
||||
begin
|
||||
RegisterComponents('BGRA Controls', [TBCFluentProgressRing]);
|
||||
end;
|
||||
|
||||
{ TBCFluentProgressRing }
|
||||
|
||||
procedure TBCFluentProgressRing.SetMaxValue(AValue: integer);
|
||||
begin
|
||||
if FMaxValue = AValue then
|
||||
exit;
|
||||
FMaxValue := AValue;
|
||||
if FValue > FMaxValue then
|
||||
FValue := FMaxValue;
|
||||
if FMinValue > FMaxValue then
|
||||
FMinValue := FMaxValue;
|
||||
DiscardBitmap;
|
||||
end;
|
||||
|
||||
procedure TBCFluentProgressRing.SetLineBkgColor(AValue: TColor);
|
||||
begin
|
||||
if FLineBkgColor = AValue then
|
||||
Exit;
|
||||
FLineBkgColor := AValue;
|
||||
DiscardBitmap;
|
||||
end;
|
||||
|
||||
procedure TBCFluentProgressRing.SetIndeterminate(AValue: boolean);
|
||||
begin
|
||||
if FIndeterminate=AValue then Exit;
|
||||
FIndeterminate:=AValue;
|
||||
if Enabled and Visible then
|
||||
begin
|
||||
FTimer.Enabled:= FIndeterminate;
|
||||
DiscardBitmap;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TBCFluentProgressRing.SetLineColor(AValue: TColor);
|
||||
begin
|
||||
if FLineColor = AValue then
|
||||
Exit;
|
||||
FLineColor := AValue;
|
||||
DiscardBitmap;
|
||||
end;
|
||||
|
||||
procedure TBCFluentProgressRing.SetMinValue(AValue: integer);
|
||||
begin
|
||||
if FMinValue = AValue then
|
||||
exit;
|
||||
FMinValue := AValue;
|
||||
if FValue < FMinValue then
|
||||
FValue := FMinValue;
|
||||
if FMaxValue < FMinValue then
|
||||
FMaxValue := FMinValue;
|
||||
DiscardBitmap;
|
||||
end;
|
||||
|
||||
procedure TBCFluentProgressRing.SetValue(AValue: integer);
|
||||
begin
|
||||
if FValue = AValue then
|
||||
exit;
|
||||
FValue := AValue;
|
||||
if FValue < FMinValue then
|
||||
FValue := FMinValue;
|
||||
if FValue > FMaxValue then
|
||||
FValue := FMaxValue;
|
||||
DiscardBitmap;
|
||||
end;
|
||||
|
||||
procedure TBCFluentProgressRing.SetLineWidth(AValue: integer);
|
||||
begin
|
||||
if FLineWidth = AValue then exit;
|
||||
FLineWidth := AValue;
|
||||
if Visible then DiscardBitmap;
|
||||
end;
|
||||
|
||||
procedure TBCFluentProgressRing.SetEnabled(Value: Boolean);
|
||||
begin
|
||||
inherited SetEnabled(Value);
|
||||
FTimer.Enabled := Value and Visible and FIndeterminate;
|
||||
DiscardBitmap;
|
||||
end;
|
||||
|
||||
procedure TBCFluentProgressRing.SetVisible(Value: Boolean);
|
||||
begin
|
||||
inherited SetVisible(Value);
|
||||
FTimer.Enabled := Enabled and Value and FIndeterminate;
|
||||
DiscardBitmap;
|
||||
end;
|
||||
|
||||
procedure TBCFluentProgressRing.RedrawBitmapContent;
|
||||
const
|
||||
pi2= 2*pi;
|
||||
pi15 = pi*1.5;
|
||||
var
|
||||
EffectiveSize: integer;
|
||||
EffectiveLineWidth: single;
|
||||
a, da, r: single;
|
||||
|
||||
procedure DoDrawArc(a, b: single; c: TColor);
|
||||
begin
|
||||
Bitmap.Canvas2D.strokeStyle(c);
|
||||
Bitmap.Canvas2D.beginPath;
|
||||
Bitmap.Canvas2D.arc(0, 0, r, a, b, false);
|
||||
Bitmap.Canvas2D.stroke;
|
||||
end;
|
||||
|
||||
begin
|
||||
if Width< Height then
|
||||
EffectiveSize:= Width
|
||||
else
|
||||
EffectiveSize:= Height;
|
||||
|
||||
if EffectiveSize<2 then exit;
|
||||
|
||||
|
||||
Bitmap.Canvas2D.resetTransform;
|
||||
Bitmap.Canvas2D.translate(Bitmap.Width/2, Bitmap.Height/2);
|
||||
Bitmap.Canvas2D.rotate(pi15);
|
||||
|
||||
|
||||
if FLineWidth=0 then
|
||||
EffectiveLineWidth:=EffectiveSize / 12
|
||||
else
|
||||
EffectiveLineWidth:= FLineWidth;
|
||||
r:= (EffectiveSize -EffectiveLineWidth)/2;
|
||||
|
||||
Bitmap.Canvas2D.lineWidth:= EffectiveLineWidth;
|
||||
// background line
|
||||
if (FValue < FMaxValue) and (FLineBkgColor<>clNone) then
|
||||
DoDrawArc(0, pi2, FLineBkgColor);
|
||||
Bitmap.Canvas2D.lineCapLCL:= pecRound;
|
||||
|
||||
if FIndeterminate and FTimer.Enabled then
|
||||
begin
|
||||
a:= 3*FAnimationTime*pi2/FPeriod - pi;
|
||||
da:= 2*abs(1 - 2*FAnimationTime/FPeriod);
|
||||
if da>0.005 then
|
||||
DoDrawArc(a-da, a+da, FLineColor);
|
||||
end
|
||||
else if FValue > FMinValue then
|
||||
begin
|
||||
if Enabled then
|
||||
DoDrawArc(0, pi2 * FValue / FMaxValue, FLineColor)
|
||||
else
|
||||
DoDrawArc(0, pi2 * FValue / FMaxValue, clGray);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TBCFluentProgressRing.TimerEvent(Sender: TObject);
|
||||
var
|
||||
TickCount: QWord;
|
||||
begin
|
||||
TickCount:= GetTickCount64;
|
||||
FAnimationTime:= (TickCount - FStartTickCount) mod FPeriod;
|
||||
DiscardBitmap;
|
||||
end;
|
||||
|
||||
procedure TBCFluentProgressRing.TimerStart(Sender: TObject);
|
||||
begin
|
||||
FStartTickCount:= GetTickCount64;
|
||||
FAnimationTime:=0;
|
||||
end;
|
||||
|
||||
constructor TBCFluentProgressRing.Create(AOwner: TComponent);
|
||||
begin
|
||||
inherited Create(AOwner);
|
||||
FPeriod:= 2400;
|
||||
FTimer:= TTimer.Create(self);
|
||||
FTimer.Interval := 15;
|
||||
FTimer.Enabled := false;
|
||||
FTimer.OnTimer := @TimerEvent;
|
||||
FTimer.OnStartTimer:= @TimerStart;
|
||||
|
||||
with GetControlClassDefaultSize do
|
||||
SetInitialBounds(0, 0, 100, 100);
|
||||
FMaxValue := 100;
|
||||
FMinValue := 0;
|
||||
FValue := 0;
|
||||
FLineWidth:=0;
|
||||
FLineColor := TColor($009E5A00);
|
||||
FLineBkgColor := TColor($00D3D3D3);
|
||||
end;
|
||||
|
||||
|
||||
end.
|
||||
|
||||
259
bgracontrols/bcgamegrid.pas
Normal file
259
bgracontrols/bcgamegrid.pas
Normal file
@@ -0,0 +1,259 @@
|
||||
// SPDX-License-Identifier: LGPL-3.0-linking-exception
|
||||
{
|
||||
Created by BGRA Controls Team
|
||||
Dibo, Circular, lainz (007) and contributors.
|
||||
For detailed information see readme.txt
|
||||
|
||||
Site: https://sourceforge.net/p/bgra-controls/
|
||||
Wiki: http://wiki.lazarus.freepascal.org/BGRAControls
|
||||
Forum: http://forum.lazarus.freepascal.org/index.php/board,46.0.html
|
||||
}
|
||||
|
||||
{******************************* CONTRIBUTOR(S) ******************************
|
||||
- Edivando S. Santos Brasil | mailedivando@gmail.com
|
||||
(Compatibility with delphi VCL 11/2018)
|
||||
|
||||
***************************** END CONTRIBUTOR(S) *****************************}
|
||||
unit BCGameGrid;
|
||||
|
||||
{$I bgracontrols.inc}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils, {$IFDEF FPC}LResources, LCLProc,{$ENDIF} Types, Forms, Controls, Graphics, Dialogs,
|
||||
{$IFNDEF FPC}BGRAGraphics, GraphType, FPImage, {$ENDIF}
|
||||
BCBaseCtrls, BGRABitmap, BGRABitmapTypes;
|
||||
|
||||
type
|
||||
|
||||
TOnRenderControl = procedure(Sender: TObject; Bitmap: TBGRABitmap;
|
||||
r: TRect; n, x, y: integer) of object;
|
||||
TOnClickControl = procedure(Sender: TObject; n, x, y: integer) of object;
|
||||
|
||||
{ TBCCustomGrid }
|
||||
|
||||
TBCCustomGrid = class(TBCGraphicControl)
|
||||
private
|
||||
FBGRA: TBGRABitmap;
|
||||
FGridWidth: integer;
|
||||
FGridHeight: integer;
|
||||
FBlockWidth: integer;
|
||||
FBlockHeight: integer;
|
||||
FOnRenderControl: TOnRenderControl;
|
||||
FOnClickControl: TOnClickControl;
|
||||
private
|
||||
procedure SetFBlockHeight(AValue: integer);
|
||||
procedure SetFBlockWidth(AValue: integer);
|
||||
procedure SetFGridHeight(AValue: integer);
|
||||
procedure SetFGridWidth(AValue: integer);
|
||||
{ Private declarations }
|
||||
protected
|
||||
{ Protected declarations }
|
||||
procedure Click; override;
|
||||
procedure DrawControl; override;
|
||||
procedure RenderControl; override;
|
||||
public
|
||||
{ Public declarations }
|
||||
constructor Create(AOwner: TComponent); override;
|
||||
destructor Destroy; override;
|
||||
procedure RenderAndDrawControl;
|
||||
property GridWidth: integer read FGridWidth write SetFGridWidth;
|
||||
property GridHeight: integer read FGridHeight write SetFGridHeight;
|
||||
property BlockWidth: integer read FBlockWidth write SetFBlockWidth;
|
||||
property BlockHeight: integer read FBlockHeight write SetFBlockHeight;
|
||||
property OnRenderControl: TOnRenderControl
|
||||
read FOnRenderControl write FOnRenderControl;
|
||||
property OnClickControl: TOnClickControl read FOnClickControl write FOnClickControl;
|
||||
published
|
||||
{ Published declarations }
|
||||
end;
|
||||
|
||||
TBCGameGrid = class(TBCCustomGrid)
|
||||
published
|
||||
property GridWidth;
|
||||
property GridHeight;
|
||||
property BlockWidth;
|
||||
property BlockHeight;
|
||||
// Support 'n, x, y'
|
||||
property OnRenderControl;
|
||||
property OnClickControl;
|
||||
// 'Classic' events, to be changed...
|
||||
property OnMouseDown;
|
||||
property OnMouseMove;
|
||||
property OnMouseUp;
|
||||
// Ok...
|
||||
property OnMouseEnter;
|
||||
property OnMouseLeave;
|
||||
property OnMouseWheel;
|
||||
property OnMouseWheelDown;
|
||||
property OnMouseWheelUp;
|
||||
end;
|
||||
|
||||
{$IFDEF FPC}procedure Register;{$ENDIF}
|
||||
|
||||
implementation
|
||||
|
||||
{$IFDEF FPC}
|
||||
procedure Register;
|
||||
begin
|
||||
RegisterComponents('BGRA Controls', [TBCGameGrid]);
|
||||
end;
|
||||
{$ENDIF}
|
||||
|
||||
{ TBCCustomGrid }
|
||||
|
||||
procedure TBCCustomGrid.SetFBlockHeight(AValue: integer);
|
||||
begin
|
||||
if FBlockHeight = AValue then
|
||||
Exit;
|
||||
if AValue < 1 then
|
||||
FBlockHeight := 1
|
||||
else
|
||||
FBlockHeight := AValue;
|
||||
|
||||
RenderAndDrawControl;
|
||||
end;
|
||||
|
||||
procedure TBCCustomGrid.SetFBlockWidth(AValue: integer);
|
||||
begin
|
||||
if FBlockWidth = AValue then
|
||||
Exit;
|
||||
if AValue < 1 then
|
||||
FBlockWidth := 1
|
||||
else
|
||||
FBlockWidth := AValue;
|
||||
|
||||
RenderAndDrawControl;
|
||||
end;
|
||||
|
||||
procedure TBCCustomGrid.SetFGridHeight(AValue: integer);
|
||||
begin
|
||||
if FGridHeight = AValue then
|
||||
Exit;
|
||||
if AValue < 1 then
|
||||
FGridHeight := 1
|
||||
else
|
||||
FGridHeight := AValue;
|
||||
|
||||
RenderAndDrawControl;
|
||||
end;
|
||||
|
||||
procedure TBCCustomGrid.SetFGridWidth(AValue: integer);
|
||||
begin
|
||||
if FGridWidth = AValue then
|
||||
Exit;
|
||||
if AValue < 1 then
|
||||
FGridWidth := 1
|
||||
else
|
||||
FGridWidth := AValue;
|
||||
|
||||
RenderAndDrawControl;
|
||||
end;
|
||||
|
||||
procedure TBCCustomGrid.Click;
|
||||
var
|
||||
n, x, y: integer;
|
||||
r: TRect;
|
||||
var
|
||||
pos: TPoint;
|
||||
begin
|
||||
if (BlockWidth <= 0) or (BlockHeight <= 0) or (GridWidth <= 0) or
|
||||
(GridHeight <= 0) then
|
||||
Exit;
|
||||
|
||||
pos := ScreenToClient(Mouse.CursorPos);
|
||||
|
||||
n := 0;
|
||||
|
||||
for y := 0 to GridHeight - 1 do
|
||||
begin
|
||||
for x := 0 to GridWidth - 1 do
|
||||
begin
|
||||
r.Left := BlockWidth * x;
|
||||
r.Top := BlockHeight * y;
|
||||
r.Right := r.Left + BlockWidth;
|
||||
r.Bottom := r.Top + BlockHeight;
|
||||
|
||||
if (pos.x >= r.Left) and (pos.x <= r.Right) and (pos.y >= r.Top) and
|
||||
(pos.y <= r.Bottom) then
|
||||
begin
|
||||
//DebugLn(['TControl.Click ',DbgSName(Self)]);
|
||||
if Assigned(FOnClickControl) then
|
||||
FOnClickControl(Self, n, x, y);
|
||||
if (not (csDesigning in ComponentState)) and (ActionLink <> nil) then
|
||||
ActionLink.Execute(Self)
|
||||
end;
|
||||
|
||||
Inc(n);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TBCCustomGrid.DrawControl;
|
||||
begin
|
||||
if FBGRA <> nil then
|
||||
FBGRA.Draw(Canvas, 0, 0, False);
|
||||
end;
|
||||
|
||||
procedure TBCCustomGrid.RenderControl;
|
||||
var
|
||||
n, x, y: integer;
|
||||
r: TRect;
|
||||
begin
|
||||
if (BlockWidth <= 0) or (BlockHeight <= 0) or (GridWidth <= 0) or
|
||||
(GridHeight <= 0) then
|
||||
Exit;
|
||||
|
||||
if FBGRA <> nil then
|
||||
FreeAndNil(FBGRA);
|
||||
|
||||
FBGRA := TBGRABitmap.Create(Width, Height);
|
||||
|
||||
n := 0;
|
||||
|
||||
for y := 0 to GridHeight - 1 do
|
||||
begin
|
||||
for x := 0 to GridWidth - 1 do
|
||||
begin
|
||||
r.Left := BlockWidth * x;
|
||||
r.Top := BlockHeight * y;
|
||||
r.Right := r.Left + BlockWidth;
|
||||
r.Bottom := r.Top + BlockHeight;
|
||||
|
||||
FBGRA.Rectangle(r, BGRA(127, 127, 127, 127), BGRA(255, 255, 255, 127),
|
||||
dmDrawWithTransparency);
|
||||
|
||||
if Assigned(FOnRenderControl) then
|
||||
FOnRenderControl(Self, FBGRA, r, n, x, y);
|
||||
|
||||
Inc(n);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TBCCustomGrid.RenderAndDrawControl;
|
||||
begin
|
||||
RenderControl;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
constructor TBCCustomGrid.Create(AOwner: TComponent);
|
||||
begin
|
||||
inherited Create(AOwner);
|
||||
with GetControlClassDefaultSize do
|
||||
SetInitialBounds(0, 0, CX, CY);
|
||||
BlockHeight := 30;
|
||||
BlockWidth := 30;
|
||||
GridHeight := 5;
|
||||
GridWidth := 5;
|
||||
end;
|
||||
|
||||
destructor TBCCustomGrid.Destroy;
|
||||
begin
|
||||
if FBGRA <> nil then
|
||||
FreeAndNil(FBGRA);
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
end.
|
||||
254
bgracontrols/bcgradientbutton.pas
Normal file
254
bgracontrols/bcgradientbutton.pas
Normal file
@@ -0,0 +1,254 @@
|
||||
// SPDX-License-Identifier: LGPL-3.0-linking-exception
|
||||
unit BCGradientButton;
|
||||
|
||||
{$mode delphi}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs,
|
||||
BGRABitmap, BGRABitmapTypes, BCTypes;
|
||||
|
||||
type
|
||||
|
||||
{ TBCGradientButton }
|
||||
|
||||
TBCGradientButton = class(TGraphicControl)
|
||||
private
|
||||
FBorderColor: TBCPixel;
|
||||
FBorderSize: integer;
|
||||
FColor1: TBCPixel;
|
||||
FColor2: TBCPixel;
|
||||
FDimColor: TBCPixel;
|
||||
FLockHorizontal: boolean;
|
||||
FLockVertical: boolean;
|
||||
FOnAfterRedraw: TBGRARedrawEvent;
|
||||
FOnBeforeRedraw: TBGRARedrawEvent;
|
||||
Fx: integer;
|
||||
Fy: integer;
|
||||
Fdraw: boolean;
|
||||
Fupdating: boolean;
|
||||
Fdown: boolean;
|
||||
procedure ColorInvalidate({%H-}ASender: TObject; {%H-}AData: PtrInt);
|
||||
procedure SetBorderColor(AValue: TBCPixel);
|
||||
procedure SetBorderSize(AValue: integer);
|
||||
procedure SetColor1(AValue: TBCPixel);
|
||||
procedure SetColor2(AValue: TBCPixel);
|
||||
procedure SetDimColor(AValue: TBCPixel);
|
||||
procedure SetLockHorizontal(AValue: boolean);
|
||||
procedure SetLockVertical(AValue: boolean);
|
||||
protected
|
||||
procedure Paint; override;
|
||||
procedure MouseMove(Shift: TShiftState; X, Y: integer); override;
|
||||
procedure MouseLeave; override;
|
||||
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: integer); override;
|
||||
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: integer); override;
|
||||
public
|
||||
constructor Create(AOwner: TComponent); override;
|
||||
destructor Destroy; override;
|
||||
procedure Invalidate; override;
|
||||
procedure BeginUpdate;
|
||||
procedure EndUpdate;
|
||||
published
|
||||
property LockHorizontal: boolean read FLockHorizontal
|
||||
write SetLockHorizontal default False;
|
||||
property LockVertical: boolean
|
||||
read FLockVertical write SetLockVertical default False;
|
||||
property DimColor: TBCPixel read FDimColor write SetDimColor;
|
||||
property Color1: TBCPixel read FColor1 write SetColor1;
|
||||
property Color2: TBCPixel read FColor2 write SetColor2;
|
||||
property BorderColor: TBCPixel read FBorderColor write SetBorderColor;
|
||||
property BorderSize: integer read FBorderSize write SetBorderSize;
|
||||
property OnBeforeRedraw: TBGRARedrawEvent read FOnBeforeRedraw write FOnBeforeRedraw;
|
||||
property OnAfterRedraw: TBGRARedrawEvent read FOnAfterRedraw write FOnAfterRedraw;
|
||||
published
|
||||
property Align;
|
||||
property Anchors;
|
||||
property BorderSpacing;
|
||||
property Caption;
|
||||
property Enabled;
|
||||
property ShowHint;
|
||||
end;
|
||||
|
||||
procedure Register;
|
||||
|
||||
implementation
|
||||
|
||||
procedure Register;
|
||||
begin
|
||||
RegisterComponents('BGRA Button Controls', [TBCGradientButton]);
|
||||
end;
|
||||
|
||||
{ TBCGradientButton }
|
||||
|
||||
procedure TBCGradientButton.SetLockHorizontal(AValue: boolean);
|
||||
begin
|
||||
if FLockHorizontal = AValue then
|
||||
Exit;
|
||||
FLockHorizontal := AValue;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBCGradientButton.SetColor1(AValue: TBCPixel);
|
||||
begin
|
||||
if FColor1 = AValue then
|
||||
Exit;
|
||||
FColor1 := AValue;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBCGradientButton.SetBorderColor(AValue: TBCPixel);
|
||||
begin
|
||||
if FBorderColor = AValue then
|
||||
Exit;
|
||||
FBorderColor := AValue;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBCGradientButton.ColorInvalidate(ASender: TObject; AData: PtrInt);
|
||||
begin
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBCGradientButton.SetBorderSize(AValue: integer);
|
||||
begin
|
||||
if FBorderSize = AValue then
|
||||
Exit;
|
||||
FBorderSize := AValue;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBCGradientButton.SetColor2(AValue: TBCPixel);
|
||||
begin
|
||||
if FColor2 = AValue then
|
||||
Exit;
|
||||
FColor2 := AValue;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBCGradientButton.SetDimColor(AValue: TBCPixel);
|
||||
begin
|
||||
if FDimColor = AValue then
|
||||
Exit;
|
||||
FDimColor := AValue;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBCGradientButton.SetLockVertical(AValue: boolean);
|
||||
begin
|
||||
if FLockVertical = AValue then
|
||||
Exit;
|
||||
FLockVertical := AValue;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBCGradientButton.Paint;
|
||||
var
|
||||
bmp: TBGRABitmap;
|
||||
x, y: integer;
|
||||
begin
|
||||
bmp := TBGRABitmap.Create(Width, Height);
|
||||
if Assigned(FOnBeforeRedraw) then
|
||||
FOnBeforeRedraw(Self, bmp);
|
||||
if Fdraw and Enabled then
|
||||
begin
|
||||
x := Fx;
|
||||
y := Fy;
|
||||
if FLockHorizontal then
|
||||
x := Width div 2;
|
||||
if FLockVertical then
|
||||
y := Height div 2;
|
||||
bmp.GradientFill(0, 0, Width, Height, FColor1.Pixel, FColor2.Pixel, gtRadial,
|
||||
PointF(x, y), PointF(x - Width, y), dmDrawWithTransparency);
|
||||
bmp.RectangleAntialias(0, 0, Width, Height, FBorderColor.Pixel,
|
||||
FBorderSize, BGRAPixelTransparent);
|
||||
if Fdown then
|
||||
bmp.Rectangle(0, 0, Width, Height, FDimColor.Pixel, FDimColor.Pixel,
|
||||
dmDrawWithTransparency);
|
||||
end;
|
||||
if Assigned(FOnAfterRedraw) then
|
||||
FOnAfterRedraw(Self, bmp);
|
||||
bmp.Draw(Canvas, 0, 0, False);
|
||||
bmp.Free;
|
||||
end;
|
||||
|
||||
procedure TBCGradientButton.Invalidate;
|
||||
begin
|
||||
if Fupdating then
|
||||
Exit;
|
||||
inherited Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBCGradientButton.MouseMove(Shift: TShiftState; X, Y: integer);
|
||||
begin
|
||||
inherited MouseMove(Shift, X, Y);
|
||||
Fx := X;
|
||||
Fy := Y;
|
||||
Fdraw := True;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBCGradientButton.MouseLeave;
|
||||
begin
|
||||
inherited MouseLeave;
|
||||
Fdraw := False;
|
||||
Fdown := False;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBCGradientButton.MouseDown(Button: TMouseButton; Shift: TShiftState;
|
||||
X, Y: integer);
|
||||
begin
|
||||
inherited MouseDown(Button, Shift, X, Y);
|
||||
Fdown := True;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBCGradientButton.MouseUp(Button: TMouseButton; Shift: TShiftState;
|
||||
X, Y: integer);
|
||||
begin
|
||||
inherited MouseUp(Button, Shift, X, Y);
|
||||
Fdown := False;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
constructor TBCGradientButton.Create(AOwner: TComponent);
|
||||
begin
|
||||
inherited Create(AOwner);
|
||||
BeginUpdate;
|
||||
FLockHorizontal := False;
|
||||
FLockVertical := False;
|
||||
FColor1 := TBCPixel.Create(Self, BGRA(255, 255, 255, 100));
|
||||
FColor1.OnChange := ColorInvalidate;
|
||||
FColor2 := TBCPixel.Create(Self, BGRA(0, 0, 0, 0));
|
||||
FColor2.OnChange := ColorInvalidate;
|
||||
FBorderColor := TBCPixel.Create(Self, BGRA(255, 255, 255, 100));
|
||||
FBorderColor.OnChange := ColorInvalidate;
|
||||
FDimColor := TBCPixel.Create(Self, BGRA(0, 0, 0, 100));
|
||||
FDimColor.OnChange := ColorInvalidate;
|
||||
FBorderSize := 2;
|
||||
Fdown := False;
|
||||
EndUpdate;
|
||||
end;
|
||||
|
||||
destructor TBCGradientButton.Destroy;
|
||||
begin
|
||||
FColor1.Free;
|
||||
FColor2.Free;
|
||||
FBorderColor.Free;
|
||||
FDimColor.Free;
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
procedure TBCGradientButton.BeginUpdate;
|
||||
begin
|
||||
Fupdating := True;
|
||||
end;
|
||||
|
||||
procedure TBCGradientButton.EndUpdate;
|
||||
begin
|
||||
Fupdating := False;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
end.
|
||||
1454
bgracontrols/bcimagebutton.pas
Normal file
1454
bgracontrols/bcimagebutton.pas
Normal file
File diff suppressed because it is too large
Load Diff
514
bgracontrols/bckeyboard.pas
Normal file
514
bgracontrols/bckeyboard.pas
Normal file
@@ -0,0 +1,514 @@
|
||||
// SPDX-License-Identifier: LGPL-3.0-linking-exception
|
||||
{******************************* CONTRIBUTOR(S) ******************************
|
||||
- Edivando S. Santos Brasil | mailedivando@gmail.com
|
||||
(Compatibility with delphi VCL 11/2018)
|
||||
|
||||
***************************** END CONTRIBUTOR(S) *****************************}
|
||||
unit BCKeyboard;
|
||||
|
||||
{$I bgracontrols.inc}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils, {$IFDEF FPC}LCLType, LResources, LMessages,{$ENDIF}Forms, Controls, Graphics, Dialogs,
|
||||
{$IFNDEF FPC}Types, Windows, Messages, BGRAGraphics, GraphType, FPImage, BCBaseCtrls,{$ENDIF}
|
||||
BCThemeManager, BCButton, BCPanel, MouseAndKeyInput;
|
||||
|
||||
type
|
||||
|
||||
{ TBCKeyboard }
|
||||
|
||||
TBCKeyboard = class(TComponent)
|
||||
private
|
||||
FBCThemeManager: TBCThemeManager;
|
||||
FButton: TBCButton;
|
||||
FOnUserChange: TNotifyEvent;
|
||||
FPanel, FRow1, FRow2, FRow3, FRow4: TBCPanel;
|
||||
FPanelsColor: TColor;
|
||||
F_q, F_w, F_e, F_r, F_t, F_y, F_u, F_i, F_o, F_p, F_a, F_s, F_d,
|
||||
F_f, F_g, F_h, F_j, F_k, F_l, F_z, F_x, F_c, F_v, F_b, F_n, F_m,
|
||||
F_shift, F_space, F_back: TBCButton;
|
||||
FVisible: boolean;
|
||||
procedure SetFButton(AValue: TBCButton);
|
||||
procedure SetFPanel(AValue: TBCPanel);
|
||||
procedure SetFPanelsColor(AValue: TColor);
|
||||
procedure SetFThemeManager(AValue: TBCThemeManager);
|
||||
protected
|
||||
procedure PressVirtKey(p: longint);
|
||||
procedure PressShiftVirtKey(p: longint);
|
||||
procedure OnButtonClick(Sender: TObject; {%H-}Button: TMouseButton;
|
||||
{%H-}Shift: TShiftState; {%H-}X, {%H-}Y: integer); virtual;
|
||||
{ When value is changed by the user }
|
||||
property OnUserChange: TNotifyEvent read FOnUserChange write FOnUserChange;
|
||||
public
|
||||
constructor Create(AOwner: TComponent); override;
|
||||
destructor Destroy; override;
|
||||
// Show in a custom form or panel
|
||||
procedure Show(AControl: TWinControl); overload;
|
||||
// Try to Show in the form where this component is placed
|
||||
procedure Show(); overload;
|
||||
// Hide the component
|
||||
procedure Hide();
|
||||
// Update buttons style
|
||||
procedure UpdateButtonStyle;
|
||||
public
|
||||
{ The real panel that's used as container for all the numeric buttons }
|
||||
property Panel: TBCPanel read FPanel write SetFPanel;
|
||||
{ The color of all the panels involved in the control }
|
||||
property PanelsColor: TColor read FPanelsColor write SetFPanelsColor;
|
||||
{ A fake button that's used as style base for all the numeric buttons }
|
||||
property ButtonStyle: TBCButton read FButton write SetFButton;
|
||||
{ If it's visible or not }
|
||||
property Visible: boolean read FVisible;
|
||||
published
|
||||
property ThemeManager: TBCThemeManager read FBCThemeManager write SetFThemeManager;
|
||||
end;
|
||||
|
||||
{$IFDEF FPC}procedure Register;{$ENDIF}
|
||||
|
||||
implementation
|
||||
|
||||
{$IFDEF FPC}procedure Register;
|
||||
begin
|
||||
RegisterComponents('BGRA Controls', [TBCKeyboard]);
|
||||
end;
|
||||
{$ENDIF}
|
||||
|
||||
{ TBCKeyboard }
|
||||
|
||||
procedure TBCKeyboard.SetFThemeManager(AValue: TBCThemeManager);
|
||||
begin
|
||||
if FBCThemeManager = AValue then
|
||||
Exit;
|
||||
FBCThemeManager := AValue;
|
||||
end;
|
||||
|
||||
procedure TBCKeyboard.PressVirtKey(p: longint);
|
||||
begin
|
||||
KeyInput.Down(p);
|
||||
KeyInput.Up(p);
|
||||
end;
|
||||
|
||||
procedure TBCKeyboard.PressShiftVirtKey(p: longint);
|
||||
begin
|
||||
KeyInput.Down(VK_SHIFT);
|
||||
KeyInput.Down(p);
|
||||
KeyInput.Up(p);
|
||||
KeyInput.Up(VK_SHIFT);
|
||||
end;
|
||||
|
||||
procedure TBCKeyboard.OnButtonClick(Sender: TObject; Button: TMouseButton;
|
||||
Shift: TShiftState; X, Y: integer);
|
||||
var
|
||||
btn: TBCButton;
|
||||
str: string;
|
||||
begin
|
||||
btn := TBCButton(Sender);
|
||||
str := btn.Caption;
|
||||
|
||||
if str = F_shift.Caption then
|
||||
begin
|
||||
F_shift.Down := not F_shift.Down;
|
||||
if not F_shift.Down then
|
||||
begin
|
||||
F_q.Caption := LowerCase(F_q.Caption);
|
||||
F_w.Caption := LowerCase(F_w.Caption);
|
||||
F_e.Caption := LowerCase(F_e.Caption);
|
||||
F_r.Caption := LowerCase(F_r.Caption);
|
||||
F_t.Caption := LowerCase(F_t.Caption);
|
||||
F_y.Caption := LowerCase(F_y.Caption);
|
||||
F_u.Caption := LowerCase(F_u.Caption);
|
||||
F_i.Caption := LowerCase(F_i.Caption);
|
||||
F_o.Caption := LowerCase(F_o.Caption);
|
||||
F_p.Caption := LowerCase(F_p.Caption);
|
||||
F_a.Caption := LowerCase(F_a.Caption);
|
||||
F_s.Caption := LowerCase(F_s.Caption);
|
||||
F_d.Caption := LowerCase(F_d.Caption);
|
||||
F_f.Caption := LowerCase(F_f.Caption);
|
||||
F_g.Caption := LowerCase(F_g.Caption);
|
||||
F_h.Caption := LowerCase(F_h.Caption);
|
||||
F_j.Caption := LowerCase(F_j.Caption);
|
||||
F_k.Caption := LowerCase(F_k.Caption);
|
||||
F_l.Caption := LowerCase(F_l.Caption);
|
||||
F_z.Caption := LowerCase(F_z.Caption);
|
||||
F_x.Caption := LowerCase(F_x.Caption);
|
||||
F_c.Caption := LowerCase(F_c.Caption);
|
||||
F_v.Caption := LowerCase(F_v.Caption);
|
||||
F_b.Caption := LowerCase(F_b.Caption);
|
||||
F_n.Caption := LowerCase(F_n.Caption);
|
||||
F_m.Caption := LowerCase(F_m.Caption);
|
||||
end
|
||||
else
|
||||
begin
|
||||
F_q.Caption := UpperCase(F_q.Caption);
|
||||
F_w.Caption := UpperCase(F_w.Caption);
|
||||
F_e.Caption := UpperCase(F_e.Caption);
|
||||
F_r.Caption := UpperCase(F_r.Caption);
|
||||
F_t.Caption := UpperCase(F_t.Caption);
|
||||
F_y.Caption := UpperCase(F_y.Caption);
|
||||
F_u.Caption := UpperCase(F_u.Caption);
|
||||
F_i.Caption := UpperCase(F_i.Caption);
|
||||
F_o.Caption := UpperCase(F_o.Caption);
|
||||
F_p.Caption := UpperCase(F_p.Caption);
|
||||
F_a.Caption := UpperCase(F_a.Caption);
|
||||
F_s.Caption := UpperCase(F_s.Caption);
|
||||
F_d.Caption := UpperCase(F_d.Caption);
|
||||
F_f.Caption := UpperCase(F_f.Caption);
|
||||
F_g.Caption := UpperCase(F_g.Caption);
|
||||
F_h.Caption := UpperCase(F_h.Caption);
|
||||
F_j.Caption := UpperCase(F_j.Caption);
|
||||
F_k.Caption := UpperCase(F_k.Caption);
|
||||
F_l.Caption := UpperCase(F_l.Caption);
|
||||
F_z.Caption := UpperCase(F_z.Caption);
|
||||
F_x.Caption := UpperCase(F_x.Caption);
|
||||
F_c.Caption := UpperCase(F_c.Caption);
|
||||
F_v.Caption := UpperCase(F_v.Caption);
|
||||
F_b.Caption := UpperCase(F_b.Caption);
|
||||
F_n.Caption := UpperCase(F_n.Caption);
|
||||
F_m.Caption := UpperCase(F_m.Caption);
|
||||
end;
|
||||
end
|
||||
else if str = F_back.Caption then
|
||||
begin
|
||||
{$IFDEF CPUX86_64}
|
||||
Application.ProcessMessages;
|
||||
KeyInput.Press(VK_BACK);
|
||||
Application.ProcessMessages;
|
||||
{$ELSE}
|
||||
{$IFDEF FPC}
|
||||
Application.QueueAsyncCall(@PressVirtKey, VK_BACK);
|
||||
{$ELSE}
|
||||
SendKey(VK_BACK);
|
||||
{$ENDIF}
|
||||
{$ENDIF}
|
||||
end
|
||||
else
|
||||
begin
|
||||
if str = F_space.Caption then
|
||||
str := ' ';
|
||||
{$IFDEF CPUX86_64}
|
||||
Application.ProcessMessages;
|
||||
if F_shift.Down then
|
||||
KeyInput.Down(VK_SHIFT);
|
||||
KeyInput.Press(Ord(UpperCase(str)[1]));
|
||||
if F_shift.Down then
|
||||
KeyInput.Up(VK_SHIFT);
|
||||
Application.ProcessMessages;
|
||||
{$ELSE}
|
||||
if F_shift.Down then
|
||||
{$IFDEF FPC}
|
||||
Application.QueueAsyncCall(@PressShiftVirtKey, Ord(UpperCase(str)[1]))
|
||||
{$ELSE}
|
||||
SendKey(Ord(UpperCase(str)[1]), Shift)
|
||||
{$ENDIF}
|
||||
else
|
||||
{$IFDEF FPC}
|
||||
Application.QueueAsyncCall(@PressVirtKey, Ord(UpperCase(str)[1]));
|
||||
{$ELSE}
|
||||
SendKey(Ord(UpperCase(str)[1]))
|
||||
{$ENDIF}
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
if Assigned(FOnUserChange) then
|
||||
FOnUserChange(Self);
|
||||
end;
|
||||
|
||||
constructor TBCKeyboard.Create(AOwner: TComponent);
|
||||
begin
|
||||
inherited Create(AOwner);
|
||||
|
||||
FVisible := False;
|
||||
|
||||
FButton := TBCButton.Create(Self);
|
||||
|
||||
FPanel := TBCPanel.Create(Self);
|
||||
FPanel.AutoSize := True;
|
||||
FPanel.ChildSizing.ControlsPerLine := 1;
|
||||
FPanel.ChildSizing.Layout := cclLeftToRightThenTopToBottom;
|
||||
FPanel.Caption := 'Panel1';
|
||||
FPanel.BorderBCStyle := bpsBorder;
|
||||
|
||||
{ qwertyuiop }
|
||||
|
||||
FRow1 := TBCPanel.Create(FPanel);
|
||||
FRow1.AutoSize := True;
|
||||
FRow1.Caption := '';
|
||||
FRow1.BorderBCStyle := bpsBorder;
|
||||
FRow1.ChildSizing.ControlsPerLine := 10;
|
||||
FRow1.ChildSizing.Layout := cclLeftToRightThenTopToBottom;
|
||||
FRow1.Parent := FPanel;
|
||||
|
||||
F_q := TBCButton.Create(FRow1);
|
||||
F_q.Caption := 'Q';
|
||||
F_q.Parent := FRow1;
|
||||
F_q.OnMouseDown := OnButtonClick;
|
||||
|
||||
F_w := TBCButton.Create(FRow1);
|
||||
F_w.Caption := 'W';
|
||||
F_w.Parent := FRow1;
|
||||
F_w.OnMouseDown := OnButtonClick;
|
||||
|
||||
F_e := TBCButton.Create(FRow1);
|
||||
F_e.Caption := 'E';
|
||||
F_e.Parent := FRow1;
|
||||
F_e.OnMouseDown := OnButtonClick;
|
||||
|
||||
F_r := TBCButton.Create(FRow1);
|
||||
F_r.Caption := 'R';
|
||||
F_r.Parent := FRow1;
|
||||
F_r.OnMouseDown := OnButtonClick;
|
||||
|
||||
F_t := TBCButton.Create(FRow1);
|
||||
F_t.Caption := 'T';
|
||||
F_t.Parent := FRow1;
|
||||
F_t.OnMouseDown := OnButtonClick;
|
||||
|
||||
F_y := TBCButton.Create(FRow1);
|
||||
F_y.Caption := 'Y';
|
||||
F_y.Parent := FRow1;
|
||||
F_y.OnMouseDown := OnButtonClick;
|
||||
|
||||
F_u := TBCButton.Create(FRow1);
|
||||
F_u.Caption := 'U';
|
||||
F_u.Parent := FRow1;
|
||||
F_u.OnMouseDown := OnButtonClick;
|
||||
|
||||
F_i := TBCButton.Create(FRow1);
|
||||
F_i.Caption := 'I';
|
||||
F_i.Parent := FRow1;
|
||||
F_i.OnMouseDown := OnButtonClick;
|
||||
|
||||
F_o := TBCButton.Create(FRow1);
|
||||
F_o.Caption := 'O';
|
||||
F_o.Parent := FRow1;
|
||||
F_o.OnMouseDown := OnButtonClick;
|
||||
|
||||
F_p := TBCButton.Create(FRow1);
|
||||
F_p.Caption := 'P';
|
||||
F_p.Parent := FRow1;
|
||||
F_p.OnMouseDown := OnButtonClick;
|
||||
|
||||
|
||||
{ asdfghjkl }
|
||||
|
||||
FRow2 := TBCPanel.Create(FPanel);
|
||||
FRow2.AutoSize := True;
|
||||
FRow2.Caption := '';
|
||||
FRow2.BorderBCStyle := bpsBorder;
|
||||
FRow2.ChildSizing.ControlsPerLine := 9;
|
||||
FRow2.ChildSizing.Layout := cclLeftToRightThenTopToBottom;
|
||||
FRow2.Parent := FPanel;
|
||||
|
||||
F_a := TBCButton.Create(FRow2);
|
||||
F_a.Caption := 'A';
|
||||
F_a.Parent := FRow2;
|
||||
F_a.OnMouseDown := OnButtonClick;
|
||||
|
||||
F_s := TBCButton.Create(FRow2);
|
||||
F_s.Caption := 'S';
|
||||
F_s.Parent := FRow2;
|
||||
F_s.OnMouseDown := OnButtonClick;
|
||||
|
||||
F_d := TBCButton.Create(FRow2);
|
||||
F_d.Caption := 'D';
|
||||
F_d.Parent := FRow2;
|
||||
F_d.OnMouseDown := OnButtonClick;
|
||||
|
||||
F_f := TBCButton.Create(FRow2);
|
||||
F_f.Caption := 'F';
|
||||
F_f.Parent := FRow2;
|
||||
F_f.OnMouseDown := OnButtonClick;
|
||||
|
||||
F_g := TBCButton.Create(FRow2);
|
||||
F_g.Caption := 'G';
|
||||
F_g.Parent := FRow2;
|
||||
F_g.OnMouseDown := OnButtonClick;
|
||||
|
||||
F_h := TBCButton.Create(FRow2);
|
||||
F_h.Caption := 'H';
|
||||
F_h.Parent := FRow2;
|
||||
F_h.OnMouseDown := OnButtonClick;
|
||||
|
||||
F_j := TBCButton.Create(FRow2);
|
||||
F_j.Caption := 'J';
|
||||
F_j.Parent := FRow2;
|
||||
F_j.OnMouseDown := OnButtonClick;
|
||||
|
||||
F_k := TBCButton.Create(FRow2);
|
||||
F_k.Caption := 'K';
|
||||
F_k.Parent := FRow2;
|
||||
F_k.OnMouseDown := OnButtonClick;
|
||||
|
||||
F_l := TBCButton.Create(FRow2);
|
||||
F_l.Caption := 'L';
|
||||
F_l.Parent := FRow2;
|
||||
F_l.OnMouseDown := OnButtonClick;
|
||||
|
||||
{ zxcvbnm }
|
||||
|
||||
FRow3 := TBCPanel.Create(FPanel);
|
||||
FRow3.AutoSize := True;
|
||||
FRow3.Caption := '';
|
||||
FRow3.BorderBCStyle := bpsBorder;
|
||||
FRow3.ChildSizing.ControlsPerLine := 9;
|
||||
FRow3.ChildSizing.Layout := cclLeftToRightThenTopToBottom;
|
||||
FRow3.Parent := FPanel;
|
||||
|
||||
F_shift := TBCButton.Create(FRow3);
|
||||
F_shift.Caption := '^';
|
||||
F_shift.Parent := FRow3;
|
||||
F_shift.OnMouseDown := OnButtonClick;
|
||||
F_shift.Down := True;
|
||||
|
||||
F_z := TBCButton.Create(FRow3);
|
||||
F_z.Caption := 'Z';
|
||||
F_z.Parent := FRow3;
|
||||
F_z.OnMouseDown := OnButtonClick;
|
||||
|
||||
F_x := TBCButton.Create(FRow3);
|
||||
F_x.Caption := 'X';
|
||||
F_x.Parent := FRow3;
|
||||
F_x.OnMouseDown := OnButtonClick;
|
||||
|
||||
F_c := TBCButton.Create(FRow3);
|
||||
F_c.Caption := 'C';
|
||||
F_c.Parent := FRow3;
|
||||
F_c.OnMouseDown := OnButtonClick;
|
||||
|
||||
F_v := TBCButton.Create(FRow3);
|
||||
F_v.Caption := 'V';
|
||||
F_v.Parent := FRow3;
|
||||
F_v.OnMouseDown := OnButtonClick;
|
||||
|
||||
F_b := TBCButton.Create(FRow3);
|
||||
F_b.Caption := 'B';
|
||||
F_b.Parent := FRow3;
|
||||
F_b.OnMouseDown := OnButtonClick;
|
||||
|
||||
F_n := TBCButton.Create(FRow3);
|
||||
F_n.Caption := 'N';
|
||||
F_n.Parent := FRow3;
|
||||
F_n.OnMouseDown := OnButtonClick;
|
||||
|
||||
F_m := TBCButton.Create(FRow3);
|
||||
F_m.Caption := 'M';
|
||||
F_m.Parent := FRow3;
|
||||
F_m.OnMouseDown := OnButtonClick;
|
||||
|
||||
F_back := TBCButton.Create(FRow3);
|
||||
F_back.Caption := '<-';
|
||||
F_back.Parent := FRow3;
|
||||
F_back.OnMouseDown := OnButtonClick;
|
||||
|
||||
{ shift space back }
|
||||
|
||||
FRow4 := TBCPanel.Create(FPanel);
|
||||
FRow4.AutoSize := True;
|
||||
FRow4.Caption := '';
|
||||
FRow4.BorderBCStyle := bpsBorder;
|
||||
FRow4.ChildSizing.ControlsPerLine := 1;
|
||||
FRow4.ChildSizing.Layout := cclLeftToRightThenTopToBottom;
|
||||
FRow4.Parent := FPanel;
|
||||
|
||||
F_space := TBCButton.Create(FRow4);
|
||||
F_space.Caption := '____________________';
|
||||
F_space.Parent := FRow4;
|
||||
F_space.OnMouseDown := OnButtonClick;
|
||||
end;
|
||||
|
||||
destructor TBCKeyboard.Destroy;
|
||||
begin
|
||||
{ Everything inside the panel will be freed }
|
||||
FPanel.Free;
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
procedure TBCKeyboard.Show(AControl: TWinControl);
|
||||
begin
|
||||
FPanel.Parent := AControl;
|
||||
FVisible := True;
|
||||
end;
|
||||
|
||||
procedure TBCKeyboard.Show;
|
||||
begin
|
||||
if Self.Owner is TWinControl then
|
||||
Show(Self.Owner as TWinControl)
|
||||
else
|
||||
raise Exception.Create('The parent is not TWinControl descendant.');
|
||||
end;
|
||||
|
||||
procedure TBCKeyboard.Hide;
|
||||
begin
|
||||
FPanel.Parent := nil;
|
||||
FVisible := False;
|
||||
end;
|
||||
|
||||
procedure TBCKeyboard.UpdateButtonStyle;
|
||||
var
|
||||
shift_down: boolean;
|
||||
begin
|
||||
F_q.Assign(FButton);
|
||||
F_w.Assign(FButton);
|
||||
F_e.Assign(FButton);
|
||||
F_r.Assign(FButton);
|
||||
F_t.Assign(FButton);
|
||||
F_y.Assign(FButton);
|
||||
F_u.Assign(FButton);
|
||||
F_i.Assign(FButton);
|
||||
F_o.Assign(FButton);
|
||||
F_p.Assign(FButton);
|
||||
F_a.Assign(FButton);
|
||||
F_s.Assign(FButton);
|
||||
F_d.Assign(FButton);
|
||||
F_f.Assign(FButton);
|
||||
F_g.Assign(FButton);
|
||||
F_h.Assign(FButton);
|
||||
F_j.Assign(FButton);
|
||||
F_k.Assign(FButton);
|
||||
F_l.Assign(FButton);
|
||||
F_z.Assign(FButton);
|
||||
F_x.Assign(FButton);
|
||||
F_c.Assign(FButton);
|
||||
F_v.Assign(FButton);
|
||||
F_b.Assign(FButton);
|
||||
F_n.Assign(FButton);
|
||||
F_m.Assign(FButton);
|
||||
|
||||
shift_down := F_shift.Down;
|
||||
F_shift.Assign(FButton);
|
||||
F_shift.Down := shift_down;
|
||||
|
||||
F_back.Assign(FButton);
|
||||
|
||||
F_space.Assign(FButton);
|
||||
end;
|
||||
|
||||
procedure TBCKeyboard.SetFButton(AValue: TBCButton);
|
||||
begin
|
||||
if FButton = AValue then
|
||||
Exit;
|
||||
FButton := AValue;
|
||||
end;
|
||||
|
||||
procedure TBCKeyboard.SetFPanel(AValue: TBCPanel);
|
||||
begin
|
||||
if FPanel = AValue then
|
||||
Exit;
|
||||
FPanel := AValue;
|
||||
end;
|
||||
|
||||
procedure TBCKeyboard.SetFPanelsColor(AValue: TColor);
|
||||
begin
|
||||
if FPanelsColor = AValue then
|
||||
Exit;
|
||||
FPanelsColor := AValue;
|
||||
FPanel.Background.Color := AValue;
|
||||
FRow1.Background.Color := AValue;
|
||||
FRow2.Background.Color := AValue;
|
||||
FRow3.Background.Color := AValue;
|
||||
FRow4.Background.Color := AValue;
|
||||
end;
|
||||
|
||||
end.
|
||||
384
bgracontrols/bclabel.pas
Normal file
384
bgracontrols/bclabel.pas
Normal file
@@ -0,0 +1,384 @@
|
||||
// SPDX-License-Identifier: LGPL-3.0-linking-exception
|
||||
{ Equivalent of standard lazarus TLabel but using BGRA Controls framework for text
|
||||
render.
|
||||
|
||||
Functionality:
|
||||
- Customizable background (gradients etc.)
|
||||
- Customizable border (rounding etc.)
|
||||
- FontEx (shadow, word wrap, etc.)
|
||||
|
||||
originally written in 2012 by Krzysztof Dibowski dibowski at interia.pl
|
||||
}
|
||||
{******************************* CONTRIBUTOR(S) ******************************
|
||||
- Edivando S. Santos Brasil | mailedivando@gmail.com
|
||||
(Compatibility with delphi VCL 11/2018)
|
||||
|
||||
***************************** END CONTRIBUTOR(S) *****************************}
|
||||
unit BCLabel;
|
||||
|
||||
{$I bgracontrols.inc}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils,{$IFDEF FPC}LResources,{$ENDIF}
|
||||
types, Forms, Controls, Graphics, Dialogs,
|
||||
BCBasectrls, BGRABitmap, BGRABitmapTypes, BCTypes;
|
||||
|
||||
type
|
||||
|
||||
{ TCustomBCLabel }
|
||||
|
||||
TCustomBCLabel = class(TBCStyleGraphicControl)
|
||||
private
|
||||
{ Private declarations }
|
||||
{$IFDEF INDEBUG}
|
||||
FRenderCount: Integer;
|
||||
{$ENDIF}
|
||||
FBackground: TBCBackground;
|
||||
FBGRA: TBGRABitmapEx;
|
||||
FBorder: TBCBorder;
|
||||
FFontEx: TBCFont;
|
||||
FInnerMargin: single;
|
||||
FRounding: TBCRounding;
|
||||
procedure Render;
|
||||
procedure SetInnerMargin(AValue: single);
|
||||
procedure SetRounding(AValue: TBCRounding);
|
||||
procedure UpdateSize;
|
||||
procedure SetBackground(AValue: TBCBackground);
|
||||
procedure SetBorder(AValue: TBCBorder);
|
||||
procedure SetFontEx(AValue: TBCFont);
|
||||
procedure OnChangeProperty(Sender: TObject; {%H-}Data: BGRAPtrInt);
|
||||
procedure OnChangeFont({%H-}Sender: TObject; {%H-}AData: BGRAPtrInt);
|
||||
protected
|
||||
procedure CalculatePreferredSize(var PreferredWidth, PreferredHeight: integer;
|
||||
{%H-}WithThemeSpace: boolean); override;
|
||||
class function GetControlClassDefaultSize: TSize; override;
|
||||
procedure TextChanged; override;
|
||||
protected
|
||||
{$IFDEF INDEBUG}
|
||||
function GetDebugText: String; override;
|
||||
{$ENDIF}
|
||||
procedure DrawControl; override;
|
||||
procedure RenderControl; override;
|
||||
function GetStyleExtension: String; override;
|
||||
protected
|
||||
{ Protected declarations }
|
||||
property AutoSize default True;
|
||||
property Background: TBCBackground read FBackground write SetBackground;
|
||||
property Border: TBCBorder read FBorder write SetBorder;
|
||||
property FontEx: TBCFont read FFontEx write SetFontEx;
|
||||
property Rounding: TBCRounding read FRounding write SetRounding;
|
||||
property InnerMargin: single read FInnerMargin write SetInnerMargin;
|
||||
public
|
||||
{ Public declarations }
|
||||
constructor Create(AOwner: TComponent); override;
|
||||
destructor Destroy; override;
|
||||
procedure UpdateControl; override; // Called by EndUpdate
|
||||
public
|
||||
{ Streaming }
|
||||
{$IFDEF FPC}
|
||||
procedure SaveToFile(AFileName: string); override;
|
||||
procedure LoadFromFile(AFileName: string); override;
|
||||
{$ENDIF}
|
||||
procedure OnFindClass({%H-}Reader: TReader; const AClassName: string;
|
||||
var ComponentClass: TComponentClass);
|
||||
end;
|
||||
|
||||
{ TBCLabel }
|
||||
|
||||
TBCLabel = class(TCustomBCLabel)
|
||||
published
|
||||
property Action;
|
||||
property Align;
|
||||
property Anchors;
|
||||
property AssignStyle;
|
||||
property AutoSize;
|
||||
property Background;
|
||||
property Border;
|
||||
property BorderSpacing;
|
||||
property Caption;
|
||||
property Cursor;
|
||||
property Enabled;
|
||||
property FontEx;
|
||||
property Height;
|
||||
property HelpContext;
|
||||
property HelpKeyword;
|
||||
property HelpType;
|
||||
property Hint;
|
||||
property InnerMargin;
|
||||
property Left;
|
||||
property PopupMenu;
|
||||
property Rounding;
|
||||
property ShowHint;
|
||||
property Tag;
|
||||
property Top;
|
||||
property Visible;
|
||||
property Width;
|
||||
property OnClick;
|
||||
property OnDblClick;
|
||||
property OnMouseDown;
|
||||
property OnMouseEnter;
|
||||
property OnMouseLeave;
|
||||
property OnMouseMove;
|
||||
property OnMouseUp;
|
||||
property OnMouseWheel;
|
||||
property OnMouseWheelDown;
|
||||
property OnMouseWheelUp;
|
||||
end;
|
||||
|
||||
{$IFDEF FPC}procedure Register;{$ENDIF}
|
||||
|
||||
implementation
|
||||
|
||||
uses BCTools;
|
||||
|
||||
{$IFDEF FPC}procedure Register;
|
||||
begin
|
||||
RegisterComponents('BGRA Controls',[TBCLabel]);
|
||||
end;
|
||||
{$ENDIF}
|
||||
|
||||
{ TCustomBCLabel }
|
||||
|
||||
procedure TCustomBCLabel.Render;
|
||||
var r: TRect;
|
||||
begin
|
||||
if (csCreating in ControlState) or IsUpdating then
|
||||
Exit;
|
||||
|
||||
FBGRA.NeedRender := False;
|
||||
|
||||
FBGRA.SetSize(Width, Height);
|
||||
FBGRA.Fill(BGRAPixelTransparent); // Clear;
|
||||
r := FBGRA.ClipRect;
|
||||
CalculateBorderRect(FBorder,r);
|
||||
|
||||
RenderBackgroundAndBorder(FBGRA.ClipRect, FBackground, TBGRABitmap(FBGRA), FRounding, FBorder, FInnerMargin);
|
||||
RenderText(FBGRA.ClipRect, FFontEx, Caption, TBGRABitmap(FBGRA), Enabled);
|
||||
|
||||
{$IFDEF INDEBUG}
|
||||
FRenderCount := FRenderCount +1;
|
||||
{$ENDIF}
|
||||
{$IFNDEF FPC}//# //@ IN DELPHI NEEDRENDER NEED TO BE TRUE. IF FALSE COMPONENT IN BGRANORMAL BE BLACK AFTER INVALIDATE.
|
||||
FBGRA.NeedRender := True;
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
procedure TCustomBCLabel.SetInnerMargin(AValue: single);
|
||||
begin
|
||||
if FInnerMargin=AValue then Exit;
|
||||
FInnerMargin:=AValue;
|
||||
RenderControl;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TCustomBCLabel.SetRounding(AValue: TBCRounding);
|
||||
begin
|
||||
if FRounding = AValue then Exit;
|
||||
FRounding.Assign(AValue);
|
||||
|
||||
RenderControl;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TCustomBCLabel.UpdateSize;
|
||||
begin
|
||||
InvalidatePreferredSize;
|
||||
AdjustSize;
|
||||
end;
|
||||
|
||||
procedure TCustomBCLabel.SetBackground(AValue: TBCBackground);
|
||||
begin
|
||||
FBackground.Assign(AValue);
|
||||
|
||||
RenderControl;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TCustomBCLabel.SetBorder(AValue: TBCBorder);
|
||||
begin
|
||||
FBorder.Assign(AValue);
|
||||
|
||||
RenderControl;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TCustomBCLabel.SetFontEx(AValue: TBCFont);
|
||||
begin
|
||||
FFontEx.Assign(AValue);
|
||||
|
||||
RenderControl;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TCustomBCLabel.OnChangeProperty(Sender: TObject; Data: BGRAPtrInt);
|
||||
begin
|
||||
RenderControl;
|
||||
if (Sender = FBorder) and AutoSize then
|
||||
UpdateSize;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TCustomBCLabel.OnChangeFont(Sender: TObject; AData: BGRAPtrInt);
|
||||
begin
|
||||
RenderControl;
|
||||
UpdateSize;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TCustomBCLabel.CalculatePreferredSize(var PreferredWidth,
|
||||
PreferredHeight: integer; WithThemeSpace: boolean);
|
||||
begin
|
||||
if (Parent = nil) or (not Parent.HandleAllocated) then
|
||||
Exit;
|
||||
|
||||
CalculateTextSize(Caption, FFontEx, PreferredWidth, PreferredHeight);
|
||||
|
||||
if AutoSize and (FBorder.Style<>bboNone) then
|
||||
begin
|
||||
Inc(PreferredHeight, 2 * FBorder.Width);
|
||||
Inc(PreferredWidth, 2 * FBorder.Width);
|
||||
end;
|
||||
end;
|
||||
|
||||
class function TCustomBCLabel.GetControlClassDefaultSize: TSize;
|
||||
begin
|
||||
Result.cx := 100;
|
||||
Result.cy := 25;
|
||||
end;
|
||||
|
||||
procedure TCustomBCLabel.TextChanged;
|
||||
begin
|
||||
inherited TextChanged;
|
||||
RenderControl;
|
||||
UpdateSize;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
{$IFDEF INDEBUG}
|
||||
function TCustomBCLabel.GetDebugText: String;
|
||||
begin
|
||||
Result := 'R: '+IntToStr(FRenderCount);
|
||||
end;
|
||||
{$ENDIF}
|
||||
|
||||
procedure TCustomBCLabel.DrawControl;
|
||||
begin
|
||||
inherited DrawControl;
|
||||
if FBGRA.NeedRender then
|
||||
Render;
|
||||
FBGRA.Draw(Self.Canvas,0,0,False);
|
||||
{$IFNDEF FPC}//# //@ IN DELPHI RenderControl NEDD. IF NO RenderControl BE BLACK AFTER INVALIDATE.
|
||||
FBGRA.NeedRender := True;
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
procedure TCustomBCLabel.RenderControl;
|
||||
begin
|
||||
inherited RenderControl;
|
||||
if FBGRA<>nil then
|
||||
FBGRA.NeedRender := True;
|
||||
end;
|
||||
|
||||
function TCustomBCLabel.GetStyleExtension: String;
|
||||
begin
|
||||
Result := 'bclbl';
|
||||
end;
|
||||
|
||||
procedure TCustomBCLabel.UpdateControl;
|
||||
begin
|
||||
RenderControl;
|
||||
inherited UpdateControl; // invalidate
|
||||
end;
|
||||
{$IFDEF FPC}
|
||||
procedure TCustomBCLabel.SaveToFile(AFileName: string);
|
||||
var
|
||||
AStream: TMemoryStream;
|
||||
begin
|
||||
AStream := TMemoryStream.Create;
|
||||
try
|
||||
WriteComponentAsTextToStream(AStream, Self);
|
||||
AStream.SaveToFile(AFileName);
|
||||
finally
|
||||
AStream.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TCustomBCLabel.LoadFromFile(AFileName: string);
|
||||
var
|
||||
AStream: TMemoryStream;
|
||||
begin
|
||||
AStream := TMemoryStream.Create;
|
||||
try
|
||||
AStream.LoadFromFile(AFileName);
|
||||
ReadComponentFromTextStream(AStream, TComponent(Self), OnFindClass);
|
||||
finally
|
||||
AStream.Free;
|
||||
end;
|
||||
end;
|
||||
{$ENDIF}
|
||||
|
||||
procedure TCustomBCLabel.OnFindClass(Reader: TReader; const AClassName: string;
|
||||
var ComponentClass: TComponentClass);
|
||||
begin
|
||||
if CompareText(AClassName, 'TBCLabel') = 0 then
|
||||
ComponentClass := TBCLabel;
|
||||
end;
|
||||
|
||||
constructor TCustomBCLabel.Create(AOwner: TComponent);
|
||||
begin
|
||||
inherited Create(AOwner);
|
||||
{$IFDEF INDEBUG}
|
||||
FRenderCount := 0;
|
||||
{$ENDIF}
|
||||
{$IFDEF FPC}
|
||||
DisableAutoSizing;
|
||||
Include(FControlState, csCreating);
|
||||
{$ELSE} //#
|
||||
|
||||
{$ENDIF}
|
||||
BeginUpdate;
|
||||
try
|
||||
with GetControlClassDefaultSize do
|
||||
SetInitialBounds(0, 0, CX, CY);
|
||||
FBGRA := TBGRABitmapEx.Create(Width, Height);
|
||||
FBackground := TBCBackground.Create(Self);
|
||||
FBorder := TBCBorder.Create(Self);
|
||||
FFontEx := TBCFont.Create(Self);
|
||||
ParentColor := True;
|
||||
|
||||
FBackground.OnChange := OnChangeProperty;
|
||||
FBorder.OnChange := OnChangeProperty;
|
||||
FFontEx.OnChange := OnChangeFont;
|
||||
|
||||
FBackground.Style := bbsClear;
|
||||
FBorder.Style := bboNone;
|
||||
|
||||
FRounding := TBCRounding.Create(Self);
|
||||
FRounding.OnChange := OnChangeProperty;
|
||||
|
||||
AutoSize := True;
|
||||
finally
|
||||
{$IFDEF FPC}
|
||||
EnableAutoSizing;
|
||||
{$ENDIF}
|
||||
EndUpdate;
|
||||
{$IFDEF FPC}
|
||||
Exclude(FControlState, csCreating);
|
||||
{$ELSE} //#
|
||||
{$ENDIF}
|
||||
end;
|
||||
end;
|
||||
|
||||
destructor TCustomBCLabel.Destroy;
|
||||
begin
|
||||
FBGRA.Free;
|
||||
FBackground.Free;
|
||||
FBorder.Free;
|
||||
FFontEx.Free;
|
||||
FRounding.Free;
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
end.
|
||||
181
bgracontrols/bclistbox.pas
Normal file
181
bgracontrols/bclistbox.pas
Normal file
@@ -0,0 +1,181 @@
|
||||
// SPDX-License-Identifier: LGPL-3.0-linking-exception
|
||||
{******************************* CONTRIBUTOR(S) ******************************
|
||||
- Edivando S. Santos Brasil | mailedivando@gmail.com
|
||||
(Compatibility with delphi VCL 11/2018)
|
||||
|
||||
***************************** END CONTRIBUTOR(S) *****************************}
|
||||
unit BCListBox;
|
||||
|
||||
{$I bgracontrols.inc}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils, {$IFDEF FPC}LCLType, LResources, {$ENDIF}
|
||||
Forms, Controls, Graphics, Dialogs, StdCtrls,
|
||||
{$IFNDEF FPC}Types, BGRAGraphics, GraphType, FPImage, BCBaseCtrls,{$ENDIF}
|
||||
BGRAVirtualScreen, BGRABitmap, BGRASliceScaling;
|
||||
|
||||
type
|
||||
|
||||
TBCListBox = class;
|
||||
TBCPaperPanel = class;
|
||||
|
||||
{ TBCPaperPanel }
|
||||
|
||||
TBCPaperPanel = class(TBGRAVirtualScreen)
|
||||
private
|
||||
FShadow: TBGRASliceScaling;
|
||||
procedure LoadShadowFromBitmapResource;
|
||||
protected
|
||||
procedure BCRedraw(Sender: TObject; ABitmap: TBGRABitmap);
|
||||
public
|
||||
constructor Create(TheOwner: TComponent); override;
|
||||
destructor Destroy; override;
|
||||
published
|
||||
end;
|
||||
|
||||
{ TBCListBox }
|
||||
|
||||
TBCListBox = class(TListBox)
|
||||
private
|
||||
{ Private declarations }
|
||||
protected
|
||||
procedure BCDrawItem(Control: TWinControl; Index: integer;
|
||||
ARect: TRect; State: TOwnerDrawState);
|
||||
{ Protected declarations }
|
||||
public
|
||||
{ Public declarations }
|
||||
constructor Create(TheOwner: TComponent); override;
|
||||
published
|
||||
{ Published declarations }
|
||||
end;
|
||||
|
||||
{ TBCPaperListBox }
|
||||
|
||||
TBCPaperListBox = class(TBCPaperPanel)
|
||||
private
|
||||
FListBox: TBCListBox;
|
||||
public
|
||||
constructor Create(TheOwner: TComponent); override;
|
||||
published
|
||||
property ListBox: TBCListBox read FListBox write FListBox;
|
||||
end;
|
||||
|
||||
{$IFDEF FPC}procedure Register;{$ENDIF}
|
||||
|
||||
implementation
|
||||
|
||||
{$IFDEF FPC}
|
||||
uses
|
||||
PropEdits;
|
||||
{$ENDIF}
|
||||
|
||||
{$IFDEF FPC}
|
||||
procedure Register;
|
||||
begin
|
||||
RegisterComponents('BGRA Controls', [TBCListBox]);
|
||||
RegisterComponents('BGRA Controls', [TBCPaperPanel]);
|
||||
RegisterComponents('BGRA Controls', [TBCPaperListBox]);
|
||||
{$IFDEF FPC}//#
|
||||
RegisterPropertyEditor(TypeInfo(TBCListBox),
|
||||
TBCPaperListBox, 'ListBox', TClassPropertyEditor);
|
||||
{$ENDIF}
|
||||
end;
|
||||
{$ENDIF}
|
||||
|
||||
{ TBCPaperListBox }
|
||||
|
||||
constructor TBCPaperListBox.Create(TheOwner: TComponent);
|
||||
begin
|
||||
inherited Create(TheOwner);
|
||||
Self.ChildSizing.ControlsPerLine := 1;
|
||||
Self.ChildSizing.LeftRightSPacing := 4;
|
||||
Self.ChildSizing.TopBottomSpacing := 5;
|
||||
FListBox := TBCListBox.Create(Self);
|
||||
FListBox.Align := alClient;
|
||||
FListBox.Parent := Self;
|
||||
FListBox.SetSubComponent(true);
|
||||
end;
|
||||
|
||||
{ TBCPaperListBox }
|
||||
|
||||
procedure TBCPaperPanel.LoadShadowFromBitmapResource;
|
||||
{$IFDEF FPC}
|
||||
var
|
||||
res: TLazarusResourceStream;
|
||||
{$ENDIF}
|
||||
begin
|
||||
{$IFDEF FPC}
|
||||
res := TLazarusResourceStream.Create('SHADOW', nil);
|
||||
FShadow := TBGRASliceScaling.Create(res);
|
||||
FShadow.Margins := Margins(6, 9, 6, 9);
|
||||
res.Free;
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
procedure TBCPaperPanel.BCRedraw(Sender: TObject; ABitmap: TBGRABitmap);
|
||||
begin
|
||||
FShadow.Draw(ABitmap, 0, 0, ABitmap.Width, ABitmap.Height);
|
||||
end;
|
||||
|
||||
constructor TBCPaperPanel.Create(TheOwner: TComponent);
|
||||
begin
|
||||
inherited Create(TheOwner);
|
||||
LoadShadowFromBitmapResource;
|
||||
Self.OnRedraw := BCRedraw;
|
||||
end;
|
||||
|
||||
destructor TBCPaperPanel.Destroy;
|
||||
begin
|
||||
inherited Destroy;
|
||||
FShadow.Free;
|
||||
end;
|
||||
|
||||
{ TBCListBox }
|
||||
|
||||
procedure TBCListBox.BCDrawItem(Control: TWinControl; Index: integer;
|
||||
ARect: TRect; State: TOwnerDrawState);
|
||||
var
|
||||
lb: TListBox;
|
||||
hg: integer;
|
||||
begin
|
||||
{$IFDEF FPC}
|
||||
lb := TListBox(Control);
|
||||
|
||||
lb.Canvas.Clipping := False;
|
||||
|
||||
if odFocused in State then
|
||||
lb.Canvas.Brush.Color := $00e4e4e4
|
||||
else
|
||||
lb.Canvas.Brush.Color := clWhite;
|
||||
|
||||
if odSelected in State then
|
||||
lb.Canvas.Font.Style := [fsBold];
|
||||
|
||||
lb.Canvas.FillRect(ARect);
|
||||
hg := lb.Canvas.TextHeight(lb.Items[Index]);
|
||||
lb.Canvas.Font.Color := clBlack;
|
||||
lb.Canvas.TextOut(ARect.Left + ScaleX(16, 96), ARect.Top +
|
||||
(lb.ItemHeight - hg) div 2, lb.Items[Index]);
|
||||
|
||||
lb.Canvas.Clipping := True;
|
||||
lb.Canvas.ClipRect := Rect(0, 0, 0, 0);
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
constructor TBCListBox.Create(TheOwner: TComponent);
|
||||
begin
|
||||
inherited Create(TheOwner);
|
||||
Self.Style := lbOwnerDrawFixed;
|
||||
Self.OnDrawItem := BCDrawItem;
|
||||
{$IFDEF FPC}
|
||||
Self.ItemHeight := ScaleY(48, 96);
|
||||
{$ENDIF}
|
||||
Self.BorderStyle := bsNone;
|
||||
end;
|
||||
|
||||
initialization
|
||||
{$I bcpaperlistbox.lrs}
|
||||
|
||||
end.
|
||||
238
bgracontrols/bclistboxex.pas
Normal file
238
bgracontrols/bclistboxex.pas
Normal file
@@ -0,0 +1,238 @@
|
||||
unit BCListBoxEx;
|
||||
|
||||
{$mode delphi}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs,
|
||||
LCLType;
|
||||
|
||||
type
|
||||
TBCListBoxEx = class(TCustomControl)
|
||||
private
|
||||
mousepos: TPoint;
|
||||
scrolly: integer;
|
||||
fitems: TStringList;
|
||||
itemselected: integer;
|
||||
itemheight: integer;
|
||||
lastitem: integer;
|
||||
invalidatecount: integer;
|
||||
scrollwidth: integer;
|
||||
function GetItemRect(index: integer): TRect;
|
||||
function GetItemVertically(y: integer): integer;
|
||||
procedure ScrollToItemTop();
|
||||
procedure ScrollToItemBottom();
|
||||
procedure ScrollToItem(index: integer);
|
||||
function ItemIsVisible(index: integer): boolean;
|
||||
protected
|
||||
procedure Click; override;
|
||||
procedure KeyDown(var Key: word; Shift: TShiftState); override;
|
||||
procedure MouseMove(Shift: TShiftState; X, Y: integer); override;
|
||||
function DoMouseWheelDown(Shift: TShiftState; MousePos: TPoint): boolean; override;
|
||||
function DoMouseWheelUp(Shift: TShiftState; MousePos: TPoint): boolean; override;
|
||||
procedure Paint; override;
|
||||
public
|
||||
constructor Create(AOwner: TComponent); override;
|
||||
destructor Destroy; override;
|
||||
published
|
||||
property Align;
|
||||
property Items: TStringList read Fitems;
|
||||
end;
|
||||
|
||||
procedure Register;
|
||||
|
||||
implementation
|
||||
|
||||
procedure Register;
|
||||
begin
|
||||
RegisterComponents('BGRA Controls', [TBCListBoxEx]);
|
||||
end;
|
||||
|
||||
procedure TBCListBoxEx.Click;
|
||||
var
|
||||
tempitem: integer;
|
||||
begin
|
||||
tempitem := GetItemVertically(mousepos.Y);
|
||||
if tempitem <> itemselected then
|
||||
begin
|
||||
itemselected := tempitem;
|
||||
Invalidate;
|
||||
end;
|
||||
end;
|
||||
|
||||
constructor TBCListBoxEx.Create(AOwner: TComponent);
|
||||
begin
|
||||
inherited Create(AOwner);
|
||||
scrolly := 0;
|
||||
itemheight := 150;
|
||||
scrollwidth := 20;
|
||||
lastitem := -1;
|
||||
invalidatecount := 0;
|
||||
itemselected := -1;
|
||||
fitems := TStringList.Create;
|
||||
end;
|
||||
|
||||
destructor TBCListBoxEx.Destroy;
|
||||
begin
|
||||
items.Free;
|
||||
end;
|
||||
|
||||
procedure TBCListBoxEx.KeyDown(var Key: word; Shift: TShiftState);
|
||||
var
|
||||
tempitem: integer;
|
||||
begin
|
||||
case key of
|
||||
vk_down:
|
||||
begin
|
||||
tempitem := itemselected + 1;
|
||||
if (tempitem < items.Count) then
|
||||
begin
|
||||
itemselected := tempitem;
|
||||
if not ItemIsVisible(itemselected) then
|
||||
ScrollToItemBottom();
|
||||
if not ItemIsVisible(itemselected) then
|
||||
ScrollToItem(itemselected);
|
||||
Invalidate;
|
||||
end;
|
||||
end;
|
||||
vk_up:
|
||||
begin
|
||||
tempitem := itemselected - 1;
|
||||
if (tempitem >= 0) then
|
||||
begin
|
||||
itemselected := tempitem;
|
||||
if not ItemIsVisible(itemselected) then
|
||||
ScrollToItemTop();
|
||||
if not ItemIsVisible(itemselected) then
|
||||
ScrollToItem(itemselected);
|
||||
Invalidate;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TBCListBoxEx.MouseMove(Shift: TShiftState; X, Y: integer);
|
||||
var
|
||||
tempitem: integer;
|
||||
begin
|
||||
mousepos := Point(x, y);
|
||||
tempitem := GetItemVertically(mousepos.Y);
|
||||
if tempitem <> lastitem then
|
||||
begin
|
||||
lastitem := tempitem;
|
||||
Invalidate;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TBCListBoxEx.DoMouseWheelDown(Shift: TShiftState; MousePos: TPoint): boolean;
|
||||
var
|
||||
r: TRect;
|
||||
begin
|
||||
result := False;
|
||||
r := GetItemRect(items.Count - 1);
|
||||
if (r.Bottom >= Height) then
|
||||
begin
|
||||
result := True;
|
||||
scrolly := scrolly - itemheight;
|
||||
Invalidate;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TBCListBoxEx.DoMouseWheelUp(Shift: TShiftState; MousePos: TPoint): boolean;
|
||||
var
|
||||
lastscroll: integer;
|
||||
begin
|
||||
result := False;
|
||||
lastscroll := scrolly;
|
||||
scrolly := scrolly + itemheight;
|
||||
if (scrolly > 0) then
|
||||
scrolly := 0;
|
||||
if scrolly <> lastscroll then
|
||||
begin
|
||||
result := True;
|
||||
Invalidate;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TBCListBoxEx.Paint;
|
||||
var
|
||||
i: integer;
|
||||
r: TRect;
|
||||
style: TTextStyle;
|
||||
start: integer;
|
||||
begin
|
||||
style.Alignment := taCenter;
|
||||
style.Layout := tlCenter;
|
||||
start := -1;
|
||||
|
||||
for i := trunc(abs(scrolly) / itemheight) to items.Count - 1 do
|
||||
begin
|
||||
r := GetItemRect(i);
|
||||
|
||||
if (r.Top < Height) then
|
||||
begin
|
||||
if start = -1 then
|
||||
start := i;
|
||||
Canvas.Brush.Color := clGreen;
|
||||
if (GetItemVertically(mousepos.Y) = i) then
|
||||
canvas.Brush.Color := clMoneyGreen;
|
||||
if (itemselected = i) then
|
||||
canvas.Brush.Color := clBlue;
|
||||
Canvas.Rectangle(r);
|
||||
Canvas.Font.Color := clWhite;
|
||||
Canvas.TextRect(r, 0, 0, items[i], style);
|
||||
Caption := IntToStr(start) + '..' + IntToStr(i);
|
||||
end
|
||||
else
|
||||
break;
|
||||
end;
|
||||
|
||||
Canvas.Brush.Color := clGray;
|
||||
Canvas.Rectangle(Width - scrollwidth, 0, Width, Height);
|
||||
|
||||
Canvas.Font.Color := clRed;
|
||||
Canvas.TextOut(10, 10, IntToStr(invalidatecount));
|
||||
Inc(invalidatecount);
|
||||
end;
|
||||
|
||||
function TBCListBoxEx.GetItemRect(index: integer): TRect;
|
||||
begin
|
||||
Result := Rect(0, (index * itemheight) + scrolly, Width - scrollwidth,
|
||||
(index * itemheight) + scrolly + itemheight);
|
||||
end;
|
||||
|
||||
function TBCListBoxEx.GetItemVertically(y: integer): integer;
|
||||
var
|
||||
i: integer;
|
||||
begin
|
||||
i := trunc(abs(scrolly) / itemheight);
|
||||
Result := i + trunc(y / itemheight);
|
||||
if (Result > items.Count) or (Result < 0) then
|
||||
Result := -1;
|
||||
end;
|
||||
|
||||
procedure TBCListBoxEx.ScrollToItemTop();
|
||||
begin
|
||||
scrolly := scrolly + itemheight;
|
||||
end;
|
||||
|
||||
procedure TBCListBoxEx.ScrollToItemBottom();
|
||||
begin
|
||||
scrolly := scrolly - itemheight;
|
||||
end;
|
||||
|
||||
procedure TBCListBoxEx.ScrollToItem(index: integer);
|
||||
begin
|
||||
scrolly := -itemheight * index;
|
||||
end;
|
||||
|
||||
function TBCListBoxEx.ItemIsVisible(index: integer): boolean;
|
||||
var
|
||||
r: TRect;
|
||||
begin
|
||||
r := GetItemRect(index);
|
||||
Result := Rect(0, 0, Width, Height).Contains(r);
|
||||
end;
|
||||
|
||||
end.
|
||||
529
bgracontrols/bcmaterialdesignbutton.pas
Normal file
529
bgracontrols/bcmaterialdesignbutton.pas
Normal file
@@ -0,0 +1,529 @@
|
||||
// SPDX-License-Identifier: LGPL-3.0-linking-exception
|
||||
{******************************* CONTRIBUTOR(S) ******************************
|
||||
- Edivando S. Santos Brasil | mailedivando@gmail.com
|
||||
(Compatibility with delphi VCL 11/2018)
|
||||
|
||||
***************************** END CONTRIBUTOR(S) *****************************}
|
||||
unit BCMaterialDesignButton;
|
||||
|
||||
{$I bgracontrols.inc}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils, {$IFDEF FPC}LResources,{$ENDIF}
|
||||
Types, Controls, Graphics, ExtCtrls, BCBaseCtrls, BGRABitmap, BGRABitmapTypes;
|
||||
|
||||
type
|
||||
|
||||
{ TBCMaterialDesignButton }
|
||||
|
||||
TBCMaterialDesignButton = class(TBGRAGraphicCtrl)
|
||||
private
|
||||
FNormalColor: TColor;
|
||||
FNormalColorEffect: TColor;
|
||||
FRoundBorders: single;
|
||||
FShadow: boolean;
|
||||
FShadowColor: TColor;
|
||||
FShadowSize: integer;
|
||||
FTextColor: TColor;
|
||||
FTextFont: string;
|
||||
FTextQuality: TBGRAFontQuality;
|
||||
FTextShadow: boolean;
|
||||
FTextShadowColor: TColor;
|
||||
FTextShadowOffsetX: integer;
|
||||
FTextShadowOffsetY: integer;
|
||||
FTextShadowSize: integer;
|
||||
FTextSize: integer;
|
||||
FTextStyle: TFontStyles;
|
||||
FTimer: TTimer;
|
||||
FBGRA: TBGRABitmap;
|
||||
FBGRAShadow: TBGRABitmap;
|
||||
FMousePos: TPoint;
|
||||
FCircleSize: single;
|
||||
FCircleAlpha: byte;
|
||||
procedure SetFNormalColor(AValue: TColor);
|
||||
procedure SetFNormalColorEffect(AValue: TColor);
|
||||
procedure SetFRoundBorders(AValue: single);
|
||||
procedure SetFShadow(AValue: boolean);
|
||||
procedure SetFShadowColor(AValue: TColor);
|
||||
procedure SetFShadowSize(AValue: integer);
|
||||
procedure SetFTextColor(AValue: TColor);
|
||||
procedure SetFTextFont(AValue: string);
|
||||
procedure SetFTextQuality(AValue: TBGRAFontQuality);
|
||||
procedure SetFTextShadow(AValue: boolean);
|
||||
procedure SetFTextShadowColor(AValue: TColor);
|
||||
procedure SetFTextShadowOffsetX(AValue: integer);
|
||||
procedure SetFTextShadowOffsetY(AValue: integer);
|
||||
procedure SetFTextShadowSize(AValue: integer);
|
||||
procedure SetFTextSize(AValue: integer);
|
||||
procedure SetFTextStyle(AValue: TFontStyles);
|
||||
protected
|
||||
procedure CalculatePreferredSize(var PreferredWidth, PreferredHeight: integer;
|
||||
{%H-}WithThemeSpace: boolean); override;
|
||||
procedure OnStartTimer({%H-}Sender: TObject);
|
||||
procedure OnTimer({%H-}Sender: TObject);
|
||||
procedure Paint; override;
|
||||
procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
|
||||
X, Y: integer); override;
|
||||
class function GetControlClassDefaultSize: TSize; override;
|
||||
procedure TextChanged; override;
|
||||
procedure UpdateShadow;
|
||||
public
|
||||
constructor Create(AOwner: TComponent); override;
|
||||
destructor Destroy; override;
|
||||
procedure ClickMe;
|
||||
published
|
||||
property RoundBorders: single read FRoundBorders write SetFRoundBorders {$IFDEF FPC}default 5{$ENDIF};
|
||||
property NormalColor: TColor read FNormalColor write SetFNormalColor default clWhite;
|
||||
property NormalColorEffect: TColor read FNormalColorEffect
|
||||
write SetFNormalColorEffect default clSilver;
|
||||
property Shadow: boolean read FShadow write SetFShadow default True;
|
||||
property ShadowColor: TColor read FShadowColor write SetFShadowColor default clGray;
|
||||
property ShadowSize: integer read FShadowSize write SetFShadowSize default 5;
|
||||
property TextColor: TColor read FTextColor write SetFTextColor default clBlack;
|
||||
property TextSize: integer read FTextSize write SetFTextSize default 16;
|
||||
property TextShadow: boolean read FTextShadow write SetFTextShadow default True;
|
||||
property TextShadowColor: TColor read FTextShadowColor
|
||||
write SetFTextShadowColor default clBlack;
|
||||
property TextShadowSize: integer read FTextShadowSize
|
||||
write SetFTextShadowSize default 2;
|
||||
property TextShadowOffsetX: integer read FTextShadowOffsetX
|
||||
write SetFTextShadowOffsetX default 0;
|
||||
property TextShadowOffsetY: integer read FTextShadowOffsetY
|
||||
write SetFTextShadowOffsetY default 0;
|
||||
property TextStyle: TFontStyles read FTextStyle write SetFTextStyle default [];
|
||||
property TextFont: string read FTextFont write SetFTextFont;
|
||||
property TextQuality: TBGRAFontQuality read FTextQuality
|
||||
write SetFTextQuality default fqFineAntialiasing;
|
||||
published
|
||||
property Action;
|
||||
property Align;
|
||||
property Anchors;
|
||||
property AutoSize;
|
||||
property BidiMode;
|
||||
property BorderSpacing;
|
||||
{$IFDEF FPC} //#
|
||||
property OnChangeBounds;
|
||||
{$ENDIF}
|
||||
property Caption;
|
||||
property Constraints;
|
||||
property DragCursor;
|
||||
property DragKind;
|
||||
property DragMode;
|
||||
property Enabled;
|
||||
property OnClick;
|
||||
property OnContextPopup;
|
||||
property OnDragDrop;
|
||||
property OnDragOver;
|
||||
property OnEndDrag;
|
||||
property OnMouseDown;
|
||||
property OnMouseMove;
|
||||
property OnMouseUp;
|
||||
property OnMouseEnter;
|
||||
property OnMouseLeave;
|
||||
property OnMouseWheel;
|
||||
property OnMouseWheelDown;
|
||||
property OnMouseWheelUp;
|
||||
property OnResize;
|
||||
property OnStartDrag;
|
||||
property ParentBidiMode;
|
||||
property ParentFont;
|
||||
property ParentShowHint;
|
||||
property PopupMenu;
|
||||
property ShowHint;
|
||||
property Visible;
|
||||
end;
|
||||
|
||||
{$IFDEF FPC}procedure Register;{$ENDIF}
|
||||
|
||||
implementation
|
||||
|
||||
function DrawTextShadow(AWidth, AHeight: integer; AText: string;
|
||||
AFontHeight: integer; ATextColor, AShadowColor: TBGRAPixel;
|
||||
AOffSetX, AOffSetY: integer; ARadius: integer = 0; AFontStyle: TFontStyles = [];
|
||||
AFontName: string = 'Default'; AShowShadow: boolean = True;
|
||||
AFontQuality: TBGRAFontQuality = fqFineAntialiasing): TBGRACustomBitmap;
|
||||
var
|
||||
bmpOut, bmpSdw: TBGRABitmap;
|
||||
begin
|
||||
bmpOut := TBGRABitmap.Create(AWidth, AHeight);
|
||||
bmpOut.FontAntialias := True;
|
||||
bmpOut.FontHeight := AFontHeight;
|
||||
bmpOut.FontStyle := AFontStyle;
|
||||
bmpOut.FontName := AFontName;
|
||||
bmpOut.FontQuality := AFontQuality;
|
||||
|
||||
if AShowShadow then
|
||||
begin
|
||||
bmpSdw := TBGRABitmap.Create(AWidth, AHeight);
|
||||
bmpSdw.FontAntialias := True;
|
||||
bmpSdw.FontHeight := AFontHeight;
|
||||
bmpSdw.FontStyle := AFontStyle;
|
||||
bmpSdw.FontName := AFontName;
|
||||
bmpSdw.FontQuality := AFontQuality;
|
||||
|
||||
bmpSdw.TextRect(Rect(0, 0, bmpSdw.Width, bmpSdw.Height), AText, taCenter, tlCenter, AShadowColor);
|
||||
BGRAReplace(bmpSdw, bmpSdw.FilterBlurRadial(ARadius, rbFast));
|
||||
bmpOut.PutImage(0 + AOffSetX, 0 + AOffSetY, bmpSdw,
|
||||
dmDrawWithTransparency);
|
||||
bmpSdw.Free;
|
||||
end;
|
||||
|
||||
bmpOut.TextRect(Rect(0, 0, bmpOut.Width, bmpOut.Height), AText, taCenter, tlCenter, ATextColor);
|
||||
|
||||
Result := bmpOut;
|
||||
end;
|
||||
|
||||
{$IFDEF FPC}procedure Register;
|
||||
begin
|
||||
RegisterComponents('BGRA Button Controls', [TBCMaterialDesignButton]);
|
||||
end;
|
||||
{$ENDIF}
|
||||
|
||||
{ TBCMaterialDesignButton }
|
||||
|
||||
procedure TBCMaterialDesignButton.SetFRoundBorders(AValue: single);
|
||||
begin
|
||||
if FRoundBorders = AValue then
|
||||
Exit;
|
||||
FRoundBorders := AValue;
|
||||
UpdateShadow;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBCMaterialDesignButton.SetFShadow(AValue: boolean);
|
||||
begin
|
||||
if FShadow = AValue then
|
||||
Exit;
|
||||
FShadow := AValue;
|
||||
InvalidatePreferredSize;
|
||||
AdjustSize;
|
||||
UpdateShadow;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBCMaterialDesignButton.SetFShadowColor(AValue: TColor);
|
||||
begin
|
||||
if FShadowColor = AValue then
|
||||
Exit;
|
||||
FShadowColor := AValue;
|
||||
UpdateShadow;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBCMaterialDesignButton.SetFShadowSize(AValue: integer);
|
||||
begin
|
||||
if FShadowSize = AValue then
|
||||
Exit;
|
||||
FShadowSize := AValue;
|
||||
InvalidatePreferredSize;
|
||||
AdjustSize;
|
||||
UpdateShadow;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBCMaterialDesignButton.SetFTextColor(AValue: TColor);
|
||||
begin
|
||||
if FTextColor = AValue then
|
||||
Exit;
|
||||
FTextColor := AValue;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBCMaterialDesignButton.SetFTextFont(AValue: string);
|
||||
begin
|
||||
if FTextFont = AValue then
|
||||
Exit;
|
||||
FTextFont := AValue;
|
||||
InvalidatePreferredSize;
|
||||
AdjustSize;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBCMaterialDesignButton.SetFTextQuality(AValue: TBGRAFontQuality);
|
||||
begin
|
||||
if FTextQuality = AValue then
|
||||
Exit;
|
||||
FTextQuality := AValue;
|
||||
InvalidatePreferredSize;
|
||||
AdjustSize;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBCMaterialDesignButton.SetFTextShadow(AValue: boolean);
|
||||
begin
|
||||
if FTextShadow = AValue then
|
||||
Exit;
|
||||
FTextShadow := AValue;
|
||||
InvalidatePreferredSize;
|
||||
AdjustSize;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBCMaterialDesignButton.SetFTextShadowColor(AValue: TColor);
|
||||
begin
|
||||
if FTextShadowColor = AValue then
|
||||
Exit;
|
||||
FTextShadowColor := AValue;
|
||||
UpdateShadow;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBCMaterialDesignButton.SetFTextShadowOffsetX(AValue: integer);
|
||||
begin
|
||||
if FTextShadowOffsetX = AValue then
|
||||
Exit;
|
||||
FTextShadowOffsetX := AValue;
|
||||
InvalidatePreferredSize;
|
||||
AdjustSize;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBCMaterialDesignButton.SetFTextShadowOffsetY(AValue: integer);
|
||||
begin
|
||||
if FTextShadowOffsetY = AValue then
|
||||
Exit;
|
||||
FTextShadowOffsetY := AValue;
|
||||
InvalidatePreferredSize;
|
||||
AdjustSize;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBCMaterialDesignButton.SetFTextShadowSize(AValue: integer);
|
||||
begin
|
||||
if FTextShadowSize = AValue then
|
||||
Exit;
|
||||
FTextShadowSize := AValue;
|
||||
InvalidatePreferredSize;
|
||||
AdjustSize;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBCMaterialDesignButton.SetFTextSize(AValue: integer);
|
||||
begin
|
||||
if FTextSize = AValue then
|
||||
Exit;
|
||||
FTextSize := AValue;
|
||||
InvalidatePreferredSize;
|
||||
AdjustSize;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBCMaterialDesignButton.SetFTextStyle(AValue: TFontStyles);
|
||||
begin
|
||||
if FTextStyle = AValue then
|
||||
Exit;
|
||||
FTextStyle := AValue;
|
||||
InvalidatePreferredSize;
|
||||
AdjustSize;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBCMaterialDesignButton.CalculatePreferredSize(
|
||||
var PreferredWidth, PreferredHeight: integer; WithThemeSpace: boolean);
|
||||
var
|
||||
ts: TSize;
|
||||
begin
|
||||
inherited CalculatePreferredSize(PreferredWidth, PreferredHeight,
|
||||
WithThemeSpace);
|
||||
if Caption <> '' then
|
||||
begin
|
||||
FBGRA.FontQuality := FTextQuality;
|
||||
FBGRA.FontName := FTextFont;
|
||||
FBGRA.FontStyle := FTextStyle;
|
||||
FBGRA.FontHeight := FTextSize;
|
||||
FBGRA.FontAntialias := True;
|
||||
|
||||
ts := FBGRA.TextSize(Caption);
|
||||
Inc(PreferredWidth, ts.cx + 26);
|
||||
Inc(PreferredHeight, ts.cy + 10);
|
||||
end;
|
||||
|
||||
if FShadow then
|
||||
begin
|
||||
Inc(PreferredWidth, FShadowSize * 2);
|
||||
Inc(PreferredHeight, FShadowSize * 2);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TBCMaterialDesignButton.SetFNormalColor(AValue: TColor);
|
||||
begin
|
||||
if FNormalColor = AValue then
|
||||
Exit;
|
||||
FNormalColor := AValue;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBCMaterialDesignButton.SetFNormalColorEffect(AValue: TColor);
|
||||
begin
|
||||
if FNormalColorEffect = AValue then
|
||||
Exit;
|
||||
FNormalColorEffect := AValue;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBCMaterialDesignButton.OnStartTimer(Sender: TObject);
|
||||
begin
|
||||
FCircleAlpha := 255;
|
||||
FCircleSize := 5;
|
||||
end;
|
||||
|
||||
procedure TBCMaterialDesignButton.OnTimer(Sender: TObject);
|
||||
begin
|
||||
FCircleSize := FCircleSize + 8;
|
||||
if FCircleAlpha - 10 > 0 then
|
||||
FCircleAlpha := FCircleAlpha - 10
|
||||
else
|
||||
FCircleAlpha := 0;
|
||||
if FCircleAlpha <= 0 then
|
||||
FTimer.Enabled := False;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBCMaterialDesignButton.Paint;
|
||||
var
|
||||
temp: TBGRABitmap;
|
||||
round_rect_left: integer;
|
||||
round_rect_width: integer;
|
||||
round_rect_height: integer;
|
||||
text_height: integer;
|
||||
begin
|
||||
if (FBGRA.Width <> Width) or (FBGRA.Height <> Height) then
|
||||
begin
|
||||
FBGRA.SetSize(Width, Height);
|
||||
FBGRAShadow.SetSize(Width, Height);
|
||||
UpdateShadow;
|
||||
end;
|
||||
|
||||
FBGRA.FillTransparent;
|
||||
if FShadow then
|
||||
FBGRA.PutImage(0, 0, FBGRAShadow, dmDrawWithTransparency);
|
||||
|
||||
temp := TBGRABitmap.Create(Width, Height, FNormalColor);
|
||||
temp.EllipseAntialias(FMousePos.X, FMousePos.Y, FCircleSize, FCircleSize,
|
||||
ColorToBGRA(FNormalColorEffect, FCircleAlpha), 1,
|
||||
ColorToBGRA(FNormalColorEffect, FCircleAlpha));
|
||||
|
||||
if FShadow then
|
||||
begin
|
||||
round_rect_left := FShadowSize;
|
||||
round_rect_width := Width - FShadowSize;
|
||||
round_rect_height := Height - FShadowSize;
|
||||
end
|
||||
else
|
||||
begin
|
||||
round_rect_left := 0;
|
||||
round_rect_width := width;
|
||||
round_rect_height := height;
|
||||
end;
|
||||
|
||||
FBGRA.FillRoundRectAntialias(round_rect_left, 0, round_rect_width, round_rect_height,
|
||||
FRoundBorders, FRoundBorders, temp, [rrDefault], False);
|
||||
|
||||
temp.Free;
|
||||
|
||||
if Caption <> '' then
|
||||
begin
|
||||
if FShadow then
|
||||
text_height := Height - FShadowSize
|
||||
else
|
||||
text_height := Height;
|
||||
temp := DrawTextShadow(Width, text_height, Caption,
|
||||
FTextSize, FTextColor, FTextShadowColor, FTextShadowOffsetX,
|
||||
FTextShadowOffsetY, FTextShadowSize, FTextStyle, FTextFont,
|
||||
FTextShadow, FTextQuality) as TBGRABitmap;
|
||||
FBGRA.PutImage(0, 0, temp, dmDrawWithTransparency);
|
||||
temp.Free;
|
||||
end;
|
||||
|
||||
FBGRA.Draw(Canvas, 0, 0, False);
|
||||
end;
|
||||
|
||||
procedure TBCMaterialDesignButton.MouseDown(Button: TMouseButton;
|
||||
Shift: TShiftState; X, Y: integer);
|
||||
begin
|
||||
FTimer.Enabled := False;
|
||||
FMousePos := Point(X, Y);
|
||||
FTimer.Enabled := True;
|
||||
inherited MouseDown(Button, Shift, X, Y);
|
||||
end;
|
||||
|
||||
class function TBCMaterialDesignButton.GetControlClassDefaultSize: TSize;
|
||||
begin
|
||||
Result.CX := 123;
|
||||
Result.CY := 33;
|
||||
end;
|
||||
|
||||
procedure TBCMaterialDesignButton.TextChanged;
|
||||
begin
|
||||
InvalidatePreferredSize;
|
||||
AdjustSize;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBCMaterialDesignButton.UpdateShadow;
|
||||
begin
|
||||
FBGRAShadow.FillTransparent;
|
||||
if FShadow then
|
||||
begin
|
||||
FBGRAShadow.RoundRectAntialias(FShadowSize, FShadowSize, Width - FShadowSize,
|
||||
Height - FShadowSize, FRoundBorders, FRoundBorders,
|
||||
FShadowColor, 1, FShadowColor, [rrDefault]);
|
||||
BGRAReplace(FBGRAShadow, FBGRAShadow.FilterBlurRadial(FShadowSize,
|
||||
FShadowSize, rbFast) as TBGRABitmap);
|
||||
end;
|
||||
end;
|
||||
|
||||
constructor TBCMaterialDesignButton.Create(AOwner: TComponent);
|
||||
begin
|
||||
inherited Create(AOwner);
|
||||
with GetControlClassDefaultSize do
|
||||
SetInitialBounds(0, 0, CX, CY);
|
||||
FTimer := TTimer.Create(Self);
|
||||
FTimer.Interval := 15;
|
||||
FTimer.Enabled := False;
|
||||
{$IFDEF FPC}//#
|
||||
FTimer.OnStartTimer := OnStartTimer;
|
||||
{$ENDIF}
|
||||
FTimer.OnTimer := OnTimer;
|
||||
FBGRA := TBGRABitmap.Create(Width, Height);
|
||||
FBGRAShadow := TBGRABitmap.Create(Width, Height);
|
||||
FRoundBorders := 5;
|
||||
FNormalColor := clWhite;
|
||||
FNormalColorEffect := clSilver;
|
||||
FShadow := True;
|
||||
FShadowColor := clGray;
|
||||
FShadowSize := 5;
|
||||
FTextColor := clBlack;
|
||||
FTextSize := 16;
|
||||
FTextShadow := True;
|
||||
FTextShadowColor := clBlack;
|
||||
FTextShadowSize := 2;
|
||||
FTextShadowOffsetX := 0;
|
||||
FTextShadowOffsetY := 0;
|
||||
FTextStyle := [];
|
||||
FTextFont := 'default';
|
||||
FTextQuality := fqFineAntialiasing;
|
||||
end;
|
||||
|
||||
destructor TBCMaterialDesignButton.Destroy;
|
||||
begin
|
||||
FTimer.Enabled := False;
|
||||
{$IFDEF FPC}//#
|
||||
FTimer.OnStartTimer := nil;
|
||||
{$ENDIF}
|
||||
FTimer.OnTimer := nil;
|
||||
FreeAndNil(FBGRA);
|
||||
FreeAndNil(FBGRAShadow);
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
procedure TBCMaterialDesignButton.ClickMe;
|
||||
begin
|
||||
FMousePos := Point(Width div 2, Height div 2);
|
||||
FTimer.Enabled := True;
|
||||
inherited Click;
|
||||
end;
|
||||
|
||||
end.
|
||||
128
bgracontrols/bcmaterialedit.pas
Normal file
128
bgracontrols/bcmaterialedit.pas
Normal file
@@ -0,0 +1,128 @@
|
||||
unit BCMaterialEdit;
|
||||
|
||||
{$mode objfpc}{$H+}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, ExtCtrls,
|
||||
StdCtrls;
|
||||
|
||||
type
|
||||
|
||||
{ TBCMaterialEdit }
|
||||
|
||||
TBCMaterialEdit = class(TCustomPanel)
|
||||
private
|
||||
FAccentColor: TColor;
|
||||
FDisabledColor: TColor;
|
||||
Flbl: TLabel;
|
||||
Fedt: TEdit;
|
||||
Ffocused: boolean;
|
||||
FOnChange: TNotifyEvent;
|
||||
FTexto: string;
|
||||
procedure ChangeEdit(Sender: TObject);
|
||||
procedure EnterEdit(Sender: TObject);
|
||||
procedure ExitEdit(Sender: TObject);
|
||||
procedure SetTexto(AValue: string);
|
||||
protected
|
||||
procedure Paint; override;
|
||||
public
|
||||
constructor Create(AOwner: TComponent); override;
|
||||
published
|
||||
property Color;
|
||||
property Text: string read FTexto write SetTexto;
|
||||
property Edit: TEdit read Fedt;
|
||||
property Title: TLabel read Flbl;
|
||||
property DisabledColor: TColor read FDisabledColor write FDisabledColor;
|
||||
property AccentColor: TColor read FAccentColor write FAccentColor;
|
||||
property OnChange: TNotifyEvent read FOnChange write FOnChange;
|
||||
end;
|
||||
|
||||
procedure Register;
|
||||
|
||||
implementation
|
||||
|
||||
procedure Register;
|
||||
begin
|
||||
RegisterComponents('BGRA Controls', [TBCMaterialEdit]);
|
||||
end;
|
||||
|
||||
{ TBCMaterialEdit }
|
||||
|
||||
procedure TBCMaterialEdit.EnterEdit(Sender: TObject);
|
||||
begin
|
||||
Ffocused := True;
|
||||
Invalidate;
|
||||
Flbl.Font.Color := accentColor;
|
||||
end;
|
||||
|
||||
procedure TBCMaterialEdit.ChangeEdit(Sender: TObject);
|
||||
begin
|
||||
if Assigned(FOnChange) then
|
||||
FOnChange(Self);
|
||||
end;
|
||||
|
||||
procedure TBCMaterialEdit.ExitEdit(Sender: TObject);
|
||||
begin
|
||||
Ffocused := False;
|
||||
Invalidate;
|
||||
Flbl.Font.Color := DisabledColor;
|
||||
end;
|
||||
|
||||
procedure TBCMaterialEdit.SetTexto(AValue: string);
|
||||
begin
|
||||
if FTexto = AValue then
|
||||
Exit;
|
||||
FTexto := AValue;
|
||||
Flbl.Caption := FTexto;
|
||||
//Fedt.TextHint := FTexto;
|
||||
end;
|
||||
|
||||
procedure TBCMaterialEdit.Paint;
|
||||
begin
|
||||
inherited Paint;
|
||||
Canvas.Brush.Color := Color;
|
||||
Canvas.Pen.Color := Color;
|
||||
Canvas.Rectangle(0, 0, Width, Height);
|
||||
if (fFocused) then
|
||||
begin
|
||||
Canvas.Pen.Color := AccentColor;
|
||||
Canvas.Line(0, Height - 2, Width, Height - 2);
|
||||
Canvas.Line(0, Height - 1, Width, Height - 1);
|
||||
end
|
||||
else
|
||||
begin
|
||||
Canvas.Pen.Color := DisabledColor;
|
||||
Canvas.Line(0, Height - 1, Width, Height - 1);
|
||||
end;
|
||||
end;
|
||||
|
||||
constructor TBCMaterialEdit.Create(AOwner: TComponent);
|
||||
begin
|
||||
inherited Create(AOwner);
|
||||
Self.BevelOuter := bvNone;
|
||||
Self.Color := clWhite;
|
||||
AccentColor := clHighlight;
|
||||
DisabledColor := $00B8AFA8;
|
||||
Flbl := TLabel.Create(Self);
|
||||
Flbl.Align := alTop;
|
||||
Flbl.Caption := 'Buscar';
|
||||
Flbl.BorderSpacing.Around := 4;
|
||||
Flbl.Font.Style := [fsBold];
|
||||
Flbl.Font.Color := $00B8AFA8;
|
||||
Flbl.Parent := Self;
|
||||
Fedt := TEdit.Create(Self);
|
||||
Fedt.Color := Color;
|
||||
Fedt.Font.Color := clBlack;
|
||||
Fedt.OnEnter := @EnterEdit;
|
||||
Fedt.OnExit := @ExitEdit;
|
||||
Fedt.OnChange:=@ChangeEdit;
|
||||
Fedt.Align := alClient;
|
||||
Fedt.BorderStyle := bsNone;
|
||||
//Fedt.TextHint := 'Buscar';
|
||||
Fedt.BorderSpacing.Around := 4;
|
||||
Fedt.Parent := Self;
|
||||
end;
|
||||
|
||||
end.
|
||||
130
bgracontrols/bcmaterialfloatspinedit.pas
Normal file
130
bgracontrols/bcmaterialfloatspinedit.pas
Normal file
@@ -0,0 +1,130 @@
|
||||
unit BCMaterialFloatSpinEdit;
|
||||
|
||||
{$mode objfpc}{$H+}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, ExtCtrls,
|
||||
StdCtrls, Spin;
|
||||
|
||||
type
|
||||
|
||||
{ TBCMaterialFloatSpinEdit }
|
||||
|
||||
TBCMaterialFloatSpinEdit = class(TCustomPanel)
|
||||
private
|
||||
FAccentColor: TColor;
|
||||
FDisabledColor: TColor;
|
||||
Flbl: TLabel;
|
||||
Fedt: TFloatSpinEdit;
|
||||
Ffocused: boolean;
|
||||
FOnChange: TNotifyEvent;
|
||||
FTexto: string;
|
||||
procedure ChangeEdit(Sender: TObject);
|
||||
procedure EnterEdit(Sender: TObject);
|
||||
procedure ExitEdit(Sender: TObject);
|
||||
procedure SetTexto(AValue: string);
|
||||
protected
|
||||
procedure Paint; override;
|
||||
public
|
||||
constructor Create(AOwner: TComponent); override;
|
||||
published
|
||||
property Color;
|
||||
property Text: string read FTexto write SetTexto;
|
||||
property Edit: TFloatSpinEdit read Fedt;
|
||||
property Title: TLabel read Flbl;
|
||||
property DisabledColor: TColor read FDisabledColor write FDisabledColor;
|
||||
property AccentColor: TColor read FAccentColor write FAccentColor;
|
||||
property OnChange: TNotifyEvent read FOnChange write FOnChange;
|
||||
end;
|
||||
|
||||
procedure Register;
|
||||
|
||||
implementation
|
||||
|
||||
procedure Register;
|
||||
begin
|
||||
RegisterComponents('BGRA Controls', [TBCMaterialFloatSpinEdit]);
|
||||
end;
|
||||
|
||||
{ TBCMaterialFloatSpinEdit }
|
||||
|
||||
procedure TBCMaterialFloatSpinEdit.EnterEdit(Sender: TObject);
|
||||
begin
|
||||
Ffocused := True;
|
||||
Invalidate;
|
||||
Flbl.Font.Color := AccentColor;
|
||||
end;
|
||||
|
||||
procedure TBCMaterialFloatSpinEdit.ChangeEdit(Sender: TObject);
|
||||
begin
|
||||
if Assigned(FOnChange) then
|
||||
FOnChange(Self);
|
||||
end;
|
||||
|
||||
procedure TBCMaterialFloatSpinEdit.ExitEdit(Sender: TObject);
|
||||
begin
|
||||
Ffocused := False;
|
||||
Invalidate;
|
||||
Flbl.Font.Color := DisabledColor;
|
||||
end;
|
||||
|
||||
procedure TBCMaterialFloatSpinEdit.SetTexto(AValue: string);
|
||||
begin
|
||||
if FTexto = AValue then
|
||||
Exit;
|
||||
FTexto := AValue;
|
||||
Flbl.Caption := FTexto;
|
||||
//Fedt.TextHint := FTexto;
|
||||
end;
|
||||
|
||||
procedure TBCMaterialFloatSpinEdit.Paint;
|
||||
begin
|
||||
inherited Paint;
|
||||
Canvas.Brush.Color := Color;
|
||||
Canvas.Pen.Color := Color;
|
||||
Canvas.Rectangle(0, 0, Width, Height);
|
||||
if (fFocused) then
|
||||
begin
|
||||
Canvas.Pen.Color := AccentColor;
|
||||
Canvas.Line(0, Height - 2, Width, Height - 2);
|
||||
Canvas.Line(0, Height - 1, Width, Height - 1);
|
||||
end
|
||||
else
|
||||
begin
|
||||
Canvas.Pen.Color := DisabledColor;
|
||||
Canvas.Line(0, Height - 1, Width, Height - 1);
|
||||
end;
|
||||
end;
|
||||
|
||||
constructor TBCMaterialFloatSpinEdit.Create(AOwner: TComponent);
|
||||
begin
|
||||
inherited Create(AOwner);
|
||||
Self.BevelOuter := bvNone;
|
||||
Self.Color := clWhite;
|
||||
AccentColor := clHighlight;
|
||||
DisabledColor := $00B8AFA8;
|
||||
Flbl := TLabel.Create(Self);
|
||||
Flbl.Align := alTop;
|
||||
Flbl.Caption := 'Buscar';
|
||||
Flbl.BorderSpacing.Around := 4;
|
||||
Flbl.Font.Style := [fsBold];
|
||||
Flbl.Font.Color := $00B8AFA8;
|
||||
Flbl.Parent := Self;
|
||||
Fedt := TFloatSpinEdit.Create(Self);
|
||||
Fedt.Color := Color;
|
||||
Fedt.Font.Color := clBlack;
|
||||
Fedt.OnEnter := @EnterEdit;
|
||||
Fedt.OnExit := @ExitEdit;
|
||||
Fedt.OnChange:=@ChangeEdit;
|
||||
Fedt.Align := alClient;
|
||||
Fedt.BorderStyle := bsNone;
|
||||
//Fedt.TextHint := 'Buscar';
|
||||
Fedt.BorderSpacing.Around := 4;
|
||||
Fedt.Parent := Self;
|
||||
Fedt.MinValue := 0;
|
||||
Fedt.MaxValue := MaxInt;
|
||||
end;
|
||||
|
||||
end.
|
||||
128
bgracontrols/bcmaterialprogressbarmarquee.pas
Normal file
128
bgracontrols/bcmaterialprogressbarmarquee.pas
Normal file
@@ -0,0 +1,128 @@
|
||||
unit BCMaterialProgressBarMarquee;
|
||||
|
||||
{$mode delphi}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, BGRAGraphicControl,
|
||||
ExtCtrls, BGRABitmap, BGRABitmapTypes;
|
||||
|
||||
type
|
||||
|
||||
{ TBCMaterialProgressBarMarquee }
|
||||
|
||||
TBCMaterialProgressBarMarquee = class(TBGRAGraphicControl)
|
||||
private
|
||||
FBarColor: TColor;
|
||||
progressbasr_cx, progressbar_cw: integer;
|
||||
progressbar_x, progressbar_w: integer;
|
||||
progressbar_increase: boolean;
|
||||
FTimer: TTimer;
|
||||
procedure SetBarColor(AValue: TColor);
|
||||
procedure TimerOnTimer(Sender: TObject);
|
||||
protected
|
||||
procedure SetEnabled(Value: Boolean); override;
|
||||
procedure SetVisible(Value: Boolean); override;
|
||||
public
|
||||
procedure DiscardBitmap;
|
||||
procedure RedrawBitmapContent; override;
|
||||
constructor Create(AOwner: TComponent); override;
|
||||
published
|
||||
property BarColor: TColor read FBarColor write SetBarColor;
|
||||
property Visible;
|
||||
end;
|
||||
|
||||
procedure Register;
|
||||
|
||||
implementation
|
||||
|
||||
procedure Register;
|
||||
begin
|
||||
RegisterComponents('BGRA Controls', [TBCMaterialProgressBarMarquee]);
|
||||
end;
|
||||
|
||||
{ TBCMaterialProgressBarMarquee }
|
||||
|
||||
procedure TBCMaterialProgressBarMarquee.TimerOnTimer(Sender: TObject);
|
||||
begin
|
||||
if progressbar_increase then
|
||||
begin
|
||||
progressbar_w := progressbar_w + progressbar_cw;
|
||||
if (progressbar_w >= Width - 5) then
|
||||
begin
|
||||
progressbar_increase := False;
|
||||
end;
|
||||
end
|
||||
else
|
||||
begin
|
||||
progressbar_w := progressbar_w - progressbar_cw;
|
||||
if (progressbar_w <= progressbar_cw) then
|
||||
begin
|
||||
progressbar_increase := True;
|
||||
end;
|
||||
end;
|
||||
progressbar_x := progressbar_x + progressbasr_cx;
|
||||
if (progressbar_x >= Width) then
|
||||
progressbar_x := -progressbar_w;
|
||||
DiscardBitmap;
|
||||
end;
|
||||
|
||||
procedure TBCMaterialProgressBarMarquee.SetEnabled(Value: Boolean);
|
||||
begin
|
||||
inherited SetEnabled(Value);
|
||||
FTimer.Enabled := Value and Visible;
|
||||
DiscardBitmap;
|
||||
end;
|
||||
|
||||
procedure TBCMaterialProgressBarMarquee.SetVisible(Value: Boolean);
|
||||
begin
|
||||
inherited SetVisible(Value);
|
||||
FTimer.Enabled := Enabled and Value;
|
||||
DiscardBitmap;
|
||||
end;
|
||||
|
||||
procedure TBCMaterialProgressBarMarquee.SetBarColor(AValue: TColor);
|
||||
begin
|
||||
if FBarColor = AValue then
|
||||
Exit;
|
||||
FBarColor := AValue;
|
||||
DiscardBitmap;
|
||||
end;
|
||||
|
||||
procedure TBCMaterialProgressBarMarquee.DiscardBitmap;
|
||||
begin
|
||||
inherited DiscardBitmap;
|
||||
progressbar_cw := Width div 50;
|
||||
progressbasr_cx := progressbar_cw * 2;
|
||||
end;
|
||||
|
||||
procedure TBCMaterialProgressBarMarquee.RedrawBitmapContent;
|
||||
begin
|
||||
if FTimer.Enabled then
|
||||
begin
|
||||
Bitmap.Fill(Color);
|
||||
Bitmap.Rectangle(Rect(progressbar_x, 0, progressbar_x + progressbar_w, Bitmap.Height),
|
||||
BarColor, BarColor);
|
||||
end
|
||||
else
|
||||
begin
|
||||
Bitmap.Fill(BarColor);
|
||||
end;
|
||||
end;
|
||||
|
||||
constructor TBCMaterialProgressBarMarquee.Create(AOwner: TComponent);
|
||||
begin
|
||||
inherited Create(AOwner);
|
||||
progressbar_w := Width;
|
||||
progressbar_x := -progressbar_w;
|
||||
progressbar_increase := False;
|
||||
FTimer := TTimer.Create(Self);
|
||||
FTimer.Interval := 15;
|
||||
FTimer.OnTimer := TimerOnTimer;
|
||||
FTimer.Enabled := True;
|
||||
Color := clWhite;
|
||||
BarColor := $00E2A366;
|
||||
end;
|
||||
|
||||
end.
|
||||
130
bgracontrols/bcmaterialspinedit.pas
Normal file
130
bgracontrols/bcmaterialspinedit.pas
Normal file
@@ -0,0 +1,130 @@
|
||||
unit BCMaterialSpinEdit;
|
||||
|
||||
{$mode objfpc}{$H+}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, ExtCtrls,
|
||||
StdCtrls, Spin;
|
||||
|
||||
type
|
||||
|
||||
{ TBCMaterialSpinEdit }
|
||||
|
||||
TBCMaterialSpinEdit = class(TCustomPanel)
|
||||
private
|
||||
FAccentColor: TColor;
|
||||
FDisabledColor: TColor;
|
||||
Flbl: TLabel;
|
||||
Fedt: TSpinEdit;
|
||||
Ffocused: boolean;
|
||||
FOnChange: TNotifyEvent;
|
||||
FTexto: string;
|
||||
procedure ChangeEdit(Sender: TObject);
|
||||
procedure EnterEdit(Sender: TObject);
|
||||
procedure ExitEdit(Sender: TObject);
|
||||
procedure SetTexto(AValue: string);
|
||||
protected
|
||||
procedure Paint; override;
|
||||
public
|
||||
constructor Create(AOwner: TComponent); override;
|
||||
published
|
||||
property Color;
|
||||
property Text: string read FTexto write SetTexto;
|
||||
property Edit: TSpinEdit read Fedt;
|
||||
property Title: TLabel read Flbl;
|
||||
property DisabledColor: TColor read FDisabledColor write FDisabledColor;
|
||||
property AccentColor: TColor read FAccentColor write FAccentColor;
|
||||
property OnChange: TNotifyEvent read FOnChange write FOnChange;
|
||||
end;
|
||||
|
||||
procedure Register;
|
||||
|
||||
implementation
|
||||
|
||||
procedure Register;
|
||||
begin
|
||||
RegisterComponents('BGRA Controls', [TBCMaterialSpinEdit]);
|
||||
end;
|
||||
|
||||
{ TBCMaterialSpinEdit }
|
||||
|
||||
procedure TBCMaterialSpinEdit.EnterEdit(Sender: TObject);
|
||||
begin
|
||||
Ffocused := True;
|
||||
Invalidate;
|
||||
Flbl.Font.Color := AccentColor;
|
||||
end;
|
||||
|
||||
procedure TBCMaterialSpinEdit.ChangeEdit(Sender: TObject);
|
||||
begin
|
||||
if Assigned(FOnChange) then
|
||||
FOnChange(Self);
|
||||
end;
|
||||
|
||||
procedure TBCMaterialSpinEdit.ExitEdit(Sender: TObject);
|
||||
begin
|
||||
Ffocused := False;
|
||||
Invalidate;
|
||||
Flbl.Font.Color := DisabledColor;
|
||||
end;
|
||||
|
||||
procedure TBCMaterialSpinEdit.SetTexto(AValue: string);
|
||||
begin
|
||||
if FTexto = AValue then
|
||||
Exit;
|
||||
FTexto := AValue;
|
||||
Flbl.Caption := FTexto;
|
||||
//Fedt.TextHint := FTexto;
|
||||
end;
|
||||
|
||||
procedure TBCMaterialSpinEdit.Paint;
|
||||
begin
|
||||
inherited Paint;
|
||||
Canvas.Brush.Color := Color;
|
||||
Canvas.Pen.Color := Color;
|
||||
Canvas.Rectangle(0, 0, Width, Height);
|
||||
if (fFocused) then
|
||||
begin
|
||||
Canvas.Pen.Color := AccentColor;
|
||||
Canvas.Line(0, Height - 2, Width, Height - 2);
|
||||
Canvas.Line(0, Height - 1, Width, Height - 1);
|
||||
end
|
||||
else
|
||||
begin
|
||||
Canvas.Pen.Color := DisabledColor;
|
||||
Canvas.Line(0, Height - 1, Width, Height - 1);
|
||||
end;
|
||||
end;
|
||||
|
||||
constructor TBCMaterialSpinEdit.Create(AOwner: TComponent);
|
||||
begin
|
||||
inherited Create(AOwner);
|
||||
Self.BevelOuter := bvNone;
|
||||
Self.Color := clWhite;
|
||||
AccentColor := clHighlight;
|
||||
DisabledColor := $00B8AFA8;
|
||||
Flbl := TLabel.Create(Self);
|
||||
Flbl.Align := alTop;
|
||||
Flbl.Caption := 'Buscar';
|
||||
Flbl.BorderSpacing.Around := 4;
|
||||
Flbl.Font.Style := [fsBold];
|
||||
Flbl.Font.Color := $00B8AFA8;
|
||||
Flbl.Parent := Self;
|
||||
Fedt := TSpinEdit.Create(Self);
|
||||
Fedt.Color := Color;
|
||||
Fedt.Font.Color := clBlack;
|
||||
Fedt.OnEnter := @EnterEdit;
|
||||
Fedt.OnExit := @ExitEdit;
|
||||
Fedt.OnChange:=@ChangeEdit;
|
||||
Fedt.Align := alClient;
|
||||
Fedt.BorderStyle := bsNone;
|
||||
//Fedt.TextHint := 'Buscar';
|
||||
Fedt.BorderSpacing.Around := 4;
|
||||
Fedt.Parent := Self;
|
||||
Fedt.MinValue := 0;
|
||||
Fedt.MaxValue := MaxInt;
|
||||
end;
|
||||
|
||||
end.
|
||||
914
bgracontrols/bcmdbutton.pas
Normal file
914
bgracontrols/bcmdbutton.pas
Normal file
@@ -0,0 +1,914 @@
|
||||
// SPDX-License-Identifier: LGPL-3.0-linking-exception
|
||||
{******************************* CONTRIBUTOR(S) ******************************
|
||||
- Edivando S. Santos Brasil | mailedivando@gmail.com
|
||||
(Compatibility with delphi VCL 11/2018)
|
||||
|
||||
***************************** END CONTRIBUTOR(S) *****************************}
|
||||
unit BCMDButton;
|
||||
|
||||
{$I bgracontrols.inc}
|
||||
|
||||
// Set this to show number of repaint in each MDBUTTON
|
||||
{ $DEFINE MDBUTTON_DEBUG}
|
||||
|
||||
// Set this to animate only a MDBUTTON at a time
|
||||
{$DEFINE MDBUTTON_ANIMATEONLYONE}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils, Types, {$IFDEF FPC}LResources,{$ELSE}BGRAGraphics, GraphType, FPImage,{$ENDIF}
|
||||
Forms, Controls, Graphics, Dialogs,
|
||||
BCBaseCtrls, BGRABitmap, BGRABitmapTypes, ExtCtrls, Math, BGRABlend;
|
||||
|
||||
type
|
||||
TBCMDButtonCheckMarkPosition = (cmpBottom,cmpTop,cmpLeft,cmpRight);
|
||||
|
||||
var
|
||||
// Default icons for Check Box
|
||||
{BCMDBUTTONBALLOTBOX: string = '☐'; // '✗'
|
||||
BCMDBUTTONBALLOTBOXWITHCHECK: string = '☑'; // '✓'
|
||||
|
||||
// Default icons for Radio Button
|
||||
BCMDBUTTONRADIOBUTTON: string = '🔘';
|
||||
BCMDBUTTONRADIOBUTTONCIRCLE: string = '◯';}
|
||||
|
||||
// Characters that can be used on systems that lack of the previous unicode symbols
|
||||
BCMDBUTTONBALLOTBOX: string = '[ ]';
|
||||
BCMDBUTTONBALLOTBOXWITHCHECK: string = '[X]';
|
||||
BCMDBUTTONRADIOBUTTON: string = '[O]';
|
||||
BCMDBUTTONRADIOBUTTONCIRCLE: string = '[ ]';
|
||||
|
||||
// Animation speed
|
||||
// Possible values: between 0 and 1
|
||||
// 0 is an infinite animation that display nothing (only redraw itself)
|
||||
// 1 is the faster animation (like no animation, from 0 to 1 in 1 frame)
|
||||
// Recommended values: between 0.01 (slow) and 0.1 (fast), default 0.04
|
||||
// Hint: turn on debug to see how much frames are rendered
|
||||
BCMDBUTTONANIMATIONSPEED: double = 0.04;
|
||||
|
||||
// Global enable/disable animations
|
||||
BCMDBUTTONANIMATION: boolean = True;
|
||||
|
||||
// Global posiotn of checkmarks 0=bottom, 1=top, 2=left, 3=right
|
||||
BCMDBUTTONCHECKMARKPOSITION : TBCMDButtonCheckMarkPosition = cmpBottom;
|
||||
|
||||
BCMDBUTTONCHECKMARKCOLOR : TColor = $00BB513F;
|
||||
|
||||
const
|
||||
// Timer speed: default 15 (a bit more than 60 fps)
|
||||
// Other values: 16 (60 fps) 20 (50 fps) 25 (40 fps) 33 (30 fps)
|
||||
// Hint: 15 is the smoothest -tested- value on Windows, even if 16 is closer to 60 fps
|
||||
// * values below 15 are not noticeable
|
||||
// * higher values are not smooth
|
||||
// Hint: changing this doesn't change the ammount of frames rendered,
|
||||
// only changes the time between frames
|
||||
// Hint: if you decrease MDBUTTONTIMERSPEED, increase BCMDBUTTONANIMATIONSPEED
|
||||
// to keep a smooth animation
|
||||
BCMDBUTTONTIMERSPEED: integer = 15;
|
||||
|
||||
type
|
||||
TBCMDButtonState = (mdbsNormal, mdbsHover, mdbsActive);
|
||||
TBCMDButtonKind = (mdbkNormal, mdbkToggle, mdbkToggleGroup, mdbkCheckBox,
|
||||
mdbkRadioButton, mdbkTab);
|
||||
|
||||
{ TBCMDButtonStyle }
|
||||
|
||||
TBCMDButtonStyle = class(TPersistent)
|
||||
private
|
||||
FColor: TColor;
|
||||
FOnChange: TNotifyEvent;
|
||||
FTextColor: TColor;
|
||||
procedure SetFColor(AValue: TColor);
|
||||
procedure SetFTextColor(AValue: TColor);
|
||||
public
|
||||
property OnChange: TNotifyEvent read FOnChange write FOnChange;
|
||||
public
|
||||
constructor Create;
|
||||
published
|
||||
property Color: TColor read FColor write SetFColor;
|
||||
property TextColor: TColor read FTextColor write SetFTextColor;
|
||||
end;
|
||||
|
||||
{ TCustomBCMDButton }
|
||||
|
||||
TCustomBCMDButton = class(TBGRAGraphicCtrl)
|
||||
private
|
||||
FChecked: boolean;
|
||||
FKind: TBCMDButtonKind;
|
||||
{$IFDEF INDEBUG}
|
||||
FCount: integer;
|
||||
{$ENDIF}
|
||||
FRounding: integer;
|
||||
FTextAutoSize: boolean;
|
||||
FTextProportional: boolean;
|
||||
FTextProportionalRatio: single;
|
||||
FTimer: TTimer;
|
||||
FPercent: double;
|
||||
FCircleSize: double;
|
||||
FCX, FCY: integer;
|
||||
FAlphaPercent: double;
|
||||
FAlignment: TAlignment;
|
||||
FAnimation: boolean;
|
||||
FState: TBCMDButtonState;
|
||||
FStyleActive: TBCMDButtonStyle;
|
||||
FStyleDisabled: TBCMDButtonStyle;
|
||||
FStyleHover: TBCMDButtonStyle;
|
||||
FStyleNormal: TBCMDButtonStyle;
|
||||
FTextLayout: TTextLayout;
|
||||
procedure OnChangeStyle(Sender: TObject);
|
||||
procedure SetFAlignment(AValue: TAlignment);
|
||||
procedure SetFAnimation(AValue: boolean);
|
||||
procedure SetFChecked(AValue: boolean);
|
||||
procedure SetFKind(AValue: TBCMDButtonKind);
|
||||
procedure SetFStyleActive(AValue: TBCMDButtonStyle);
|
||||
procedure SetFStyleDisabled(AValue: TBCMDButtonStyle);
|
||||
procedure SetFStyleHover(AValue: TBCMDButtonStyle);
|
||||
procedure SetFStyleNormal(AValue: TBCMDButtonStyle);
|
||||
procedure SetFTextAutoSize(AValue: boolean);
|
||||
procedure SetFTextLayout(AValue: TTextLayout);
|
||||
procedure SetFTextProportional(AValue: boolean);
|
||||
procedure SetFTextProportionalRatio(AValue: single);
|
||||
protected
|
||||
procedure CalculatePreferredSize(var PreferredWidth, PreferredHeight: integer;
|
||||
{%H-}WithThemeSpace: boolean); override;
|
||||
procedure Paint; override;
|
||||
procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
|
||||
X, Y: integer); override;
|
||||
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: integer); override;
|
||||
procedure MouseEnter; override;
|
||||
procedure MouseLeave; override;
|
||||
procedure RealSetText(const Value: TCaption); override;
|
||||
procedure OnTimer(Sender: TObject);
|
||||
procedure OnStartTimer(Sender: TObject);
|
||||
procedure OnStopTimer(Sender: TObject);
|
||||
function easeInOutQuad(t: double): double;
|
||||
function easeOutQuad(t: double): double;
|
||||
procedure UncheckOthers;
|
||||
class function GetControlClassDefaultSize: TSize; override;
|
||||
function GetRealCaption: string;
|
||||
public
|
||||
constructor Create(AOwner: TComponent); override;
|
||||
destructor Destroy; override;
|
||||
procedure SelectAll;
|
||||
procedure UnselectAll;
|
||||
procedure InvertSelection;
|
||||
function GetSelected: TStringList;
|
||||
published
|
||||
property Animation: boolean read FAnimation write SetFAnimation default False;
|
||||
property Alignment: TAlignment read FAlignment write SetFAlignment default taCenter;
|
||||
property TextLayout: TTextLayout
|
||||
read FTextLayout write SetFTextLayout default tlCenter;
|
||||
property StyleNormal: TBCMDButtonStyle read FStyleNormal write SetFStyleNormal;
|
||||
property StyleHover: TBCMDButtonStyle read FStyleHover write SetFStyleHover;
|
||||
property StyleActive: TBCMDButtonStyle read FStyleActive write SetFStyleActive;
|
||||
property StyleDisabled: TBCMDButtonStyle read FStyleDisabled write SetFStyleDisabled;
|
||||
property Checked: boolean read FChecked write SetFChecked default False;
|
||||
property Kind: TBCMDButtonKind read FKind write SetFKind default mdbkNormal;
|
||||
// If text size is used to measure buttons
|
||||
// Disable it if you use the buttons in a grid, for example
|
||||
property TextAutoSize: boolean read FTextAutoSize write SetFTextAutoSize;
|
||||
// Enable it if you want that text size grows with height
|
||||
property TextProportional: boolean read FTextProportional write SetFTextProportional;
|
||||
// Each character font height proportional to height of control
|
||||
// Set it in conjunction with TextProportional, values recommended between 0...1
|
||||
property TextProportionalRatio: single read FTextProportionalRatio
|
||||
write SetFTextProportionalRatio;
|
||||
end;
|
||||
|
||||
TBCMDButton = class(TCustomBCMDButton)
|
||||
property Action;
|
||||
property Align;
|
||||
property Anchors;
|
||||
property AutoSize;
|
||||
property BidiMode;
|
||||
property BorderSpacing;
|
||||
{$IFDEF FPC} //#
|
||||
property OnChangeBounds;
|
||||
{$ENDIF}
|
||||
//property Cancel;
|
||||
property Caption;
|
||||
property Color;
|
||||
property Constraints;
|
||||
//property Default;
|
||||
property DragCursor;
|
||||
property DragKind;
|
||||
property DragMode;
|
||||
property Enabled;
|
||||
property Font;
|
||||
property ParentBidiMode;
|
||||
//property ModalResult;
|
||||
property OnClick;
|
||||
property OnContextPopup;
|
||||
property OnDragDrop;
|
||||
property OnDragOver;
|
||||
property OnEndDrag;
|
||||
//property OnEnter;
|
||||
//property OnExit;
|
||||
//property OnKeyDown;
|
||||
//property OnKeyPress;
|
||||
//property OnKeyUp;
|
||||
property OnMouseDown;
|
||||
property OnMouseEnter;
|
||||
property OnMouseLeave;
|
||||
property OnMouseMove;
|
||||
property OnMouseUp;
|
||||
property OnMouseWheel;
|
||||
property OnMouseWheelDown;
|
||||
property OnMouseWheelUp;
|
||||
property OnResize;
|
||||
property OnStartDrag;
|
||||
//property OnUTF8KeyPress;
|
||||
property ParentFont;
|
||||
property ParentShowHint;
|
||||
property PopupMenu;
|
||||
property ShowHint;
|
||||
//property TabOrder;
|
||||
//property TabStop;
|
||||
property Visible;
|
||||
end;
|
||||
|
||||
{$IFDEF FPC}procedure Register;{$ENDIF}
|
||||
|
||||
implementation
|
||||
|
||||
{$IFDEF MDBUTTON_ANIMATEONLYONE}
|
||||
var
|
||||
MDAnimating: TCustomBCMDButton;
|
||||
|
||||
{$ENDIF}
|
||||
|
||||
{$IFDEF FPC}
|
||||
procedure Register;
|
||||
begin
|
||||
RegisterComponents('BGRA Button Controls', [TBCMDButton]);
|
||||
end;
|
||||
{$ENDIF}
|
||||
|
||||
{ TBCMDButtonStyle }
|
||||
|
||||
procedure TBCMDButtonStyle.SetFColor(AValue: TColor);
|
||||
begin
|
||||
if FColor = AValue then
|
||||
Exit;
|
||||
FColor := AValue;
|
||||
if Assigned(FOnChange) then
|
||||
OnChange(Self);
|
||||
end;
|
||||
|
||||
procedure TBCMDButtonStyle.SetFTextColor(AValue: TColor);
|
||||
begin
|
||||
if FTextColor = AValue then
|
||||
Exit;
|
||||
FTextColor := AValue;
|
||||
if Assigned(FOnChange) then
|
||||
OnChange(Self);
|
||||
end;
|
||||
|
||||
constructor TBCMDButtonStyle.Create;
|
||||
begin
|
||||
inherited Create;
|
||||
FColor := clWhite;
|
||||
FTextColor := clBlack;
|
||||
end;
|
||||
|
||||
{ TCustomBCMDButton }
|
||||
|
||||
procedure TCustomBCMDButton.SetFStyleActive(AValue: TBCMDButtonStyle);
|
||||
begin
|
||||
if FStyleActive = AValue then
|
||||
Exit;
|
||||
FStyleActive := AValue;
|
||||
end;
|
||||
|
||||
procedure TCustomBCMDButton.SetFAlignment(AValue: TAlignment);
|
||||
begin
|
||||
if FAlignment = AValue then
|
||||
Exit;
|
||||
FAlignment := AValue;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TCustomBCMDButton.SetFAnimation(AValue: boolean);
|
||||
begin
|
||||
if FAnimation = AValue then
|
||||
Exit;
|
||||
FAnimation := AValue;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TCustomBCMDButton.SetFChecked(AValue: boolean);
|
||||
begin
|
||||
if FChecked = AValue then
|
||||
Exit;
|
||||
FChecked := AValue;
|
||||
if FChecked and (FKind in [mdbkToggleGroup, mdbkRadioButton, mdbkTab]) then
|
||||
UncheckOthers;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TCustomBCMDButton.SetFKind(AValue: TBCMDButtonKind);
|
||||
begin
|
||||
if FKind = AValue then
|
||||
Exit;
|
||||
FKind := AValue;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TCustomBCMDButton.OnChangeStyle(Sender: TObject);
|
||||
begin
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TCustomBCMDButton.SetFStyleDisabled(AValue: TBCMDButtonStyle);
|
||||
begin
|
||||
if FStyleDisabled = AValue then
|
||||
Exit;
|
||||
FStyleDisabled := AValue;
|
||||
end;
|
||||
|
||||
procedure TCustomBCMDButton.SetFStyleHover(AValue: TBCMDButtonStyle);
|
||||
begin
|
||||
if FStyleHover = AValue then
|
||||
Exit;
|
||||
FStyleHover := AValue;
|
||||
end;
|
||||
|
||||
procedure TCustomBCMDButton.SetFStyleNormal(AValue: TBCMDButtonStyle);
|
||||
begin
|
||||
if FStyleNormal = AValue then
|
||||
Exit;
|
||||
FStyleNormal := AValue;
|
||||
end;
|
||||
|
||||
procedure TCustomBCMDButton.SetFTextAutoSize(AValue: boolean);
|
||||
begin
|
||||
if FTextAutoSize = AValue then
|
||||
Exit;
|
||||
FTextAutoSize := AValue;
|
||||
end;
|
||||
|
||||
procedure TCustomBCMDButton.SetFTextLayout(AValue: TTextLayout);
|
||||
begin
|
||||
if FTextLayout = AValue then
|
||||
Exit;
|
||||
FTextLayout := AValue;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TCustomBCMDButton.SetFTextProportional(AValue: boolean);
|
||||
begin
|
||||
if FTextProportional=AValue then Exit;
|
||||
FTextProportional:=AValue;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TCustomBCMDButton.SetFTextProportionalRatio(AValue: single);
|
||||
begin
|
||||
if FTextProportionalRatio=AValue then Exit;
|
||||
FTextProportionalRatio:=AValue;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TCustomBCMDButton.CalculatePreferredSize(
|
||||
var PreferredWidth, PreferredHeight: integer; WithThemeSpace: boolean);
|
||||
var
|
||||
bmp: TBGRABitmap;
|
||||
s: TSize;
|
||||
begin
|
||||
bmp := TBGRABitmap.Create;
|
||||
bmp.FontName := Font.Name;
|
||||
if FTextProportional then
|
||||
bmp.FontHeight := Round(Height * FTextProportionalRatio)
|
||||
else
|
||||
bmp.FontHeight := 0;
|
||||
bmp.FontAntialias := True;
|
||||
bmp.FontQuality := fqSystemClearType;
|
||||
bmp.FontStyle := Font.Style;
|
||||
s := bmp.TextSize(GetRealCaption);
|
||||
if FTextAutoSize then
|
||||
begin
|
||||
PreferredWidth := s.Width + 26 {$IFDEF FPC}+ BorderSpacing.InnerBorder{$ENDIF};
|
||||
PreferredHeight := s.Height + 10 {$IFDEF FPC}+ BorderSpacing.InnerBorder{$ENDIF};
|
||||
end
|
||||
else
|
||||
begin
|
||||
{$IFDEF FPC}//#
|
||||
PreferredWidth := BorderSpacing.InnerBorder;
|
||||
PreferredHeight := BorderSpacing.InnerBorder;
|
||||
{$ENDIF}
|
||||
end;
|
||||
bmp.Free;
|
||||
end;
|
||||
|
||||
procedure TCustomBCMDButton.Paint;
|
||||
var
|
||||
bmp: TBGRABitmap;
|
||||
iTemp: integer;
|
||||
alpha: byte;
|
||||
tempState: TBCMDButtonState;
|
||||
tempText: string;
|
||||
tempRounding: integer;
|
||||
tempColor, hoverColor: TBGRAPixel;
|
||||
begin
|
||||
bmp := TBGRABitmap.Create(Width, Height);
|
||||
bmp.FontName := Font.Name;
|
||||
if FTextProportional then
|
||||
bmp.FontHeight := Round(Height * FTextProportionalRatio)
|
||||
else
|
||||
bmp.FontHeight := 0;
|
||||
bmp.FontAntialias := True;
|
||||
bmp.FontQuality := fqSystemClearType;
|
||||
bmp.FontStyle := Font.Style;
|
||||
tempState := FState;
|
||||
|
||||
if Kind = mdbkTab then
|
||||
tempRounding := 0
|
||||
else
|
||||
tempRounding := FRounding;
|
||||
|
||||
if FChecked then
|
||||
tempState := mdbsActive
|
||||
else
|
||||
tempState := FState;
|
||||
|
||||
tempText := GetRealCaption;
|
||||
|
||||
// Enabled
|
||||
if Enabled then
|
||||
begin
|
||||
if not FTimer.Enabled then
|
||||
begin
|
||||
case tempState of
|
||||
mdbsNormal:
|
||||
begin
|
||||
bmp.RoundRect(0, 0, Width, Height, tempRounding, tempRounding,
|
||||
FStyleNormal.Color,
|
||||
FStyleNormal.Color);
|
||||
{$IFDEF FPC}
|
||||
bmp.TextRect(Rect(BorderSpacing.InnerBorder, BorderSpacing.InnerBorder,
|
||||
Width - BorderSpacing.InnerBorder, Height - BorderSpacing.InnerBorder),
|
||||
tempText, Alignment,
|
||||
TextLayout, FStyleNormal.TextColor);
|
||||
{$ELSE}
|
||||
bmp.TextRect(Rect(0, 0,Width, Height),tempText, Alignment, TextLayout, FStyleNormal.TextColor);
|
||||
{$ENDIF}
|
||||
end;
|
||||
mdbsHover:
|
||||
begin
|
||||
bmp.RoundRect(0, 0, Width, Height, tempRounding, tempRounding,
|
||||
FStyleHover.Color, FStyleHover.Color);
|
||||
{$IFDEF FPC}
|
||||
bmp.TextRect(Rect(BorderSpacing.InnerBorder, BorderSpacing.InnerBorder,
|
||||
Width - BorderSpacing.InnerBorder, Height - BorderSpacing.InnerBorder),
|
||||
tempText, Alignment,
|
||||
TextLayout, FStyleHover.TextColor);
|
||||
{$ELSE}
|
||||
bmp.TextRect(Rect(0, 0,Width, Height),tempText, Alignment, TextLayout, FStyleHover.TextColor);
|
||||
{$ENDIF}
|
||||
end;
|
||||
mdbsActive:
|
||||
begin
|
||||
if not FAnimation then
|
||||
begin
|
||||
if FKind in [mdbkNormal] then
|
||||
bmp.RoundRect(0, 0, Width, Height, tempRounding,
|
||||
tempRounding, FStyleActive.Color,
|
||||
FStyleActive.Color)
|
||||
else
|
||||
bmp.RoundRect(0, 0, Width, Height, tempRounding,
|
||||
tempRounding, FStyleHover.Color,
|
||||
FStyleHover.Color);
|
||||
end
|
||||
else
|
||||
bmp.RoundRect(0, 0, Width, Height, tempRounding, tempRounding,
|
||||
FStyleHover.Color,
|
||||
FStyleHover.Color);
|
||||
{$IFDEF FPC}
|
||||
bmp.TextRect(Rect(BorderSpacing.InnerBorder, BorderSpacing.InnerBorder,
|
||||
Width - BorderSpacing.InnerBorder, Height - BorderSpacing.InnerBorder),
|
||||
tempText, Alignment,
|
||||
TextLayout, FStyleActive.TextColor);
|
||||
{$ELSE}
|
||||
bmp.TextRect(Rect(0, 0,Width, Height),tempText, Alignment, TextLayout, FStyleActive.TextColor);
|
||||
{$ENDIF}
|
||||
end;
|
||||
end;
|
||||
end
|
||||
else
|
||||
begin
|
||||
iTemp := round(FCircleSize * easeOutQuad(FPercent));
|
||||
alpha := round(easeInOutQuad(FAlphaPercent) * 255);
|
||||
case tempState of
|
||||
mdbsNormal:
|
||||
begin
|
||||
bmp.RoundRect(0, 0, Width, Height, tempRounding, tempRounding,
|
||||
FStyleNormal.Color,
|
||||
FStyleNormal.Color);
|
||||
if FPercent < 1 then
|
||||
tempColor := FStyleHover.Color
|
||||
else
|
||||
begin
|
||||
tempColor := FStyleNormal.Color;
|
||||
hoverColor := ColorToBGRA(FStyleHover.Color, alpha);
|
||||
PutPixels(@tempColor, @hoverColor, 1, dmDrawWithTransparency, 255);
|
||||
end;
|
||||
bmp.FillEllipseAntialias(FCX, FCY, iTemp,
|
||||
iTemp, tempColor);
|
||||
{$IFDEF FPC}
|
||||
bmp.TextRect(Rect(BorderSpacing.InnerBorder, BorderSpacing.InnerBorder,
|
||||
Width - BorderSpacing.InnerBorder, Height - BorderSpacing.InnerBorder),
|
||||
tempText, Alignment,
|
||||
TextLayout, FStyleNormal.TextColor);
|
||||
{$ELSE}
|
||||
bmp.TextRect(Rect(0, 0,Width, Height),tempText, Alignment, TextLayout, FStyleNormal.TextColor);
|
||||
{$ENDIF}
|
||||
end;
|
||||
mdbsHover, mdbsActive:
|
||||
begin
|
||||
bmp.RoundRect(0, 0, Width, Height, tempRounding, tempRounding,
|
||||
FStyleHover.Color, FStyleHover.Color);
|
||||
if FPercent < 1 then
|
||||
tempColor := FStyleActive.Color
|
||||
else
|
||||
begin
|
||||
tempColor := FStyleHover.Color;
|
||||
hoverColor := ColorToBGRA(FStyleActive.Color, alpha);
|
||||
PutPixels(@tempColor, @hoverColor, 1, dmDrawWithTransparency, 255);
|
||||
end;
|
||||
bmp.FillEllipseAntialias(FCX, FCY, iTemp,
|
||||
iTemp, tempColor);
|
||||
{$IFDEF FPC}
|
||||
bmp.TextRect(Rect(BorderSpacing.InnerBorder, BorderSpacing.InnerBorder,
|
||||
Width - BorderSpacing.InnerBorder, Height - BorderSpacing.InnerBorder),
|
||||
tempText, Alignment,
|
||||
TextLayout, FStyleHover.TextColor);
|
||||
{$ELSE}
|
||||
bmp.TextRect(Rect(0, 0,Width, Height),tempText, Alignment, TextLayout, FStyleHover.TextColor);
|
||||
{$ENDIF}
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
end
|
||||
// Disabled
|
||||
else
|
||||
begin
|
||||
if FChecked then
|
||||
begin
|
||||
bmp.RoundRect(0, 0, Width, Height, tempRounding, tempRounding,
|
||||
FStyleHover.Color, FStyleHover.Color);
|
||||
end
|
||||
else
|
||||
bmp.RoundRect(0, 0, Width, Height, tempRounding, tempRounding,
|
||||
FStyleDisabled.Color, FStyleDisabled.Color);
|
||||
{$IFDEF FPC}
|
||||
bmp.TextRect(Rect(BorderSpacing.InnerBorder, BorderSpacing.InnerBorder,
|
||||
Width - BorderSpacing.InnerBorder, Height - BorderSpacing.InnerBorder),
|
||||
tempText, Alignment,
|
||||
TextLayout, FStyleDisabled.TextColor);
|
||||
{$ELSE}
|
||||
bmp.TextRect(Rect(0, 0,Width, Height),tempText, Alignment, TextLayout, FStyleDisabled.TextColor);
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
// Tab
|
||||
if Kind = mdbkTab then
|
||||
begin
|
||||
if FTimer.Enabled then
|
||||
begin
|
||||
iTemp := round((bmp.Width div 2) * easeInOutQuad(FPercent));
|
||||
case BCMDBUTTONCHECKMARKPOSITION of
|
||||
cmpBottom : begin
|
||||
iTemp := round((bmp.Width div 2) * easeInOutQuad(FPercent));
|
||||
bmp.Rectangle((bmp.Width div 2) - iTemp, bmp.Height - 2,(bmp.Width div 2) + iTemp, bmp.Height, BCMDBUTTONCHECKMARKCOLOR, dmSet);
|
||||
end;
|
||||
cmpTop : begin
|
||||
iTemp := round((bmp.Width div 2) * easeInOutQuad(FPercent));
|
||||
bmp.Rectangle((bmp.Width div 2) - iTemp, 0,(bmp.Width div 2) + iTemp, 2, BCMDBUTTONCHECKMARKCOLOR, dmSet);
|
||||
end;
|
||||
cmpLeft : begin
|
||||
iTemp := round((bmp.Height div 2) * easeInOutQuad(FPercent));
|
||||
bmp.Rectangle(0, (bmp.Height div 2) - iTemp, 2, (bmp.Height div 2) + iTemp, BCMDBUTTONCHECKMARKCOLOR, dmSet);
|
||||
end;
|
||||
cmpRight : begin
|
||||
iTemp := round((bmp.Height div 2) * easeInOutQuad(FPercent));
|
||||
bmp.Rectangle(bmp.width-2, (bmp.Height div 2) - iTemp, bmp.width, (bmp.Height div 2) + iTemp, BCMDBUTTONCHECKMARKCOLOR, dmSet);
|
||||
end;
|
||||
end; // case
|
||||
end
|
||||
else
|
||||
begin
|
||||
if FChecked then
|
||||
case BCMDBUTTONCHECKMARKPOSITION of
|
||||
cmpBottom : bmp.Rectangle(0, bmp.Height - 2, bmp.Width, bmp.Height, BCMDBUTTONCHECKMARKCOLOR, dmSet);
|
||||
cmpTop : bmp.Rectangle(0, 0, bmp.Width, 2, BCMDBUTTONCHECKMARKCOLOR, dmSet);
|
||||
cmpLeft : bmp.Rectangle(0, 0, 2, bmp.Height, BCMDBUTTONCHECKMARKCOLOR, dmSet);
|
||||
cmpRight : bmp.Rectangle(bmp.Width - 2, 0, bmp.Width, bmp.Height, BCMDBUTTONCHECKMARKCOLOR, dmSet);
|
||||
end; // case
|
||||
end;
|
||||
end;
|
||||
|
||||
{$IFDEF MDBUTTON_DEBUG}
|
||||
bmp.FontHeight := 10;
|
||||
bmp.TextOut(0, 0, FCount.ToString, BGRA(255, 0, 0, 255));
|
||||
FCount += 1;
|
||||
{$ENDIF}
|
||||
bmp.Draw(Canvas, 0, 0, False);
|
||||
bmp.Free;
|
||||
inherited Paint;
|
||||
end;
|
||||
|
||||
procedure TCustomBCMDButton.MouseDown(Button: TMouseButton; Shift: TShiftState;
|
||||
X, Y: integer);
|
||||
begin
|
||||
inherited MouseDown(Button, Shift, X, Y);
|
||||
FState := mdbsActive;
|
||||
if FAnimation and BCMDBUTTONANIMATION then
|
||||
begin
|
||||
FCircleSize := max(round(Width / 1.5) + abs((Width div 2) - X),
|
||||
round(Height / 1.5) + abs((Height div 2) - Y));
|
||||
FCX := X;
|
||||
FCY := Y;
|
||||
FTimer.Enabled := False;
|
||||
FTimer.Enabled := True;
|
||||
{$IFDEF MDBUTTON_ANIMATEONLYONE}
|
||||
MDAnimating := Self;
|
||||
{$ENDIF}
|
||||
end;
|
||||
if FKind in [mdbkToggle, mdbkToggleGroup, mdbkCheckBox, mdbkRadioButton, mdbkTab] then
|
||||
begin
|
||||
FChecked := not FChecked;
|
||||
if FKind in [mdbkToggleGroup, mdbkRadioButton, mdbkTab] then
|
||||
begin
|
||||
FChecked := True;
|
||||
UncheckOthers;
|
||||
end;
|
||||
end;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TCustomBCMDButton.MouseUp(Button: TMouseButton; Shift: TShiftState;
|
||||
X, Y: integer);
|
||||
begin
|
||||
inherited MouseUp(Button, Shift, X, Y);
|
||||
if (x > 0) and (x < Width) and (y > 0) and (y < Height) and (FState = mdbsActive) then
|
||||
FState := mdbsHover
|
||||
else
|
||||
FState := mdbsNormal;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TCustomBCMDButton.MouseEnter;
|
||||
begin
|
||||
inherited MouseEnter;
|
||||
FState := mdbsHover;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TCustomBCMDButton.MouseLeave;
|
||||
begin
|
||||
inherited MouseLeave;
|
||||
FState := mdbsNormal;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TCustomBCMDButton.RealSetText(const Value: TCaption);
|
||||
begin
|
||||
inherited RealSetText(Value);
|
||||
InvalidatePreferredSize;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TCustomBCMDButton.OnTimer(Sender: TObject);
|
||||
begin
|
||||
{$IFDEF MDBUTTON_ANIMATEONLYONE}
|
||||
if MDAnimating = Self then
|
||||
begin
|
||||
{$ENDIF}
|
||||
FPercent := FPercent + BCMDBUTTONANIMATIONSPEED;
|
||||
if FPercent < 0 then
|
||||
FPercent := 0
|
||||
else if FPercent > 1 then
|
||||
FPercent := 1;
|
||||
|
||||
if FPercent = 1 then
|
||||
begin
|
||||
FAlphaPercent := FAlphaPercent -BCMDBUTTONANIMATIONSPEED;
|
||||
if FAlphaPercent < 0 then
|
||||
FAlphaPercent := 0
|
||||
else if FAlphaPercent > 1 then
|
||||
FAlphaPercent := 1;
|
||||
end;
|
||||
{$IFDEF MDBUTTON_ANIMATEONLYONE}
|
||||
end
|
||||
else
|
||||
FTimer.Enabled := False;
|
||||
{$ENDIF}
|
||||
|
||||
Invalidate;
|
||||
if (FPercent >= 1) and (FAlphaPercent <= 0) then
|
||||
FTimer.Enabled := False;
|
||||
end;
|
||||
|
||||
procedure TCustomBCMDButton.OnStartTimer(Sender: TObject);
|
||||
begin
|
||||
FPercent := 0;
|
||||
FAlphaPercent := 1;
|
||||
end;
|
||||
|
||||
procedure TCustomBCMDButton.OnStopTimer(Sender: TObject);
|
||||
begin
|
||||
|
||||
end;
|
||||
|
||||
function TCustomBCMDButton.easeInOutQuad(t: double): double;
|
||||
begin
|
||||
if t < 0.5 then
|
||||
Result := 2 * t * t
|
||||
else
|
||||
Result := -1 + (4 - 2 * t) * t;
|
||||
end;
|
||||
|
||||
function TCustomBCMDButton.easeOutQuad(t: double): double;
|
||||
begin
|
||||
Result := t * (2 - t);
|
||||
end;
|
||||
|
||||
procedure TCustomBCMDButton.UncheckOthers;
|
||||
var
|
||||
i: integer;
|
||||
control: TWinControl;
|
||||
begin
|
||||
if Parent is TWinControl then
|
||||
begin
|
||||
control := TWinControl(Parent);
|
||||
for i := 0 to control.ControlCount - 1 do
|
||||
if (control.Controls[i] <> Self) and (control.Controls[i] is TCustomBCMDButton) then
|
||||
if (TCustomBCMDButton(control.Controls[i]).Kind in
|
||||
[mdbkToggleGroup, mdbkRadioButton, mdbkTab]) then
|
||||
TCustomBCMDButton(control.Controls[i]).Checked := False;
|
||||
end;
|
||||
end;
|
||||
|
||||
class function TCustomBCMDButton.GetControlClassDefaultSize: TSize;
|
||||
begin
|
||||
Result.CX := 75;
|
||||
Result.CY := 25;
|
||||
end;
|
||||
|
||||
function TCustomBCMDButton.GetRealCaption: string;
|
||||
var
|
||||
tempText: string;
|
||||
begin
|
||||
tempText := Caption;
|
||||
|
||||
case FKind of
|
||||
mdbkCheckBox:
|
||||
begin
|
||||
if Length(Caption) > 0 then
|
||||
tempText := ' ' + Caption;
|
||||
if FChecked then
|
||||
tempText := BCMDBUTTONBALLOTBOXWITHCHECK + tempText
|
||||
else
|
||||
tempText := BCMDBUTTONBALLOTBOX + tempText;
|
||||
end;
|
||||
mdbkRadioButton:
|
||||
begin
|
||||
if Length(Caption) > 0 then
|
||||
tempText := ' ' + Caption;
|
||||
if FChecked then
|
||||
tempText := BCMDBUTTONRADIOBUTTON + tempText
|
||||
else
|
||||
tempText := BCMDBUTTONRADIOBUTTONCIRCLE + tempText;
|
||||
end;
|
||||
end;
|
||||
result := tempText;
|
||||
end;
|
||||
|
||||
constructor TCustomBCMDButton.Create(AOwner: TComponent);
|
||||
begin
|
||||
inherited Create(AOwner);
|
||||
{$IFDEF INDEBUG}
|
||||
FCount := 0;
|
||||
{$ENDIF}
|
||||
// State
|
||||
FState := mdbsNormal;
|
||||
FChecked := False;
|
||||
FKind := mdbkNormal;
|
||||
// Text
|
||||
FTextAutoSize := True;
|
||||
FAlignment := taCenter;
|
||||
FTextLayout := tlCenter;
|
||||
FTextProportional := False;
|
||||
FTextProportionalRatio := 0.5;
|
||||
// Style
|
||||
FRounding := 6;
|
||||
FStyleNormal := TBCMDButtonStyle.Create;
|
||||
FStyleNormal.OnChange := OnChangeStyle;
|
||||
FStyleHover := TBCMDButtonStyle.Create;
|
||||
FStyleHover.OnChange := OnChangeStyle;
|
||||
FStyleActive := TBCMDButtonStyle.Create;
|
||||
FStyleActive.OnChange := OnChangeStyle;
|
||||
FStyleDisabled := TBCMDButtonStyle.Create;
|
||||
FStyleDisabled.OnChange := OnChangeStyle;
|
||||
// Default Style
|
||||
FStyleHover.Color := RGBToColor(220, 220, 220);
|
||||
FStyleActive.Color := RGBToColor(198, 198, 198);
|
||||
FStyleDisabled.TextColor := RGBToColor(163, 163, 163);
|
||||
// Animation
|
||||
FAnimation := False;
|
||||
FTimer := TTimer.Create(Self);
|
||||
FTimer.Enabled := False;
|
||||
FTimer.Interval := BCMDBUTTONTIMERSPEED;
|
||||
FTimer.OnTimer := OnTimer;
|
||||
{$IFDEF FPC}//#
|
||||
FTimer.OnStartTimer := OnStartTimer;
|
||||
FTimer.OnStopTimer := OnStopTimer;
|
||||
{$ENDIF}
|
||||
// Setup default sizes
|
||||
with GetControlClassDefaultSize do
|
||||
SetInitialBounds(0, 0, CX, CY);
|
||||
end;
|
||||
|
||||
destructor TCustomBCMDButton.Destroy;
|
||||
begin
|
||||
FTimer.OnTimer := nil;
|
||||
{$IFDEF FPC}//#
|
||||
FTimer.OnStartTimer := nil;
|
||||
FTimer.OnStopTimer := nil;
|
||||
{$ENDIF}
|
||||
FTimer.Enabled := False;
|
||||
FStyleNormal.Free;
|
||||
FStyleHover.Free;
|
||||
FStyleActive.Free;
|
||||
FStyleDisabled.Free;
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
procedure TCustomBCMDButton.SelectAll;
|
||||
var
|
||||
i: integer;
|
||||
control: TWinControl;
|
||||
begin
|
||||
if (Parent <> nil) and (Parent is TWinControl) then
|
||||
begin
|
||||
control := TWinControl(Parent);
|
||||
for i := 0 to control.ControlCount - 1 do
|
||||
if (control.Controls[i] is TCustomBCMDButton) then
|
||||
if (TCustomBCMDButton(control.Controls[i]).Kind in
|
||||
[mdbkToggle, mdbkCheckBox]) then
|
||||
TCustomBCMDButton(control.Controls[i]).Checked := True;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TCustomBCMDButton.UnselectAll;
|
||||
var
|
||||
i: integer;
|
||||
control: TWinControl;
|
||||
begin
|
||||
if (Parent <> nil) and (Parent is TWinControl) then
|
||||
begin
|
||||
control := TWinControl(Parent);
|
||||
for i := 0 to control.ControlCount - 1 do
|
||||
if (control.Controls[i] is TCustomBCMDButton) then
|
||||
if (TCustomBCMDButton(control.Controls[i]).Kind in
|
||||
[mdbkToggle, mdbkCheckBox]) then
|
||||
TCustomBCMDButton(control.Controls[i]).Checked := False;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TCustomBCMDButton.InvertSelection;
|
||||
var
|
||||
i: integer;
|
||||
control: TWinControl;
|
||||
begin
|
||||
if (Parent <> nil) and (Parent is TWinControl) then
|
||||
begin
|
||||
control := TWinControl(Parent);
|
||||
for i := 0 to control.ControlCount - 1 do
|
||||
if (control.Controls[i] is TCustomBCMDButton) then
|
||||
if (TCustomBCMDButton(control.Controls[i]).Kind in
|
||||
[mdbkToggle, mdbkCheckBox]) then
|
||||
TCustomBCMDButton(control.Controls[i]).Checked :=
|
||||
not TCustomBCMDButton(control.Controls[i]).Checked;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TCustomBCMDButton.GetSelected: TStringList;
|
||||
var
|
||||
i: integer;
|
||||
control: TWinControl;
|
||||
begin
|
||||
Result := TStringList.Create;
|
||||
if (Parent <> nil) and (Parent is TWinControl) then
|
||||
begin
|
||||
control := TWinControl(Parent);
|
||||
for i := 0 to control.ControlCount - 1 do
|
||||
if (control.Controls[i] is TCustomBCMDButton) then
|
||||
if TCustomBCMDButton(control.Controls[i]).Checked then
|
||||
Result.AddObject(TCustomBCMDButton(control.Controls[i]).Caption,
|
||||
TCustomBCMDButton(control.Controls[i]));
|
||||
end;
|
||||
end;
|
||||
|
||||
end.
|
||||
863
bgracontrols/bcmdbuttonfocus.pas
Normal file
863
bgracontrols/bcmdbuttonfocus.pas
Normal file
@@ -0,0 +1,863 @@
|
||||
// SPDX-License-Identifier: LGPL-3.0-linking-exception
|
||||
{******************************* CONTRIBUTOR(S) ******************************
|
||||
- Edivando S. Santos Brasil | mailedivando@gmail.com
|
||||
(Compatibility with delphi VCL 11/2018)
|
||||
|
||||
***************************** END CONTRIBUTOR(S) *****************************}
|
||||
unit BCMDButtonFocus;
|
||||
|
||||
{$I bgracontrols.inc}
|
||||
|
||||
// Set this to show number of repaint in each MDBUTTON
|
||||
{ $DEFINE MDBUTTON_DEBUG}
|
||||
|
||||
// Set this to animate only a MDBUTTON at a time
|
||||
{ $DEFINE MDBUTTON_ANIMATEONLYONE}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils, Types, {$IFDEF FPC}LCLType, LResources, LMessages,{$ENDIF}
|
||||
Forms, Controls, Graphics, Dialogs,
|
||||
{$IFNDEF FPC}Windows, Messages, BGRAGraphics, GraphType, FPImage, {$ENDIF}
|
||||
BCBaseCtrls, BGRABitmap, BGRABitmapTypes, ExtCtrls, Math, BGRABlend, BCMDButton;
|
||||
|
||||
type
|
||||
|
||||
{ TCustomBCMDButtonFocus }
|
||||
|
||||
TCustomBCMDButtonFocus = class(TBGRACustomCtrl)
|
||||
private
|
||||
FChecked: boolean;
|
||||
FKind: TBCMDButtonKind;
|
||||
{$IFDEF INDEBUG}
|
||||
FCount: integer;
|
||||
{$ENDIF}
|
||||
FRounding: integer;
|
||||
FTextAutoSize: boolean;
|
||||
FTextProportional: boolean;
|
||||
FTextProportionalRatio: single;
|
||||
FTimer: TTimer;
|
||||
FPercent: double;
|
||||
FCircleSize: double;
|
||||
FCX, FCY: integer;
|
||||
FAlphaPercent: double;
|
||||
FAlignment: TAlignment;
|
||||
FAnimation: boolean;
|
||||
FState: TBCMDButtonState;
|
||||
FStyleActive: TBCMDButtonStyle;
|
||||
FStyleDisabled: TBCMDButtonStyle;
|
||||
FStyleHover: TBCMDButtonStyle;
|
||||
FStyleNormal: TBCMDButtonStyle;
|
||||
FTextLayout: TTextLayout;
|
||||
procedure OnChangeStyle(Sender: TObject);
|
||||
procedure SetFAlignment(AValue: TAlignment);
|
||||
procedure SetFAnimation(AValue: boolean);
|
||||
procedure SetFChecked(AValue: boolean);
|
||||
procedure SetFKind(AValue: TBCMDButtonKind);
|
||||
procedure SetFStyleActive(AValue: TBCMDButtonStyle);
|
||||
procedure SetFStyleDisabled(AValue: TBCMDButtonStyle);
|
||||
procedure SetFStyleHover(AValue: TBCMDButtonStyle);
|
||||
procedure SetFStyleNormal(AValue: TBCMDButtonStyle);
|
||||
procedure SetFTextAutoSize(AValue: boolean);
|
||||
procedure SetFTextLayout(AValue: TTextLayout);
|
||||
procedure SetFTextProportional(AValue: boolean);
|
||||
procedure SetFTextProportionalRatio(AValue: single);
|
||||
protected
|
||||
// START / MDBUTTONFOCUS ONLY
|
||||
procedure WMSetFocus(var Message: {$IFDEF FPC}TLMSetFocus{$ELSE}TWMKillFocus{$ENDIF}); message {$IFDEF FPC}LM_SETFOCUS{$ELSE}WM_SETFOCUS{$ENDIF};
|
||||
procedure WMKillFocus(var Message: {$IFDEF FPC}TLMKillFocus{$ELSE}TWMKillFocus{$ENDIF}); message {$IFDEF FPC}LM_KILLFOCUS{$ELSE}WM_KILLFOCUS{$ENDIF};
|
||||
procedure UpdateFocus(AFocused: boolean);
|
||||
procedure KeyDown(var Key: word; Shift: TShiftState); override;
|
||||
procedure KeyUp(var Key: word; Shift: TShiftState); override;
|
||||
// END / MDBUTTONFOCUS ONLY
|
||||
procedure CalculatePreferredSize(var PreferredWidth, PreferredHeight: integer;
|
||||
{%H-}WithThemeSpace: boolean); override;
|
||||
procedure Paint; override;
|
||||
procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
|
||||
X, Y: integer); override;
|
||||
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: integer); override;
|
||||
procedure MouseEnter; override;
|
||||
procedure MouseLeave; override;
|
||||
procedure RealSetText(const Value: TCaption); override;
|
||||
procedure OnTimer(Sender: TObject);
|
||||
procedure OnStartTimer(Sender: TObject);
|
||||
procedure OnStopTimer(Sender: TObject);
|
||||
function easeInOutQuad(t: double): double;
|
||||
function easeOutQuad(t: double): double;
|
||||
procedure UncheckOthers;
|
||||
class function GetControlClassDefaultSize: TSize;override;
|
||||
public
|
||||
constructor Create(AOwner: TComponent); override;
|
||||
destructor Destroy; override;
|
||||
procedure SelectAll;
|
||||
procedure UnselectAll;
|
||||
procedure InvertSelection;
|
||||
function GetSelected: TStringList;
|
||||
published
|
||||
property Animation: boolean read FAnimation write SetFAnimation default False;
|
||||
property Alignment: TAlignment read FAlignment write SetFAlignment default taCenter;
|
||||
property TextLayout: TTextLayout
|
||||
read FTextLayout write SetFTextLayout default tlCenter;
|
||||
property StyleNormal: TBCMDButtonStyle read FStyleNormal write SetFStyleNormal;
|
||||
property StyleHover: TBCMDButtonStyle read FStyleHover write SetFStyleHover;
|
||||
property StyleActive: TBCMDButtonStyle read FStyleActive write SetFStyleActive;
|
||||
property StyleDisabled: TBCMDButtonStyle read FStyleDisabled write SetFStyleDisabled;
|
||||
property Checked: boolean read FChecked write SetFChecked default False;
|
||||
property Kind: TBCMDButtonKind read FKind write SetFKind default mdbkNormal;
|
||||
// If text size is used to measure buttons
|
||||
// Disable it if you use the buttons in a grid, for example
|
||||
property TextAutoSize: boolean read FTextAutoSize write SetFTextAutoSize;
|
||||
// Enable it if you want that text size grows with height
|
||||
property TextProportional: boolean read FTextProportional write SetFTextProportional;
|
||||
// Each character font height proportional to height of control
|
||||
// Set it in conjunction with TextProportional, values recommended between 0...1
|
||||
property TextProportionalRatio: single read FTextProportionalRatio
|
||||
write SetFTextProportionalRatio;
|
||||
end;
|
||||
|
||||
TBCMDButtonFocus = class(TCustomBCMDButtonFocus)
|
||||
property Action;
|
||||
property Align;
|
||||
property Anchors;
|
||||
property AutoSize;
|
||||
property BidiMode;
|
||||
property BorderSpacing;
|
||||
{$IFDEF FPC} //#
|
||||
property OnChangeBounds;
|
||||
{$ENDIF}
|
||||
//property Cancel;
|
||||
property Caption;
|
||||
property Color;
|
||||
property Constraints;
|
||||
//property Default;
|
||||
property DragCursor;
|
||||
property DragKind;
|
||||
property DragMode;
|
||||
property Enabled;
|
||||
property Font;
|
||||
property ParentBidiMode;
|
||||
//property ModalResult;
|
||||
property OnClick;
|
||||
property OnContextPopup;
|
||||
property OnDragDrop;
|
||||
property OnDragOver;
|
||||
property OnEndDrag;
|
||||
//property OnEnter;
|
||||
//property OnExit;
|
||||
//property OnKeyDown;
|
||||
//property OnKeyPress;
|
||||
//property OnKeyUp;
|
||||
property OnMouseDown;
|
||||
property OnMouseEnter;
|
||||
property OnMouseLeave;
|
||||
property OnMouseMove;
|
||||
property OnMouseUp;
|
||||
property OnMouseWheel;
|
||||
property OnMouseWheelDown;
|
||||
property OnMouseWheelUp;
|
||||
property OnResize;
|
||||
property OnStartDrag;
|
||||
//property OnUTF8KeyPress;
|
||||
property ParentFont;
|
||||
property ParentShowHint;
|
||||
property PopupMenu;
|
||||
property ShowHint;
|
||||
//property TabOrder;
|
||||
//property TabStop;
|
||||
property Visible;
|
||||
end;
|
||||
|
||||
{$IFDEF FPC}procedure Register;{$ENDIF}
|
||||
|
||||
implementation
|
||||
|
||||
{$IFDEF MDBUTTON_ANIMATEONLYONE}
|
||||
var
|
||||
MDAnimating: TCustomMDButtonFocus;
|
||||
|
||||
{$ENDIF}
|
||||
|
||||
{$IFDEF FPC}
|
||||
procedure Register;
|
||||
begin
|
||||
RegisterComponents('BGRA Button Controls', [TBCMDButtonFocus]);
|
||||
end;
|
||||
{$ENDIF}
|
||||
|
||||
{ TCustomBCMDButtonFocus }
|
||||
|
||||
procedure TCustomBCMDButtonFocus.SetFStyleActive(AValue: TBCMDButtonStyle);
|
||||
begin
|
||||
if FStyleActive = AValue then
|
||||
Exit;
|
||||
FStyleActive := AValue;
|
||||
end;
|
||||
|
||||
procedure TCustomBCMDButtonFocus.SetFAlignment(AValue: TAlignment);
|
||||
begin
|
||||
if FAlignment = AValue then
|
||||
Exit;
|
||||
FAlignment := AValue;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TCustomBCMDButtonFocus.SetFAnimation(AValue: boolean);
|
||||
begin
|
||||
if FAnimation = AValue then
|
||||
Exit;
|
||||
FAnimation := AValue;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TCustomBCMDButtonFocus.SetFChecked(AValue: boolean);
|
||||
begin
|
||||
if FChecked = AValue then
|
||||
Exit;
|
||||
FChecked := AValue;
|
||||
if FChecked and (FKind in [mdbkToggleGroup, mdbkRadioButton, mdbkTab]) then
|
||||
UncheckOthers;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TCustomBCMDButtonFocus.SetFKind(AValue: TBCMDButtonKind);
|
||||
begin
|
||||
if FKind = AValue then
|
||||
Exit;
|
||||
FKind := AValue;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TCustomBCMDButtonFocus.OnChangeStyle(Sender: TObject);
|
||||
begin
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TCustomBCMDButtonFocus.SetFStyleDisabled(AValue: TBCMDButtonStyle);
|
||||
begin
|
||||
if FStyleDisabled = AValue then
|
||||
Exit;
|
||||
FStyleDisabled := AValue;
|
||||
end;
|
||||
|
||||
procedure TCustomBCMDButtonFocus.SetFStyleHover(AValue: TBCMDButtonStyle);
|
||||
begin
|
||||
if FStyleHover = AValue then
|
||||
Exit;
|
||||
FStyleHover := AValue;
|
||||
end;
|
||||
|
||||
procedure TCustomBCMDButtonFocus.SetFStyleNormal(AValue: TBCMDButtonStyle);
|
||||
begin
|
||||
if FStyleNormal = AValue then
|
||||
Exit;
|
||||
FStyleNormal := AValue;
|
||||
end;
|
||||
|
||||
procedure TCustomBCMDButtonFocus.SetFTextAutoSize(AValue: boolean);
|
||||
begin
|
||||
if FTextAutoSize = AValue then
|
||||
Exit;
|
||||
FTextAutoSize := AValue;
|
||||
end;
|
||||
|
||||
procedure TCustomBCMDButtonFocus.SetFTextLayout(AValue: TTextLayout);
|
||||
begin
|
||||
if FTextLayout = AValue then
|
||||
Exit;
|
||||
FTextLayout := AValue;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TCustomBCMDButtonFocus.SetFTextProportional(AValue: boolean);
|
||||
begin
|
||||
if FTextProportional = AValue then
|
||||
Exit;
|
||||
FTextProportional := AValue;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TCustomBCMDButtonFocus.SetFTextProportionalRatio(AValue: single);
|
||||
begin
|
||||
if FTextProportionalRatio = AValue then
|
||||
Exit;
|
||||
FTextProportionalRatio := AValue;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TCustomBCMDButtonFocus.WMSetFocus(var Message: {$IFDEF FPC}TLMSetFocus{$ELSE}TWMKillFocus{$ENDIF});
|
||||
begin
|
||||
inherited;
|
||||
|
||||
UpdateFocus(True);
|
||||
end;
|
||||
|
||||
procedure TCustomBCMDButtonFocus.WMKillFocus(var Message: {$IFDEF FPC}TLMKillFocus{$ELSE}TWMKillFocus{$ENDIF});
|
||||
begin
|
||||
inherited;
|
||||
|
||||
if Message.FocusedWnd <> Handle then
|
||||
UpdateFocus(False);
|
||||
end;
|
||||
|
||||
procedure TCustomBCMDButtonFocus.UpdateFocus(AFocused: boolean);
|
||||
var
|
||||
lForm: TCustomForm;
|
||||
begin
|
||||
lForm := GetParentForm(Self);
|
||||
if lForm = nil then
|
||||
exit;
|
||||
|
||||
{$IFDEF FPC}//#
|
||||
if AFocused then
|
||||
ActiveDefaultControlChanged(lForm.ActiveControl)
|
||||
else
|
||||
ActiveDefaultControlChanged(nil);
|
||||
{$ENDIF}
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TCustomBCMDButtonFocus.KeyDown(var Key: word; Shift: TShiftState);
|
||||
begin
|
||||
inherited KeyDown(Key, Shift);
|
||||
|
||||
if (Key = VK_SPACE) or (Key = VK_RETURN) then
|
||||
MouseDown(mbLeft, [], Width div 2, Height div 2);
|
||||
end;
|
||||
|
||||
procedure TCustomBCMDButtonFocus.KeyUp(var Key: word; Shift: TShiftState);
|
||||
begin
|
||||
if (Key = VK_SPACE) or (Key = VK_RETURN) then
|
||||
begin
|
||||
MouseLeave;
|
||||
Self.Click;
|
||||
end;
|
||||
|
||||
inherited KeyUp(Key, Shift);
|
||||
end;
|
||||
|
||||
procedure TCustomBCMDButtonFocus.CalculatePreferredSize(
|
||||
var PreferredWidth, PreferredHeight: integer; WithThemeSpace: boolean);
|
||||
var
|
||||
bmp: TBGRABitmap;
|
||||
s: TSize;
|
||||
begin
|
||||
bmp := TBGRABitmap.Create;
|
||||
bmp.FontName := Font.Name;
|
||||
if FTextProportional then
|
||||
bmp.FontHeight := Round(Height * FTextProportionalRatio)
|
||||
else
|
||||
bmp.FontHeight := 0;
|
||||
bmp.FontAntialias := True;
|
||||
bmp.FontQuality := fqSystemClearType;
|
||||
bmp.FontStyle := Font.Style;
|
||||
s := bmp.TextSize(Caption);
|
||||
if FTextAutoSize then
|
||||
begin
|
||||
PreferredWidth := s.Width + 26 {$IFDEF FPC}+ BorderSpacing.InnerBorder{$ENDIF};
|
||||
PreferredHeight := s.Height + 10 {$IFDEF FPC}+ BorderSpacing.InnerBorder{$ENDIF};
|
||||
end
|
||||
else
|
||||
begin
|
||||
{$IFDEF FPC}//#
|
||||
PreferredWidth := BorderSpacing.InnerBorder;
|
||||
PreferredHeight := BorderSpacing.InnerBorder;
|
||||
{$ENDIF}
|
||||
end;
|
||||
bmp.Free;
|
||||
end;
|
||||
|
||||
procedure TCustomBCMDButtonFocus.Paint;
|
||||
var
|
||||
bmp: TBGRABitmap;
|
||||
iTemp: integer;
|
||||
alpha: byte;
|
||||
tempState: TBCMDButtonState;
|
||||
tempText: string;
|
||||
tempRounding: integer;
|
||||
tempColor, hoverColor: TBGRAPixel;
|
||||
begin
|
||||
bmp := TBGRABitmap.Create(Width, Height);
|
||||
bmp.FontName := Font.Name;
|
||||
if FTextProportional then
|
||||
bmp.FontHeight := Round(Height * FTextProportionalRatio)
|
||||
else
|
||||
bmp.FontHeight := 0;
|
||||
bmp.FontAntialias := True;
|
||||
bmp.FontQuality := fqSystemClearType;
|
||||
bmp.FontStyle := Font.Style;
|
||||
tempState := FState;
|
||||
|
||||
if Kind = mdbkTab then
|
||||
tempRounding := 0
|
||||
else
|
||||
tempRounding := FRounding;
|
||||
|
||||
if FChecked then
|
||||
tempState := mdbsActive
|
||||
else
|
||||
tempState := FState;
|
||||
|
||||
// START / MDBUTTONFOCUS ONLY
|
||||
if Focused and (tempState = mdbsNormal) then
|
||||
tempState := mdbsHover;
|
||||
// END / MDBUTTONFOCUS ONLY
|
||||
|
||||
tempText := Caption;
|
||||
|
||||
case FKind of
|
||||
mdbkCheckBox:
|
||||
begin
|
||||
if Length(Caption) > 0 then
|
||||
tempText := ' ' + Caption;
|
||||
if FChecked then
|
||||
tempText := BCMDBUTTONBALLOTBOXWITHCHECK + tempText
|
||||
else
|
||||
tempText := BCMDBUTTONBALLOTBOX + tempText;
|
||||
end;
|
||||
mdbkRadioButton:
|
||||
begin
|
||||
if Length(Caption) > 0 then
|
||||
tempText := ' ' + Caption;
|
||||
if FChecked then
|
||||
tempText := BCMDBUTTONRADIOBUTTON + tempText
|
||||
else
|
||||
tempText := BCMDBUTTONRADIOBUTTONCIRCLE + tempText;
|
||||
end;
|
||||
end;
|
||||
|
||||
// Enabled
|
||||
if Enabled then
|
||||
begin
|
||||
if not FTimer.Enabled then
|
||||
begin
|
||||
case tempState of
|
||||
mdbsNormal:
|
||||
begin
|
||||
bmp.RoundRect(0, 0, Width, Height, tempRounding, tempRounding,
|
||||
FStyleNormal.Color,
|
||||
FStyleNormal.Color);
|
||||
{$IFDEF FPC}
|
||||
bmp.TextRect(Rect(BorderSpacing.InnerBorder, BorderSpacing.InnerBorder,
|
||||
Width - BorderSpacing.InnerBorder, Height - BorderSpacing.InnerBorder),
|
||||
tempText, Alignment,
|
||||
TextLayout, FStyleNormal.TextColor);
|
||||
{$ELSE}
|
||||
bmp.TextRect(Rect(0, 0, Width, Height), tempText, Alignment, TextLayout, FStyleNormal.TextColor);
|
||||
{$ENDIF}
|
||||
end;
|
||||
mdbsHover:
|
||||
begin
|
||||
bmp.RoundRect(0, 0, Width, Height, tempRounding, tempRounding,
|
||||
FStyleHover.Color, FStyleHover.Color);
|
||||
{$IFDEF FPC}
|
||||
bmp.TextRect(Rect(BorderSpacing.InnerBorder, BorderSpacing.InnerBorder,
|
||||
Width - BorderSpacing.InnerBorder, Height - BorderSpacing.InnerBorder),
|
||||
tempText, Alignment,
|
||||
TextLayout, FStyleHover.TextColor);
|
||||
{$ELSE}
|
||||
bmp.TextRect(Rect(0, 0, Width, Height), tempText, Alignment, TextLayout, FStyleHover.TextColor);
|
||||
{$ENDIF}
|
||||
end;
|
||||
mdbsActive:
|
||||
begin
|
||||
if not FAnimation then
|
||||
begin
|
||||
if FKind in [mdbkNormal] then
|
||||
bmp.RoundRect(0, 0, Width, Height, tempRounding,
|
||||
tempRounding, FStyleActive.Color,
|
||||
FStyleActive.Color)
|
||||
else
|
||||
bmp.RoundRect(0, 0, Width, Height, tempRounding,
|
||||
tempRounding, FStyleHover.Color,
|
||||
FStyleHover.Color);
|
||||
end
|
||||
else
|
||||
bmp.RoundRect(0, 0, Width, Height, tempRounding, tempRounding,
|
||||
FStyleHover.Color,
|
||||
FStyleHover.Color);
|
||||
{$IFDEF FPC}
|
||||
bmp.TextRect(Rect(BorderSpacing.InnerBorder, BorderSpacing.InnerBorder,
|
||||
Width - BorderSpacing.InnerBorder, Height - BorderSpacing.InnerBorder),
|
||||
tempText, Alignment,
|
||||
TextLayout, FStyleActive.TextColor);
|
||||
{$ELSE}
|
||||
bmp.TextRect(Rect(0, 0, Width, Height), tempText, Alignment, TextLayout, FStyleActive.TextColor);
|
||||
{$ENDIF}
|
||||
end;
|
||||
end;
|
||||
end
|
||||
else
|
||||
begin
|
||||
iTemp := round(FCircleSize * easeOutQuad(FPercent));
|
||||
alpha := round(easeInOutQuad(FAlphaPercent) * 255);
|
||||
case tempState of
|
||||
mdbsNormal:
|
||||
begin
|
||||
bmp.RoundRect(0, 0, Width, Height, tempRounding, tempRounding,
|
||||
FStyleNormal.Color,
|
||||
FStyleNormal.Color);
|
||||
if FPercent < 1 then
|
||||
tempColor := FStyleHover.Color
|
||||
else
|
||||
begin
|
||||
tempColor := FStyleNormal.Color;
|
||||
hoverColor := ColorToBGRA(FStyleHover.Color, alpha);
|
||||
PutPixels(@tempColor, @hoverColor, 1, dmDrawWithTransparency, 255);
|
||||
end;
|
||||
bmp.FillEllipseAntialias(FCX, FCY, iTemp,
|
||||
iTemp, tempColor);
|
||||
{$IFDEF FPC}
|
||||
bmp.TextRect(Rect(BorderSpacing.InnerBorder, BorderSpacing.InnerBorder,
|
||||
Width - BorderSpacing.InnerBorder, Height - BorderSpacing.InnerBorder),
|
||||
tempText, Alignment,
|
||||
TextLayout, FStyleNormal.TextColor);
|
||||
{$ELSE}
|
||||
bmp.TextRect(Rect(0, 0, Width, Height), tempText, Alignment, TextLayout, FStyleNormal.TextColor);
|
||||
{$ENDIF}
|
||||
end;
|
||||
mdbsHover, mdbsActive:
|
||||
begin
|
||||
bmp.RoundRect(0, 0, Width, Height, tempRounding, tempRounding,
|
||||
FStyleHover.Color, FStyleHover.Color);
|
||||
if FPercent < 1 then
|
||||
tempColor := FStyleActive.Color
|
||||
else
|
||||
begin
|
||||
tempColor := FStyleHover.Color;
|
||||
hoverColor := ColorToBGRA(FStyleActive.Color, alpha);
|
||||
PutPixels(@tempColor, @hoverColor, 1, dmDrawWithTransparency, 255);
|
||||
end;
|
||||
bmp.FillEllipseAntialias(FCX, FCY, iTemp,
|
||||
iTemp, tempColor);
|
||||
{$IFDEF FPC}
|
||||
bmp.TextRect(Rect(BorderSpacing.InnerBorder, BorderSpacing.InnerBorder,
|
||||
Width - BorderSpacing.InnerBorder, Height - BorderSpacing.InnerBorder),
|
||||
tempText, Alignment,
|
||||
TextLayout, FStyleHover.TextColor);
|
||||
{$ELSE}
|
||||
bmp.TextRect(Rect(0, 0, Width, Height), tempText, Alignment, TextLayout, FStyleHover.TextColor);
|
||||
{$ENDIF}
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
end
|
||||
// Disabled
|
||||
else
|
||||
begin
|
||||
if FChecked then
|
||||
begin
|
||||
bmp.RoundRect(0, 0, Width, Height, tempRounding, tempRounding,
|
||||
FStyleHover.Color, FStyleHover.Color);
|
||||
end
|
||||
else
|
||||
bmp.RoundRect(0, 0, Width, Height, tempRounding, tempRounding,
|
||||
FStyleDisabled.Color, FStyleDisabled.Color);
|
||||
{$IFDEF FPC}
|
||||
bmp.TextRect(Rect(BorderSpacing.InnerBorder, BorderSpacing.InnerBorder,
|
||||
Width - BorderSpacing.InnerBorder, Height - BorderSpacing.InnerBorder),
|
||||
tempText, Alignment,
|
||||
TextLayout, FStyleDisabled.TextColor);
|
||||
{$ELSE}
|
||||
bmp.TextRect(Rect(0, 0, Width, Height), tempText, Alignment, TextLayout, FStyleDisabled.TextColor);
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
// Tab
|
||||
if Kind = mdbkTab then
|
||||
begin
|
||||
if FTimer.Enabled then
|
||||
begin
|
||||
iTemp := round((bmp.Width div 2) * easeInOutQuad(FPercent));
|
||||
bmp.Rectangle((bmp.Width div 2) - iTemp, bmp.Height - 2,
|
||||
(bmp.Width div 2) + iTemp, bmp.Height, $00BB513F, dmSet);
|
||||
end
|
||||
else
|
||||
begin
|
||||
if FChecked then
|
||||
bmp.Rectangle(0, bmp.Height - 2, bmp.Width, bmp.Height, $00BB513F, dmSet);
|
||||
end;
|
||||
end;
|
||||
|
||||
{$IFDEF MDBUTTON_DEBUG}
|
||||
bmp.FontHeight := 10;
|
||||
bmp.TextOut(0, 0, FCount.ToString, BGRA(255, 0, 0, 255));
|
||||
FCount += 1;
|
||||
{$ENDIF}
|
||||
bmp.Draw(Canvas, 0, 0, False);
|
||||
bmp.Free;
|
||||
inherited Paint;
|
||||
end;
|
||||
|
||||
procedure TCustomBCMDButtonFocus.MouseDown(Button: TMouseButton;
|
||||
Shift: TShiftState; X, Y: integer);
|
||||
begin
|
||||
inherited MouseDown(Button, Shift, X, Y);
|
||||
FState := mdbsActive;
|
||||
if FAnimation and BCMDBUTTONANIMATION then
|
||||
begin
|
||||
FCircleSize := max(round(Width / 1.5) + abs((Width div 2) - X),
|
||||
round(Height / 1.5) + abs((Height div 2) - Y));
|
||||
FCX := X;
|
||||
FCY := Y;
|
||||
FTimer.Enabled := False;
|
||||
FTimer.Enabled := True;
|
||||
{$IFDEF MDBUTTON_ANIMATEONLYONE}
|
||||
MDAnimating := Self;
|
||||
{$ENDIF}
|
||||
end;
|
||||
if FKind in [mdbkToggle, mdbkToggleGroup, mdbkCheckBox, mdbkRadioButton, mdbkTab] then
|
||||
begin
|
||||
FChecked := not FChecked;
|
||||
if FKind in [mdbkToggleGroup, mdbkRadioButton, mdbkTab] then
|
||||
begin
|
||||
FChecked := True;
|
||||
UncheckOthers;
|
||||
end;
|
||||
end;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TCustomBCMDButtonFocus.MouseUp(Button: TMouseButton;
|
||||
Shift: TShiftState; X, Y: integer);
|
||||
begin
|
||||
inherited MouseUp(Button, Shift, X, Y);
|
||||
if (x > 0) and (x < Width) and (y > 0) and (y < Height) and (FState = mdbsActive) then
|
||||
FState := mdbsHover
|
||||
else
|
||||
FState := mdbsNormal;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TCustomBCMDButtonFocus.MouseEnter;
|
||||
begin
|
||||
inherited MouseEnter;
|
||||
FState := mdbsHover;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TCustomBCMDButtonFocus.MouseLeave;
|
||||
begin
|
||||
inherited MouseLeave;
|
||||
FState := mdbsNormal;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TCustomBCMDButtonFocus.RealSetText(const Value: TCaption);
|
||||
begin
|
||||
inherited RealSetText(Value);
|
||||
InvalidatePreferredSize;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TCustomBCMDButtonFocus.OnTimer(Sender: TObject);
|
||||
begin
|
||||
{$IFDEF MDBUTTON_ANIMATEONLYONE}
|
||||
if MDAnimating = Self then
|
||||
begin
|
||||
{$ENDIF}
|
||||
FPercent := FPercent + BCMDBUTTONANIMATIONSPEED;
|
||||
if FPercent < 0 then
|
||||
FPercent := 0
|
||||
else if FPercent > 1 then
|
||||
FPercent := 1;
|
||||
|
||||
if FPercent = 1 then
|
||||
begin
|
||||
FAlphaPercent := FAlphaPercent - BCMDBUTTONANIMATIONSPEED;
|
||||
if FAlphaPercent < 0 then
|
||||
FAlphaPercent := 0
|
||||
else if FAlphaPercent > 1 then
|
||||
FAlphaPercent := 1;
|
||||
end;
|
||||
{$IFDEF MDBUTTON_ANIMATEONLYONE}
|
||||
end
|
||||
else
|
||||
FTimer.Enabled := False;
|
||||
{$ENDIF}
|
||||
|
||||
Invalidate;
|
||||
if (FPercent >= 1) and (FAlphaPercent <= 0) then
|
||||
FTimer.Enabled := False;
|
||||
end;
|
||||
|
||||
procedure TCustomBCMDButtonFocus.OnStartTimer(Sender: TObject);
|
||||
begin
|
||||
FPercent := 0;
|
||||
FAlphaPercent := 1;
|
||||
end;
|
||||
|
||||
procedure TCustomBCMDButtonFocus.OnStopTimer(Sender: TObject);
|
||||
begin
|
||||
|
||||
end;
|
||||
|
||||
function TCustomBCMDButtonFocus.easeInOutQuad(t: double): double;
|
||||
begin
|
||||
if t < 0.5 then
|
||||
Result := 2 * t * t
|
||||
else
|
||||
Result := -1 + (4 - 2 * t) * t;
|
||||
end;
|
||||
|
||||
function TCustomBCMDButtonFocus.easeOutQuad(t: double): double;
|
||||
begin
|
||||
Result := t * (2 - t);
|
||||
end;
|
||||
|
||||
procedure TCustomBCMDButtonFocus.UncheckOthers;
|
||||
var
|
||||
i: integer;
|
||||
control: TWinControl;
|
||||
begin
|
||||
if Parent is TWinControl then
|
||||
begin
|
||||
control := TWinControl(Parent);
|
||||
for i := 0 to control.ControlCount - 1 do
|
||||
if (control.Controls[i] <> Self) and (control.Controls[i] is
|
||||
TCustomBCMDButtonFocus) then
|
||||
if (TCustomBCMDButtonFocus(control.Controls[i]).Kind in
|
||||
[mdbkToggleGroup, mdbkRadioButton, mdbkTab]) then
|
||||
TCustomBCMDButtonFocus(control.Controls[i]).Checked := False;
|
||||
end;
|
||||
end;
|
||||
|
||||
class function TCustomBCMDButtonFocus.GetControlClassDefaultSize: TSize;
|
||||
begin
|
||||
Result.CX := 75;
|
||||
Result.CY := 25;
|
||||
end;
|
||||
|
||||
constructor TCustomBCMDButtonFocus.Create(AOwner: TComponent);
|
||||
begin
|
||||
inherited Create(AOwner);
|
||||
// START / MDBUTTONFOCUS ONLY
|
||||
TabStop := True;
|
||||
ControlStyle := ControlStyle + [csAcceptsControls, csParentBackground];
|
||||
DoubleBuffered := True;
|
||||
// END / MDBUTTONFOCUS ONLY
|
||||
{$IFDEF INDEBUG}
|
||||
FCount := 0;
|
||||
{$ENDIF}
|
||||
// State
|
||||
FState := mdbsNormal;
|
||||
FChecked := False;
|
||||
FKind := mdbkNormal;
|
||||
// Text
|
||||
FTextAutoSize := True;
|
||||
FAlignment := taCenter;
|
||||
FTextLayout := tlCenter;
|
||||
FTextProportional := False;
|
||||
FTextProportionalRatio := 0.5;
|
||||
// Style
|
||||
FRounding := 6;
|
||||
FStyleNormal := TBCMDButtonStyle.Create;
|
||||
FStyleNormal.OnChange := OnChangeStyle;
|
||||
FStyleHover := TBCMDButtonStyle.Create;
|
||||
FStyleHover.OnChange := OnChangeStyle;
|
||||
FStyleActive := TBCMDButtonStyle.Create;
|
||||
FStyleActive.OnChange := OnChangeStyle;
|
||||
FStyleDisabled := TBCMDButtonStyle.Create;
|
||||
FStyleDisabled.OnChange := OnChangeStyle;
|
||||
// Default Style
|
||||
FStyleHover.Color := RGBToColor(220, 220, 220);
|
||||
FStyleActive.Color := RGBToColor(198, 198, 198);
|
||||
FStyleDisabled.TextColor := RGBToColor(163, 163, 163);
|
||||
// Animation
|
||||
FAnimation := False;
|
||||
FTimer := TTimer.Create(Self);
|
||||
FTimer.Enabled := False;
|
||||
FTimer.Interval := BCMDBUTTONTIMERSPEED;
|
||||
FTimer.OnTimer := OnTimer;
|
||||
{$IFDEF FPC}//#
|
||||
FTimer.OnStartTimer := OnStartTimer;
|
||||
FTimer.OnStopTimer := OnStopTimer;
|
||||
{$ENDIF}
|
||||
|
||||
// Setup default sizes
|
||||
with GetControlClassDefaultSize do
|
||||
SetInitialBounds(0, 0, CX, CY);
|
||||
end;
|
||||
|
||||
destructor TCustomBCMDButtonFocus.Destroy;
|
||||
begin
|
||||
FTimer.OnTimer := nil;
|
||||
{$IFDEF FPC}//#
|
||||
FTimer.OnStartTimer := nil;
|
||||
FTimer.OnStopTimer := nil;
|
||||
{$ENDIF}
|
||||
FTimer.Enabled := False;
|
||||
FStyleNormal.Free;
|
||||
FStyleHover.Free;
|
||||
FStyleActive.Free;
|
||||
FStyleDisabled.Free;
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
procedure TCustomBCMDButtonFocus.SelectAll;
|
||||
var
|
||||
i: integer;
|
||||
control: TWinControl;
|
||||
begin
|
||||
if Parent is TWinControl then
|
||||
begin
|
||||
control := TWinControl(Parent);
|
||||
for i := 0 to control.ControlCount - 1 do
|
||||
if (control.Controls[i] is TCustomBCMDButtonFocus) then
|
||||
if (TCustomBCMDButtonFocus(control.Controls[i]).Kind in
|
||||
[mdbkToggle, mdbkCheckBox]) then
|
||||
TCustomBCMDButtonFocus(control.Controls[i]).Checked := True;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TCustomBCMDButtonFocus.UnselectAll;
|
||||
var
|
||||
i: integer;
|
||||
control: TWinControl;
|
||||
begin
|
||||
if Parent is TWinControl then
|
||||
begin
|
||||
control := TWinControl(Parent);
|
||||
for i := 0 to control.ControlCount - 1 do
|
||||
if (control.Controls[i] is TCustomBCMDButtonFocus) then
|
||||
if (TCustomBCMDButtonFocus(control.Controls[i]).Kind in
|
||||
[mdbkToggle, mdbkCheckBox]) then
|
||||
TCustomBCMDButtonFocus(control.Controls[i]).Checked := False;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TCustomBCMDButtonFocus.InvertSelection;
|
||||
var
|
||||
i: integer;
|
||||
control: TWinControl;
|
||||
begin
|
||||
if Parent is TWinControl then
|
||||
begin
|
||||
control := TWinControl(Parent);
|
||||
for i := 0 to control.ControlCount - 1 do
|
||||
if (control.Controls[i] is TCustomBCMDButtonFocus) then
|
||||
if (TCustomBCMDButtonFocus(control.Controls[i]).Kind in
|
||||
[mdbkToggle, mdbkCheckBox]) then
|
||||
TCustomBCMDButtonFocus(control.Controls[i]).Checked :=
|
||||
not TCustomBCMDButtonFocus(control.Controls[i]).Checked;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TCustomBCMDButtonFocus.GetSelected: TStringList;
|
||||
var
|
||||
i: integer;
|
||||
control: TWinControl;
|
||||
begin
|
||||
Result := TStringList.Create;
|
||||
if Parent is TWinControl then
|
||||
begin
|
||||
control := TWinControl(Parent);
|
||||
for i := 0 to control.ControlCount - 1 do
|
||||
if (control.Controls[i] is TCustomBCMDButtonFocus) then
|
||||
if TCustomBCMDButtonFocus(control.Controls[i]).Checked then
|
||||
Result.AddObject(TCustomBCMDButtonFocus(control.Controls[i]).Caption,
|
||||
TCustomBCMDButtonFocus(control.Controls[i]));
|
||||
end;
|
||||
end;
|
||||
|
||||
end.
|
||||
361
bgracontrols/bcnumerickeyboard.pas
Normal file
361
bgracontrols/bcnumerickeyboard.pas
Normal file
@@ -0,0 +1,361 @@
|
||||
// SPDX-License-Identifier: LGPL-3.0-linking-exception
|
||||
{******************************* CONTRIBUTOR(S) ******************************
|
||||
- Edivando S. Santos Brasil | mailedivando@gmail.com
|
||||
(Compatibility with delphi VCL 11/2018)
|
||||
|
||||
***************************** END CONTRIBUTOR(S) *****************************}
|
||||
unit BCNumericKeyboard;
|
||||
|
||||
{$I bgracontrols.inc}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils, {$IFDEF FPC}LCLType, LResources, LMessages,{$ENDIF}
|
||||
Forms, Controls, Graphics, Dialogs, MouseAndKeyInput,
|
||||
{$IFNDEF FPC}Types, Windows, BGRAGraphics, GraphType, FPImage, BCBaseCtrls, {$ENDIF}
|
||||
BCPanel, BCButton, BCThemeManager;
|
||||
|
||||
type
|
||||
|
||||
{ TBCCustomNumericKeyboard }
|
||||
|
||||
TBCCustomNumericKeyboard = class(TComponent)
|
||||
private
|
||||
FBCThemeManager: TBCThemeManager;
|
||||
procedure SetFThemeManager(AValue: TBCThemeManager);
|
||||
protected
|
||||
FOnChange: TNotifyEvent;
|
||||
FOnUserChange: TNotifyEvent;
|
||||
FPanel: TBCPanel;
|
||||
FButton: TBCButton;
|
||||
FBtn0, FBtn1, FBtn2, FBtn3, FBtn4, FBtn5, FBtn6, FBtn7, FBtn8,
|
||||
FBtn9, FBtnDot, FBtnClr: TBCButton;
|
||||
FValue: string;
|
||||
FVisible: boolean;
|
||||
procedure SetFButton(AValue: TBCButton);
|
||||
procedure SetFPanel(AValue: TBCPanel);
|
||||
procedure SetFValue(AValue: string);
|
||||
protected
|
||||
procedure OnButtonClick(Sender: TObject; {%H-}Button: TMouseButton;
|
||||
{%H-}Shift: TShiftState; {%H-}X, {%H-}Y: integer); virtual;
|
||||
protected
|
||||
{ The input value }
|
||||
property Value: string read FValue write SetFValue;
|
||||
{ When value is changed by code or by the user }
|
||||
property OnChange: TNotifyEvent read FOnChange write FOnChange;
|
||||
{ When value is changed by the user }
|
||||
property OnUserChange: TNotifyEvent read FOnUserChange write FOnUserChange;
|
||||
public
|
||||
constructor Create(AOwner: TComponent); override;
|
||||
destructor Destroy; override;
|
||||
// Show in a custom form or panel
|
||||
procedure Show(AControl: TWinControl); overload;
|
||||
// Try to Show in the form where this component is placed
|
||||
procedure Show(); overload;
|
||||
// Hide the component
|
||||
procedure Hide();
|
||||
// Update buttons style
|
||||
procedure UpdateButtonStyle;
|
||||
public
|
||||
{ The real panel that's used as container for all the numeric buttons }
|
||||
property Panel: TBCPanel read FPanel write SetFPanel;
|
||||
{ A fake button that's used as style base for all the numeric buttons }
|
||||
property ButtonStyle: TBCButton read FButton write SetFButton;
|
||||
{ If it's visible or not }
|
||||
property Visible: boolean read FVisible;
|
||||
published
|
||||
property ThemeManager: TBCThemeManager read FBCThemeManager write SetFThemeManager;
|
||||
end;
|
||||
|
||||
TBCNumericKeyboard = class(TBCCustomNumericKeyboard)
|
||||
published
|
||||
property Value;
|
||||
property OnChange;
|
||||
property OnUserChange;
|
||||
property ThemeManager;
|
||||
end;
|
||||
|
||||
{ TBCRealNumericKeyboard }
|
||||
|
||||
TBCRealNumericKeyboard = class(TBCCustomNumericKeyboard)
|
||||
protected
|
||||
procedure OnButtonClick(Sender: TObject; {%H-}Button: TMouseButton;
|
||||
{%H-}Shift: TShiftState; {%H-}X, {%H-}Y: integer); override;
|
||||
procedure PressVirtKey(p: longint);
|
||||
public
|
||||
constructor Create(AOwner: TComponent); override;
|
||||
published
|
||||
property OnUserChange;
|
||||
property ThemeManager;
|
||||
end;
|
||||
|
||||
{$IFDEF FPC}procedure Register;{$ENDIF}
|
||||
|
||||
implementation
|
||||
|
||||
{$IFDEF FPC}
|
||||
procedure Register;
|
||||
begin
|
||||
RegisterComponents('BGRA Controls', [TBCNumericKeyboard]);
|
||||
RegisterComponents('BGRA Controls', [TBCRealNumericKeyboard]);
|
||||
end;
|
||||
{$ENDIF}
|
||||
|
||||
{ TBCRealNumericKeyboard }
|
||||
|
||||
procedure TBCRealNumericKeyboard.OnButtonClick(Sender: TObject;
|
||||
Button: TMouseButton; Shift: TShiftState; X, Y: integer);
|
||||
const
|
||||
{$IFDEF LINUX}
|
||||
vk_DotNumPad = 110;
|
||||
{$ELSE}
|
||||
vk_DotNumPad = 190;
|
||||
{$ENDIF}
|
||||
var
|
||||
btn: TBCButton;
|
||||
num: string;
|
||||
begin
|
||||
btn := TBCButton(Sender);
|
||||
num := btn.Caption;
|
||||
|
||||
if num = FBtnClr.Caption then
|
||||
begin
|
||||
{$IFDEF CPUX86_64}
|
||||
Application.ProcessMessages;
|
||||
KeyInput.Press(VK_BACK);
|
||||
Application.ProcessMessages;
|
||||
{$ELSE}
|
||||
{$IFDEF FPC}
|
||||
Application.QueueAsyncCall(@PressVirtKey, VK_BACK);
|
||||
{$ELSE}
|
||||
SendKey(VK_BACK);
|
||||
{$ENDIF}
|
||||
{$ENDIF}
|
||||
end
|
||||
else if num = FBtnDot.Caption then
|
||||
begin
|
||||
{$IFDEF CPUX86_64}
|
||||
Application.ProcessMessages;
|
||||
KeyInput.Press(vk_DotNumPad);
|
||||
Application.ProcessMessages;
|
||||
{$ELSE}
|
||||
{$IFDEF FPC}
|
||||
Application.QueueAsyncCall(@PressVirtKey, vk_DotNumPad);
|
||||
{$ELSE}
|
||||
SendKey(vk_DotNumPad);
|
||||
{$ENDIF}
|
||||
{$ENDIF}
|
||||
end
|
||||
else
|
||||
begin
|
||||
{$IFDEF CPUX86_64}
|
||||
Application.ProcessMessages;
|
||||
KeyInput.Press(Ord(TBCButton(Sender).Caption[1]));
|
||||
Application.ProcessMessages;
|
||||
{$ELSE}
|
||||
{$IFDEF FPC}
|
||||
Application.QueueAsyncCall(@PressVirtKey, Ord(TBCButton(Sender).Caption[1]));
|
||||
{$ELSE}
|
||||
SendKey(Ord(TBCButton(Sender).Caption[1]));
|
||||
{$ENDIF}
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
if Assigned(FOnUserChange) then
|
||||
FOnUserChange(Self);
|
||||
end;
|
||||
|
||||
procedure TBCRealNumericKeyboard.PressVirtKey(p: longint);
|
||||
begin
|
||||
KeyInput.Down(p);
|
||||
KeyInput.Up(p);
|
||||
end;
|
||||
|
||||
constructor TBCRealNumericKeyboard.Create(AOwner: TComponent);
|
||||
begin
|
||||
inherited Create(AOwner);
|
||||
FBtnClr.Caption := '<-';
|
||||
end;
|
||||
|
||||
{ TBCCustomNumericKeyboard }
|
||||
|
||||
procedure TBCCustomNumericKeyboard.SetFPanel(AValue: TBCPanel);
|
||||
begin
|
||||
if FPanel = AValue then
|
||||
Exit;
|
||||
FPanel := AValue;
|
||||
end;
|
||||
|
||||
procedure TBCCustomNumericKeyboard.SetFValue(AValue: string);
|
||||
begin
|
||||
if FValue = AValue then
|
||||
Exit;
|
||||
FValue := AValue;
|
||||
if Assigned(FOnChange) then
|
||||
FOnChange(Self);
|
||||
end;
|
||||
|
||||
procedure TBCCustomNumericKeyboard.OnButtonClick(Sender: TObject;
|
||||
Button: TMouseButton; Shift: TShiftState; X, Y: integer);
|
||||
var
|
||||
btn: TBCButton;
|
||||
num: string;
|
||||
begin
|
||||
btn := TBCButton(Sender);
|
||||
num := btn.Caption;
|
||||
|
||||
if num = FBtnClr.Caption then
|
||||
begin
|
||||
Value := '';
|
||||
end
|
||||
else if num = FBtnDot.Caption then
|
||||
begin
|
||||
if Length(Value) = 0 then
|
||||
Value := '0' + num;
|
||||
if Pos(num, Value) = 0 then
|
||||
Value := Value + num;
|
||||
end
|
||||
else
|
||||
begin
|
||||
Value := Value + num;
|
||||
end;
|
||||
|
||||
if Assigned(FOnUserChange) then
|
||||
FOnUserChange(Self);
|
||||
end;
|
||||
|
||||
procedure TBCCustomNumericKeyboard.SetFThemeManager(AValue: TBCThemeManager);
|
||||
begin
|
||||
if FBCThemeManager = AValue then
|
||||
Exit;
|
||||
FBCThemeManager := AValue;
|
||||
end;
|
||||
|
||||
procedure TBCCustomNumericKeyboard.SetFButton(AValue: TBCButton);
|
||||
begin
|
||||
if FButton = AValue then
|
||||
Exit;
|
||||
FButton := AValue;
|
||||
end;
|
||||
|
||||
constructor TBCCustomNumericKeyboard.Create(AOwner: TComponent);
|
||||
begin
|
||||
inherited Create(AOwner);
|
||||
|
||||
FVisible := False;
|
||||
|
||||
FButton := TBCButton.Create(Self);
|
||||
|
||||
FPanel := TBCPanel.Create(Self);
|
||||
FPanel.AutoSize := True;
|
||||
FPanel.ChildSizing.ControlsPerLine := 3;
|
||||
FPanel.ChildSizing.Layout := cclLeftToRightThenTopToBottom;
|
||||
FPanel.Caption := '';
|
||||
FPanel.BorderBCStyle := bpsBorder;
|
||||
|
||||
FBtn7 := TBCButton.Create(FPanel);
|
||||
FBtn7.Parent := FPanel;
|
||||
FBtn7.Caption := '7';
|
||||
FBtn7.OnMouseDown := OnButtonClick;
|
||||
|
||||
FBtn8 := TBCButton.Create(FPanel);
|
||||
FBtn8.Parent := FPanel;
|
||||
FBtn8.Caption := '8';
|
||||
FBtn8.OnMouseDown := OnButtonClick;
|
||||
|
||||
FBtn9 := TBCButton.Create(FPanel);
|
||||
FBtn9.Caption := '9';
|
||||
FBtn9.Parent := FPanel;
|
||||
FBtn9.OnMouseDown := OnButtonClick;
|
||||
|
||||
FBtn4 := TBCButton.Create(FPanel);
|
||||
FBtn4.Parent := FPanel;
|
||||
FBtn4.Caption := '4';
|
||||
FBtn4.OnMouseDown := OnButtonClick;
|
||||
|
||||
FBtn5 := TBCButton.Create(FPanel);
|
||||
FBtn5.Parent := FPanel;
|
||||
FBtn5.Caption := '5';
|
||||
FBtn5.OnMouseDown := OnButtonClick;
|
||||
|
||||
FBtn6 := TBCButton.Create(FPanel);
|
||||
FBtn6.Parent := FPanel;
|
||||
FBtn6.Caption := '6';
|
||||
FBtn6.OnMouseDown := OnButtonClick;
|
||||
|
||||
FBtn1 := TBCButton.Create(FPanel);
|
||||
FBtn1.Parent := FPanel;
|
||||
FBtn1.Caption := '1';
|
||||
FBtn1.OnMouseDown := OnButtonClick;
|
||||
|
||||
FBtn2 := TBCButton.Create(FPanel);
|
||||
FBtn2.Parent := FPanel;
|
||||
FBtn2.Caption := '2';
|
||||
FBtn2.OnMouseDown := OnButtonClick;
|
||||
|
||||
FBtn3 := TBCButton.Create(FPanel);
|
||||
FBtn3.Parent := FPanel;
|
||||
FBtn3.Caption := '3';
|
||||
FBtn3.OnMouseDown := OnButtonClick;
|
||||
|
||||
FBtn0 := TBCButton.Create(FPanel);
|
||||
FBtn0.Parent := FPanel;
|
||||
FBtn0.Caption := '0';
|
||||
FBtn0.OnMouseDown := OnButtonClick;
|
||||
|
||||
FBtnDot := TBCButton.Create(FPanel);
|
||||
FBtnDot.Parent := FPanel;
|
||||
FBtnDot.Caption := {$IFDEF FPC}DefaultFormatSettings{$ELSE}FormatSettings{$ENDIF}.DecimalSeparator;
|
||||
FBtnDot.OnMouseDown := OnButtonClick;
|
||||
|
||||
FBtnClr := TBCButton.Create(FPanel);
|
||||
FBtnClr.Parent := FPanel;
|
||||
FBtnClr.Caption := 'C';
|
||||
FBtnClr.OnMouseDown := OnButtonClick;
|
||||
end;
|
||||
|
||||
destructor TBCCustomNumericKeyboard.Destroy;
|
||||
begin
|
||||
{ Everything inside the panel will be freed }
|
||||
FPanel.Free;
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
procedure TBCCustomNumericKeyboard.Show(AControl: TWinControl);
|
||||
begin
|
||||
FPanel.Parent := AControl;
|
||||
FVisible := True;
|
||||
end;
|
||||
|
||||
procedure TBCCustomNumericKeyboard.Show;
|
||||
begin
|
||||
if Self.Owner is TWinControl then
|
||||
Show(Self.Owner as TWinControl)
|
||||
else
|
||||
raise Exception.Create('The parent is not TWinControl descendant.');
|
||||
end;
|
||||
|
||||
procedure TBCCustomNumericKeyboard.Hide;
|
||||
begin
|
||||
FPanel.Parent := nil;
|
||||
FVisible := False;
|
||||
end;
|
||||
|
||||
procedure TBCCustomNumericKeyboard.UpdateButtonStyle;
|
||||
begin
|
||||
FBtn0.Assign(FButton);
|
||||
FBtn1.Assign(FButton);
|
||||
FBtn2.Assign(FButton);
|
||||
FBtn3.Assign(FButton);
|
||||
FBtn4.Assign(FButton);
|
||||
FBtn5.Assign(FButton);
|
||||
FBtn6.Assign(FButton);
|
||||
FBtn7.Assign(FButton);
|
||||
FBtn8.Assign(FButton);
|
||||
FBtn9.Assign(FButton);
|
||||
FBtnDot.Assign(FButton);
|
||||
FBtnClr.Assign(FButton);
|
||||
end;
|
||||
|
||||
end.
|
||||
517
bgracontrols/bcpanel.pas
Normal file
517
bgracontrols/bcpanel.pas
Normal file
@@ -0,0 +1,517 @@
|
||||
// SPDX-License-Identifier: LGPL-3.0-linking-exception
|
||||
{ Equivalent of standard lazarus TPanel but using BGRA Controls framework for render
|
||||
|
||||
Functionality:
|
||||
- Customizable background (gradient etc.)
|
||||
- Customizable border (frame 3D or normal border, rounding etc)
|
||||
- FontEx (shadow etc.)
|
||||
|
||||
originally written in 2011 by Krzysztof Dibowski dibowski at interia.pl
|
||||
}
|
||||
{******************************* CONTRIBUTOR(S) ******************************
|
||||
- Edivando S. Santos Brasil | mailedivando@gmail.com
|
||||
(Compatibility with delphi VCL 11/2018)
|
||||
|
||||
***************************** END CONTRIBUTOR(S) *****************************}
|
||||
unit BCPanel;
|
||||
|
||||
{$I bgracontrols.inc}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils, {$IFDEF FPC}LResources,{$ENDIF} Types, Forms, Controls, Graphics, Dialogs,
|
||||
BGRABitmap, BCBaseCtrls, BGRABitmapTypes, BCTypes, LCLVersion;
|
||||
|
||||
type
|
||||
TOnAfterRenderBCPanel = procedure(Sender: TObject; const ABGRA: TBGRABitmap;
|
||||
ARect: TRect) of object;
|
||||
TBCPanelBorderStyle = (bpsBorder, bpsFrame3d);
|
||||
|
||||
{ TCustomBCPanel }
|
||||
|
||||
TCustomBCPanel = class(TBCStyleCustomControl)
|
||||
private
|
||||
{ Private declarations }
|
||||
{$IFDEF INDEBUG}
|
||||
FRenderCount: Integer;
|
||||
{$ENDIF}
|
||||
FBackground: TBCBackground;
|
||||
FBevelWidth: Integer;
|
||||
FBGRA: TBGRABitmapEx;
|
||||
FBevelInner, FBevelOuter : TBevelCut;
|
||||
FBorder: TBCBorder;
|
||||
FBorderBCStyle: TBCPanelBorderStyle;
|
||||
FFontEx: TBCFont;
|
||||
FOnAfterRenderBCPanel: TOnAfterRenderBCPanel;
|
||||
FRounding: TBCRounding;
|
||||
procedure SetBackground(AValue: TBCBackground);
|
||||
procedure SetBevelInner(AValue: TBevelCut);
|
||||
procedure SetBevelOuter(AValue: TBevelCut);
|
||||
procedure SetBevelWidth(AValue: Integer);
|
||||
procedure SetBorder(AValue: TBCBorder);
|
||||
procedure SetBorderBCStyle(AValue: TBCPanelBorderStyle);
|
||||
procedure SetFontEx(AValue: TBCFont);
|
||||
procedure SetRounding(AValue: TBCRounding);
|
||||
procedure Render;
|
||||
procedure OnChangeProperty({%H-}Sender: TObject; {%H-}AData: BGRAPtrInt);
|
||||
procedure OnChangeFont({%H-}Sender: TObject; {%H-}AData: BGRAPtrInt);
|
||||
protected
|
||||
{ Protected declarations }
|
||||
procedure AdjustClientRect(var aRect: TRect); override;
|
||||
class function GetControlClassDefaultSize: TSize; override;
|
||||
function GetDefaultDockCaption: String; override;
|
||||
procedure SetEnabled(Value: boolean); override;
|
||||
procedure TextChanged; override;
|
||||
protected
|
||||
function GetStyleExtension: String; override;
|
||||
{$IFDEF INDEBUG}
|
||||
function GetDebugText: String; override;
|
||||
{$ENDIF}
|
||||
procedure DrawControl; override;
|
||||
procedure RenderControl; override;
|
||||
protected
|
||||
{$IF LCL_FULLVERSION >= 2080000}
|
||||
procedure SetParentBackground(const AParentBackground: Boolean); override;
|
||||
{$ENDIF}
|
||||
property Background: TBCBackground read FBackground write SetBackground;
|
||||
property BevelInner: TBevelCut read FBevelInner write SetBevelInner;
|
||||
property BevelOuter: TBevelCut read FBevelOuter write SetBevelOuter;
|
||||
property BevelWidth: Integer read FBevelWidth write SetBevelWidth;
|
||||
property Border: TBCBorder read FBorder write SetBorder;
|
||||
property BorderBCStyle: TBCPanelBorderStyle
|
||||
read FBorderBCStyle write SetBorderBCStyle default bpsFrame3d;
|
||||
property FontEx: TBCFont read FFontEx write SetFontEx;
|
||||
property Rounding: TBCRounding read FRounding write SetRounding;
|
||||
protected
|
||||
{ Events }
|
||||
property OnAfterRenderBCPanel: TOnAfterRenderBCPanel
|
||||
Read FOnAfterRenderBCPanel Write FOnAfterRenderBCPanel;
|
||||
public
|
||||
{ Public declarations }
|
||||
constructor Create(TheOwner: TComponent); override;
|
||||
destructor Destroy; override;
|
||||
procedure UpdateControl; override; // Called by EndUpdate
|
||||
public
|
||||
{ Streaming }
|
||||
{$IFDEF FPC}
|
||||
procedure SaveToFile(AFileName: string);
|
||||
procedure LoadFromFile(AFileName: string);
|
||||
{$ENDIF}
|
||||
procedure OnFindClass({%H-}Reader: TReader; const AClassName: string;
|
||||
var ComponentClass: TComponentClass);
|
||||
end;
|
||||
|
||||
{ TBCPanel }
|
||||
|
||||
TBCPanel = class(TCustomBCPanel)
|
||||
published
|
||||
property Align;
|
||||
property Anchors;
|
||||
property AssignStyle;
|
||||
property AutoSize;
|
||||
property BorderSpacing;
|
||||
property ChildSizing;
|
||||
{$IFDEF FPC} //#
|
||||
property OnGetDockCaption;
|
||||
{$ENDIF}
|
||||
property Background;
|
||||
property BevelInner;
|
||||
property BevelOuter;
|
||||
property BevelWidth;
|
||||
property Border;
|
||||
property BorderBCStyle;
|
||||
property Caption;
|
||||
property Color;
|
||||
property Constraints;
|
||||
property DockSite;
|
||||
property DragCursor;
|
||||
property DragKind;
|
||||
property DragMode;
|
||||
property Enabled;
|
||||
property FontEx;
|
||||
property ParentBackground;
|
||||
property PopupMenu;
|
||||
property Rounding;
|
||||
property ShowHint;
|
||||
property TabOrder;
|
||||
property TabStop;
|
||||
property UseDockManager default True;
|
||||
property Visible;
|
||||
property OnClick;
|
||||
property OnContextPopup;
|
||||
property OnDockDrop;
|
||||
property OnDockOver;
|
||||
property OnDblClick;
|
||||
property OnDragDrop;
|
||||
property OnDragOver;
|
||||
property OnEndDock;
|
||||
property OnEndDrag;
|
||||
property OnEnter;
|
||||
property OnExit;
|
||||
property OnGetSiteInfo;
|
||||
property OnMouseDown;
|
||||
property OnMouseEnter;
|
||||
property OnMouseLeave;
|
||||
property OnMouseMove;
|
||||
property OnMouseUp;
|
||||
property OnMouseWheel;
|
||||
property OnMouseWheelDown;
|
||||
property OnMouseWheelUp;
|
||||
property OnResize;
|
||||
property OnStartDock;
|
||||
property OnStartDrag;
|
||||
property OnUnDock;
|
||||
property OnAfterRenderBCPanel;
|
||||
end;
|
||||
|
||||
{$IFDEF FPC}procedure Register;{$ENDIF}
|
||||
|
||||
implementation
|
||||
|
||||
uses BCTools;
|
||||
|
||||
{$IFDEF FPC}
|
||||
procedure Register;
|
||||
begin
|
||||
RegisterComponents('BGRA Controls', [TBCPanel]);
|
||||
end;
|
||||
{$ENDIF}
|
||||
|
||||
{ TCustomBCPanel }
|
||||
|
||||
procedure TCustomBCPanel.DrawControl;
|
||||
begin
|
||||
inherited DrawControl;
|
||||
if FBGRA.NeedRender then
|
||||
Render;
|
||||
if Assigned (FRounding) then
|
||||
begin
|
||||
if (FRounding.RoundX<>0) and (FRounding.RoundY<>0) then
|
||||
FBGRA.Draw(Self.Canvas, 0, 0, False)
|
||||
else
|
||||
FBGRA.Draw(Self.Canvas, 0, 0);
|
||||
end
|
||||
else
|
||||
FBGRA.Draw(Self.Canvas, 0, 0);
|
||||
|
||||
{$IFNDEF FPC}//# //@ IN DELPHI RenderControl NEDD. IF NO RenderControl BE BLACK AFTER INVALIDATE.
|
||||
FBGRA.NeedRender := True;
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
procedure TCustomBCPanel.RenderControl;
|
||||
begin
|
||||
inherited RenderControl;
|
||||
if FBGRA<>nil then
|
||||
FBGRA.NeedRender := True;
|
||||
end;
|
||||
|
||||
{$IF LCL_FULLVERSION >= 2080000}
|
||||
procedure TCustomBCPanel.SetParentBackground(const AParentBackground: Boolean);
|
||||
begin
|
||||
if ParentBackground=AParentBackground then
|
||||
Exit;
|
||||
if AParentBackground then
|
||||
ControlStyle := ControlStyle - [csOpaque]
|
||||
else
|
||||
ControlStyle := ControlStyle + [csOpaque];
|
||||
inherited;
|
||||
end;
|
||||
{$ENDIF}
|
||||
|
||||
function TCustomBCPanel.GetStyleExtension: String;
|
||||
begin
|
||||
Result := 'bcpnl';
|
||||
end;
|
||||
|
||||
{$IFDEF INDEBUG}
|
||||
function TCustomBCPanel.GetDebugText: String;
|
||||
begin
|
||||
Result := 'R: '+IntToStr(FRenderCount);
|
||||
end;
|
||||
{$ENDIF}
|
||||
|
||||
procedure TCustomBCPanel.Render;
|
||||
var r: TRect;
|
||||
begin
|
||||
if (csCreating in ControlState) or IsUpdating then
|
||||
Exit;
|
||||
|
||||
FBGRA.NeedRender := False;
|
||||
|
||||
FBGRA.SetSize(Width, Height);
|
||||
FBGRA.Fill(BGRAPixelTransparent);
|
||||
r := FBGRA.ClipRect;
|
||||
|
||||
case FBorderBCStyle of
|
||||
bpsBorder:
|
||||
begin
|
||||
RenderBackgroundAndBorder(FBGRA.ClipRect, FBackground, TBGRABitmap(FBGRA), FRounding, FBorder);
|
||||
CalculateBorderRect(FBorder,r);
|
||||
end;
|
||||
bpsFrame3d:
|
||||
begin
|
||||
// if BevelOuter is set then draw a frame with BevelWidth
|
||||
if (FBevelOuter <> bvNone) and (FBevelWidth > 0) then
|
||||
FBGRA.CanvasBGRA.Frame3d(r, FBevelWidth, FBevelOuter,
|
||||
BGRA(255, 255, 255, 180), BGRA(0, 0, 0, 160)); // Note: Frame3D inflates ARect
|
||||
|
||||
// if BevelInner is set then skip the BorderWidth and draw a frame with BevelWidth
|
||||
if (FBevelInner <> bvNone) and (FBevelWidth > 0) then
|
||||
begin
|
||||
InflateRect(r, -FBevelWidth, -FBevelWidth);
|
||||
FBGRA.CanvasBGRA.Frame3d(r, FBevelWidth, FBevelInner,
|
||||
BGRA(255, 255, 255, 160), BGRA(0, 0, 0, 160)); // Note: Frame3D inflates ARect
|
||||
end;
|
||||
RenderBackground(r, FBackground, TBGRABitmap(FBGRA), nil, True);
|
||||
end;
|
||||
else
|
||||
RenderBackground(FBGRA.ClipRect, FBackground, TBGRABitmap(FBGRA), FRounding, True);
|
||||
end;
|
||||
|
||||
if Caption <> '' then
|
||||
RenderText(r,FFontEx,Caption,TBGRABitmap(FBGRA),Enabled);
|
||||
|
||||
if Assigned(FOnAfterRenderBCPanel) then
|
||||
FOnAfterRenderBCPanel(Self, FBGRA, r);
|
||||
|
||||
{$IFDEF INDEBUG}
|
||||
FRenderCount := FRenderCount + 1;
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
procedure TCustomBCPanel.OnChangeProperty(Sender: TObject; AData: BGRAPtrInt);
|
||||
begin
|
||||
RenderControl;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TCustomBCPanel.OnChangeFont(Sender: TObject; AData: BGRAPtrInt);
|
||||
begin
|
||||
RenderControl;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TCustomBCPanel.SetRounding(AValue: TBCRounding);
|
||||
begin
|
||||
if FRounding = AValue then Exit;
|
||||
FRounding.Assign(AValue);
|
||||
|
||||
RenderControl;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TCustomBCPanel.AdjustClientRect(var aRect: TRect);
|
||||
var BevelSize: Integer;
|
||||
begin
|
||||
inherited AdjustClientRect(aRect);
|
||||
|
||||
BevelSize := BorderWidth;
|
||||
if (BevelOuter <> bvNone) then
|
||||
inc(BevelSize, BevelWidth);
|
||||
if (BevelInner <> bvNone) then
|
||||
inc(BevelSize, BevelWidth);
|
||||
|
||||
InflateRect(aRect, -BevelSize, -BevelSize);
|
||||
end;
|
||||
|
||||
class function TCustomBCPanel.GetControlClassDefaultSize: TSize;
|
||||
begin
|
||||
Result.CX := 170;
|
||||
Result.CY := 50;
|
||||
end;
|
||||
|
||||
function TCustomBCPanel.GetDefaultDockCaption: String;
|
||||
begin
|
||||
Result := Caption;
|
||||
end;
|
||||
|
||||
procedure TCustomBCPanel.SetBackground(AValue: TBCBackground);
|
||||
begin
|
||||
if FBackground = AValue then Exit;
|
||||
FBackground.Assign(AValue);
|
||||
|
||||
RenderControl;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TCustomBCPanel.SetBevelInner(AValue: TBevelCut);
|
||||
begin
|
||||
if FBevelInner = AValue then Exit;
|
||||
FBevelInner := AValue;
|
||||
|
||||
RenderControl;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TCustomBCPanel.SetBevelOuter(AValue: TBevelCut);
|
||||
begin
|
||||
if FBevelOuter = AValue then Exit;
|
||||
FBevelOuter := AValue;
|
||||
|
||||
RenderControl;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TCustomBCPanel.SetBevelWidth(AValue: Integer);
|
||||
begin
|
||||
if FBevelWidth = AValue then Exit;
|
||||
FBevelWidth := AValue;
|
||||
|
||||
RenderControl;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TCustomBCPanel.SetBorder(AValue: TBCBorder);
|
||||
begin
|
||||
if FBorder = AValue then Exit;
|
||||
FBorder.Assign(AValue);
|
||||
|
||||
RenderControl;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TCustomBCPanel.SetBorderBCStyle(AValue: TBCPanelBorderStyle);
|
||||
begin
|
||||
if FBorderBCStyle = AValue then Exit;
|
||||
FBorderBCStyle := AValue;
|
||||
|
||||
RenderControl;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TCustomBCPanel.SetFontEx(AValue: TBCFont);
|
||||
begin
|
||||
if FFontEx = AValue then Exit;
|
||||
FFontEx.Assign(AValue);
|
||||
|
||||
RenderControl;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TCustomBCPanel.SetEnabled(Value: boolean);
|
||||
begin
|
||||
inherited SetEnabled(Value);
|
||||
|
||||
RenderControl;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TCustomBCPanel.TextChanged;
|
||||
begin
|
||||
{$IFDEF FPC}
|
||||
inherited TextChanged;
|
||||
{$ENDIF}
|
||||
|
||||
RenderControl;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
constructor TCustomBCPanel.Create(TheOwner: TComponent);
|
||||
begin
|
||||
inherited Create(TheOwner);
|
||||
{$IFDEF INDEBUG}
|
||||
FRenderCount := 0;
|
||||
{$ENDIF}
|
||||
{$IFDEF FPC}
|
||||
DisableAutoSizing;
|
||||
Include(FControlState, csCreating);
|
||||
{$ELSE} //#
|
||||
|
||||
{$ENDIF}
|
||||
|
||||
BeginUpdate;
|
||||
try
|
||||
ControlStyle := ControlStyle + [csAcceptsControls, csCaptureMouse,
|
||||
csClickEvents, csSetCaption, csDoubleClicks, csReplicatable{$IFDEF FPC},
|
||||
csNoFocus, csAutoSize0x0{$ENDIF}]
|
||||
+ [csOpaque]; // we need the default background
|
||||
//Self.DoubleBuffered := True;
|
||||
with GetControlClassDefaultSize do
|
||||
SetInitialBounds(0, 0, CX, CY);
|
||||
|
||||
FBGRA := TBGRABitmapEx.Create;
|
||||
FBorderBCStyle := bpsFrame3d;
|
||||
FBackground := TBCBackground.Create(Self);
|
||||
FBorder := TBCBorder.Create(Self);
|
||||
FFontEx := TBCFont.Create(Self);
|
||||
FBevelOuter := bvRaised;
|
||||
FBevelInner := bvNone;
|
||||
FBevelWidth := 1;
|
||||
ParentColor := True;
|
||||
UseDockManager := True;
|
||||
|
||||
FBackground.OnChange := OnChangeProperty;
|
||||
FBorder.OnChange := OnChangeProperty;
|
||||
FFontEx.OnChange := OnChangeFont;
|
||||
|
||||
FBackground.Style := bbsColor;
|
||||
FBackground.Color := {$ifdef UseCLDefault}clDefault{$else}clBtnFace{$endif};
|
||||
FBorder.Style := bboNone;
|
||||
|
||||
FRounding := TBCRounding.Create(Self);
|
||||
FRounding.OnChange := OnChangeProperty;
|
||||
finally
|
||||
{$IFDEF FPC}
|
||||
EnableAutoSizing;
|
||||
{$ENDIF}
|
||||
EndUpdate;
|
||||
{$IFDEF FPC}
|
||||
Exclude(FControlState, csCreating);
|
||||
{$ELSE} //#
|
||||
{$ENDIF}
|
||||
end;
|
||||
end;
|
||||
|
||||
destructor TCustomBCPanel.Destroy;
|
||||
begin
|
||||
FBackground.Free;
|
||||
FBorder.Free;
|
||||
FFontEx.Free;
|
||||
FBGRA.Free;
|
||||
FRounding.Free;
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
procedure TCustomBCPanel.UpdateControl;
|
||||
begin
|
||||
Render;
|
||||
inherited UpdateControl; // invalidate
|
||||
end;
|
||||
{$IFDEF FPC}
|
||||
procedure TCustomBCPanel.SaveToFile(AFileName: string);
|
||||
var
|
||||
AStream: TMemoryStream;
|
||||
begin
|
||||
AStream := TMemoryStream.Create;
|
||||
try
|
||||
WriteComponentAsTextToStream(AStream, Self);
|
||||
AStream.SaveToFile(AFileName);
|
||||
finally
|
||||
AStream.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TCustomBCPanel.LoadFromFile(AFileName: string);
|
||||
var
|
||||
AStream: TMemoryStream;
|
||||
begin
|
||||
AStream := TMemoryStream.Create;
|
||||
try
|
||||
AStream.LoadFromFile(AFileName);
|
||||
ReadComponentFromTextStream(AStream, TComponent(Self), OnFindClass);
|
||||
finally
|
||||
AStream.Free;
|
||||
end;
|
||||
end;
|
||||
{$ENDIF}
|
||||
|
||||
procedure TCustomBCPanel.OnFindClass(Reader: TReader; const AClassName: string;
|
||||
var ComponentClass: TComponentClass);
|
||||
begin
|
||||
if CompareText(AClassName, 'TBCPanel') = 0 then
|
||||
ComponentClass := TBCPanel;
|
||||
end;
|
||||
|
||||
end.
|
||||
334
bgracontrols/bcradialprogressbar.pas
Normal file
334
bgracontrols/bcradialprogressbar.pas
Normal file
@@ -0,0 +1,334 @@
|
||||
// SPDX-License-Identifier: LGPL-3.0-linking-exception
|
||||
{******************************* CONTRIBUTOR(S) ******************************
|
||||
- Edivando S. Santos Brasil | mailedivando@gmail.com
|
||||
(Compatibility with delphi VCL 11/2018)
|
||||
|
||||
***************************** END CONTRIBUTOR(S) *****************************}
|
||||
unit BCRadialProgressBar;
|
||||
|
||||
{$I bgracontrols.inc}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils, {$IFDEF FPC}LResources,{$ENDIF} Forms, Controls, Graphics, Dialogs, BCBaseCtrls,
|
||||
{$IFNDEF FPC}Types, BGRAGraphics, GraphType, FPImage, {$ENDIF}
|
||||
BGRABitmap, BGRABitmapTypes, BGRATextFX;
|
||||
|
||||
type
|
||||
|
||||
{ TBCRadialProgressBar }
|
||||
|
||||
TBCRadialProgressBar = class(TBCGraphicControl)
|
||||
private
|
||||
FDrawText: boolean;
|
||||
{ Private declarations }
|
||||
FMaxValue: integer;
|
||||
FMinValue: integer;
|
||||
FRotation: single;
|
||||
FValue: integer;
|
||||
FBitmap: TBGRABitmap;
|
||||
FLineColor: TColor;
|
||||
FLineBkgColor: TColor;
|
||||
FFontShadowColor: TColor;
|
||||
FFontShadowOffsetX: integer;
|
||||
FFontShadowOffsetY: integer;
|
||||
FFontShadowRadius: integer;
|
||||
FLineWidth: single;
|
||||
procedure SetDrawText(AValue: boolean);
|
||||
procedure SetFFontShadowColor(AValue: TColor);
|
||||
procedure SetFFontShadowOffsetX(AValue: integer);
|
||||
procedure SetFFontShadowOffsetY(AValue: integer);
|
||||
procedure SetFFontShadowRadius(AValue: integer);
|
||||
procedure SetFLineBkgColor(AValue: TColor);
|
||||
procedure SetFLineColor(AValue: TColor);
|
||||
procedure SetMaxValue(AValue: integer);
|
||||
procedure SetMinValue(AValue: integer);
|
||||
procedure SetRotation(AValue: single);
|
||||
procedure SetValue(AValue: integer);
|
||||
procedure SetLineWidth(AValue: single);
|
||||
protected
|
||||
{ Protected declarations }
|
||||
procedure CalculatePreferredSize(var PreferredWidth, PreferredHeight: integer;
|
||||
{%H-}WithThemeSpace: boolean); override;
|
||||
procedure DrawControl; override;
|
||||
procedure RenderControl; override;
|
||||
procedure SetColor(Value: TColor); override;
|
||||
public
|
||||
{ Public declarations }
|
||||
constructor Create(AOwner: TComponent); override;
|
||||
destructor Destroy; override;
|
||||
property Rotation: single read FRotation write SetRotation default 0;
|
||||
property DrawText: boolean read FDrawText write SetDrawText default true;
|
||||
published
|
||||
{ Published declarations }
|
||||
property Align;
|
||||
property Anchors;
|
||||
property MinValue: integer read FMinValue write SetMinValue default 0;
|
||||
property MaxValue: integer read FMaxValue write SetMaxValue default 100;
|
||||
property Value: integer read FValue write SetValue default 0;
|
||||
property OnClick;
|
||||
property OnMouseDown;
|
||||
property OnMouseEnter;
|
||||
property OnMouseLeave;
|
||||
property OnMouseMove;
|
||||
property OnMouseUp;
|
||||
property OnMouseWheel;
|
||||
property OnMouseWheelUp;
|
||||
property OnMouseWheelDown;
|
||||
property Color default clWhite;
|
||||
property LineColor: TColor read FLineColor write SetFLineColor default clBlack;
|
||||
property LineBkgColor: TColor read FLineBkgColor write SetFLineBkgColor default
|
||||
clSilver;
|
||||
property LineWidth: single read FLineWidth write SetLineWidth {$IFDEF FPC}default 4{$ENDIF};
|
||||
property FontShadowColor: TColor read FFontShadowColor
|
||||
write SetFFontShadowColor default clBlack;
|
||||
property FontShadowOffsetX: integer read FFontShadowOffsetX
|
||||
write SetFFontShadowOffsetX default 2;
|
||||
property FontShadowOffsetY: integer read FFontShadowOffsetY
|
||||
write SetFFontShadowOffsetY default 2;
|
||||
property FontShadowRadius: integer read FFontSHadowRadius
|
||||
write SetFFontShadowRadius default 4;
|
||||
property Font;
|
||||
end;
|
||||
|
||||
{$IFDEF FPC}procedure Register;{$ENDIF}
|
||||
|
||||
implementation
|
||||
|
||||
{$IFDEF FPC}
|
||||
procedure Register;
|
||||
begin
|
||||
{$IFDEF FPC}
|
||||
{$I icons\bcradialprogressbar_icon.lrs}
|
||||
{$ENDIF}
|
||||
RegisterComponents('BGRA Controls', [TBCRadialProgressBar]);
|
||||
end;
|
||||
{$ENDIF}
|
||||
|
||||
{ TBCRadialProgressBar }
|
||||
|
||||
procedure TBCRadialProgressBar.SetMaxValue(AValue: integer);
|
||||
begin
|
||||
if FMaxValue = AValue then
|
||||
exit;
|
||||
FMaxValue := AValue;
|
||||
if FValue > FMaxValue then
|
||||
FValue := FMaxValue;
|
||||
if FMinValue > FMaxValue then
|
||||
FMinValue := FMaxValue;
|
||||
RenderControl;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBCRadialProgressBar.SetFLineBkgColor(AValue: TColor);
|
||||
begin
|
||||
if FLineBkgColor = AValue then
|
||||
Exit;
|
||||
FLineBkgColor := AValue;
|
||||
RenderControl;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBCRadialProgressBar.SetFFontShadowColor(AValue: TColor);
|
||||
begin
|
||||
if FFontShadowColor = AValue then
|
||||
Exit;
|
||||
FFontShadowColor := AValue;
|
||||
RenderControl;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBCRadialProgressBar.SetDrawText(AValue: boolean);
|
||||
begin
|
||||
if FDrawText=AValue then Exit;
|
||||
FDrawText:=AValue;
|
||||
RenderControl;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBCRadialProgressBar.SetFFontShadowOffsetX(AValue: integer);
|
||||
begin
|
||||
if FFontShadowOffsetX = AValue then
|
||||
Exit;
|
||||
FFontShadowOffsetX := AValue;
|
||||
RenderControl;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBCRadialProgressBar.SetFFontShadowOffsetY(AValue: integer);
|
||||
begin
|
||||
if FFontShadowOffsetY = AValue then
|
||||
Exit;
|
||||
FFontShadowOffsetY := AValue;
|
||||
RenderControl;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBCRadialProgressBar.SetFFontShadowRadius(AValue: integer);
|
||||
begin
|
||||
if FFontSHadowRadius = AValue then
|
||||
Exit;
|
||||
FFontSHadowRadius := AValue;
|
||||
RenderControl;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBCRadialProgressBar.SetFLineColor(AValue: TColor);
|
||||
begin
|
||||
if FLineColor = AValue then
|
||||
Exit;
|
||||
FLineColor := AValue;
|
||||
RenderControl;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBCRadialProgressBar.SetMinValue(AValue: integer);
|
||||
begin
|
||||
if FMinValue = AValue then
|
||||
exit;
|
||||
FMinValue := AValue;
|
||||
if FValue < FMinValue then
|
||||
FValue := FMinValue;
|
||||
if FMaxValue < FMinValue then
|
||||
FMaxValue := FMinValue;
|
||||
RenderControl;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBCRadialProgressBar.SetRotation(AValue: single);
|
||||
begin
|
||||
if FRotation=AValue then Exit;
|
||||
FRotation:=AValue;
|
||||
RenderControl;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBCRadialProgressBar.SetValue(AValue: integer);
|
||||
begin
|
||||
if FValue = AValue then
|
||||
exit;
|
||||
FValue := AValue;
|
||||
if FValue < FMinValue then
|
||||
FValue := FMinValue;
|
||||
if FValue > FMaxValue then
|
||||
FValue := FMaxValue;
|
||||
RenderControl;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBCRadialProgressBar.SetLineWidth(AValue: single);
|
||||
begin
|
||||
if (FLineWidth = AValue) then
|
||||
exit;
|
||||
FLineWidth := AValue;
|
||||
RenderControl;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBCRadialProgressBar.CalculatePreferredSize(
|
||||
var PreferredWidth, PreferredHeight: integer; WithThemeSpace: boolean);
|
||||
begin
|
||||
PreferredWidth := 200;
|
||||
PreferredHeight := 200;
|
||||
end;
|
||||
|
||||
procedure TBCRadialProgressBar.DrawControl;
|
||||
begin
|
||||
{$IFNDEF FPC}//# //@ IN DELPHI RenderControl NEDD. IF NO RenderControl BE BLACK AFTER INVALIDATE.
|
||||
RenderControl;
|
||||
{$ENDIF}
|
||||
FBitmap.Draw(Canvas, 0, 0, False);
|
||||
end;
|
||||
|
||||
procedure TBCRadialProgressBar.RenderControl;
|
||||
var
|
||||
textBmp: TBGRABitmap;
|
||||
textStr: string;
|
||||
EffectiveLineWidth:single;
|
||||
begin
|
||||
FreeAndNil(FBitmap);
|
||||
FBitmap := TBGRABitmap.Create(Width, Height);
|
||||
|
||||
FBitmap.Canvas2D.resetTransform;
|
||||
FBitmap.Canvas2D.translate(FBitmap.Width/2, FBitmap.Height/2);
|
||||
FBitmap.Canvas2D.rotate(FRotation*Pi/180);
|
||||
|
||||
FBitmap.Canvas2D.beginPath;
|
||||
FBitmap.Canvas2D.arc(0, 0, Height / 2.5, 0, pi * 2, False);
|
||||
FBitmap.Canvas2D.fillStyle(Color);
|
||||
FBitmap.Canvas2D.fill;
|
||||
|
||||
if LineWidth=0 then
|
||||
EffectiveLineWidth:=Height / 50
|
||||
else
|
||||
EffectiveLineWidth:=LineWidth;
|
||||
|
||||
FBitmap.Canvas2D.lineWidth := EffectiveLineWidth;
|
||||
FBitmap.Canvas2D.strokeStyle(LineBkgColor);
|
||||
FBitmap.Canvas2D.stroke;
|
||||
|
||||
FBitmap.Canvas2D.beginPath;
|
||||
if Value <> MinValue then
|
||||
FBitmap.Canvas2D.arc(0, 0, Height / 2.5, pi * 1.5,
|
||||
(pi * 1.5) + ((pi * 2) * Value / MaxValue), False);
|
||||
FBitmap.Canvas2D.fillStyle(BGRAPixelTransparent);
|
||||
FBitmap.Canvas2D.fill;
|
||||
|
||||
FBitmap.Canvas2D.lineWidth := EffectiveLineWidth;
|
||||
FBitmap.Canvas2D.strokeStyle(LineColor);
|
||||
FBitmap.Canvas2D.stroke;
|
||||
|
||||
if MaxValue = 0 then
|
||||
textStr := '0%'
|
||||
else
|
||||
textStr := FloatToStr(Round((Value / MaxValue) * 100)) + '%';
|
||||
|
||||
if DrawText then
|
||||
begin
|
||||
textBmp := TextShadow(Width, Height, textStr, Font.Height,
|
||||
Font.Color, FontShadowColor, FontShadowOFfsetX,
|
||||
FontShadowOffsetY, FontSHadowRadius, Font.Style, Font.Name) as TBGRABitmap;
|
||||
|
||||
FBitmap.PutImage(0, 0, textBmp, dmDrawWithTransparency);
|
||||
textBmp.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TBCRadialProgressBar.SetColor(Value: TColor);
|
||||
begin
|
||||
inherited SetColor(Value);
|
||||
RenderControl;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
constructor TBCRadialProgressBar.Create(AOwner: TComponent);
|
||||
begin
|
||||
inherited Create(AOwner);
|
||||
|
||||
with GetControlClassDefaultSize do
|
||||
SetInitialBounds(0, 0, 200, 200);
|
||||
FMaxValue := 100;
|
||||
FMinValue := 0;
|
||||
FValue := 0;
|
||||
FLineColor := clBlack;
|
||||
FLineBkgColor := clSilver;
|
||||
FLineWidth:=0;
|
||||
FFontShadowColor := clBlack;
|
||||
FFontShadowOffsetX := 2;
|
||||
FFontShadowOffsetY := 2;
|
||||
FFontShadowRadius := 4;
|
||||
Font.Color := clBlack;
|
||||
Font.Height := 20;
|
||||
Color := clWhite;
|
||||
FRotation := 0;
|
||||
FDrawText := True;
|
||||
end;
|
||||
|
||||
destructor TBCRadialProgressBar.Destroy;
|
||||
begin
|
||||
FreeAndNil(FBitmap);
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
end.
|
||||
55
bgracontrols/bcreg.pas
Normal file
55
bgracontrols/bcreg.pas
Normal file
@@ -0,0 +1,55 @@
|
||||
// SPDX-License-Identifier: LGPL-3.0-linking-exception
|
||||
{******************************* CONTRIBUTOR(S) ******************************
|
||||
- Edivando S. Santos Brasil | mailedivando@gmail.com
|
||||
(Compatibility with delphi VCL 11/2018)
|
||||
|
||||
***************************** END CONTRIBUTOR(S) *****************************}
|
||||
unit bcReg;
|
||||
|
||||
{$I bgracontrols.inc}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils, BCBaseCtrls,
|
||||
BCButton, BCButtonFocus, BCEffect, bcfilters, BCGameGrid, BCImageButton,
|
||||
BCLabel, BCListBox, BCMaterialDesignButton, BCPanel, BCRadialProgressBar,
|
||||
BCRTTI, BCSamples, BCStylesForm, BCSVGButton, BCSVGViewer, BCToolBar,
|
||||
BCTrackbarUpdown, BGRAFlashProgressBar, BGRAGraphicControl,
|
||||
BGRAImageList, BGRAImageManipulation, BGRAKnob, BGRAResizeSpeedButton,
|
||||
BGRAShape, BGRASpeedButton, BGRASpriteAnimation, BGRAVirtualScreen,
|
||||
ColorSpeedButton, DTAnalogClock, DTAnalogGauge, dtthemedclock,
|
||||
dtthemedgauge, MaterialColors, bcmdbutton, bcmdbuttonfocus;
|
||||
|
||||
procedure Register;
|
||||
|
||||
implementation
|
||||
|
||||
procedure Register;
|
||||
begin
|
||||
{$R images\bgracontrols_images.res}
|
||||
|
||||
RegisterNoIcon([TBCCustomControl]);
|
||||
// RegisterComponents('BGRA Custom Drawn', [TBCDButton, TBCDEdit,
|
||||
// TBCDStaticText, TBCDProgressBar, TBCDSpinEdit, TBCDCheckBox, TBCDRadioButton, TBCDPanel]);
|
||||
|
||||
RegisterComponents('BGRA Controls', [TBGRAShape, TBCListBox, TBCPaperPanel, TBCPaperListBox,
|
||||
TBCButton, TBCButtonFocus, TDTThemedGauge, TBCLabel, TBCImageButton, TBCXButton, TBCGameGrid,
|
||||
TDTThemedClock, TDTAnalogGauge, TDTAnalogClock, TColorSpeedButton,
|
||||
TBGRAVirtualScreen, TBGRASpriteAnimation, TBGRASpeedButton, TBGRAResizeSpeedButton,
|
||||
TBGRAKnob, TBGRAImageManipulation, TBGRAImageList, TBGRAGraphicControl, TBGRAFlashProgressBar,
|
||||
TBCTrackbarUpdown, TBCToolBar, TBCSVGViewer, TBCSVGButton, TBCRadialProgressBar,
|
||||
TBCPanel,TBCMDButtonFocus, TBCMDButton, TBCMaterialDesignButton
|
||||
{TBCDefaultThemeManager, TBCKeyboard, TBCNumericKeyboard, TBCRealNumericKeyboard}]);
|
||||
|
||||
|
||||
{$IFDEF FPC}
|
||||
RegisterPropertyEditor(TypeInfo(TBCListBox),TBCPaperListBox, 'ListBox', TClassPropertyEditor);
|
||||
RegisterPropertyEditor(TypeInfo(integer), TBCButton,'ImageIndex', TBCButtonImageIndexPropertyEditor);
|
||||
RegisterPropertyEditor(TypeInfo(integer), TBCButtonFocus,'ImageIndex', TBCButtonImageIndexPropertyEditor);
|
||||
RegisterPropertyEditor(TypeInfo(TBCListBox), TBCPaperListBox, 'ListBox', TClassPropertyEditor);
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
end.
|
||||
|
||||
170
bgracontrols/bcroundedimage.pas
Normal file
170
bgracontrols/bcroundedimage.pas
Normal file
@@ -0,0 +1,170 @@
|
||||
// SPDX-License-Identifier: LGPL-3.0-linking-exception
|
||||
{
|
||||
BCRoundedImage
|
||||
by Lainz
|
||||
|
||||
Last modified: 2020-09-06 19:16 GMT-3
|
||||
|
||||
Changelog:
|
||||
- 2020-09-06: Initial version supporting circle, rounded rectangle and square.
|
||||
Changing the quality of the resample, setting the rounding.
|
||||
OnPaintEvent to customize the final drawing.
|
||||
}
|
||||
unit BCRoundedImage;
|
||||
|
||||
{$mode objfpc}{$H+}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs,
|
||||
BGRABitmap, BGRABitmapTypes;
|
||||
|
||||
type
|
||||
TBCRoundedImage = class;
|
||||
|
||||
// Event to draw before the image is sent to canvas
|
||||
TBCRoundedImagePaintEvent = procedure (const Sender: TBCRoundedImage; const Bitmap: TBGRABitmap) of object;
|
||||
// Supported styles are circle, rounded rectangle and square
|
||||
TBCRoundedImageStyle = (isCircle, isRoundedRectangle, isSquare);
|
||||
|
||||
// Control that draws an image within a rounded border
|
||||
|
||||
{ TBCRoundedImage }
|
||||
|
||||
TBCRoundedImage = class(TGraphicControl)
|
||||
private
|
||||
FBorderStyle: TRoundRectangleOptions;
|
||||
FOnPaintEvent: TBCRoundedImagePaintEvent;
|
||||
FPicture: TPicture;
|
||||
FQuality: TResampleFilter;
|
||||
FStyle: TBCRoundedImageStyle;
|
||||
FRounding: single;
|
||||
procedure SetBorderStyle(AValue: TRoundRectangleOptions);
|
||||
procedure SetPicture(AValue: TPicture);
|
||||
procedure SetQuality(AValue: TResampleFilter);
|
||||
procedure SetStyle(AValue: TBCRoundedImageStyle);
|
||||
procedure SetRounding(AValue: single);
|
||||
protected
|
||||
public
|
||||
constructor Create(AOwner: TComponent); override;
|
||||
destructor Destroy; override;
|
||||
procedure Paint; override;
|
||||
published
|
||||
// The image that's used as background
|
||||
property Picture: TPicture read FPicture write SetPicture;
|
||||
// The style can be circle, rounded rectangle or square
|
||||
property Style: TBCRoundedImageStyle read FStyle write SetStyle;
|
||||
// The style of the rounded rectangle
|
||||
property BorderStyle: TRoundRectangleOptions read FBorderStyle write SetBorderStyle;
|
||||
// Rounding is used when you choose the rounded rectangle style
|
||||
property Rounding: single read FRounding write SetRounding;
|
||||
// The quality when resizing the image
|
||||
property Quality: TResampleFilter read FQuality write SetQuality;
|
||||
// You can paint before the bitmap is drawn on canvas
|
||||
property OnPaintEvent: TBCRoundedImagePaintEvent read FOnPaintEvent write FOnPaintEvent;
|
||||
published
|
||||
property Anchors;
|
||||
property Align;
|
||||
property OnMouseEnter;
|
||||
property OnMouseLeave;
|
||||
property OnClick;
|
||||
end;
|
||||
|
||||
procedure Register;
|
||||
|
||||
implementation
|
||||
|
||||
procedure Register;
|
||||
begin
|
||||
RegisterComponents('BGRA Controls', [TBCRoundedImage]);
|
||||
end;
|
||||
|
||||
procedure TBCRoundedImage.SetPicture(AValue: TPicture);
|
||||
begin
|
||||
if FPicture = AValue then
|
||||
Exit;
|
||||
FPicture := AValue;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBCRoundedImage.SetBorderStyle(AValue: TRoundRectangleOptions);
|
||||
begin
|
||||
if FBorderStyle=AValue then Exit;
|
||||
FBorderStyle:=AValue;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBCRoundedImage.SetQuality(AValue: TResampleFilter);
|
||||
begin
|
||||
if FQuality = AValue then
|
||||
Exit;
|
||||
FQuality := AValue;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBCRoundedImage.SetStyle(AValue: TBCRoundedImageStyle);
|
||||
begin
|
||||
if FStyle = AValue then
|
||||
Exit;
|
||||
FStyle := AValue;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBCRoundedImage.SetRounding(AValue: single);
|
||||
begin
|
||||
if FRounding = AValue then
|
||||
Exit;
|
||||
FRounding := AValue;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
constructor TBCRoundedImage.Create(AOwner: TComponent);
|
||||
begin
|
||||
inherited Create(AOwner);
|
||||
FPicture := TPicture.Create;
|
||||
FRounding := 10;
|
||||
FQuality := rfBestQuality;
|
||||
end;
|
||||
|
||||
destructor TBCRoundedImage.Destroy;
|
||||
begin
|
||||
FPicture.Free;
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
procedure TBCRoundedImage.Paint;
|
||||
var
|
||||
bgra: TBGRABitmap;
|
||||
image: TBGRABitmap;
|
||||
begin
|
||||
if (FPicture.Width = 0) or (FPicture.Height = 0) then
|
||||
Exit;
|
||||
// Picture
|
||||
image := TBGRABitmap.Create(FPicture.Bitmap);
|
||||
bgra := TBGRABitmap.Create(Width, Height, BGRAPixelTransparent);
|
||||
try
|
||||
// Quality
|
||||
image.ResampleFilter := FQuality;
|
||||
BGRAReplace(image, image.Resample(Width, Height));
|
||||
// Style
|
||||
case FStyle of
|
||||
isCircle: bgra.FillEllipseAntialias(Width div 2, Height div 2,
|
||||
Width div 2, Height div 2, image);
|
||||
// Rounding, BorderStyle
|
||||
isRoundedRectangle: bgra.FillRoundRectAntialias(0, 0, Width,
|
||||
Height, FRounding, FRounding, image, FBorderStyle);
|
||||
else
|
||||
bgra.PutImage(0, 0, image, dmDrawWithTransparency);
|
||||
end;
|
||||
// OnPaintEvent
|
||||
if Assigned(FOnPaintEvent) then
|
||||
FOnPaintEvent(Self, bgra);
|
||||
bgra.Draw(Canvas, 0, 0, False);
|
||||
finally
|
||||
bgra.Free;
|
||||
image.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
end.
|
||||
340
bgracontrols/bcrtti.pas
Normal file
340
bgracontrols/bcrtti.pas
Normal file
@@ -0,0 +1,340 @@
|
||||
// SPDX-License-Identifier: LGPL-3.0-linking-exception
|
||||
{ Useful tools for RTTI. Functions are used expecialy for save/load styles.
|
||||
Styles has construction similar to INI files:
|
||||
|
||||
[Header]
|
||||
Author=Krzysztof Dibowski
|
||||
Description=My test style
|
||||
ControlClass=TBCButton
|
||||
|
||||
[Properties]
|
||||
State.Border.Width=2
|
||||
.....
|
||||
|
||||
But instead of IniFiles unit, we have own functions for read and write styles.
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
originally written in 2012 by Krzysztof Dibowski dibowski at interia.pl
|
||||
}
|
||||
{******************************* CONTRIBUTOR(S) ******************************
|
||||
- Edivando S. Santos Brasil | mailedivando@gmail.com
|
||||
(Compatibility with delphi VCL 11/2018)
|
||||
|
||||
***************************** END CONTRIBUTOR(S) *****************************}
|
||||
unit BCRTTI;
|
||||
|
||||
{$I bgracontrols.inc}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes;
|
||||
|
||||
type
|
||||
PBCStyleHeader = ^TBCStyleHeader;
|
||||
TBCStyleHeader = record
|
||||
Author: String;
|
||||
ControlClass: String;
|
||||
Description: String;
|
||||
end;
|
||||
|
||||
// Function return data of specified section (header, properties, etc).
|
||||
// This is smart function, because it doesn't read whole file but read file
|
||||
// line by line and return only needed section. So it should fastest for reading
|
||||
// header info instead of TIniFile object which read, parse and index all file.
|
||||
function GetSectionData(const AFileName, ASectionName: String): TStrings;
|
||||
// Methods which read header from list or file and parse it into pascal record
|
||||
procedure GetStyleHeader(const AFileName: String; AOutHeader: PBCStyleHeader);
|
||||
// Function check if specified name is on ignored list
|
||||
function IsPropIgnored(const AName: String): Boolean;
|
||||
// Method load style saved by SaveStyle method
|
||||
procedure LoadStyle(AControl: TObject; const AFileName: String; ALogs: TStrings = nil);
|
||||
// Method save all (which are not on ignored list or readonly) public propertys to
|
||||
// the output string list. This method have support for property
|
||||
// tree (Propert1.Subpropert1.Color = 543467). Values are represented as "human readable"
|
||||
// (e.g. Align = alClient). Header info is save too.
|
||||
procedure SaveStyle(AControl: TObject; const AAuthor, ADescription: String;
|
||||
ATargetList: TStrings);
|
||||
|
||||
implementation
|
||||
|
||||
uses typinfo, variants, sysutils, {%H-}strutils;
|
||||
|
||||
const
|
||||
tIGNORED_PROPS: array[0..5] of string =
|
||||
('name','caption','left','top','height','width');
|
||||
sSECTION_HEADER_NAME = 'HEADER';
|
||||
sSECTION_PROP_NAME = 'PROPERTIES';
|
||||
sSECTION_HEADER = '['+sSECTION_HEADER_NAME+']';
|
||||
sSECTION_PROP = '['+sSECTION_PROP_NAME+']';
|
||||
|
||||
procedure RemovePadChars(var S: String; const CSet: TSysCharset);
|
||||
var
|
||||
I,J,K: LONGINT;
|
||||
begin
|
||||
I:=Length(S);
|
||||
IF (I>0) Then
|
||||
Begin
|
||||
J:=I;
|
||||
While (j>0) and (S[J] IN CSet) DO DEC(J);
|
||||
if j=0 Then
|
||||
begin
|
||||
s:='';
|
||||
exit;
|
||||
end;
|
||||
k:=1;
|
||||
While (k<=I) And (S[k] IN CSet) DO
|
||||
INC(k);
|
||||
IF k>1 Then
|
||||
begin
|
||||
move(s[k],s[1],j-k+1);
|
||||
setlength(s,j-k+1);
|
||||
end
|
||||
else
|
||||
setlength(s,j);
|
||||
end;
|
||||
end;
|
||||
|
||||
function TrimSet(const S: String;const CSet:TSysCharSet): String;
|
||||
begin
|
||||
result:=s;
|
||||
RemovePadChars(result,cset);
|
||||
end;
|
||||
|
||||
function IsPropIgnored(const AName: String): Boolean;
|
||||
var
|
||||
i: Integer;
|
||||
begin
|
||||
Result := False;
|
||||
for i := Low(tIGNORED_PROPS) to High(tIGNORED_PROPS) do
|
||||
if SameText(tIGNORED_PROPS[i],Trim(AName)) then
|
||||
Exit(True);
|
||||
end;
|
||||
|
||||
procedure LoadStyle(AControl: TObject; const AFileName: String;
|
||||
ALogs: TStrings = nil);
|
||||
var
|
||||
i, iDot: Integer;
|
||||
sPath, sVal: String;
|
||||
obj: TObject;
|
||||
sl: TStrings;
|
||||
const
|
||||
sLOG_NO_PROP = 'Can not find property "%s"';
|
||||
sLOG_SET_ERR = 'Can not set value "%s" to property "%s"';
|
||||
sLOG_READ_ONLY = 'Property "%s" is read-only';
|
||||
|
||||
procedure _AddLog(const AText: String);
|
||||
begin
|
||||
if ALogs<>nil then
|
||||
ALogs.Add(AText);
|
||||
end;
|
||||
|
||||
function _ValidateProp(AObj: TObject; const APropName: String): Boolean;
|
||||
begin
|
||||
Result := True;
|
||||
// If can't find property
|
||||
if not IsPublishedProp(AObj,APropName) then
|
||||
begin
|
||||
_AddLog(Format(sLOG_NO_PROP,[APropName]));
|
||||
Exit(False);
|
||||
end;
|
||||
// If read-only property
|
||||
if (GetPropInfo(AObj,APropName)^.SetProc=nil) then
|
||||
begin
|
||||
_AddLog(Format(sLOG_READ_ONLY,[APropName]));
|
||||
Exit(False);
|
||||
end;
|
||||
end;
|
||||
|
||||
begin
|
||||
if not FileExists(AFileName) then
|
||||
Exit;
|
||||
|
||||
if ALogs<>nil then
|
||||
ALogs.Clear;
|
||||
|
||||
sl := GetSectionData(AFileName, sSECTION_PROP_NAME);
|
||||
try
|
||||
for i:=0 to Pred(sl.Count) do
|
||||
begin
|
||||
// Full path with hierarchy tree
|
||||
sPath := Trim(sl.Names[i]);
|
||||
// "Human readable" value
|
||||
sVal := Trim(sl.ValueFromIndex[i]);
|
||||
iDot := Pos('.', sPath);
|
||||
// If simple property then write it value
|
||||
if iDot=0 then
|
||||
begin
|
||||
if not _ValidateProp(AControl,sPath) then
|
||||
Continue;
|
||||
// Writting property value
|
||||
try
|
||||
SetPropValue(AControl,sPath,sVal)
|
||||
except
|
||||
_AddLog(Format(sLOG_SET_ERR,[sVal, sPath]));
|
||||
end
|
||||
end
|
||||
else
|
||||
begin
|
||||
//... else we must go down in hierarchy tree to the last
|
||||
// object and then write value to property
|
||||
obj := AControl;
|
||||
while iDot>0 do
|
||||
begin
|
||||
if not _ValidateProp(obj,Copy(sPath,1,iDot-1)) then
|
||||
begin
|
||||
obj := nil;
|
||||
Break;
|
||||
end;
|
||||
|
||||
obj := GetObjectProp(obj,Copy(sPath,1,iDot-1));
|
||||
|
||||
Delete(sPath,1,iDot);
|
||||
iDot := Pos('.', sPath);
|
||||
end;
|
||||
|
||||
// If no dots, then this word is property name
|
||||
if (obj<>nil) and (sPath<>'') and _ValidateProp(obj,sPath) then
|
||||
begin
|
||||
try
|
||||
SetPropValue(obj,sPath,sVal)
|
||||
except
|
||||
_AddLog(Format(sLOG_SET_ERR,[sVal, sPath]));
|
||||
end
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
finally
|
||||
sl.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure SaveStyle(AControl: TObject; const AAuthor, ADescription: String;
|
||||
ATargetList: TStrings);
|
||||
|
||||
procedure _SaveProp(AObj: TObject; APath: String = '');
|
||||
var
|
||||
iCount, i: Integer;
|
||||
lst: TPropList;
|
||||
s: String;
|
||||
begin
|
||||
if AObj=nil then Exit;
|
||||
|
||||
iCount := GetPropList(PTypeInfo(AObj.ClassInfo), tkProperties, @lst);
|
||||
for i := 0 to Pred(iCount) do
|
||||
{ Notice:
|
||||
- IsPublishedProp return true for ALL public properties, not only
|
||||
for properties in Published section. For saving styles, we don't need
|
||||
all public properties, but only published (visible in object inspector).
|
||||
I don't know if this is a bug, I leave it. Maybe it will start
|
||||
working in future ;)
|
||||
- Second argument check if property should be ignored (but only from root tree),
|
||||
because we can't save basic properties of control like Name, Top, Left etc.
|
||||
- SetProc<>nil mean "not read only"
|
||||
}
|
||||
if IsPublishedProp(AObj,lst[i]^.Name) and
|
||||
((AControl<>AObj) or (not IsPropIgnored(lst[i]^.Name))) and
|
||||
(lst[i]^.SetProc<>nil)
|
||||
then
|
||||
begin
|
||||
// Building property tree
|
||||
if APath=''
|
||||
then s := lst[i]^.Name
|
||||
else s := APath+'.'+lst[i]^.Name;
|
||||
|
||||
// If property has subproperty, then we start recurrence to
|
||||
// build hierarchy tree.
|
||||
if (lst[i]^.PropType^.Kind = tkClass) then
|
||||
_SaveProp(GetObjectProp(AObj,lst[i]),s)
|
||||
else
|
||||
begin
|
||||
// We are in bottom node, so we can save final property with value
|
||||
s := s + ' = ' + String(GetPropValue(AObj,lst[i]^.Name,True));
|
||||
ATargetList.Add(s);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
begin
|
||||
if ATargetList=nil then
|
||||
Exit;
|
||||
ATargetList.Clear;
|
||||
|
||||
ATargetList.Add(sSECTION_HEADER);
|
||||
ATargetList.Add('Author='+AAuthor);
|
||||
ATargetList.Add('Description='+ADescription);
|
||||
ATargetList.Add('ControlClass='+AControl.ClassName);
|
||||
ATargetList.Add('');
|
||||
ATargetList.Add(sSECTION_PROP);
|
||||
_SaveProp(AControl);
|
||||
end;
|
||||
|
||||
function GetSectionData(const AFileName, ASectionName: String): TStrings;
|
||||
var
|
||||
f: TextFile;
|
||||
s: String;
|
||||
bReading: Boolean;
|
||||
begin
|
||||
Result := TStringList.Create;
|
||||
Result.Clear;
|
||||
|
||||
if (not FileExists(AFileName)) or (ASectionName='') then
|
||||
Exit;
|
||||
|
||||
AssignFile(f,AFileName);
|
||||
try
|
||||
Reset(f);
|
||||
bReading := False;
|
||||
while not EOF(f) do
|
||||
begin
|
||||
ReadLn(f,s);
|
||||
s := Trim(s);
|
||||
if s='' then
|
||||
Continue;
|
||||
|
||||
// If current line is section tag
|
||||
if s[1]='[' then
|
||||
begin
|
||||
// If we currently reading section then we read it all and we must
|
||||
// break because another section occur
|
||||
if bReading then
|
||||
begin
|
||||
bReading := False;
|
||||
Break;
|
||||
end
|
||||
else
|
||||
// Otherwise if this is section we are looking for, then set flag
|
||||
// to "start reading"
|
||||
if SameText(ASectionName,TrimSet(s,['[',']'])) then
|
||||
bReading := True;
|
||||
end else
|
||||
// Read section line
|
||||
if bReading then
|
||||
Result.Add(s);
|
||||
end;
|
||||
finally
|
||||
CloseFile(f);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure GetStyleHeader(const AFileName: String; AOutHeader: PBCStyleHeader);
|
||||
var sl: TStrings;
|
||||
begin
|
||||
if (AOutHeader=nil) or (not FileExists(AFileName)) then
|
||||
Exit;
|
||||
|
||||
sl := GetSectionData(AFileName,sSECTION_HEADER_NAME);
|
||||
try
|
||||
// Header info (with format Author=Foo) should be at the top of file
|
||||
with AOutHeader^ do
|
||||
begin
|
||||
Author := sl.Values['Author'];
|
||||
Description := sl.Values['Description'];
|
||||
ControlClass := sl.Values['ControlClass'];
|
||||
end;
|
||||
finally
|
||||
sl.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
end.
|
||||
|
||||
1302
bgracontrols/bcsamples.pas
Normal file
1302
bgracontrols/bcsamples.pas
Normal file
File diff suppressed because it is too large
Load Diff
234
bgracontrols/bcstylesform.lfm
Normal file
234
bgracontrols/bcstylesform.lfm
Normal file
@@ -0,0 +1,234 @@
|
||||
object BCfrmStyle: TBCfrmStyle
|
||||
Left = 471
|
||||
Height = 363
|
||||
Top = 199
|
||||
Width = 642
|
||||
Caption = 'Style manager'
|
||||
ClientHeight = 363
|
||||
ClientWidth = 642
|
||||
OnCloseQuery = FormCloseQuery
|
||||
Position = poScreenCenter
|
||||
LCLVersion = '1.1'
|
||||
object pnlBottom: TPanel
|
||||
Left = 0
|
||||
Height = 37
|
||||
Top = 326
|
||||
Width = 642
|
||||
Align = alBottom
|
||||
AutoSize = True
|
||||
ClientHeight = 37
|
||||
ClientWidth = 642
|
||||
TabOrder = 0
|
||||
object BitBtn1: TBitBtn
|
||||
Left = 565
|
||||
Height = 29
|
||||
Top = 4
|
||||
Width = 73
|
||||
Align = alRight
|
||||
AutoSize = True
|
||||
BorderSpacing.Around = 3
|
||||
Cancel = True
|
||||
DefaultCaption = True
|
||||
Kind = bkCancel
|
||||
ModalResult = 2
|
||||
TabOrder = 0
|
||||
end
|
||||
object BitBtn2: TBitBtn
|
||||
Left = 452
|
||||
Height = 29
|
||||
Top = 4
|
||||
Width = 110
|
||||
Align = alRight
|
||||
AutoSize = True
|
||||
BorderSpacing.Around = 3
|
||||
Caption = 'Assign style'
|
||||
Default = True
|
||||
Glyph.Data = {
|
||||
36040000424D3604000000000000360000002800000010000000100000000100
|
||||
2000000000000004000064000000640000000000000000000000000000000000
|
||||
0000000000000000000000000000000000003796697937976AF23696696D0000
|
||||
0000000000000000000000000000000000000000000000000000000000000000
|
||||
0000000000000000000024926D0735966AA8369A6FF339B091FF36956BF43A97
|
||||
6816000000000000000000000000000000000000000000000000000000000000
|
||||
000000000000399C631236966CC739A079F441BDA3FF41C0A6FF3BA882F53596
|
||||
6B94000000000000000000000000000000000000000000000000000000000000
|
||||
000036946B2637976CE33FA985F94CC5ADFF43C3AAFF42C2AAFF4CC2A9FF3897
|
||||
6DF6389768200000000000000000000000000000000000000000000000003595
|
||||
6A4838986DF24BB899FD53CBB4FF49C8B0FF54CCB5FF4ECAB2FF4FCAB2FF48B2
|
||||
91F937986DAD000000000000000000000000000000000000000035946B43399A
|
||||
6FF557C7ADFF58D0BAFF53CEB8FF5ECEB8FF4AB495FC5ECFB9FF4FCDB6FF5ED0
|
||||
BAFF3A9B70F535956A35000000000000000000000000000000003696695540A1
|
||||
79F469D5C1FF60D4C0FF62CDB8FF3E9E75F436966BE251B798F960D5C1FF5CD4
|
||||
BFFF57C0A5FE38996ECA00000000000000000000000000000000000000003899
|
||||
6FB14FB392F962CAB2FF3A9A70F538976D6037926D1C39986DF66ED6C3FF5AD7
|
||||
C3FF6FDBCAFF41A179F23794674A000000000000000000000000000000002E8B
|
||||
740B38986DD537986DE838946B32000000000000000038976D8C54B696F672E0
|
||||
CFFF66DDCBFF6ACEB6FF37996DDE55AA55030000000000000000000000000000
|
||||
00000000000000000000000000000000000000000000308F701039996EF27BDC
|
||||
C9FF67E0CEFF7FE5D6FF4AA985F235966C610000000000000000000000000000
|
||||
000000000000000000000000000000000000000000000000000037986E7954B4
|
||||
94F582E9DBFF70E6D5FF7AD9C6FF399A6FE82BAA550600000000000000000000
|
||||
00000000000000000000000000000000000000000000000000003399660A3898
|
||||
6DEC82E1CEFF76EADBFF8AEDE0FF57B595F537986C7400000000000000000000
|
||||
0000000000000000000000000000000000000000000000000000000000003596
|
||||
6C6150AF8BF291EEE2FF74EADBFF8CE5D6FF3A996FF33399660F000000000000
|
||||
0000000000000000000000000000000000000000000000000000000000000080
|
||||
80023A9970D981DAC7FF88EDE0FF9BF0E5FF5DB898F835956A6A000000000000
|
||||
0000000000000000000000000000000000000000000000000000000000000000
|
||||
00003794674549A480F490E4D4FF5CB595F6399A6EE539956A24000000000000
|
||||
0000000000000000000000000000000000000000000000000000000000000000
|
||||
000000000000389A6FAC39996EEF36966C6D3399660500000000
|
||||
}
|
||||
ModalResult = 1
|
||||
TabOrder = 1
|
||||
end
|
||||
end
|
||||
object gboxPreview: TGroupBox
|
||||
Left = 454
|
||||
Height = 320
|
||||
Top = 3
|
||||
Width = 185
|
||||
Align = alRight
|
||||
BorderSpacing.Around = 3
|
||||
Caption = 'Preview'
|
||||
ChildSizing.EnlargeHorizontal = crsHomogenousSpaceResize
|
||||
ChildSizing.EnlargeVertical = crsHomogenousSpaceResize
|
||||
ChildSizing.Layout = cclLeftToRightThenTopToBottom
|
||||
ChildSizing.ControlsPerLine = 1
|
||||
TabOrder = 1
|
||||
end
|
||||
object Splitter1: TSplitter
|
||||
Left = 446
|
||||
Height = 326
|
||||
Top = 0
|
||||
Width = 5
|
||||
Align = alRight
|
||||
ResizeAnchor = akRight
|
||||
end
|
||||
object gboxStyles: TGroupBox
|
||||
Left = 3
|
||||
Height = 320
|
||||
Top = 3
|
||||
Width = 440
|
||||
Align = alClient
|
||||
BorderSpacing.Around = 3
|
||||
Caption = 'Styles'
|
||||
ClientHeight = 301
|
||||
ClientWidth = 436
|
||||
TabOrder = 3
|
||||
object memoLogs: TMemo
|
||||
Left = 3
|
||||
Height = 40
|
||||
Top = 258
|
||||
Width = 430
|
||||
Align = alBottom
|
||||
BorderSpacing.Around = 3
|
||||
Font.Color = clRed
|
||||
ParentFont = False
|
||||
ReadOnly = True
|
||||
ScrollBars = ssAutoVertical
|
||||
TabOrder = 0
|
||||
Visible = False
|
||||
end
|
||||
object sptrLog: TSplitter
|
||||
Cursor = crVSplit
|
||||
Left = 0
|
||||
Height = 5
|
||||
Top = 250
|
||||
Width = 436
|
||||
Align = alBottom
|
||||
ResizeAnchor = akBottom
|
||||
Visible = False
|
||||
end
|
||||
object ToolBar1: TToolBar
|
||||
Left = 0
|
||||
Height = 26
|
||||
Top = 0
|
||||
Width = 436
|
||||
Caption = 'ToolBar1'
|
||||
EdgeInner = esNone
|
||||
EdgeOuter = esNone
|
||||
ParentShowHint = False
|
||||
ShowHint = True
|
||||
TabOrder = 2
|
||||
object btnDelete: TToolButton
|
||||
Left = 1
|
||||
Top = 0
|
||||
Action = ActionDelete
|
||||
end
|
||||
object btnNewFromCtrl: TToolButton
|
||||
Left = 24
|
||||
Top = 0
|
||||
Action = ActionNewFromCtrl
|
||||
end
|
||||
object ToolButton1: TToolButton
|
||||
Left = 47
|
||||
Top = 0
|
||||
Width = 5
|
||||
Caption = 'ToolButton1'
|
||||
Style = tbsDivider
|
||||
end
|
||||
object btnNewFromFile: TToolButton
|
||||
Left = 52
|
||||
Top = 0
|
||||
Action = ActionNewFromFile
|
||||
end
|
||||
object btnRefresh: TToolButton
|
||||
Left = 75
|
||||
Top = 0
|
||||
Action = ActionRefresh
|
||||
end
|
||||
end
|
||||
object lvFiles: TListView
|
||||
Left = 3
|
||||
Height = 218
|
||||
Top = 29
|
||||
Width = 430
|
||||
Align = alClient
|
||||
BorderSpacing.Around = 3
|
||||
Columns = <
|
||||
item
|
||||
Caption = 'File'
|
||||
Width = 100
|
||||
end
|
||||
item
|
||||
AutoSize = True
|
||||
Caption = 'Author'
|
||||
Width = 57
|
||||
end
|
||||
item
|
||||
Caption = 'Description'
|
||||
Width = 255
|
||||
end>
|
||||
TabOrder = 3
|
||||
ViewStyle = vsReport
|
||||
OnSelectItem = lvFilesSelectItem
|
||||
end
|
||||
end
|
||||
object ActionList1: TActionList
|
||||
left = 312
|
||||
top = 96
|
||||
object ActionNewFromCtrl: TAction
|
||||
Hint = 'Create new style from selected control'
|
||||
OnExecute = ActionNewFromCtrlExecute
|
||||
end
|
||||
object ActionDelete: TAction
|
||||
Caption = 'ActionDelete'
|
||||
Hint = 'Delete style and file (from package "style" folder)'
|
||||
OnExecute = ActionDeleteExecute
|
||||
end
|
||||
object ActionNewFromFile: TAction
|
||||
Caption = 'ActionNewFromFile'
|
||||
Hint = 'Create new style from file'
|
||||
OnExecute = ActionNewFromFileExecute
|
||||
end
|
||||
object ActionRefresh: TAction
|
||||
Caption = 'ActionRefresh'
|
||||
OnExecute = ActionRefreshExecute
|
||||
end
|
||||
end
|
||||
object OpenDialog1: TOpenDialog
|
||||
left = 312
|
||||
top = 163
|
||||
end
|
||||
end
|
||||
516
bgracontrols/bcstylesform.pas
Normal file
516
bgracontrols/bcstylesform.pas
Normal file
@@ -0,0 +1,516 @@
|
||||
// SPDX-License-Identifier: LGPL-3.0-linking-exception
|
||||
{ Styles form manager
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
originally written in 2012 by Krzysztof Dibowski dibowski at interia.pl
|
||||
}
|
||||
{******************************* CONTRIBUTOR(S) ******************************
|
||||
- Edivando S. Santos Brasil | mailedivando@gmail.com
|
||||
(Compatibility with delphi VCL 11/2018)
|
||||
|
||||
***************************** END CONTRIBUTOR(S) *****************************}
|
||||
unit BCStylesForm;
|
||||
|
||||
{$I bgracontrols.inc}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils, {$IFDEF FPC}FileUtil, ComponentEditors, PropEdits,{$ELSE}
|
||||
Windows, DesignIntf, DesignEditors, PropertyCategories,
|
||||
ToolIntf, ExptIntf, DesignWindows,
|
||||
{$ENDIF}
|
||||
Forms, Controls, Graphics, Dialogs, ExtCtrls,
|
||||
StdCtrls, ActnList, ComCtrls, Buttons,
|
||||
bcbasectrls;
|
||||
|
||||
type
|
||||
|
||||
{ TBCfrmStyle }
|
||||
|
||||
TBCfrmStyle = class(TForm)
|
||||
ActionRefresh: TAction;
|
||||
ActionNewFromFile: TAction;
|
||||
ActionDelete: TAction;
|
||||
ActionNewFromCtrl: TAction;
|
||||
ActionList1: TActionList;
|
||||
BitBtn1: TBitBtn;
|
||||
BitBtn2: TBitBtn;
|
||||
gboxPreview: TGroupBox;
|
||||
gboxStyles: TGroupBox;
|
||||
lvFiles: TListView;
|
||||
memoLogs: TMemo;
|
||||
OpenDialog1: TOpenDialog;
|
||||
pnlBottom: TPanel;
|
||||
Splitter1: TSplitter;
|
||||
sptrLog: TSplitter;
|
||||
ToolBar1: TToolBar;
|
||||
btnDelete: TToolButton;
|
||||
btnNewFromCtrl: TToolButton;
|
||||
ToolButton1: TToolButton;
|
||||
btnNewFromFile: TToolButton;
|
||||
btnRefresh: TToolButton;
|
||||
procedure ActionDeleteExecute({%H-}Sender: TObject);
|
||||
procedure ActionNewFromCtrlExecute({%H-}Sender: TObject);
|
||||
procedure ActionNewFromFileExecute({%H-}Sender: TObject);
|
||||
procedure ActionRefreshExecute({%H-}Sender: TObject);
|
||||
procedure FormCloseQuery({%H-}Sender: TObject; var CanClose: boolean);
|
||||
procedure lvFilesSelectItem({%H-}Sender: TObject; Item: TListItem;
|
||||
Selected: Boolean);
|
||||
private
|
||||
{ private declarations }
|
||||
FControl: TControl;
|
||||
FPreviewControl: TControl;
|
||||
FStyleExt: String;
|
||||
procedure AddLog(const AText: String; AClear: Boolean = True);
|
||||
procedure CreatePreviewControl;
|
||||
function GetFileName: String;
|
||||
function GetStylesDir: String;
|
||||
public
|
||||
{ public declarations }
|
||||
constructor {%H-}Create(AControl: TControl; const AFileExt: String);
|
||||
|
||||
property FileName: String read GetFileName;
|
||||
end;
|
||||
|
||||
{ TBCStyleComponentEditor }
|
||||
|
||||
TBCStyleComponentEditor = class(TComponentEditor)
|
||||
protected
|
||||
procedure BeginUpdate;
|
||||
procedure EndUpdate;
|
||||
function GetStyleExtension: String;
|
||||
procedure DoShowEditor;
|
||||
public
|
||||
procedure ExecuteVerb(Index: Integer); override;
|
||||
function GetVerb({%H-}Index: Integer): String; override;
|
||||
function GetVerbCount: Integer; override;
|
||||
end;
|
||||
|
||||
{ TBCSylePropertyEditor }
|
||||
|
||||
TBCSylePropertyEditor = class({$IFDEF FPC}TClassPropertyEditor{$ELSE}TPropertyEditor{$ENDIF})
|
||||
private
|
||||
procedure BeginUpdate;
|
||||
procedure EndUpdate;
|
||||
function GetStyleExtension: String;
|
||||
procedure DoShowEditor;
|
||||
public
|
||||
procedure Edit; Override;
|
||||
function GetAttributes: TPropertyAttributes; Override;
|
||||
end;
|
||||
|
||||
implementation
|
||||
|
||||
{$IFDEF FPC}
|
||||
uses MacroIntf, BCRTTI, IDEImagesIntf;
|
||||
{$ELSE}
|
||||
uses BCRTTI;
|
||||
{$ENDIF}
|
||||
|
||||
{ TBCSylePropertyEditor }
|
||||
|
||||
procedure TBCSylePropertyEditor.BeginUpdate;
|
||||
begin
|
||||
if GetComponent(0).InheritsFrom(TBCStyleGraphicControl) then
|
||||
TBCStyleGraphicControl(GetComponent(0)).BeginUpdate
|
||||
else
|
||||
if GetComponent(0).InheritsFrom(TBCStyleCustomControl) then
|
||||
TBCStyleCustomControl(GetComponent(0)).BeginUpdate;
|
||||
end;
|
||||
|
||||
procedure TBCSylePropertyEditor.EndUpdate;
|
||||
begin
|
||||
if GetComponent(0).InheritsFrom(TBCStyleGraphicControl) then
|
||||
TBCStyleGraphicControl(GetComponent(0)).EndUpdate
|
||||
else
|
||||
if GetComponent(0).InheritsFrom(TBCStyleCustomControl) then
|
||||
TBCStyleCustomControl(GetComponent(0)).EndUpdate;
|
||||
end;
|
||||
|
||||
function TBCSylePropertyEditor.GetStyleExtension: String;
|
||||
begin
|
||||
if GetComponent(0).InheritsFrom(TBCStyleGraphicControl) then
|
||||
Result := TBCStyleGraphicControl(GetComponent(0)).StyleExtension
|
||||
else
|
||||
if GetComponent(0).InheritsFrom(TBCStyleCustomControl) then
|
||||
Result := TBCStyleCustomControl(GetComponent(0)).StyleExtension
|
||||
else
|
||||
Result := '';
|
||||
end;
|
||||
|
||||
procedure TBCSylePropertyEditor.DoShowEditor;
|
||||
var f: TBCfrmStyle;
|
||||
begin
|
||||
if GetStyleExtension='' then
|
||||
begin
|
||||
{$IFDEF FPC}
|
||||
MessageDlg('Empty ext', Format('Class %s has empty style extension',
|
||||
[GetComponent(0).ClassName]),mtError,[mbOK],0);
|
||||
{$ELSE}
|
||||
MessageDlg('Empty ext' + #10#13 + Format('Class %s has empty style extension',
|
||||
[GetComponent(0).ClassName]),mtError,[mbOK],0);
|
||||
{$ENDIF}
|
||||
Exit;
|
||||
end;
|
||||
|
||||
f := TBCfrmStyle.Create(TControl(GetComponent(0)),GetStyleExtension);
|
||||
try
|
||||
if (f.ShowModal=mrOK) and FileExists(f.FileName) then
|
||||
begin
|
||||
try
|
||||
BeginUpdate;
|
||||
LoadStyle(GetComponent(0),f.FileName);
|
||||
finally
|
||||
EndUpdate;
|
||||
end;
|
||||
end;
|
||||
finally
|
||||
f.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TBCSylePropertyEditor.Edit;
|
||||
begin
|
||||
DoShowEditor;
|
||||
end;
|
||||
|
||||
function TBCSylePropertyEditor.GetAttributes: TPropertyAttributes;
|
||||
begin
|
||||
Result := [paDialog, paReadOnly];
|
||||
end;
|
||||
|
||||
{ TBCfrmStyle }
|
||||
|
||||
procedure TBCfrmStyle.ActionNewFromCtrlExecute(Sender: TObject);
|
||||
var
|
||||
sName: String;
|
||||
sl: TStrings;
|
||||
begin
|
||||
sName := 'My new style';
|
||||
if InputQuery('Create new style', 'Style name', sName) then
|
||||
begin
|
||||
if Trim(sName)='' then
|
||||
raise Exception.Create('Name can not be empty');
|
||||
sName := IncludeTrailingBackslash(GetStylesDir) + sName+'.'+FStyleExt;
|
||||
if FileExists(sName) then
|
||||
raise Exception.Create('Style with this name already exists!');
|
||||
sl := TStringList.Create;
|
||||
try
|
||||
SaveStyle(FControl,'Me','',sl);
|
||||
sl.SaveToFile(sName);
|
||||
ActionRefresh.Execute;
|
||||
finally
|
||||
sl.Free;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TBCfrmStyle.ActionNewFromFileExecute(Sender: TObject);
|
||||
begin
|
||||
if OpenDialog1.Execute then
|
||||
begin
|
||||
if FileExists(IncludeTrailingBackslash(GetStylesDir)+ExtractFileName(OpenDialog1.FileName)) then
|
||||
raise Exception.Create('This style already exists');
|
||||
{$IFDEF FPC}
|
||||
CopyFile(OpenDialog1.FileName,IncludeTrailingBackslash(GetStylesDir)+ExtractFileName(OpenDialog1.FileName));
|
||||
{$ELSE}
|
||||
CopyFile(PWidechar(OpenDialog1.FileName),PWidechar(IncludeTrailingBackslash(GetStylesDir)+ExtractFileName(OpenDialog1.FileName)),False);
|
||||
{$ENDIF}
|
||||
ActionRefresh.Execute;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TBCfrmStyle.ActionRefreshExecute(Sender: TObject);
|
||||
var
|
||||
sl: TStrings;
|
||||
i: Integer;
|
||||
it: TListItem;
|
||||
h: TBCStyleHeader;
|
||||
begin
|
||||
{$IFDEF FPC}//#
|
||||
sl := FindAllFiles(GetStylesDir,'*.'+FStyleExt,False);
|
||||
{$ENDIF}
|
||||
try
|
||||
lvFiles.ItemIndex := -1;
|
||||
lvFiles.Selected := nil;
|
||||
lvFiles.Clear;
|
||||
if (sl<>nil) and (sl.Count>0) then
|
||||
begin
|
||||
lvFiles.{$IFNDEF FPC}Items.{$ENDIF}BeginUpdate;
|
||||
try
|
||||
for i:=0 to Pred(sl.Count) do
|
||||
begin
|
||||
it := lvFiles.Items.Add;
|
||||
it.Caption := ExtractFileName(sl.Strings[i]);
|
||||
GetStyleHeader(sl.Strings[i],@h);
|
||||
it.SubItems.Add(h.Author); // Author
|
||||
it.SubItems.Add(h.Description); // Description
|
||||
end;
|
||||
lvFiles.ItemIndex := 0;
|
||||
lvFiles.Selected := lvFiles.Items.Item[0];
|
||||
// I noticed that OnSelect event is not called when we change
|
||||
// selected index manually, so we must call it manually
|
||||
lvFilesSelectItem(lvFiles,lvFiles.Selected,True);
|
||||
ActionDelete.Enabled := True;
|
||||
finally
|
||||
lvFiles.{$IFNDEF FPC}Items.{$ENDIF}EndUpdate;
|
||||
end;
|
||||
end else
|
||||
begin
|
||||
memoLogs.Clear;
|
||||
memoLogs.Visible := False;
|
||||
sptrLog.Visible := False;
|
||||
FPreviewControl.Visible := False;
|
||||
ActionDelete.Enabled := False;
|
||||
end;
|
||||
finally
|
||||
if sl<>nil then sl.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TBCfrmStyle.FormCloseQuery(Sender: TObject; var CanClose: boolean);
|
||||
begin
|
||||
if (ModalResult=mrOK) and (lvFiles.ItemIndex=-1) then
|
||||
begin
|
||||
{$IFDEF FPC}
|
||||
MessageDlg('Assign file', 'No style selected', mtError, [mbOK], 0);
|
||||
{$ELSE}
|
||||
MessageDlg('Assign file' + #10#13 + 'No style selected', mtError, [mbOK], 0);
|
||||
{$ENDIF}
|
||||
CanClose := False;
|
||||
end
|
||||
else
|
||||
CanClose := True;
|
||||
end;
|
||||
|
||||
procedure TBCfrmStyle.ActionDeleteExecute(Sender: TObject);
|
||||
begin
|
||||
if (lvFiles.SelCount=0) or
|
||||
{$IFDEF FPC}
|
||||
(MessageDlg('Deleting style', 'Do you really want to delete selected style? '+
|
||||
'This action delete file: '+IncludeTrailingBackslash(GetStylesDir)+lvFiles.Selected.Caption,
|
||||
mtConfirmation,mbYesNo,0)=mrNo)
|
||||
{$ELSE}
|
||||
(MessageDlg('Deleting style' + #10#13 + 'Do you really want to delete selected style? '+
|
||||
'This action delete file: '+ IncludeTrailingBackslash(GetStylesDir) + lvFiles.Selected.Caption,
|
||||
mtConfirmation,mbYesNo,0)=mrNo)
|
||||
{$ENDIF}
|
||||
then
|
||||
Exit;
|
||||
|
||||
{$IFDEF FPC}
|
||||
DeleteFile(IncludeTrailingBackslash(GetStylesDir)+lvFiles.Selected.Caption);
|
||||
{$ELSE}
|
||||
DeleteFile(PWideChar(IncludeTrailingBackslash(GetStylesDir)+lvFiles.Selected.Caption));
|
||||
{$ENDIF}
|
||||
ActionRefresh.Execute;
|
||||
end;
|
||||
|
||||
procedure TBCfrmStyle.lvFilesSelectItem(Sender: TObject; Item: TListItem;
|
||||
Selected: Boolean);
|
||||
var
|
||||
sl_logs: TStrings;
|
||||
i: Integer;
|
||||
begin
|
||||
if Selected and (Item<>nil) then
|
||||
begin
|
||||
memoLogs.Visible := False;
|
||||
sptrLog.Visible := False;
|
||||
memoLogs.Clear;
|
||||
FPreviewControl.Visible := True;
|
||||
ActionDelete.Enabled := True;
|
||||
|
||||
sl_logs := TStringList.Create;
|
||||
try
|
||||
if not FileExists(IncludeTrailingBackslash(GetStylesDir)+Item.Caption) then
|
||||
Exit;
|
||||
|
||||
LoadStyle(FPreviewControl,IncludeTrailingBackslash(GetStylesDir)+Item.Caption,
|
||||
sl_logs);
|
||||
// Because load style override it
|
||||
FPreviewControl.Constraints.MinWidth := 100;
|
||||
FPreviewControl.Constraints.MinHeight := 100;
|
||||
// Logs
|
||||
for i:=0 to Pred(sl_logs.Count) do
|
||||
AddLog(sl_logs.Strings[i],False);
|
||||
finally
|
||||
sl_logs.Free;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TBCfrmStyle.AddLog(const AText: String; AClear: Boolean = True);
|
||||
begin
|
||||
if AClear then memoLogs.Clear;
|
||||
if not memoLogs.Visible then
|
||||
begin
|
||||
memoLogs.Visible := True;
|
||||
sptrLog.Visible := True;
|
||||
sptrLog.Top := memoLogs.Top - 1;
|
||||
end;
|
||||
memoLogs.Lines.Add(AText);
|
||||
end;
|
||||
|
||||
function TBCfrmStyle.GetStylesDir: String;
|
||||
begin
|
||||
Result := '$PkgDir(bgracontrols)';
|
||||
{$IFDEF FPC}
|
||||
IDEMacros.SubstituteMacros(Result);
|
||||
{$ENDIF}
|
||||
Result := IncludeTrailingBackslash(Result)+'styles';
|
||||
end;
|
||||
|
||||
procedure TBCfrmStyle.CreatePreviewControl;
|
||||
begin
|
||||
FPreviewControl := TControlClass(FControl.ClassType).Create(Self);
|
||||
FPreviewControl.Constraints.MinWidth := 100;
|
||||
FPreviewControl.Constraints.MinHeight := 100;
|
||||
FPreviewControl.Parent := gboxPreview;
|
||||
{$IFDEF FPC}//#
|
||||
FPreviewControl.Caption := FControl.Caption;
|
||||
if Trim(FPreviewControl.Caption) = '' then
|
||||
FPreviewControl.Caption := 'Demo';
|
||||
{$ENDIF}
|
||||
FPreviewControl.Visible := False;
|
||||
end;
|
||||
|
||||
function TBCfrmStyle.GetFileName: String;
|
||||
begin
|
||||
if lvFiles.ItemIndex=-1 then
|
||||
Result := ''
|
||||
else
|
||||
Result := IncludeTrailingBackslash(GetStylesDir)+lvFiles.Selected.Caption;
|
||||
end;
|
||||
|
||||
constructor TBCfrmStyle.Create(AControl: TControl;
|
||||
const AFileExt: String);
|
||||
|
||||
// It seems that method LoadImage load icon on each call. Others lazarus
|
||||
// component editors doesn't check if icon exist but I will do. Small memory leak
|
||||
// reduction :P
|
||||
{$IFDEF FPC}//#
|
||||
function _LoadImage(AIdx: Integer; const AName: String): Integer;
|
||||
begin
|
||||
Result := IDEImages.GetImageIndex(AIdx,AName);
|
||||
if Result=-1 then
|
||||
Result := IDEImages.LoadImage(AIdx,AName);
|
||||
end;
|
||||
{$ENDIF}
|
||||
begin
|
||||
inherited Create(Application);
|
||||
|
||||
FControl := AControl;
|
||||
FStyleExt := AFileExt;
|
||||
|
||||
CreatePreviewControl;
|
||||
ActionRefresh.Execute;
|
||||
|
||||
{$IFDEF FPC}//#
|
||||
ToolBar1.Images := IDEImages.Images_16;
|
||||
ActionList1.Images := ToolBar1.Images;
|
||||
ActionDelete.ImageIndex := _LoadImage(16,'laz_delete');
|
||||
ActionNewFromCtrl.ImageIndex := _LoadImage(16,'laz_add');
|
||||
ActionNewFromFile.ImageIndex := _LoadImage(16,'laz_open');
|
||||
ActionRefresh.ImageIndex := _LoadImage(16,'laz_refresh');
|
||||
{$ENDIF}
|
||||
|
||||
ActionDelete.Enabled := False;
|
||||
|
||||
OpenDialog1.Filter := 'BC Style|*.'+FStyleExt;
|
||||
OpenDialog1.DefaultExt := FStyleExt;
|
||||
OpenDialog1.InitialDir := GetStylesDir;
|
||||
end;
|
||||
|
||||
{$R *.lfm}
|
||||
|
||||
{ TBCStyleComponentEditor }
|
||||
|
||||
procedure TBCStyleComponentEditor.BeginUpdate;
|
||||
begin
|
||||
if Component.InheritsFrom(TBCStyleGraphicControl) then
|
||||
TBCStyleGraphicControl(Component).BeginUpdate
|
||||
else
|
||||
if Component.InheritsFrom(TBCStyleCustomControl) then
|
||||
TBCStyleCustomControl(Component).BeginUpdate;
|
||||
end;
|
||||
|
||||
procedure TBCStyleComponentEditor.EndUpdate;
|
||||
begin
|
||||
if Component.InheritsFrom(TBCStyleGraphicControl) then
|
||||
TBCStyleGraphicControl(Component).EndUpdate
|
||||
else
|
||||
if Component.InheritsFrom(TBCStyleCustomControl) then
|
||||
TBCStyleCustomControl(Component).EndUpdate;
|
||||
end;
|
||||
|
||||
function TBCStyleComponentEditor.GetStyleExtension: String;
|
||||
begin
|
||||
if Component.InheritsFrom(TBCStyleGraphicControl) then
|
||||
Result := TBCStyleGraphicControl(Component).StyleExtension
|
||||
else
|
||||
if Component.InheritsFrom(TBCStyleCustomControl) then
|
||||
Result := TBCStyleCustomControl(Component).StyleExtension
|
||||
else
|
||||
Result := '';
|
||||
end;
|
||||
|
||||
procedure TBCStyleComponentEditor.DoShowEditor;
|
||||
var f: TBCfrmStyle;
|
||||
begin
|
||||
if GetStyleExtension='' then
|
||||
begin
|
||||
{$IFDEF FPC}
|
||||
MessageDlg('Empty ext', Format('Class %s has empty style extension',
|
||||
[Component.ClassName]),mtError,[mbOK],0);
|
||||
{$ELSE}
|
||||
MessageDlg('Empty ext' + #10#13 + Format('Class %s has empty style extension',
|
||||
[Component.ClassName]),mtError,[mbOK],0);
|
||||
{$ENDIF}
|
||||
Exit;
|
||||
end;
|
||||
|
||||
f := TBCfrmStyle.Create(TControl(Component),GetStyleExtension);
|
||||
try
|
||||
if (f.ShowModal=mrOK) and FileExists(f.FileName) then
|
||||
begin
|
||||
try
|
||||
BeginUpdate;
|
||||
LoadStyle(Component,f.FileName);
|
||||
finally
|
||||
EndUpdate;
|
||||
end;
|
||||
end;
|
||||
finally
|
||||
f.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TBCStyleComponentEditor.ExecuteVerb(Index: Integer);
|
||||
begin
|
||||
case Index of
|
||||
0: DoShowEditor;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TBCStyleComponentEditor.GetVerb(Index: Integer): String;
|
||||
begin
|
||||
Result := 'Assign style';
|
||||
end;
|
||||
|
||||
function TBCStyleComponentEditor.GetVerbCount: Integer;
|
||||
begin
|
||||
Result := 1;
|
||||
end;
|
||||
|
||||
initialization
|
||||
RegisterComponentEditor(TBCStyleGraphicControl, TBCStyleComponentEditor);
|
||||
RegisterComponentEditor(TBCStyleCustomControl, TBCStyleComponentEditor);
|
||||
{$IFDEF FPC}
|
||||
RegisterPropertyEditor(ClassTypeInfo(TBCStyleDummyProperty),nil,'',TBCSylePropertyEditor);
|
||||
{$ELSE}
|
||||
RegisterPropertyEditor(TypeInfo(TBCStyleDummyProperty),nil,'',TBCSylePropertyEditor);
|
||||
{$ENDIF}
|
||||
|
||||
end.
|
||||
|
||||
356
bgracontrols/bcsvgbutton.pas
Normal file
356
bgracontrols/bcsvgbutton.pas
Normal file
@@ -0,0 +1,356 @@
|
||||
// SPDX-License-Identifier: LGPL-3.0-linking-exception
|
||||
{ A Graphic Button Control that uses SVG images as the button states
|
||||
for Normal,Hover and DOWN states.
|
||||
|
||||
originally written in 2018 by User Josh on Lazarus Forum.
|
||||
|
||||
You can use the SVGDOWNXML property to enter the SVG XML code to create the
|
||||
image or You can enter the full svg image file and pathname into the properties
|
||||
FileNameDown; it will then read in the File Information and place it in the
|
||||
SVGDownXML Property.
|
||||
|
||||
This Component uses the BGRABITMAP and BGRACONTROLS Framework to implement
|
||||
the Button's Functionality
|
||||
}
|
||||
{******************************* CONTRIBUTOR(S) ******************************
|
||||
- Edivando S. Santos Brasil | mailedivando@gmail.com
|
||||
(Compatibility with delphi VCL 11/2018)
|
||||
|
||||
***************************** END CONTRIBUTOR(S) *****************************}
|
||||
unit BCSVGButton;
|
||||
|
||||
{$I bgracontrols.inc}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils, Forms, Controls, Graphics, Dialogs,
|
||||
{$IFDEF FPC}LResources, lazutils,{$ENDIF}
|
||||
{$IFNDEF FPC}Windows, Messages, BGRAGraphics, GraphType, FPImage, {$ENDIF}
|
||||
BCSVGViewer;
|
||||
|
||||
type
|
||||
|
||||
SVGButtonState = (MouseIn, MouseOut, Pressed);
|
||||
|
||||
TBCSVGButton = class(TBCSVGViewer)
|
||||
private
|
||||
fsvgnormal:tstrings;
|
||||
fsvghover:tstrings;
|
||||
fsvgdown:tstrings;
|
||||
fdown:boolean;
|
||||
FState:SVGButtonState;
|
||||
FOwner: TComponent;
|
||||
FFileNameHover: String;
|
||||
FFileNameNormal: String;
|
||||
FFileNameDown: String;
|
||||
FPosition: Integer;
|
||||
FMax: Integer;
|
||||
FInfo1: String;
|
||||
FInfo2: String;
|
||||
// property OnPositionChange;
|
||||
procedure setdown(AValue: boolean);
|
||||
procedure ReadSVGFileAndSetString(fn:String;itm:Integer);
|
||||
procedure GenerateCompletedSVGImage(AValue: string);
|
||||
protected
|
||||
FOnPositionChange: TNotifyEvent;
|
||||
procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
|
||||
MX, MY: integer); override;
|
||||
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; MX, MY: integer); override;
|
||||
procedure MouseEnter; override;
|
||||
procedure MouseLeave; override;
|
||||
procedure setsvghoverxml(const AValue: tstrings);
|
||||
procedure setsvgnormalxml(const AValue: tstrings);
|
||||
procedure setsvgdownxml(const AValue: tstrings);
|
||||
procedure setFFileNameDown(const AValue: string);
|
||||
procedure setFFileNameHover(const AValue: string);
|
||||
procedure setFFileNameNormal(const AValue: string);
|
||||
procedure SetInfo1(const AValue:String);
|
||||
procedure SetInfo2(const AValue:String);
|
||||
procedure Setposition(const AValue:Integer);
|
||||
procedure SetMax(const AValue:Integer);
|
||||
procedure RedrawBitmapContent; override;
|
||||
public
|
||||
constructor Create(AOwner: TComponent); override;
|
||||
destructor Destroy; override;
|
||||
procedure paint; override;
|
||||
published
|
||||
property BorderSpacing;
|
||||
property Constraints;
|
||||
Property FileNameDown : String Read FFileNameDown Write setFFileNameDown;
|
||||
Property FileNameHover : String Read FFileNameHover Write setFFileNameHover;
|
||||
Property FileNameNormal : String Read FFileNameNormal Write setFFileNameNormal;
|
||||
property SVGNormalXML:tstrings read fsvgnormal write setsvgnormalxml;
|
||||
property SVGHoverXML:tstrings read fsvghover write setsvghoverxml;
|
||||
property SVGDownXML:tstrings read fsvgdown write setsvgdownxml;
|
||||
property Down:boolean read fdown write setdown default false;
|
||||
property Information1:string read FInfo1 write SetInfo1;
|
||||
property Information2:string read FInfo2 write SetInfo2;
|
||||
property Position:integer read fposition write SetPosition;
|
||||
property Maximum:integer read fmax write SetMax;
|
||||
property OnPositionChange: TNotifyEvent read FOnPositionChange write FOnPositionChange;
|
||||
end;
|
||||
|
||||
{$IFDEF FPC}procedure Register;{$ENDIF}
|
||||
|
||||
implementation
|
||||
|
||||
procedure TBCSVGButton.Paint;
|
||||
begin
|
||||
inherited Paint;
|
||||
end;
|
||||
|
||||
constructor TBCSVGButton.Create(AOwner: TComponent);
|
||||
begin
|
||||
inherited Create(AOwner);
|
||||
FOwner := AOwner;
|
||||
fsvgnormal := TStringList.Create;
|
||||
fsvghover := TStringList.Create;
|
||||
fsvgdown := TStringList.Create;
|
||||
FState := MouseOut;
|
||||
end;
|
||||
|
||||
destructor TBCSVGButton.Destroy;
|
||||
begin
|
||||
fsvghover.Free;
|
||||
fsvghover := nil;
|
||||
fsvgnormal.Free;
|
||||
fsvgnormal := nil;
|
||||
fsvgdown.Free;
|
||||
fsvgdown := nil;
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
//FSVG.CreateFromString(fsvgnormal.Text);
|
||||
procedure TBCSVGButton.GenerateCompletedSVGImage(AValue: string);
|
||||
begin
|
||||
FSVG.CreateFromString(AValue);
|
||||
end;
|
||||
|
||||
procedure TBCSVGButton.ReadSVGFileAndSetString(fn:String;itm:Integer);
|
||||
var li,st: {$IFDEF FPC}ansistring{$ELSE}string{$ENDIF};
|
||||
F: {$IFDEF FPC}Text{$ELSE}TextFile{$ENDIF};
|
||||
|
||||
begin
|
||||
li:='';
|
||||
st:='';
|
||||
if fileexists(fn) then
|
||||
begin
|
||||
AssignFile(F,fn);
|
||||
{$I-}
|
||||
Reset(F);
|
||||
{$I+}
|
||||
If (IoResult = 0) Then
|
||||
Begin
|
||||
While Not(EoF(F)) Do
|
||||
Begin
|
||||
ReadLn(F,Li);
|
||||
st:=st+li;
|
||||
If (EoF(F)) Then Break;
|
||||
End;
|
||||
End;
|
||||
CloseFile(F);
|
||||
end else showmessage('File Not Found');
|
||||
case itm of
|
||||
0:begin
|
||||
if st<>'' then fsvgNormal.Text:=st;
|
||||
FFileNameNormal:='';
|
||||
end;
|
||||
1:Begin
|
||||
if st<>'' then fsvgHover.Text:=st;
|
||||
FFileNameHover:='';
|
||||
End;
|
||||
2:Begin
|
||||
if st<>'' then fsvgDown.Text:=st;
|
||||
FFileNameDown:='';
|
||||
ENd;
|
||||
end;
|
||||
if st<>'' then RedrawBitmap;
|
||||
End;
|
||||
|
||||
procedure TBCSVGButton.SetInfo1(const AValue: string);
|
||||
begin
|
||||
If AValue<>'' then FInfo1:=AValue;
|
||||
end;
|
||||
|
||||
procedure TBCSVGButton.SetInfo2(const AValue: string);
|
||||
begin
|
||||
If AValue<>'' then FInfo2:=AValue;
|
||||
end;
|
||||
|
||||
procedure TBCSVGButton.setposition(const AValue: Integer);
|
||||
begin
|
||||
If AValue<>FPosition then
|
||||
begin
|
||||
FPosition:=AValue;
|
||||
if assigned(FOnPositionChange) then FOnPositionChange(self);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TBCSVGButton.setmax(const AValue: Integer);
|
||||
begin
|
||||
If AValue<>Fmax then Fmax:=AValue;
|
||||
end;
|
||||
|
||||
procedure TBCSVGButton.setFFileNameNormal(const AValue: string);
|
||||
begin
|
||||
If AValue<>'' then ReadSVGFileAndSetString(AValue,0);
|
||||
end;
|
||||
|
||||
procedure TBCSVGButton.setFFileNameHover(const AValue: string);
|
||||
begin
|
||||
If AValue<>'' then ReadSVGFileAndSetString(Avalue,1);
|
||||
end;
|
||||
|
||||
procedure TBCSVGButton.setFFileNameDown(const AValue: string);
|
||||
begin
|
||||
If AValue<>'' then ReadSVGFileAndSetString(Avalue,2);
|
||||
End;
|
||||
|
||||
procedure TBCSVGButton.setsvgnormalxml(const AValue: tstrings);
|
||||
begin
|
||||
if fsvgnormal.Text = AValue.Text then
|
||||
Exit;
|
||||
fsvgnormal.Assign(AValue);
|
||||
DiscardBitmap;
|
||||
if FDown=false then if fsvgnormal.Text<>'' then GenerateCompletedSVGImage(fsvgnormal.Text);
|
||||
RedrawBitmap;
|
||||
// if not fdown then RedrawBitmap;
|
||||
end;
|
||||
|
||||
procedure TBCSVGButton.setsvghoverxml(const AValue: tstrings);
|
||||
begin
|
||||
if fsvghover.Text = AValue.Text then
|
||||
Exit;
|
||||
fsvghover.Assign(AValue);
|
||||
DiscardBitmap;
|
||||
end;
|
||||
|
||||
procedure TBCSVGButton.setsvgdownxml(const AValue: tstrings);
|
||||
begin
|
||||
if fsvgdown.Text = AValue.Text then
|
||||
Exit;
|
||||
fsvgdown.Assign(AValue);
|
||||
DiscardBitmap;
|
||||
if FDown then
|
||||
begin
|
||||
if fsvgdown.Text<>'' then GenerateCompletedSVGImage(fsvgdown.Text);
|
||||
RedrawBitmap;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TBCSVGButton.setdown(AValue: boolean);
|
||||
begin
|
||||
if fdown = AValue then
|
||||
Exit;
|
||||
fdown := AValue;
|
||||
if fdown=false then Fstate:=MouseOut;
|
||||
DiscardBitmap;
|
||||
if FDown then
|
||||
begin
|
||||
if fsvgdown.Text<>'' then GenerateCompletedSVGImage(fsvgdown.Text);
|
||||
end
|
||||
else
|
||||
begin
|
||||
if fsvgnormal.Text<>'' then GenerateCompletedSVGImage(fsvgnormal.Text);
|
||||
end;
|
||||
RedrawBitmap;
|
||||
end;
|
||||
|
||||
procedure TBCSVGButton.MouseDown(Button: TMouseButton; Shift: TShiftState;
|
||||
MX, MY: integer);
|
||||
begin
|
||||
inherited MouseDown(Button, Shift, MX, MY);
|
||||
if csDesigning in ComponentState then
|
||||
exit;
|
||||
|
||||
if (Button = mbLeft) and Enabled then
|
||||
begin
|
||||
FState := Pressed;
|
||||
if fsvgdown.Text<>'' then GenerateCompletedSVGImage(fsvgdown.Text);
|
||||
// RedrawBitmapContent;
|
||||
RedrawBitmap;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TBCSVGButton.MouseUp(Button: TMouseButton; Shift: TShiftState;
|
||||
MX, MY: integer);
|
||||
begin
|
||||
inherited MouseUp(Button, Shift, MX, MY);
|
||||
|
||||
if csDesigning in ComponentState then exit;
|
||||
|
||||
if (Button = mbLeft) and Enabled then
|
||||
begin
|
||||
if FDown then
|
||||
begin
|
||||
if fsvgdown.Text<>'' then GenerateCompletedSVGImage(fsvgdown.Text)
|
||||
end
|
||||
else
|
||||
begin
|
||||
if fsvghover.Text<>'' then GenerateCompletedSVGImage(fsvghover.Text);
|
||||
end;
|
||||
FState := MouseIn;
|
||||
// RedrawBitmapContent;
|
||||
RedrawBitmap;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TBCSVGButton.MouseEnter;
|
||||
begin
|
||||
if csDesigning in ComponentState then exit;
|
||||
|
||||
inherited MouseEnter;
|
||||
|
||||
if fsvghover.Text<>'' then GenerateCompletedSVGImage(fsvghover.Text);
|
||||
FState := MouseIn;
|
||||
// RedrawBitmapContent;
|
||||
RedrawBitmap;
|
||||
|
||||
end;
|
||||
|
||||
procedure TBCSVGButton.MouseLeave;
|
||||
begin
|
||||
inherited MouseLeave;
|
||||
if csDesigning in ComponentState then
|
||||
exit;
|
||||
if FDown then
|
||||
begin
|
||||
if fsvgdown.Text<>'' then GenerateCompletedSVGImage(fsvgdown.Text)
|
||||
end
|
||||
else
|
||||
begin
|
||||
if fsvgnormal.Text<>'' then GenerateCompletedSVGImage(fsvgnormal.Text);
|
||||
end;
|
||||
FState := MouseOut;
|
||||
// RedrawBitmapContent;
|
||||
RedrawBitmap;
|
||||
|
||||
end;
|
||||
|
||||
procedure TBCSVGButton.RedrawBitmapContent;
|
||||
begin
|
||||
if FDown then
|
||||
begin
|
||||
if fsvgdown.Text<>'' then GenerateCompletedSVGImage(fsvgdown.Text)
|
||||
end
|
||||
else
|
||||
begin
|
||||
case fstate of
|
||||
mousein :if fsvghover.Text<>'' then GenerateCompletedSVGImage(fsvghover.Text);
|
||||
mouseout:if fsvgnormal.Text<>'' then GenerateCompletedSVGImage(fsvgnormal.Text);
|
||||
end;
|
||||
end;
|
||||
inherited RedrawBitmapContent;
|
||||
end;
|
||||
|
||||
{$IFDEF FPC}
|
||||
procedure Register;
|
||||
begin
|
||||
RegisterComponents('BGRA Button Controls',[TBCSVGButton]);
|
||||
end;
|
||||
{$ENDIF}
|
||||
|
||||
|
||||
|
||||
end.
|
||||
353
bgracontrols/bcsvgviewer.pas
Normal file
353
bgracontrols/bcsvgviewer.pas
Normal file
@@ -0,0 +1,353 @@
|
||||
// SPDX-License-Identifier: LGPL-3.0-linking-exception
|
||||
{******************************* CONTRIBUTOR(S) ******************************
|
||||
- Edivando S. Santos Brasil | mailedivando@gmail.com
|
||||
(Compatibility with delphi VCL 11/2018)
|
||||
|
||||
***************************** END CONTRIBUTOR(S) *****************************}
|
||||
unit BCSVGViewer;
|
||||
|
||||
{$I bgracontrols.inc}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils, Forms, Controls, Graphics, Dialogs, BGRAGraphicControl,
|
||||
{$IFDEF FPC}LResources, LCLType, {$ENDIF}
|
||||
{$IFNDEF FPC}Types, BGRAGraphics, GraphType, FPImage, {$ENDIF}
|
||||
BGRABitmap, BGRABitmapTypes, BGRASVG, BGRAUnits, BCTypes;
|
||||
|
||||
type
|
||||
|
||||
{ TBCSVGViewer }
|
||||
|
||||
TBCSVGViewer = class(TCustomBGRAGraphicControl)
|
||||
private
|
||||
FDrawCheckers: boolean;
|
||||
FHorizAlign: TAlignment;
|
||||
FProportional: boolean;
|
||||
FStretchMode: TBCStretchMode;
|
||||
FDestDPI: single;
|
||||
FUseSVGAlignment: boolean;
|
||||
FVertAlign: TTextLayout;
|
||||
Fx: single;
|
||||
Fy: single;
|
||||
function GetSVGString: string;
|
||||
procedure SetDrawCheckers(AValue: boolean);
|
||||
procedure SetFDestDPI(AValue: single);
|
||||
procedure SetSVGString(AValue: string);
|
||||
procedure SetFx(AValue: single);
|
||||
procedure SetFy(AValue: single);
|
||||
procedure SetHorizAlign(AValue: TAlignment);
|
||||
procedure SetProportional(AValue: boolean);
|
||||
procedure SetStretchMode(AValue: TBCStretchMode);
|
||||
procedure SetUseSVGAlignment(AValue: boolean);
|
||||
procedure SetVertAlign(AValue: TTextLayout);
|
||||
protected
|
||||
FSVG: TBGRASVG;
|
||||
procedure RedrawBitmapContent; override;
|
||||
public
|
||||
constructor Create(AOwner: TComponent); override;
|
||||
destructor Destroy; override;
|
||||
procedure LoadFromFile(AFileName: string);
|
||||
procedure LoadFromResource(Resource: string);
|
||||
function GetSVGRectF: TRectF;
|
||||
function GetSVGContainerRectF: TRectF;
|
||||
published
|
||||
{ Published declarations }
|
||||
property Align;
|
||||
property Anchors;
|
||||
property OnRedraw;
|
||||
property Bitmap;
|
||||
property BorderSpacing;
|
||||
property Constraints;
|
||||
property SVG: TBGRASVG read FSVG;
|
||||
property SVGString: string read GetSVGString write SetSVGString;
|
||||
property DestDPI: single read FDestDPI write SetFDestDPI {$IFDEF FPC} default
|
||||
96{$ENDIF};
|
||||
property x: single read Fx write SetFx {$IFDEF FPC} default 0{$ENDIF};
|
||||
property y: single read Fy write SetFy {$IFDEF FPC} default 0{$ENDIF};
|
||||
property HorizAlign: TAlignment read FHorizAlign write SetHorizAlign default
|
||||
taCenter;
|
||||
property VertAlign: TTextLayout read FVertAlign write SetVertAlign default tlCenter;
|
||||
property StretchMode: TBCStretchMode
|
||||
read FStretchMode write SetStretchMode default smStretch;
|
||||
property Proportional: boolean read FProportional write SetProportional default True;
|
||||
property DrawCheckers: boolean
|
||||
read FDrawCheckers write SetDrawCheckers default False;
|
||||
property UseSVGAlignment: boolean read FUseSVGAlignment write SetUseSVGAlignment default False;
|
||||
property Color;
|
||||
property ColorOpacity;
|
||||
property OnClick;
|
||||
property OnDblClick;
|
||||
property OnMouseDown;
|
||||
property OnMouseEnter;
|
||||
property OnMouseLeave;
|
||||
property OnMouseMove;
|
||||
property OnMouseUp;
|
||||
{$IFDEF FPC}
|
||||
property OnPaint;
|
||||
{$ENDIF}
|
||||
property OnResize;
|
||||
property Caption;
|
||||
end;
|
||||
|
||||
{$IFDEF FPC}procedure Register;{$ENDIF}
|
||||
|
||||
implementation
|
||||
|
||||
uses BGRAVectorize, math;
|
||||
|
||||
{$IFDEF FPC}
|
||||
procedure Register;
|
||||
begin
|
||||
RegisterComponents('BGRA Controls', [TBCSVGViewer]);
|
||||
end;
|
||||
|
||||
{$ENDIF}
|
||||
|
||||
{ TBCSVGViewer }
|
||||
|
||||
procedure TBCSVGViewer.SetFDestDPI(AValue: single);
|
||||
begin
|
||||
if FDestDPI = AValue then
|
||||
Exit;
|
||||
FDestDPI := AValue;
|
||||
DiscardBitmap;
|
||||
end;
|
||||
|
||||
procedure TBCSVGViewer.SetSVGString(AValue: string);
|
||||
begin
|
||||
FSVG.ASUTF8String := AValue;
|
||||
DiscardBitmap;
|
||||
end;
|
||||
|
||||
procedure TBCSVGViewer.SetDrawCheckers(AValue: boolean);
|
||||
begin
|
||||
if FDrawCheckers = AValue then
|
||||
Exit;
|
||||
FDrawCheckers := AValue;
|
||||
DiscardBitmap;
|
||||
end;
|
||||
|
||||
function TBCSVGViewer.GetSVGString: string;
|
||||
begin
|
||||
Result := FSVG.AsUTF8String;
|
||||
end;
|
||||
|
||||
procedure TBCSVGViewer.SetFx(AValue: single);
|
||||
begin
|
||||
if Fx = AValue then
|
||||
Exit;
|
||||
Fx := AValue;
|
||||
DiscardBitmap;
|
||||
end;
|
||||
|
||||
procedure TBCSVGViewer.SetFy(AValue: single);
|
||||
begin
|
||||
if Fy = AValue then
|
||||
Exit;
|
||||
Fy := AValue;
|
||||
DiscardBitmap;
|
||||
end;
|
||||
|
||||
procedure TBCSVGViewer.SetHorizAlign(AValue: TAlignment);
|
||||
begin
|
||||
if FHorizAlign = AValue then
|
||||
Exit;
|
||||
FHorizAlign := AValue;
|
||||
DiscardBitmap;
|
||||
end;
|
||||
|
||||
procedure TBCSVGViewer.SetProportional(AValue: boolean);
|
||||
begin
|
||||
if FProportional = AValue then
|
||||
Exit;
|
||||
FProportional := AValue;
|
||||
DiscardBitmap;
|
||||
end;
|
||||
|
||||
procedure TBCSVGViewer.SetStretchMode(AValue: TBCStretchMode);
|
||||
begin
|
||||
if FStretchMode = AValue then
|
||||
Exit;
|
||||
FStretchMode := AValue;
|
||||
DiscardBitmap;
|
||||
end;
|
||||
|
||||
procedure TBCSVGViewer.SetUseSVGAlignment(AValue: boolean);
|
||||
begin
|
||||
if FUseSVGAlignment=AValue then Exit;
|
||||
FUseSVGAlignment:=AValue;
|
||||
DiscardBitmap;
|
||||
end;
|
||||
|
||||
procedure TBCSVGViewer.SetVertAlign(AValue: TTextLayout);
|
||||
begin
|
||||
if FVertAlign = AValue then
|
||||
Exit;
|
||||
FVertAlign := AValue;
|
||||
DiscardBitmap;
|
||||
end;
|
||||
|
||||
procedure TBCSVGViewer.RedrawBitmapContent;
|
||||
var
|
||||
r: TRectF;
|
||||
checkersSize: integer;
|
||||
begin
|
||||
if (FBGRA <> nil) and (FBGRA.NbPixels <> 0) then
|
||||
begin
|
||||
r := GetSVGRectF;
|
||||
FBGRA.Fill(ColorToBGRA(ColorToRGB(Color), ColorOpacity));
|
||||
if FDrawCheckers then
|
||||
begin
|
||||
checkersSize := round(8 * DestDPI / 96 * BitmapScale);
|
||||
with GetSVGContainerRectF do
|
||||
FBGRA.DrawCheckers(rect(floor(Left), floor(Top),
|
||||
ceil(right), ceil(Bottom)), CSSWhite, CSSSilver,
|
||||
checkersSize, checkersSize);
|
||||
end;
|
||||
FBGRA.Canvas2D.FontRenderer := TBGRAVectorizedFontRenderer.Create;
|
||||
FSVG.StretchDraw(FBGRA.Canvas2D, r, UseSVGAlignment);
|
||||
if Assigned(OnRedraw) then
|
||||
OnRedraw(self, FBGRA);
|
||||
end;
|
||||
end;
|
||||
|
||||
constructor TBCSVGViewer.Create(AOwner: TComponent);
|
||||
begin
|
||||
inherited Create(AOwner);
|
||||
FSVG := TBGRASVG.Create(100, 100, TCSSUnit.cuPercent);
|
||||
FDestDPI := 96;
|
||||
Fx := 0;
|
||||
Fy := 0;
|
||||
FStretchMode := smStretch;
|
||||
FHorizAlign := taCenter;
|
||||
FVertAlign := tlCenter;
|
||||
FProportional := True;
|
||||
FBitmapAutoScale := False;
|
||||
FUseSVGAlignment:= false;
|
||||
end;
|
||||
|
||||
destructor TBCSVGViewer.Destroy;
|
||||
begin
|
||||
FSVG.Free;
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
procedure TBCSVGViewer.LoadFromFile(AFileName: string);
|
||||
begin
|
||||
FSVG.LoadFromFile(AFileName);
|
||||
DiscardBitmap;
|
||||
end;
|
||||
|
||||
procedure TBCSVGViewer.LoadFromResource(Resource: string);
|
||||
begin
|
||||
FSVG.LoadFromResource(Resource);
|
||||
DiscardBitmap;
|
||||
end;
|
||||
|
||||
function TBCSVGViewer.GetSVGRectF: TRectF;
|
||||
var
|
||||
vbSize: TPointF;
|
||||
w, h, dpi: single;
|
||||
containerRect: TRectF;
|
||||
|
||||
function NoStretch(AX, AY: single): TRectF;
|
||||
begin
|
||||
case HorizAlign of
|
||||
taCenter: Result.Left := (w - vbSize.x) / 2;
|
||||
taRightJustify: Result.Left := w - AX - vbSize.x;
|
||||
else
|
||||
{taLeftJustify} Result.Left := AX;
|
||||
end;
|
||||
case VertAlign of
|
||||
tlCenter: Result.Top := (h - vbSize.y) / 2;
|
||||
tlBottom: Result.Top := h - AY - vbSize.y;
|
||||
else
|
||||
{tlTop} Result.Top := AY;
|
||||
end;
|
||||
Result.Right := Result.Left + vbSize.x;
|
||||
Result.Bottom := Result.Top + vbSize.y;
|
||||
end;
|
||||
|
||||
begin
|
||||
if FSVG = nil then exit(EmptyRectF);
|
||||
|
||||
containerRect := GetSVGContainerRectF;
|
||||
w := containerRect.Width;
|
||||
h := containerRect.Height;
|
||||
dpi := DestDPI * BitmapScale;
|
||||
|
||||
FSVG.Units.ContainerWidth := FloatWithCSSUnit(w * FSVG.Units.DpiX / dpi, cuPixel);
|
||||
FSVG.Units.ContainerHeight := FloatWithCSSUnit(h * FSVG.Units.DpiY / dpi, cuPixel);
|
||||
|
||||
if UseSVGAlignment then
|
||||
exit(FSVG.GetStretchRectF(containerRect.Left, containerRect.Top, containerRect.Width, containerRect.Height));
|
||||
|
||||
vbSize := FSVG.ViewSizeInUnit[cuPixel];
|
||||
vbSize.x := vbSize.x * (dpi / FSVG.Units.DpiX);
|
||||
vbSize.y := vbSize.y * (dpi / FSVG.Units.DpiY);
|
||||
if ((StretchMode = smShrink) and ((vbSize.x > w + 0.1) or (vbSize.y > h + 0.1))) or
|
||||
(StretchMode in[smStretch, smCover]) then
|
||||
begin
|
||||
if Proportional then
|
||||
Result := FSVG.GetStretchRectF(HorizAlign, VertAlign, 0, 0, w, h, StretchMode = smCover)
|
||||
else
|
||||
if StretchMode = smShrink then
|
||||
begin
|
||||
NoStretch(0, 0);
|
||||
if vbSize.x > w then
|
||||
begin
|
||||
Result.Left := 0;
|
||||
Result.Right := w;
|
||||
end;
|
||||
if vbSize.y > h then
|
||||
begin
|
||||
Result.Top := 0;
|
||||
Result.Bottom := h;
|
||||
end;
|
||||
end
|
||||
else
|
||||
Result := RectF(0, 0, w, h);
|
||||
end
|
||||
else
|
||||
result := NoStretch(x, y);
|
||||
|
||||
result.Offset(containerRect.Left, containerRect.Top);
|
||||
end;
|
||||
|
||||
function TBCSVGViewer.GetSVGContainerRectF: TRectF;
|
||||
var
|
||||
w, h: Integer;
|
||||
dpi, ratioX, ratioY, ratio: single;
|
||||
begin
|
||||
w := BitmapWidth;
|
||||
h := BitmapHeight;
|
||||
dpi := DestDPI * BitmapScale;
|
||||
Result := RectF(0, 0, w, h);
|
||||
|
||||
if (FSVG = nil) or not UseSVGAlignment then exit;
|
||||
|
||||
FSVG.Units.ContainerWidth := FloatWithCSSUnit(w * FSVG.Units.DpiX / dpi, cuPixel);
|
||||
FSVG.Units.ContainerHeight := FloatWithCSSUnit(h * FSVG.Units.DpiY / dpi, cuPixel);
|
||||
|
||||
if (FSVG = nil) or (FSVG.WidthAsPixel = 0) or
|
||||
(FSVG.HeightAsPixel = 0) or (BitmapWidth = 0)
|
||||
or (BitmapHeight = 0) then exit(EmptyRectF);
|
||||
|
||||
ratioX := BitmapWidth / FSVG.WidthAsPixel;
|
||||
ratioY := BitmapHeight / FSVG.HeightAsPixel;
|
||||
case StretchMode of
|
||||
smStretch: ratio := min(ratioX, ratioY);
|
||||
smShrink: ratio := min(1, min(ratioX, ratioY));
|
||||
smCover: ratio := max(ratioX, ratioY);
|
||||
else
|
||||
ratio := 1;
|
||||
end;
|
||||
result := RectWithSizeF(0, 0, FSVG.WidthAsPixel * ratio,
|
||||
FSVG.HeightAsPixel * ratio);
|
||||
result.Offset((BitmapWidth - result.Width) / 2,
|
||||
(BitmapHeight - result.Height) / 2);
|
||||
end;
|
||||
|
||||
end.
|
||||
32
bgracontrols/bcthememanager.pas
Normal file
32
bgracontrols/bcthememanager.pas
Normal file
@@ -0,0 +1,32 @@
|
||||
// SPDX-License-Identifier: LGPL-3.0-linking-exception
|
||||
{******************************* CONTRIBUTOR(S) ******************************
|
||||
- Edivando S. Santos Brasil | mailedivando@gmail.com
|
||||
(Compatibility with delphi VCL 11/2018)
|
||||
|
||||
***************************** END CONTRIBUTOR(S) *****************************}
|
||||
unit BCThemeManager;
|
||||
|
||||
{$I bgracontrols.inc}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils, Forms, Controls, Graphics,
|
||||
{$IFDEF FPC}LResources, {$ELSE}Types, BGRAGraphics, GraphType, FPImage,{$ENDIF} Dialogs;
|
||||
|
||||
type
|
||||
TBCThemeManager = class(TComponent)
|
||||
private
|
||||
|
||||
protected
|
||||
|
||||
public
|
||||
procedure Apply(AControl: TWinControl); overload; virtual; abstract;
|
||||
procedure Apply(); overload; virtual; abstract;
|
||||
published
|
||||
|
||||
end;
|
||||
|
||||
implementation
|
||||
|
||||
end.
|
||||
183
bgracontrols/bctoolbar.pas
Normal file
183
bgracontrols/bctoolbar.pas
Normal file
@@ -0,0 +1,183 @@
|
||||
// SPDX-License-Identifier: LGPL-3.0-linking-exception
|
||||
{
|
||||
Created by BGRA Controls Team
|
||||
Dibo, Circular, lainz (007) and contributors.
|
||||
For detailed information see readme.txt
|
||||
|
||||
Site: https://sourceforge.net/p/bgra-controls/
|
||||
Wiki: http://wiki.lazarus.freepascal.org/BGRAControls
|
||||
Forum: http://forum.lazarus.freepascal.org/index.php/board,46.0.html
|
||||
}
|
||||
{******************************* CONTRIBUTOR(S) ******************************
|
||||
- Edivando S. Santos Brasil | mailedivando@gmail.com
|
||||
(Compatibility with delphi VCL 11/2018)
|
||||
|
||||
***************************** END CONTRIBUTOR(S) *****************************}
|
||||
unit BCToolBar;
|
||||
|
||||
{$I bgracontrols.inc}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, {$IFDEF FPC}LResources,{$ELSE}types, BGRAGraphics, GraphType, FPImage,{$ENDIF}
|
||||
Forms, Controls, Graphics, Dialogs, ComCtrls,
|
||||
BGRABitmap, BGRABitmapTypes, BGRAGradients, BCTypes;
|
||||
|
||||
type
|
||||
|
||||
{ TBCToolBar }
|
||||
|
||||
TBCToolBar = class(TToolBar)
|
||||
private
|
||||
FLimitMemoryUsage: boolean;
|
||||
{ Private declarations }
|
||||
FOnRedraw: TBGRARedrawEvent;
|
||||
FBGRA: TBGRABitmap;
|
||||
procedure SetLimitMemoryUsage(AValue: boolean);
|
||||
protected
|
||||
{ Protected declarations }
|
||||
{$IFDEF FPC}
|
||||
procedure Paint; override;
|
||||
{$ELSE}
|
||||
procedure Paint; virtual;
|
||||
procedure PaintWindow(DC: HDC); override;
|
||||
{$ENDIF}
|
||||
procedure CheckMemoryUsage; virtual;
|
||||
public
|
||||
{ Public declarations }
|
||||
constructor Create(TheOwner: TComponent); override;
|
||||
destructor Destroy; override;
|
||||
published
|
||||
{ Published declarations }
|
||||
property OnRedraw: TBGRARedrawEvent read FOnRedraw write FOnRedraw;
|
||||
property LimitMemoryUsage: boolean read FLimitMemoryUsage write SetLimitMemoryUsage;
|
||||
end;
|
||||
|
||||
procedure DrawWindows7ToolBar(Bitmap: TBGRABitmap; AColor: TColor = clDefault);
|
||||
|
||||
{$IFDEF FPC}procedure Register;{$ENDIF}
|
||||
|
||||
implementation
|
||||
|
||||
function SetHue(AColor: TBGRAPixel; g_hue: integer): TBGRAPixel;
|
||||
var hsla: THSLAPixel;
|
||||
begin
|
||||
if g_hue = -1 then result := AColor else
|
||||
begin
|
||||
hsla := BGRAToHSLA(AColor);
|
||||
hsla.hue := g_hue;
|
||||
result := GSBAToBGRA(hsla);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure DrawWindows7ToolBar(Bitmap: TBGRABitmap; AColor: TColor = clDefault);
|
||||
var
|
||||
c1, c2, c3, c4: TBGRAPixel;
|
||||
ARect, ARect2: TRect;
|
||||
g_hue: integer;
|
||||
begin
|
||||
if AColor = clDefault then
|
||||
g_hue := -1
|
||||
else
|
||||
g_hue := BGRAToGSBA(AColor).hue;
|
||||
ARect := Rect(0, 0, Bitmap.Width, Bitmap.Height);
|
||||
// Font: RGBToColor(30,57,91)
|
||||
|
||||
Bitmap.HorizLine(ARect.Left, ARect.Top, ARect.Right-1, SetHue(BGRA(169, 191, 214), g_hue), dmSet);
|
||||
Bitmap.HorizLine(ARect.Left, ARect.Top + 1, ARect.Right-1, SetHue(BGRA(250, 252, 253), g_hue), dmSet);
|
||||
Bitmap.HorizLine(ARect.Left, ARect.Top + 2, ARect.Right-1, SetHue(BGRA(253, 254, 255), g_hue), dmSet);
|
||||
|
||||
c1 := SetHue(BGRA(252, 254, 255), g_hue);
|
||||
c2 := SetHue(BGRA(243, 248, 253), g_hue);
|
||||
c3 := SetHue(BGRA(238, 243, 250), g_hue);
|
||||
c4 := SetHue(BGRA(238, 244, 251), g_hue);
|
||||
ARect2 := Rect(ARect.Left, ARect.Top + 3, ARect.Right, ARect.Bottom - 3);
|
||||
DoubleGradientAlphaFill(Bitmap, ARect2, c1, c2, c3, c4, gdVertical,
|
||||
gdVertical, gdVertical, 0.5);
|
||||
|
||||
c1 := SetHue(BGRA(249, 252, 255), g_hue);
|
||||
c2 := SetHue(BGRA(230, 240, 250), g_hue);
|
||||
c3 := SetHue(BGRA(220, 230, 244), g_hue);
|
||||
c4 := SetHue(BGRA(221, 233, 247), g_hue);
|
||||
ARect2 := Rect(ARect.Left + 1, ARect.Top + 3, ARect.Right - 1, ARect.Bottom - 3);
|
||||
DoubleGradientAlphaFill(Bitmap, ARect2, c1, c2, c3, c4, gdVertical,
|
||||
gdVertical, gdVertical, 0.5);
|
||||
|
||||
Bitmap.HorizLine(ARect.Left, ARect.Bottom - 3, ARect.Right-1, SetHue(BGRA(228, 239, 251), g_hue), dmSet);
|
||||
Bitmap.HorizLine(ARect.Left, ARect.Bottom - 2, ARect.Right-1, SetHue(BGRA(205, 218, 234), g_hue), dmSet);
|
||||
Bitmap.HorizLine(ARect.Left, ARect.Bottom - 1, ARect.Right-1, SetHue(BGRA(160, 175, 195), g_hue), dmSet);
|
||||
end;
|
||||
|
||||
{$IFDEF FPC}
|
||||
procedure Register;
|
||||
begin
|
||||
RegisterComponents('BGRA Controls', [TBCToolBar]);
|
||||
end;
|
||||
{$ENDIF}
|
||||
|
||||
{ TBCToolBar }
|
||||
|
||||
constructor TBCToolBar.Create(TheOwner: TComponent);
|
||||
begin
|
||||
inherited Create(TheOwner);
|
||||
FBGRA := TBGRABitmap.Create;
|
||||
end;
|
||||
|
||||
destructor TBCToolBar.Destroy;
|
||||
begin
|
||||
FBGRA.Free;
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
procedure TBCToolBar.SetLimitMemoryUsage(AValue: boolean);
|
||||
begin
|
||||
if FLimitMemoryUsage=AValue then Exit;
|
||||
FLimitMemoryUsage:=AValue;
|
||||
CheckMemoryUsage;
|
||||
end;
|
||||
|
||||
{$IFNDEF FPC}
|
||||
procedure TBCToolBar.PaintWindow(DC: HDC);
|
||||
begin
|
||||
Canvas.Lock;
|
||||
try
|
||||
Canvas.Handle := DC;
|
||||
try
|
||||
TControlCanvas(Canvas).UpdateTextFlags;
|
||||
Paint;
|
||||
finally
|
||||
Canvas.Handle := 0;
|
||||
end;
|
||||
finally
|
||||
Canvas.Unlock;
|
||||
end;
|
||||
end;
|
||||
{$ENDIF}
|
||||
|
||||
procedure TBCToolBar.Paint;
|
||||
begin
|
||||
if (FBGRA.Width <> Width) or (FBGRA.Height <> Height) then
|
||||
begin
|
||||
FBGRA.SetSize(Width, Height);
|
||||
if Assigned(FOnRedraw) then
|
||||
{ Draw using event }
|
||||
FOnRedraw(self, FBGRA)
|
||||
else
|
||||
{ Draw this default }
|
||||
DrawWindows7ToolBar(FBGRA, Color);
|
||||
end;
|
||||
FBGRA.Draw(Canvas, 0, 0);
|
||||
CheckMemoryUsage;
|
||||
end;
|
||||
|
||||
procedure TBCToolBar.CheckMemoryUsage;
|
||||
begin
|
||||
if FLimitMemoryUsage then
|
||||
begin
|
||||
if FBGRA.NbPixels <> 0 then
|
||||
FBGRA.SetSize(0,0);
|
||||
end;
|
||||
end;
|
||||
|
||||
end.
|
||||
736
bgracontrols/bctools.pas
Normal file
736
bgracontrols/bctools.pas
Normal file
@@ -0,0 +1,736 @@
|
||||
// SPDX-License-Identifier: LGPL-3.0-linking-exception
|
||||
{ General framework methods for rendering background, borders, text, etc.
|
||||
|
||||
originally written in 2012 by Krzysztof Dibowski dibowski at interia.pl
|
||||
}
|
||||
{******************************* CONTRIBUTOR(S) ******************************
|
||||
- Edivando S. Santos Brasil | mailedivando@gmail.com
|
||||
(Compatibility with delphi VCL 11/2018)
|
||||
|
||||
***************************** END CONTRIBUTOR(S) *****************************}
|
||||
unit BCTools;
|
||||
|
||||
{$I bgracontrols.inc}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils, Types, Graphics,
|
||||
{$IFDEF FPC}LCLType, LCLIntf,{$ENDIF} {$IFNDEF FPC}BGRAGraphics, GraphType, FPImage, {$ENDIF}
|
||||
BGRABitmap, BGRABitmapTypes, bctypes, Controls, BGRAGradientScanner;
|
||||
|
||||
function ScaleRect(ARect: TRect; AScale: Single): TRect;
|
||||
// This method prepare BGRABitmap for rendering BCFont type
|
||||
procedure AssignBCFont(AFont: TBCFont; var ATargetBGRA: TBGRABitmap);
|
||||
// Calculate text height and width (doesn't include wordwrap - just single line)
|
||||
procedure CalculateTextSize(const AText: String; AFont: TBCFont; out ANewWidth, ANewHeight: integer;
|
||||
AShadowMargin: boolean = true);
|
||||
// Calculate text height and width (handles wordwrap and end ellipsis)
|
||||
procedure CalculateTextSizeEx(const AText: String; AFont: TBCFont; out ANewWidth, ANewHeight: integer;
|
||||
AAvailableWidth: integer; AShadowMargin: boolean = false);
|
||||
// Determines the layout of the glyph
|
||||
procedure GetGlyphActualLayout(ACaption: string; AFont: TBCFont;
|
||||
AGlyphAlignment: TBCAlignment; AGlyphMargin: integer; out AHorizAlign: TAlignment;
|
||||
out AVertAlign: TTextLayout; out AGlyphRelativeHorizAlign: TAlignment;
|
||||
out AGlyphRelativeVertAlign: TTextLayout; out AGlyphHorizMargin: integer;
|
||||
out AGlyphVertMargin: integer);
|
||||
// Computes the position the glyph and update rAvail with the space dedicated to text.
|
||||
// Specify the flag AOldPlacement to have the old (buggy) version
|
||||
function ComputeGlyphPosition(var rAvail: TRect;
|
||||
AGlyph: TBitmap; AGlyphAlignment: TBCAlignment; AGlyphMargin: integer;
|
||||
ACaption: string; AFont: TBCFont; AOldPlacement: boolean = false;
|
||||
AGlyphScale: Single = 1): TRect; overload;
|
||||
function ComputeGlyphPosition(var rAvail: TRect;
|
||||
gw, gh: integer; AGlyphAlignment: TBCAlignment; AGlyphMargin: integer;
|
||||
ACaption: string; AFont: TBCFont; AOldPlacement: boolean = false): TRect; overload;
|
||||
// This method correct TRect to border width. As far as border width is bigger,
|
||||
// BGRA drawing rectangle with offset (half border width)
|
||||
procedure CalculateBorderRect(ABorder: TBCBorder; var ARect: TRect);
|
||||
// This returns a rectangle that is inside the border outline
|
||||
procedure CalculateInnerRect(ABorder: TBCBorder; var ARect: TRect);
|
||||
// Create BGRA Gradient Scanner based on BCGradient properties
|
||||
function CreateGradient(AGradient: TBCGradient; ARect: TRect): TBGRAGradientScanner;
|
||||
// Render arrow (used by BCButton with DropDownMenu style)
|
||||
procedure RenderArrow(ATargetBGRA: TBGRABitmap; const ARect: TRect;
|
||||
ASize: Integer; ADirection: TBCArrowDirection; AColor: TColor = clBlack;
|
||||
AOpacity: Byte = 255);
|
||||
// Render customizable backgroud (used e.g. by TBCButton, TBCPanel, TBCLabel)
|
||||
procedure RenderBackground(const ARect: TRect; ABackground: TBCBackground;
|
||||
ATargetBGRA: TBGRABitmap; ARounding: TBCRounding = nil; AHasNoBorder: boolean = false);
|
||||
procedure RenderBackgroundF(x1,y1,x2,y2: single; ABackground: TBCBackground;
|
||||
ATargetBGRA: TBGRABitmap; ARounding: TBCRounding = nil);
|
||||
procedure RenderBackgroundAndBorder(const ARect: TRect; ABackground: TBCBackground;
|
||||
ATargetBGRA: TBGRABitmap; ARounding: TBCRounding; ABorder: TBCBorder; AInnerMargin: single = 0);
|
||||
// Render customizable border (used e.g. by TBCButton, TBCPanel, TBCLabel)
|
||||
procedure RenderBorder(const ARect: TRect; ABorder: TBCBorder;
|
||||
ATargetBGRA: TBGRABitmap; ARounding: TBCRounding = nil);
|
||||
procedure RenderBorderF(x1,y1,x2,y2: single; ABorder: TBCBorder;
|
||||
ATargetBGRA: TBGRABitmap; ARounding: TBCRounding = nil);
|
||||
// Render BCFont (used e.g. by TBCButton, TBCPanel, TBCLabel)
|
||||
procedure RenderText(const ARect: TRect; AFont: TBCFont;
|
||||
const AText: String; ATargetBGRA: TBGRABitmap; AEnabled: boolean);
|
||||
// Return LCL horizontal equivalent for BCAlignment
|
||||
function BCAlign2HAlign(AAlign: TBCAlignment): TAlignment;
|
||||
// Return LCL vertical equivalent for BCAlignment
|
||||
function BCAlign2VAlign(AAlign: TBCAlignment): TTextLayout;
|
||||
|
||||
implementation
|
||||
|
||||
uses BGRAPolygon, BGRAFillInfo, BGRAText, math, BGRAUTF8, LazUTF8;
|
||||
|
||||
function ComputeGlyphPosition(var rAvail: TRect; AGlyph: TBitmap;
|
||||
AGlyphAlignment: TBCAlignment; AGlyphMargin: integer; ACaption: string;
|
||||
AFont: TBCFont; AOldPlacement: boolean; AGlyphScale: Single): TRect;
|
||||
var gw, gh: integer;
|
||||
begin
|
||||
if Assigned(AGlyph) and not AGlyph.Empty then
|
||||
begin
|
||||
gw := round(AGlyph.Width * AGlyphScale);
|
||||
gh := round(AGlyph.Height * AGlyphScale);
|
||||
end else
|
||||
begin
|
||||
gw := 0;
|
||||
gh := 0;
|
||||
end;
|
||||
result := ComputeGlyphPosition(rAvail, gw, gh, AGlyphAlignment, AGlyphMargin, ACaption,
|
||||
AFont, AOldPlacement);
|
||||
end;
|
||||
|
||||
procedure CalculateBorderRect(ABorder: TBCBorder; var ARect: TRect);
|
||||
var w: integer;
|
||||
begin
|
||||
if ABorder = nil then Exit;
|
||||
w := ABorder.Width div 2;
|
||||
Inc(ARect.Left, w);
|
||||
Inc(ARect.Top, w);
|
||||
Dec(ARect.Right, w);
|
||||
Dec(ARect.Bottom, w);
|
||||
end;
|
||||
|
||||
procedure CalculateInnerRect(ABorder: TBCBorder; var ARect: TRect);
|
||||
var w: integer;
|
||||
begin
|
||||
if (ABorder = nil) or (ABorder.Style = bboNone) then Exit;
|
||||
w := ABorder.Width;
|
||||
Inc(ARect.Left, w);
|
||||
Inc(ARect.Top, w);
|
||||
Dec(ARect.Right, w);
|
||||
Dec(ARect.Bottom, w);
|
||||
end;
|
||||
|
||||
function CreateGradient(AGradient: TBCGradient; ARect: TRect): TBGRAGradientScanner;
|
||||
begin
|
||||
Result := TBGRAGradientScanner.Create(
|
||||
ColorToBGRA(ColorToRGB(AGradient.StartColor), AGradient.StartColorOpacity),
|
||||
ColorToBGRA(ColorToRGB(AGradient.EndColor), AGradient.EndColorOpacity),
|
||||
AGradient.GradientType, PointF(ARect.Left + Round(
|
||||
((ARect.Right - ARect.Left) / 100) * AGradient.Point1XPercent),
|
||||
ARect.Top + Round(((ARect.Bottom - ARect.Top) / 100) * AGradient.Point1YPercent)),
|
||||
PointF(ARect.Left + Round(((ARect.Right - ARect.Left) / 100) *
|
||||
AGradient.Point2XPercent), ARect.Top + Round(
|
||||
((ARect.Bottom - ARect.Top) / 100) * AGradient.Point2YPercent)),
|
||||
AGradient.ColorCorrection, AGradient.Sinus);
|
||||
end;
|
||||
|
||||
procedure RenderBackgroundAndBorder(const ARect: TRect;
|
||||
ABackground: TBCBackground; ATargetBGRA: TBGRABitmap;
|
||||
ARounding: TBCRounding; ABorder: TBCBorder; AInnerMargin: single);
|
||||
var w: single;
|
||||
begin
|
||||
if ABorder.Style = bboNone then
|
||||
begin
|
||||
w := AInnerMargin-0.5;
|
||||
RenderBackgroundF(ARect.Left+w, ARect.Top+w, ARect.Right-1-w,
|
||||
ARect.Bottom-1-w,ABackground,ATargetBGRA,ARounding);
|
||||
end
|
||||
else
|
||||
begin
|
||||
w := (ABorder.Width-1)/2+AInnerMargin;
|
||||
RenderBackgroundF(ARect.Left+w,ARect.Top+w,ARect.Right-1-w,ARect.Bottom-1-w,ABackground,ATargetBGRA,ARounding);
|
||||
RenderBorderF(ARect.Left+w,ARect.Top+w,ARect.Right-1-w,ARect.Bottom-1-w,ABorder,ATargetBGRA,ARounding);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure RenderBorder(const ARect: TRect; ABorder: TBCBorder;
|
||||
ATargetBGRA: TBGRABitmap; ARounding: TBCRounding = nil);
|
||||
begin
|
||||
RenderBorderF(ARect.Left,ARect.Top,ARect.Right-1,ARect.Bottom-1,ABorder,
|
||||
ATargetBGRA,ARounding);
|
||||
end;
|
||||
|
||||
procedure RenderBorderF(x1,y1,x2,y2: single; ABorder: TBCBorder;
|
||||
ATargetBGRA: TBGRABitmap; ARounding: TBCRounding = nil);
|
||||
var
|
||||
fiLight: TFillBorderRoundRectInfo;
|
||||
rx,ry: Byte;
|
||||
ropt: TRoundRectangleOptions;
|
||||
begin
|
||||
if (x1>x2) or (y1>y2) then exit;
|
||||
if ABorder.Style=bboNone then Exit;
|
||||
|
||||
if ARounding = nil then
|
||||
begin
|
||||
rx := 0;
|
||||
ry := 0;
|
||||
ropt := [];
|
||||
end else
|
||||
begin
|
||||
rx := ARounding.RoundX;
|
||||
ry := ARounding.RoundY;
|
||||
ropt := ARounding.RoundOptions;
|
||||
end;
|
||||
|
||||
ATargetBGRA.RoundRectAntialias(x1,y1,x2,y2,
|
||||
rx, ry, ColorToBGRA(ColorToRGB(ABorder.Color),ABorder.ColorOpacity),
|
||||
ABorder.Width, ropt);
|
||||
|
||||
if ABorder.LightWidth > 0 then
|
||||
begin
|
||||
//compute light position
|
||||
fiLight := TFillBorderRoundRectInfo.Create(
|
||||
x1,y1,x2,y2, rx,
|
||||
ry, ABorder.Width + ABorder.LightWidth, ropt);
|
||||
//check if there is an inner position
|
||||
if fiLight.InnerBorder <> nil then
|
||||
with fiLight.InnerBorder do //fill with light
|
||||
ATargetBGRA.RoundRectAntialias(topleft.x, topleft.y, bottomright.x,
|
||||
bottomright.y, radiusx, radiusY,
|
||||
ColorToBGRA(ColorToRGB(ABorder.LightColor), ABorder.LightOpacity),
|
||||
ABorder.LightWidth, ropt);
|
||||
fiLight.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure RenderText(const ARect: TRect; AFont: TBCFont;
|
||||
const AText: String; ATargetBGRA: TBGRABitmap; AEnabled: boolean);
|
||||
var
|
||||
shd: TBGRABitmap;
|
||||
hal: TAlignment;
|
||||
val: TTextLayout;
|
||||
st: TTextStyle;
|
||||
r: TRect;
|
||||
c: TColor;
|
||||
begin
|
||||
if AText = '' then exit;
|
||||
|
||||
AssignBCFont(AFont,ATargetBGRA);
|
||||
|
||||
hal := BCAlign2HAlign(AFont.TextAlignment);
|
||||
val := BCAlign2VAlign(AFont.TextAlignment);
|
||||
|
||||
FillChar({%H-}st, SizeOf({%H-}st),0);
|
||||
|
||||
st.Wordbreak := AFont.WordBreak;
|
||||
st.Alignment := hal;
|
||||
st.Layout := val;
|
||||
st.SingleLine := AFont.SingleLine;
|
||||
st.EndEllipsis := AFont.EndEllipsis;
|
||||
r := ARect;
|
||||
r.Left += AFont.PaddingLeft;
|
||||
r.Right -= AFont.PaddingRight;
|
||||
r.Top += AFont.PaddingTop;
|
||||
r.Bottom -= AFont.PaddingBottom;
|
||||
|
||||
if AFont.Shadow then
|
||||
begin
|
||||
shd := TBGRABitmap.Create(ATargetBGRA.Width,ATargetBGRA.Height,BGRAPixelTransparent);
|
||||
shd.FontName := ATargetBGRA.FontName;
|
||||
shd.FontStyle := ATargetBGRA.FontStyle;
|
||||
shd.FontQuality := ATargetBGRA.FontQuality;
|
||||
shd.FontHeight := ATargetBGRA.FontHeight;
|
||||
shd.TextRect(r, r.Left, r.Top, AText, st, ColorToBGRA(ColorToRGB(AFont.ShadowColor),
|
||||
AFont.ShadowColorOpacity));
|
||||
BGRAReplace(shd, shd.FilterBlurRadial(AFont.ShadowRadius, rbFast));
|
||||
ATargetBGRA.BlendImage(AFont.ShadowOffsetX, AFont.ShadowOffsetY,
|
||||
shd, boLinearBlend);
|
||||
shd.Free;
|
||||
end;
|
||||
|
||||
if AEnabled or (AFont.DisabledColor = clNone) then
|
||||
c := AFont.Color else c := AFont.DisabledColor;
|
||||
ATargetBGRA.TextRect(r,r.Left,r.Top,AText,st,c);
|
||||
|
||||
end;
|
||||
|
||||
function BCAlign2HAlign(AAlign: TBCAlignment): TAlignment;
|
||||
begin
|
||||
if AAlign in [bcaCenter, bcaCenterTop, bcaCenterBottom] then
|
||||
Result := taCenter
|
||||
else if AAlign in [bcaRightCenter, bcaRightTop, bcaRightBottom] then
|
||||
Result := taRightJustify
|
||||
else
|
||||
Result := taLeftJustify;
|
||||
end;
|
||||
|
||||
function BCAlign2VAlign(AAlign: TBCAlignment): TTextLayout;
|
||||
begin
|
||||
if AAlign in [bcaCenter, bcaLeftCenter, bcaRightCenter] then
|
||||
Result := tlCenter
|
||||
else if AAlign in [bcaCenterBottom, bcaLeftBottom, bcaRightBottom] then
|
||||
Result := tlBottom
|
||||
else
|
||||
Result := tlTop;
|
||||
end;
|
||||
|
||||
function ScaleRect(ARect: TRect; AScale: Single): TRect;
|
||||
begin
|
||||
with ARect do
|
||||
result := rect(round(Left*AScale), round(Top*AScale),
|
||||
round(Right*AScale), round(Bottom*AScale));
|
||||
end;
|
||||
|
||||
procedure AssignBCFont(AFont: TBCFont; var ATargetBGRA: TBGRABitmap);
|
||||
var c: TBitmap;
|
||||
begin
|
||||
// Canvas is need for calculate font height
|
||||
c := TBitmap.Create;
|
||||
c.Canvas.Font.Name := AFont.Name;
|
||||
c.Canvas.Font.Style := AFont.Style;
|
||||
case AFont.FontQuality of
|
||||
fqSystem: c.Canvas.Font.Quality := fqNonAntialiased;
|
||||
fqFineAntialiasing: c.Canvas.Font.Quality := fqAntialiased;
|
||||
fqFineClearTypeRGB: c.Canvas.Font.Quality := fqProof;
|
||||
fqSystemClearType: c.Canvas.Font.Quality := fqCleartype;
|
||||
end;
|
||||
// FontAntialias is only backward compability for FontQuality property.
|
||||
// FontQuality is published in TBCFont so we don't need FontAntialias anymore.
|
||||
//ATargetBGRA.FontAntialias := AFont.FontAntialias;
|
||||
{%H-}ATargetBGRA.FontStyle := AFont.Style;
|
||||
|
||||
// If font quality is system, then we can leave default values. LCL will
|
||||
// handle everything (when name is "default" or height 0)
|
||||
if AFont.FontQuality in [fqSystem,fqSystemClearType] then
|
||||
begin
|
||||
ATargetBGRA.FontName := AFont.Name;
|
||||
ATargetBGRA.FontHeight := AFont.Height;
|
||||
end
|
||||
else
|
||||
begin
|
||||
// Getting real font name
|
||||
if SameText(AFont.Name,'default')
|
||||
then ATargetBGRA.FontName := string(GetFontData(c.Canvas.Font.Handle).Name)
|
||||
else ATargetBGRA.FontName := AFont.Name;
|
||||
|
||||
// Calculate default height, because when font quality is <> fqSystemXXX
|
||||
// then if height is 0 then it is 0 for real
|
||||
if (AFont.Height=0) then
|
||||
ATargetBGRA.FontHeight := -c.Canvas.TextHeight('Bgra')
|
||||
else
|
||||
ATargetBGRA.FontHeight := AFont.Height;
|
||||
end;
|
||||
ATargetBGRA.FontQuality := AFont.FontQuality;
|
||||
c.Free;
|
||||
end;
|
||||
|
||||
procedure CalculateTextSize(const AText: String; AFont: TBCFont; out ANewWidth,
|
||||
ANewHeight: integer; AShadowMargin: boolean);
|
||||
var
|
||||
s: TSize;
|
||||
tmp: TBGRABitmap;
|
||||
begin
|
||||
if (AText = '') or (AFont = nil) then
|
||||
begin
|
||||
ANewWidth := 0;
|
||||
ANewHeight := 0;
|
||||
Exit;
|
||||
end;
|
||||
|
||||
tmp := TBGRABitmap.Create(0,0);
|
||||
AssignBCFont(AFont, tmp);
|
||||
s := tmp.TextSize(AText);
|
||||
tmp.Free;
|
||||
|
||||
{ shadow offset }
|
||||
if AShadowMargin and AFont.Shadow then
|
||||
begin
|
||||
Inc(s.cx, 2 * Abs(AFont.ShadowOffsetX) + 2 * AFont.ShadowRadius);
|
||||
Inc(s.cy, 2 * Abs(AFont.ShadowOffsetY) + 2 * AFont.ShadowRadius);
|
||||
end;
|
||||
|
||||
inc(s.cx, AFont.PaddingLeft+Afont.PaddingRight);
|
||||
inc(s.cy, AFont.PaddingTop+Afont.PaddingBottom);
|
||||
|
||||
ANewWidth := s.cx;
|
||||
ANewHeight := s.cy;
|
||||
end;
|
||||
|
||||
procedure CalculateTextSizeEx(const AText: String; AFont: TBCFont; out
|
||||
ANewWidth, ANewHeight: integer; AAvailableWidth: integer; AShadowMargin: boolean);
|
||||
var
|
||||
s: TSize;
|
||||
tmp: TBGRABitmap;
|
||||
extraX,extraY, fitCount: integer;
|
||||
dotSize: LongInt;
|
||||
begin
|
||||
if (AText = '') or (AFont = nil) then
|
||||
begin
|
||||
ANewWidth := 0;
|
||||
ANewHeight := 0;
|
||||
Exit;
|
||||
end;
|
||||
|
||||
extraX := 0;
|
||||
extraY := 0;
|
||||
{ shadow offset }
|
||||
if AShadowMargin and AFont.Shadow then
|
||||
begin
|
||||
Inc(extraX, 2 * Abs(AFont.ShadowOffsetX) + 2 * AFont.ShadowRadius);
|
||||
Inc(extraY, 2 * Abs(AFont.ShadowOffsetY) + 2 * AFont.ShadowRadius);
|
||||
end;
|
||||
|
||||
inc(extraX, AFont.PaddingLeft+Afont.PaddingRight);
|
||||
inc(extraY, AFont.PaddingTop+Afont.PaddingBottom);
|
||||
|
||||
dec(AAvailableWidth, extraX);
|
||||
tmp := TBGRABitmap.Create(0,0);
|
||||
AssignBCFont(AFont, tmp);
|
||||
if AFont.WordBreak then
|
||||
s := tmp.TextSize(AText, AAvailableWidth)
|
||||
else
|
||||
begin
|
||||
s := tmp.TextSize(AText);
|
||||
if AFont.EndEllipsis and (s.cx > AAvailableWidth) then
|
||||
begin
|
||||
dotSize := tmp.TextSize('...').cx;
|
||||
fitCount := tmp.TextFitInfo(AText, AAvailableWidth-dotSize);
|
||||
s.cx := tmp.TextSize(UTF8Copy(AText, 1, fitCount)).cx + dotSize;
|
||||
end;
|
||||
end;
|
||||
tmp.Free;
|
||||
|
||||
ANewWidth := s.cx+extraX;
|
||||
ANewHeight := s.cy+extraY;
|
||||
end;
|
||||
|
||||
procedure GetGlyphActualLayout(ACaption: string; AFont: TBCFont;
|
||||
AGlyphAlignment: TBCAlignment; AGlyphMargin: integer; out AHorizAlign: TAlignment;
|
||||
out AVertAlign: TTextLayout; out AGlyphRelativeHorizAlign: TAlignment;
|
||||
out AGlyphRelativeVertAlign: TTextLayout; out AGlyphHorizMargin: integer;
|
||||
out AGlyphVertMargin: integer);
|
||||
begin
|
||||
if AGlyphAlignment in [bcaLeftTop,bcaLeftCenter,bcaLeftBottom] then AHorizAlign := taLeftJustify
|
||||
else if AGlyphAlignment in [bcaRightTop,bcaRightCenter,bcaRightBottom] then AHorizAlign:= taRightJustify
|
||||
else AHorizAlign:= taCenter;
|
||||
if AGlyphAlignment in [bcaCenter,bcaLeftCenter,bcaRightCenter] then AVertAlign := tlCenter
|
||||
else if AGlyphAlignment in [bcaLeftBottom,bcaCenterBottom,bcaRightBottom] then AVertAlign := tlBottom
|
||||
else AVertAlign := tlTop;
|
||||
|
||||
if ACaption<>'' then
|
||||
begin
|
||||
AGlyphRelativeVertAlign:= AVertAlign;
|
||||
if AVertAlign <> tlCenter then
|
||||
AGlyphRelativeHorizAlign:= AHorizAlign else
|
||||
begin
|
||||
if AHorizAlign = taCenter then
|
||||
begin
|
||||
if IsRightToLeftUTF8(ACaption) then AGlyphRelativeHorizAlign := taRightJustify
|
||||
else AGlyphRelativeHorizAlign := taLeftJustify;
|
||||
end else
|
||||
AGlyphRelativeHorizAlign:= AHorizAlign;
|
||||
end;
|
||||
|
||||
if AFont.TextAlignment in [bcaLeftTop,bcaLeftCenter,bcaLeftBottom] then AHorizAlign := taLeftJustify
|
||||
else if AFont.TextAlignment in [bcaRightTop,bcaRightCenter,bcaRightBottom] then AHorizAlign:= taRightJustify
|
||||
else AHorizAlign := taCenter;
|
||||
if AFont.TextAlignment in [bcaLeftTop,bcaCenterTop,bcaRightTop] then AVertAlign := tlTop
|
||||
else if AFont.TextAlignment in [bcaLeftBottom,bcaCenterBottom,bcaRightBottom] then AVertAlign:= tlBottom
|
||||
else AVertAlign:= tlCenter;
|
||||
|
||||
if AGlyphRelativeVertAlign in[tlTop,tlBottom] then
|
||||
begin
|
||||
if AGlyphRelativeHorizAlign <> taCenter then AGlyphHorizMargin:= AGlyphMargin
|
||||
else AGlyphHorizMargin:= 0;
|
||||
if AGlyphRelativeVertAlign = AVertAlign then AGlyphVertMargin:= AGlyphMargin
|
||||
else AGlyphVertMargin:= 0;
|
||||
end else
|
||||
begin
|
||||
AGlyphHorizMargin:= AGlyphMargin;
|
||||
AGlyphVertMargin:= 0;
|
||||
end;
|
||||
end else
|
||||
begin
|
||||
case AHorizAlign of
|
||||
taCenter: AGlyphRelativeHorizAlign:= taCenter;
|
||||
taRightJustify: AGlyphRelativeHorizAlign:= taLeftJustify;
|
||||
else AGlyphRelativeHorizAlign:= taRightJustify;
|
||||
end;
|
||||
if AHorizAlign <> taCenter then AGlyphHorizMargin := AGlyphMargin
|
||||
else AGlyphHorizMargin := 0;
|
||||
case AVertAlign of
|
||||
tlCenter: AGlyphRelativeVertAlign:= tlCenter;
|
||||
tlBottom: AGlyphRelativeVertAlign:= tlTop;
|
||||
else AGlyphRelativeVertAlign:= tlBottom;
|
||||
end;
|
||||
if AVertAlign <> tlCenter then AGlyphVertMargin := AGlyphMargin
|
||||
else AGlyphVertMargin := 0;
|
||||
end;
|
||||
end;
|
||||
|
||||
function ComputeGlyphPosition(var rAvail: TRect;
|
||||
gw, gh: integer; AGlyphAlignment: TBCAlignment; AGlyphMargin: integer;
|
||||
ACaption: string; AFont: TBCFont; AOldPlacement: boolean): TRect;
|
||||
var
|
||||
w, h, w2,h2, glyphHorzMargin, glyphVertMargin: integer;
|
||||
horizAlign, relHorizAlign: TAlignment;
|
||||
vertAlign, relVertAlign: TTextLayout;
|
||||
rText, rAll, rGlyph: TRect;
|
||||
l,t: integer;
|
||||
|
||||
procedure AlignRect(var ARect: TRect; const ABounds: TRect; AHorizAlign: TAlignment;
|
||||
AVertAlign: TTextLayout; AHorizMargin: integer = 0; AVertMargin: integer = 0);
|
||||
begin
|
||||
case AHorizAlign of
|
||||
taCenter: ARect.Offset((ABounds.Left+ABounds.Right - (ARect.Right-ARect.Left)) div 2,0);
|
||||
taRightJustify: ARect.Offset(ABounds.Right - AHorizMargin - (ARect.Right-ARect.Left),0);
|
||||
else ARect.Offset(ABounds.Left + AHorizMargin,0);
|
||||
end;
|
||||
case AVertAlign of
|
||||
tlCenter: ARect.Offset(0, (ABounds.Top+ABounds.Bottom - (ARect.Bottom-ARect.Top)) div 2);
|
||||
tlBottom: ARect.Offset(0, ABounds.Bottom - AVertMargin - (ARect.Bottom-ARect.Top));
|
||||
else ARect.Offset(0, ABounds.Top + AVertMargin);
|
||||
end;
|
||||
end;
|
||||
|
||||
begin
|
||||
if (gw = 0) or (gh = 0) then exit(EmptyRect);
|
||||
|
||||
if AOldPlacement then
|
||||
begin
|
||||
if ACaption = '' then
|
||||
begin
|
||||
w := 0;
|
||||
h := 0;
|
||||
end else
|
||||
CalculateTextSize(ACaption, AFont, w, h);
|
||||
l := rAvail.Right - Round(((rAvail.Right - rAvail.Left) + w + gw) / 2);
|
||||
t := rAvail.Bottom - Round(((rAvail.Bottom - rAvail.Top) + gh) / 2);
|
||||
result := rect(l,t,l+gw,t+gh);
|
||||
Inc(rAvail.Left, l + gw + AGlyphMargin);
|
||||
exit;
|
||||
end;
|
||||
|
||||
GetGlyphActualLayout(ACaption, AFont, AGlyphAlignment, AGlyphMargin,
|
||||
horizAlign, vertAlign, relHorizAlign, relVertAlign, glyphHorzMargin, glyphVertMargin);
|
||||
|
||||
if ACaption = '' then
|
||||
begin
|
||||
rGlyph := rect(0,0,gw,gh);
|
||||
AlignRect(rGlyph, rAvail, horizAlign, vertAlign, glyphHorzMargin, glyphVertMargin);
|
||||
exit(rGlyph);
|
||||
end else
|
||||
CalculateTextSizeEx(ACaption, AFont, w, h, rAvail.Right-rAvail.Left);
|
||||
|
||||
if relVertAlign in[tlTop,tlBottom] then
|
||||
begin
|
||||
w2 := max(w,gw+glyphHorzMargin);
|
||||
h2 := h+gh+glyphVertMargin;
|
||||
end else
|
||||
begin
|
||||
w2 := w+gw+glyphHorzMargin;
|
||||
if (ACaption <> '') and (w2 > rAvail.Right-rAvail.Left) then
|
||||
begin
|
||||
CalculateTextSizeEx(ACaption, AFont, w, h, rAvail.Right-rAvail.Left - (gw+glyphHorzMargin));
|
||||
w2 := w+gw+glyphHorzMargin;
|
||||
end;
|
||||
h2 := max(h,gh+glyphVertMargin);
|
||||
end;
|
||||
rAll := rect(0,0,w2,h2);
|
||||
AlignRect(rAll, rAvail, horizAlign, vertAlign);
|
||||
|
||||
rText := rect(0,0,w,h);
|
||||
rGlyph := rect(0,0,gw,gh);
|
||||
case relVertAlign of
|
||||
tlTop: begin
|
||||
AlignRect(rGlyph, rAll, relHorizAlign, tlTop,
|
||||
glyphHorzMargin, glyphVertMargin);
|
||||
AlignRect(rText, rAll, horizAlign, tlBottom);
|
||||
end;
|
||||
tlBottom: begin
|
||||
AlignRect(rGlyph, rAll, relHorizAlign, tlBottom,
|
||||
glyphHorzMargin, glyphVertMargin);
|
||||
AlignRect(rText, rAll, horizAlign, tlTop);
|
||||
end;
|
||||
else begin
|
||||
if relHorizAlign = taRightJustify then
|
||||
begin
|
||||
AlignRect(rGlyph, rAll, taRightJustify, tlCenter,
|
||||
glyphHorzMargin, glyphHorzMargin);
|
||||
AlignRect(rText, rAll, taLeftJustify, tlCenter);
|
||||
end else
|
||||
begin
|
||||
AlignRect(rGlyph, rAll, taLeftJustify, tlCenter,
|
||||
glyphHorzMargin, glyphHorzMargin);
|
||||
AlignRect(rText, rAll, taRightJustify, tlCenter);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
result := rGlyph;
|
||||
if AFont.WordBreak and (rText.Right < rAvail.Right) then inc(rText.Right); //word-break computation may be one pixel off
|
||||
rAvail := rText;
|
||||
end;
|
||||
|
||||
procedure RenderArrow(ATargetBGRA: TBGRABitmap; const ARect: TRect;
|
||||
ASize: Integer; ADirection: TBCArrowDirection; AColor: TColor; AOpacity: Byte);
|
||||
var
|
||||
p: ArrayOfTPointF;
|
||||
n: byte;
|
||||
temp: TBGRABitmap;
|
||||
w: Integer;
|
||||
begin
|
||||
// We can't draw outside rect
|
||||
w := Min(ASize, ARect.Right - ARect.Left);
|
||||
|
||||
{ Poly }
|
||||
SetLength(p, 3);
|
||||
|
||||
temp := TBGRABitmap.Create(w+1, w+1,BGRAPixelTransparent);
|
||||
|
||||
case ADirection of
|
||||
badDown:
|
||||
begin;
|
||||
p[0].x := 0;
|
||||
p[0].y := 0;
|
||||
|
||||
p[1].x := w;
|
||||
p[1].y := 0;
|
||||
|
||||
p[2].x := Round(w/2);
|
||||
p[2].y := w;
|
||||
end;
|
||||
badUp:
|
||||
begin
|
||||
p[0].x := Round(w/2);
|
||||
p[0].y := 0;
|
||||
|
||||
p[1].x := 0;
|
||||
p[1].y := w;
|
||||
|
||||
p[2].x := w;
|
||||
p[2].y := w;
|
||||
end;
|
||||
badLeft:
|
||||
begin
|
||||
p[0].x := 0;
|
||||
p[0].y := Round(w/2);
|
||||
|
||||
p[1].x := w;
|
||||
p[1].y := 0;
|
||||
|
||||
p[2].x := w;
|
||||
p[2].y := w;
|
||||
end;
|
||||
badRight:
|
||||
begin
|
||||
p[0].x := w;
|
||||
p[0].y := Round(w/2);
|
||||
|
||||
p[1].x := 0;
|
||||
p[1].y := 0;
|
||||
|
||||
p[2].x := 0;
|
||||
p[2].y := w;
|
||||
end;
|
||||
end;
|
||||
|
||||
// Fill n times to get best quality
|
||||
for n := 1 to 6 do
|
||||
temp.FillPolyAntialias(p, ColorToBGRA(ColorToRGB(AColor),AOpacity));
|
||||
|
||||
ATargetBGRA.BlendImage(
|
||||
ARect.Right-Round( ((ARect.Right-ARect.Left)/2) + (w/2) ),
|
||||
ARect.Bottom-Round( ((ARect.Bottom-ARect.Top)/2) + (w/2) ),
|
||||
temp,
|
||||
boLinearBlend
|
||||
);
|
||||
temp.Free;
|
||||
end;
|
||||
|
||||
procedure RenderBackgroundF(x1,y1,x2,y2: single; ABackground: TBCBackground;
|
||||
ATargetBGRA: TBGRABitmap; ARounding: TBCRounding = nil);
|
||||
var
|
||||
backcolor: TBGRAPixel;
|
||||
multi: TBGRAMultishapeFiller;
|
||||
back: TBGRABitmap;
|
||||
grect1, grect2: TRect;
|
||||
gra: TBGRAGradientScanner;
|
||||
rx,ry: Byte;
|
||||
ropt: TRoundRectangleOptions;
|
||||
begin
|
||||
if (x1>=x2) or (y1>=y2) then exit;
|
||||
if ARounding = nil then
|
||||
begin
|
||||
rx := 0;
|
||||
ry := 0;
|
||||
ropt := [];
|
||||
end else
|
||||
begin
|
||||
rx := ARounding.RoundX;
|
||||
ry := ARounding.RoundY;
|
||||
ropt := ARounding.RoundOptions;
|
||||
end;
|
||||
|
||||
{ Background color }
|
||||
case ABackground.Style of
|
||||
bbsClear: backcolor := BGRAPixelTransparent;
|
||||
// TODO: Why if I use some system colors like clBtnFace, clActiveCaption etc.
|
||||
// without ColorToRGB, I always get Black? Interface: QT
|
||||
bbsColor: backcolor := ColorToBGRA(ColorToRGB(ABackground.Color), ABackground.ColorOpacity);
|
||||
end;
|
||||
|
||||
case ABackground.Style of
|
||||
bbsClear, bbsColor:
|
||||
{ Solid background color }
|
||||
ATargetBGRA.FillRoundRectAntialias(x1,y1,x2,y2, rx, ry, {%H-}backcolor, ropt);
|
||||
bbsGradient:
|
||||
begin
|
||||
{ Using multishape filler to merge background gradient and border }
|
||||
multi := TBGRAMultishapeFiller.Create;
|
||||
multi.PolygonOrder := poFirstOnTop; { Border will replace background }
|
||||
|
||||
{ Gradients }
|
||||
back := TBGRABitmap.Create(ATargetBGRA.Width, ATargetBGRA.Height, BGRAPixelTransparent);
|
||||
grect1 := rect(floor(x1),floor(y1),ceil(x2)+1,ceil(y2)+1);
|
||||
grect2 := grect1;
|
||||
{ Gradient 1 }
|
||||
if ABackground.Gradient1EndPercent > 0 then
|
||||
begin
|
||||
grect1.Bottom := grect1.top + Round(((grect1.Bottom-grect1.Top) / 100) * ABackground.Gradient1EndPercent);
|
||||
gra := CreateGradient(ABackground.Gradient1, grect1);
|
||||
back.FillRect(grect1.Left, grect1.Top, grect1.Right, grect1.Bottom,
|
||||
gra, dmSet
|
||||
);
|
||||
gra.Free;
|
||||
end;
|
||||
{ Gradient 2 }
|
||||
if ABackground.Gradient1EndPercent < 100 then
|
||||
begin
|
||||
grect2.Top := grect1.Bottom;
|
||||
gra := CreateGradient(ABackground.Gradient2, grect2);
|
||||
back.FillRect(grect2.Left, grect2.Top, grect2.Right, grect2.Bottom,
|
||||
gra, dmSet
|
||||
);
|
||||
gra.Free;
|
||||
end;
|
||||
|
||||
multi.AddRoundRectangle(x1,y1,x2,y2, rx, ry, back, ropt);
|
||||
|
||||
multi.Draw(ATargetBGRA);
|
||||
multi.Free;
|
||||
back.Free;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure RenderBackground(const ARect: TRect; ABackground: TBCBackground;
|
||||
ATargetBGRA: TBGRABitmap; ARounding: TBCRounding = nil; AHasNoBorder: boolean = false);
|
||||
var
|
||||
extraSize: single;
|
||||
begin
|
||||
if AHasNoBorder then extraSize := 0.5
|
||||
else extraSize := 0;
|
||||
RenderBackgroundF(ARect.Left-extraSize, ARect.Top-extraSize, ARect.Right-1+extraSize,
|
||||
ARect.Bottom-1+extraSize,ABackground,ATargetBGRA,ARounding);
|
||||
end;
|
||||
|
||||
end.
|
||||
|
||||
814
bgracontrols/bctrackbarupdown.pas
Normal file
814
bgracontrols/bctrackbarupdown.pas
Normal file
@@ -0,0 +1,814 @@
|
||||
// SPDX-License-Identifier: LGPL-3.0-linking-exception
|
||||
{
|
||||
Created by BGRA Controls Team
|
||||
Dibo, Circular, lainz (007) and contributors.
|
||||
For detailed information see readme.txt
|
||||
|
||||
Site: https://sourceforge.net/p/bgra-controls/
|
||||
Wiki: http://wiki.lazarus.freepascal.org/BGRAControls
|
||||
Forum: http://forum.lazarus.freepascal.org/index.php/board,46.0.html
|
||||
}
|
||||
{******************************* CONTRIBUTOR(S) ******************************
|
||||
- Edivando S. Santos Brasil | mailedivando@gmail.com
|
||||
(Compatibility with delphi VCL 11/2018)
|
||||
|
||||
***************************** END CONTRIBUTOR(S) *****************************}
|
||||
unit BCTrackbarUpdown;
|
||||
|
||||
{$I bgracontrols.inc}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
{$IFDEF FPC}LCLType, LResources,{$ENDIF}
|
||||
Classes, SysUtils, Types, Forms, Controls, Graphics, Dialogs,
|
||||
{$IFNDEF FPC}BGRAGraphics, GraphType, FPImage, {$ENDIF}
|
||||
ExtCtrls, BGRABitmap, BCBaseCtrls, BCTypes;
|
||||
|
||||
type
|
||||
TTrackBarUpDownChangeEvent = procedure(Sender: TObject; AByUser: boolean) of object;
|
||||
|
||||
{ TCustomBCTrackbarUpdown }
|
||||
|
||||
TCustomBCTrackbarUpdown = class(TBCCustomControl)
|
||||
protected
|
||||
FHandlingUserInput: boolean;
|
||||
FLongTimeInterval,FShortTimeInterval: integer;
|
||||
FMinValue,FMaxValue,FIncrement,FValue: integer;
|
||||
FAllowNegativeValues: boolean;
|
||||
FStartNegativeValue: boolean;
|
||||
FBarExponent: single;
|
||||
FSelStart,FSelLength: integer;
|
||||
FEmptyText: boolean;
|
||||
FBarClick,FUpClick,FDownClick: boolean;
|
||||
|
||||
FTimer: TTimer;
|
||||
FOnChange: TTrackBarUpDownChangeEvent;
|
||||
FBCBorder: TBCBorder;
|
||||
FBCRounding: TBCRounding;
|
||||
FBCBackground: TBCBackground;
|
||||
FBCButtonBackground,FBCButtonDownBackground: TBCBackground;
|
||||
FArrowColor: TColor;
|
||||
FHasTrackBar: boolean;
|
||||
|
||||
FCanvasScaling: double;
|
||||
FTextLeft: Integer;
|
||||
FBarLeft,FBarTop,FBarWidth,FBarHeight: Integer;
|
||||
FUpDownWidth: Integer;
|
||||
FUpDownLeft: Integer;
|
||||
FDownButtonTop: integer;
|
||||
function GetValue: integer;
|
||||
procedure SetAllowNegativeValues(AValue: boolean);
|
||||
procedure SetArrowColor(AValue: TColor);
|
||||
procedure SetHasTrackBar(AValue: boolean);
|
||||
procedure SetBarExponent(AValue: single);
|
||||
procedure SetBCBackground(AValue: TBCBackground);
|
||||
procedure SetBCBorder(AValue: TBCBorder);
|
||||
procedure SetBCButtonBackground(AValue: TBCBackground);
|
||||
procedure SetBCButtonDownBackground(AValue: TBCBackground);
|
||||
procedure SetBCRounding(AValue: TBCRounding);
|
||||
procedure OnChangeProperty({%H-}Sender: TObject; {%H-}AData: PtrInt);
|
||||
procedure Timer({%H-}Sender: TObject);
|
||||
procedure RenderOnBitmap(ABitmap: TBGRABitmap);
|
||||
procedure DrawControl; override;
|
||||
procedure DoSelectAll;
|
||||
function GetText: string; virtual;
|
||||
procedure SetText(AValue: string); virtual;
|
||||
procedure EnabledChanged; override;
|
||||
procedure NotifyChange; virtual;
|
||||
procedure SetIncrement(AValue: integer);
|
||||
procedure SetMaxValue(AValue: integer);
|
||||
procedure SetMinValue(AValue: integer);
|
||||
procedure SetValue(AValue: integer);
|
||||
function ValueToBarPos(AValue: integer): integer;
|
||||
function BarPosToValue(ABarPos: integer): integer;
|
||||
procedure MouseDown(Button: TMouseButton; {%H-}Shift: TShiftState; X, Y: Integer); override;
|
||||
procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
|
||||
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
|
||||
function DoMouseWheel(Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint): Boolean; override;
|
||||
procedure UTF8KeyPress(var UTF8Key: {$IFDEF FPC}TUTF8Char{$ELSE}String{$ENDIF}); override;
|
||||
procedure DoEnter; override;
|
||||
procedure DoExit; override;
|
||||
public
|
||||
constructor Create(AOwner: TComponent); override;
|
||||
procedure SelectAll;
|
||||
function RemoveSelection: boolean; //returns True if there was a selection to be removed
|
||||
procedure DelayTimer; //use after the program has been busy updating something according to the value of this component
|
||||
procedure SetFocus; override;
|
||||
destructor Destroy; override;
|
||||
property Border: TBCBorder read FBCBorder write SetBCBorder;
|
||||
property Background: TBCBackground read FBCBackground write SetBCBackground;
|
||||
property ButtonBackground: TBCBackground read FBCButtonBackground write SetBCButtonBackground;
|
||||
property ButtonDownBackground: TBCBackground read FBCButtonDownBackground write SetBCButtonDownBackground;
|
||||
property Rounding: TBCRounding read FBCRounding write SetBCRounding;
|
||||
property ArrowColor: TColor read FArrowColor write SetArrowColor;
|
||||
property HasTrackBar: boolean read FHasTrackBar write SetHasTrackBar;
|
||||
|
||||
property AllowNegativeValues: boolean read FAllowNegativeValues write SetAllowNegativeValues;
|
||||
property BarExponent: single read FBarExponent write SetBarExponent;
|
||||
property Increment: integer read FIncrement write SetIncrement;
|
||||
property LongTimeInterval: integer read FLongTimeInterval write FLongTimeInterval;
|
||||
property MinValue: integer read FMinValue write SetMinValue;
|
||||
property MaxValue: integer read FMaxValue write SetMaxValue;
|
||||
property OnChange: TTrackBarUpDownChangeEvent read FOnChange write FOnChange;
|
||||
property Text: string read GetText write SetText;
|
||||
property Value: integer read GetValue write SetValue;
|
||||
property SelStart: integer read FSelStart;
|
||||
property SelLength: integer read FSelLength;
|
||||
property ShortTimeInterval: integer read FShortTimeInterval write FShortTimeInterval;
|
||||
end;
|
||||
|
||||
TBCTrackbarUpdown = class(TCustomBCTrackbarUpdown)
|
||||
published
|
||||
property AllowNegativeValues;
|
||||
property BarExponent;
|
||||
property Increment;
|
||||
property LongTimeInterval;
|
||||
property MinValue;
|
||||
property MaxValue;
|
||||
property OnChange;
|
||||
property Value;
|
||||
property SelStart;
|
||||
property SelLength;
|
||||
property ShortTimeInterval;
|
||||
property Background;
|
||||
property ButtonBackground;
|
||||
property ButtonDownBackground;
|
||||
property Border;
|
||||
property Rounding;
|
||||
property Font;
|
||||
property HasTrackBar;
|
||||
property ArrowColor;
|
||||
|
||||
//inherited
|
||||
property Align;
|
||||
property Anchors;
|
||||
property BorderSpacing;
|
||||
property ChildSizing;
|
||||
{$IFDEF FPC} //#
|
||||
property OnGetDockCaption;
|
||||
{$ENDIF}
|
||||
property ClientHeight;
|
||||
property ClientWidth;
|
||||
property Constraints;
|
||||
property DockSite;
|
||||
property DragCursor;
|
||||
property DragKind;
|
||||
property DragMode;
|
||||
property Enabled;
|
||||
property ParentShowHint;
|
||||
property PopupMenu;
|
||||
property ShowHint;
|
||||
property TabOrder;
|
||||
property TabStop;
|
||||
property UseDockManager default True;
|
||||
property Visible;
|
||||
property OnClick;
|
||||
property OnContextPopup;
|
||||
property OnDockDrop;
|
||||
property OnDockOver;
|
||||
property OnDblClick;
|
||||
property OnDragDrop;
|
||||
property OnDragOver;
|
||||
property OnEndDock;
|
||||
property OnEndDrag;
|
||||
property OnEnter;
|
||||
property OnExit;
|
||||
property OnGetSiteInfo;
|
||||
property OnMouseDown;
|
||||
property OnMouseEnter;
|
||||
property OnMouseLeave;
|
||||
property OnMouseMove;
|
||||
property OnMouseUp;
|
||||
property OnResize;
|
||||
property OnStartDock;
|
||||
property OnStartDrag;
|
||||
property OnUnDock;
|
||||
end;
|
||||
|
||||
{$IFDEF FPC}procedure Register;{$ENDIF}
|
||||
|
||||
implementation
|
||||
|
||||
uses BGRABitmapTypes, Math, BCTools;
|
||||
|
||||
{$IFDEF FPC}
|
||||
procedure Register;
|
||||
begin
|
||||
RegisterComponents('BGRA Controls', [TBCTrackbarUpdown]);
|
||||
end;
|
||||
{$ENDIF}
|
||||
|
||||
{ TCustomBCTrackbarUpdown }
|
||||
|
||||
function TCustomBCTrackbarUpdown.GetText: string;
|
||||
begin
|
||||
if FEmptyText then
|
||||
begin
|
||||
if FStartNegativeValue then
|
||||
result := '-'
|
||||
else
|
||||
result := '';
|
||||
end else
|
||||
result := IntToStr(FValue);
|
||||
end;
|
||||
|
||||
procedure TCustomBCTrackbarUpdown.SetText(AValue: string);
|
||||
var errPos,tempValue: integer;
|
||||
txt: string;
|
||||
prevActualValue: integer;
|
||||
begin
|
||||
if trim(AValue) = '' then
|
||||
begin
|
||||
if not FEmptyText or FStartNegativeValue then
|
||||
begin
|
||||
FEmptyText:= true;
|
||||
FStartNegativeValue:= false;
|
||||
Invalidate;
|
||||
end;
|
||||
exit;
|
||||
end;
|
||||
prevActualValue:= Value;
|
||||
val(AValue,tempValue,errPos);
|
||||
if errPos = 0 then
|
||||
begin
|
||||
if tempValue > FMaxValue then tempValue := FMaxValue;
|
||||
if (tempValue < 0) and (tempValue < FMinValue) then tempValue:= FMinValue;
|
||||
if (FValue = tempValue) and not FEmptyText then exit;
|
||||
FValue := tempValue;
|
||||
FEmptyText:= false;
|
||||
end else
|
||||
if (AValue = '-') and AllowNegativeValues then
|
||||
begin
|
||||
FEmptyText:= true;
|
||||
FStartNegativeValue:= true;
|
||||
end;
|
||||
txt := Text;
|
||||
if FSelStart > length(txt) then FSelStart := length(txt);
|
||||
if FSelStart+FSelLength > length(txt) then FSelLength:= length(txt)-FSelStart;
|
||||
Repaint;
|
||||
if Value <> prevActualValue then NotifyChange;
|
||||
end;
|
||||
|
||||
procedure TCustomBCTrackbarUpdown.EnabledChanged;
|
||||
begin
|
||||
inherited EnabledChanged;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TCustomBCTrackbarUpdown.NotifyChange;
|
||||
begin
|
||||
if Assigned(FOnChange) then FOnChange(self, FHandlingUserInput);
|
||||
end;
|
||||
|
||||
procedure TCustomBCTrackbarUpdown.SetIncrement(AValue: integer);
|
||||
begin
|
||||
if FIncrement=AValue then Exit;
|
||||
FIncrement:=AValue;
|
||||
end;
|
||||
|
||||
procedure TCustomBCTrackbarUpdown.SetMaxValue(AValue: integer);
|
||||
begin
|
||||
if not AllowNegativeValues and (AValue < 0) then AValue := 0;
|
||||
if FMaxValue=AValue then Exit;
|
||||
FMaxValue:=AValue;
|
||||
if FMaxValue < FMinValue then FMinValue := FMaxValue;
|
||||
if AValue > FMaxValue then FMaxValue:= AValue;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TCustomBCTrackbarUpdown.SetMinValue(AValue: integer);
|
||||
begin
|
||||
if not AllowNegativeValues and (AValue < 0) then AValue := 0;
|
||||
if FMinValue=AValue then Exit;
|
||||
FMinValue:=AValue;
|
||||
if FMinValue > FMaxValue then FMaxValue := FMinValue;
|
||||
if AValue < FMinValue then FMinValue:= AValue;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TCustomBCTrackbarUpdown.SetValue(AValue: integer);
|
||||
begin
|
||||
if AValue < FMinValue then AValue := FMinValue;
|
||||
if AValue > FMaxValue then AValue := FMaxValue;
|
||||
if FValue=AValue then Exit;
|
||||
FValue:=AValue;
|
||||
FEmptyText:= false;
|
||||
DoSelectAll;
|
||||
Invalidate;
|
||||
NotifyChange;
|
||||
end;
|
||||
|
||||
procedure TCustomBCTrackbarUpdown.SetArrowColor(AValue: TColor);
|
||||
begin
|
||||
if FArrowColor=AValue then Exit;
|
||||
FArrowColor:=AValue;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TCustomBCTrackbarUpdown.SetHasTrackBar(AValue: boolean);
|
||||
begin
|
||||
if FHasTrackBar=AValue then Exit;
|
||||
FHasTrackBar:=AValue;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TCustomBCTrackbarUpdown.SetAllowNegativeValues(AValue: boolean);
|
||||
var
|
||||
changeVal: Boolean;
|
||||
begin
|
||||
if FAllowNegativeValues=AValue then Exit;
|
||||
FAllowNegativeValues:=AValue;
|
||||
if not FAllowNegativeValues then
|
||||
begin
|
||||
if (FMinValue < 0) or (FValue < 0) or (FMaxValue < 0) then
|
||||
begin
|
||||
if FMinValue < 0 then FMinValue := 0;
|
||||
if FValue < 0 then
|
||||
begin
|
||||
FValue := 0;
|
||||
changeVal := true;
|
||||
end else changeVal := false;
|
||||
if FMaxValue < 0 then FMaxValue:= 0;
|
||||
Invalidate;
|
||||
if changeVal then NotifyChange;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TCustomBCTrackbarUpdown.GetValue: integer;
|
||||
begin
|
||||
if FValue < FMinValue then result := FMinValue else
|
||||
result := FValue;
|
||||
end;
|
||||
|
||||
procedure TCustomBCTrackbarUpdown.SetBarExponent(AValue: single);
|
||||
begin
|
||||
if AValue <= 0 then exit;
|
||||
if FBarExponent=AValue then Exit;
|
||||
FBarExponent:=AValue;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TCustomBCTrackbarUpdown.SetBCBackground(AValue: TBCBackground);
|
||||
begin
|
||||
if FBCBackground=AValue then Exit;
|
||||
FBCBackground.Assign(AValue);
|
||||
end;
|
||||
|
||||
procedure TCustomBCTrackbarUpdown.SetBCBorder(AValue: TBCBorder);
|
||||
begin
|
||||
if FBCBorder=AValue then Exit;
|
||||
FBCBorder.Assign(AValue);
|
||||
end;
|
||||
|
||||
procedure TCustomBCTrackbarUpdown.SetBCButtonBackground(AValue: TBCBackground);
|
||||
begin
|
||||
if FBCButtonBackground=AValue then Exit;
|
||||
FBCButtonBackground.Assign(AValue);
|
||||
end;
|
||||
|
||||
procedure TCustomBCTrackbarUpdown.SetBCButtonDownBackground(
|
||||
AValue: TBCBackground);
|
||||
begin
|
||||
if FBCButtonDownBackground=AValue then Exit;
|
||||
FBCButtonDownBackground.Assign(AValue);
|
||||
end;
|
||||
|
||||
procedure TCustomBCTrackbarUpdown.SetBCRounding(AValue: TBCRounding);
|
||||
begin
|
||||
if FBCRounding=AValue then Exit;
|
||||
FBCRounding.Assign(AValue);
|
||||
end;
|
||||
|
||||
procedure TCustomBCTrackbarUpdown.OnChangeProperty(Sender: TObject;
|
||||
AData: PtrInt);
|
||||
begin
|
||||
RenderControl;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TCustomBCTrackbarUpdown.Timer(Sender: TObject);
|
||||
begin
|
||||
FHandlingUserInput:= true;
|
||||
if FUpClick then
|
||||
begin
|
||||
Value := Value + Increment;
|
||||
end else
|
||||
if FDownClick then
|
||||
Value := Value - Increment;
|
||||
FHandlingUserInput:= false;
|
||||
FTimer.Interval := ShortTimeInterval;
|
||||
end;
|
||||
|
||||
procedure TCustomBCTrackbarUpdown.RenderOnBitmap(ABitmap: TBGRABitmap);
|
||||
var bordercolor,fgcolor,btntext: TBGRAPixel;
|
||||
x,y,ty,barx: integer;
|
||||
s: TSize;
|
||||
midy: integer;
|
||||
midx: single;
|
||||
beforeSel,inSel,afterSel: string;
|
||||
bounds,fullBounds: TRect;
|
||||
begin
|
||||
fullbounds := rect(0,0,ABitmap.Width,ABitmap.Height);
|
||||
bounds := fullBounds;
|
||||
CalculateInnerRect(Border, bounds);
|
||||
ty := bounds.bottom-bounds.top-2;
|
||||
FTextLeft := bounds.left+1+((ty+5) div 10);
|
||||
FUpDownWidth := (ty*3+3) div 5;
|
||||
FUpDownLeft := bounds.right-FUpDownWidth;
|
||||
|
||||
FBarLeft := bounds.left+1;
|
||||
if FHasTrackBar then
|
||||
begin
|
||||
FBarHeight := (bounds.bottom-bounds.top+3) div 5+1;
|
||||
FBarWidth := bounds.right-FUpDownWidth-FBarHeight+1-FBarLeft;
|
||||
if (Rounding.RoundX > 1) and (Rounding.RoundY > 1) then
|
||||
FBarLeft := FBarLeft +FBarHeight+1;
|
||||
end else
|
||||
begin
|
||||
FBarWidth := 0;
|
||||
FBarHeight := 2;
|
||||
end;
|
||||
FBarTop := bounds.bottom-FBarHeight;
|
||||
|
||||
midy := ABitmap.Height div 2;
|
||||
FDownButtonTop := midy;
|
||||
|
||||
ABitmap.ClipRect := rect(fullbounds.left,fullbounds.top,FUpDownLeft+1,fullbounds.bottom);
|
||||
RenderBackgroundAndBorder(fullbounds, Background, ABitmap, Rounding, Border);
|
||||
|
||||
bordercolor := ColorToBGRA(ColorToRGB(Border.Color),Border.ColorOpacity);
|
||||
ABitmap.VertLine(FUpDownLeft,bounds.top,bounds.bottom-1,bordercolor,dmDrawWithTransparency);
|
||||
|
||||
if FUpClick then
|
||||
begin
|
||||
ABitmap.ClipRect := rect(FUpDownLeft+1,fullbounds.top,fullbounds.Right,midy);
|
||||
RenderBackgroundAndBorder(fullbounds, ButtonDownBackground, ABitmap, Rounding, Border);
|
||||
ABitmap.ClipRect := rect(FUpDownLeft+1,midy,fullbounds.Right,fullbounds.bottom);
|
||||
RenderBackgroundAndBorder(fullbounds, ButtonBackground, ABitmap, Rounding, Border);
|
||||
end else
|
||||
if FDownClick then
|
||||
begin
|
||||
ABitmap.ClipRect := rect(FUpDownLeft+1,fullbounds.top,fullbounds.Right,midy+1);
|
||||
RenderBackgroundAndBorder(fullbounds, ButtonBackground, ABitmap, Rounding, Border);
|
||||
ABitmap.ClipRect := rect(FUpDownLeft+1,midy+1,fullbounds.Right,fullbounds.bottom);
|
||||
RenderBackgroundAndBorder(fullbounds, ButtonDownBackground, ABitmap, Rounding, Border);
|
||||
end else
|
||||
begin
|
||||
ABitmap.ClipRect := rect(FUpDownLeft+1,fullbounds.top,fullbounds.Right,fullbounds.bottom);
|
||||
RenderBackgroundAndBorder(fullbounds, ButtonBackground, ABitmap, Rounding, Border);
|
||||
end;
|
||||
ABitmap.NoClip;
|
||||
ABitmap.HorizLine(FUpDownLeft+1,midy,bounds.right-1,bordercolor,dmDrawWithTransparency);
|
||||
|
||||
ABitmap.FontQuality := fqFineAntialiasing;
|
||||
ABitmap.FontName := Font.Name;
|
||||
ABitmap.FontStyle := Font.Style;
|
||||
ABitmap.FontHeight := ((ty-FBarHeight+1)*8+4) div 9;
|
||||
fgcolor := Font.Color;
|
||||
|
||||
x := FTextLeft;
|
||||
y := bounds.top+1;
|
||||
if Focused then
|
||||
begin
|
||||
if SelStart = 0 then
|
||||
begin
|
||||
beforeSel := '';
|
||||
inSel := Text;
|
||||
end else
|
||||
begin
|
||||
beforeSel := copy(Text,1,SelStart);
|
||||
inSel := copy(Text,SelStart+1,length(Text)-SelStart);
|
||||
end;
|
||||
if length(inSel)>SelLength then
|
||||
begin
|
||||
afterSel:= copy(inSel,SelLength+1,length(inSel)-SelLength);
|
||||
inSel := copy(inSel,1,SelLength);
|
||||
end else
|
||||
afterSel := '';
|
||||
ABitmap.TextOut(x,y,beforeSel,fgcolor);
|
||||
inc(x, ABitmap.TextSize(beforeSel).cx);
|
||||
if inSel = '' then ABitmap.SetVertLine(x,y,y+ABitmap.FontFullHeight-1,fgcolor)
|
||||
else
|
||||
begin
|
||||
s := ABitmap.TextSize(inSel);
|
||||
ABitmap.FillRect(x,y+1,x+s.cx,y+s.cy,ColorToRGB(clHighlight),dmSet);
|
||||
ABitmap.TextOut(x,y,inSel,ColorToRGB(clHighlightText));
|
||||
inc(x,s.cx);
|
||||
end;
|
||||
ABitmap.TextOut(x,y,afterSel,fgcolor);
|
||||
end else
|
||||
begin
|
||||
if Enabled then
|
||||
ABitmap.TextOut(x,y,Text,fgcolor)
|
||||
else
|
||||
ABitmap.TextOut(x,y,Text,BGRA(fgcolor.red,fgcolor.green,fgcolor.blue,fgcolor.alpha div 2));
|
||||
end;
|
||||
|
||||
barx := ValueToBarPos(Value);
|
||||
if FHasTrackBar then
|
||||
ABitmap.FillPolyAntialias([PointF(barx,FBarTop),PointF(barx+FBarHeight,FBarTop+FBarHeight),
|
||||
PointF(barx-FBarHeight,FBarTop+FBarHeight)],fgcolor);
|
||||
midx := FUpDownLeft+(FUpDownWidth-1)/2;
|
||||
btntext := FArrowColor;
|
||||
ABitmap.FillPolyAntialias([PointF(FUpDownLeft+2,midy*4/5),PointF(midx,midy/5),PointF(FUpDownLeft+FUpDownWidth-3,midy*4/5)],btntext);
|
||||
ABitmap.FillPolyAntialias([PointF(FUpDownLeft+2,midy*6/5),PointF(midx,ABitmap.Height-midy/5),PointF(FUpDownLeft+FUpDownWidth-3,midy*6/5)],btntext);
|
||||
end;
|
||||
|
||||
function TCustomBCTrackbarUpdown.ValueToBarPos(AValue: integer): integer;
|
||||
var t: single;
|
||||
begin
|
||||
if FMaxValue>FMinValue then
|
||||
begin
|
||||
t := (AValue-FMinValue)/(FMaxValue-FMinValue);
|
||||
if t < 0 then t := 0;
|
||||
if t > 1 then t := 1;
|
||||
result := FBarLeft+round(power(t,1/FBarExponent)*(FBarWidth-1))
|
||||
end
|
||||
else
|
||||
result := FBarLeft;
|
||||
end;
|
||||
|
||||
function TCustomBCTrackbarUpdown.BarPosToValue(ABarPos: integer): integer;
|
||||
var t: single;
|
||||
begin
|
||||
if FBarWidth > FBarLeft then
|
||||
begin
|
||||
t := (ABarPos-FBarLeft)/(FBarWidth-1);
|
||||
if t < 0 then t := 0;
|
||||
if t > 1 then t := 1;
|
||||
result := round(power(t,FBarExponent)*(FMaxValue-FMinValue))+FMinValue
|
||||
end
|
||||
else
|
||||
result := FMinValue;
|
||||
end;
|
||||
|
||||
procedure TCustomBCTrackbarUpdown.MouseDown(Button: TMouseButton;
|
||||
Shift: TShiftState; X, Y: Integer);
|
||||
begin
|
||||
X := round(X*FCanvasScaling);
|
||||
Y := round(Y*FCanvasScaling);
|
||||
if Button = mbLeft then
|
||||
begin
|
||||
FHandlingUserInput:= true;
|
||||
if X >= FUpDownLeft then
|
||||
begin
|
||||
if Y > FDownButtonTop then
|
||||
begin
|
||||
FDownClick:= true;
|
||||
Value := Value-Increment;
|
||||
Invalidate;
|
||||
FTimer.Interval := LongTimeInterval;
|
||||
FTimer.Enabled:= true;
|
||||
end else
|
||||
if Y < FDownButtonTop then
|
||||
begin
|
||||
FUpClick:= true;
|
||||
Value := Value+Increment;
|
||||
Invalidate;
|
||||
FTimer.Interval := LongTimeInterval;
|
||||
FTimer.Enabled:= true;
|
||||
end;
|
||||
end else
|
||||
if (Y >= Height-FBarHeight-1) and (FBarWidth>1) then
|
||||
begin
|
||||
FBarClick:= true;
|
||||
Value := BarPosToValue(X);
|
||||
Repaint;
|
||||
end;
|
||||
FHandlingUserInput:= false;
|
||||
end;
|
||||
if not Focused then
|
||||
begin
|
||||
SetFocus;
|
||||
SelectAll;
|
||||
end;
|
||||
inherited MouseDown(Button, Shift, X, Y);
|
||||
end;
|
||||
|
||||
procedure TCustomBCTrackbarUpdown.MouseMove(Shift: TShiftState; X, Y: Integer);
|
||||
begin
|
||||
inherited MouseMove(Shift, X, Y);
|
||||
X := round(X*FCanvasScaling);
|
||||
Y := round(Y*FCanvasScaling);
|
||||
if FBarClick and (FBarWidth>1) then
|
||||
begin
|
||||
FHandlingUserInput:= true;
|
||||
Value := BarPosToValue(X);
|
||||
FHandlingUserInput:= false;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TCustomBCTrackbarUpdown.MouseUp(Button: TMouseButton;
|
||||
Shift: TShiftState; X, Y: Integer);
|
||||
begin
|
||||
inherited MouseUp(Button, Shift, X, Y);
|
||||
X := round(X*FCanvasScaling);
|
||||
Y := round(Y*FCanvasScaling);
|
||||
if Button = mbLeft then
|
||||
begin
|
||||
if FBarClick then FBarClick:= false else
|
||||
if FUpClick then
|
||||
begin
|
||||
FUpClick:= false;
|
||||
Invalidate;
|
||||
FTimer.Enabled:= false;
|
||||
end else
|
||||
if FDownClick then
|
||||
begin
|
||||
FDownClick:= false;
|
||||
Invalidate;
|
||||
FTimer.Enabled:= false;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TCustomBCTrackbarUpdown.DoMouseWheel(Shift: TShiftState;
|
||||
WheelDelta: Integer; MousePos: TPoint): Boolean;
|
||||
begin
|
||||
if Assigned(OnMouseWheel) or Assigned(OnMouseWheelDown) or Assigned(OnMouseWheelUp) then
|
||||
begin
|
||||
result := inherited DoMouseWheel(Shift, WheelDelta, MousePos);
|
||||
exit;
|
||||
end;
|
||||
FHandlingUserInput:= true;
|
||||
Value := Value + Increment*WheelDelta div 120;
|
||||
FHandlingUserInput := false;
|
||||
Invalidate;
|
||||
result := true;
|
||||
end;
|
||||
|
||||
procedure TCustomBCTrackbarUpdown.UTF8KeyPress(var UTF8Key: {$IFDEF FPC}TUTF8Char{$ELSE}String{$ENDIF});
|
||||
var tempText: string;
|
||||
begin
|
||||
FHandlingUserInput:= true;
|
||||
if UTF8Key = #8 then
|
||||
begin
|
||||
if not RemoveSelection and (SelStart > 0) then
|
||||
begin
|
||||
tempText := Text;
|
||||
Dec(FSelStart);
|
||||
Delete(tempText,SelStart+1,1);
|
||||
Text := tempText;
|
||||
Invalidate;
|
||||
end;
|
||||
UTF8Key:= #0;
|
||||
end else
|
||||
if (length(UTF8Key)=1) and ((UTF8Key[1] in['0'..'9']) or ((UTF8Key[1]='-') and (SelStart = 0))) then
|
||||
begin
|
||||
RemoveSelection;
|
||||
tempText := Text;
|
||||
Insert(UTF8Key,tempText,SelStart+1);
|
||||
Text := tempText;
|
||||
if FSelStart < length(Text) then inc(FSelStart);
|
||||
Invalidate;
|
||||
UTF8Key:= #0;
|
||||
end;
|
||||
FHandlingUserInput:= false;
|
||||
end;
|
||||
|
||||
procedure TCustomBCTrackbarUpdown.DoEnter;
|
||||
begin
|
||||
inherited DoEnter;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TCustomBCTrackbarUpdown.DoExit;
|
||||
begin
|
||||
inherited DoExit;
|
||||
if FValue > FMaxValue then FValue := FMaxValue;
|
||||
if FValue < FMinValue then FValue := FMinValue;
|
||||
if FEmptyText then
|
||||
begin
|
||||
FEmptyText:= false;
|
||||
SelectAll;
|
||||
end;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TCustomBCTrackbarUpdown.DrawControl;
|
||||
var bmp: TBGRABitmap;
|
||||
begin
|
||||
FCanvasScaling:= GetCanvasScaleFactor;
|
||||
bmp := TBGRABitmap.Create(round(Width*FCanvasScaling),round(Height*FCanvasScaling));
|
||||
RenderOnBitmap(bmp);
|
||||
bmp.Draw(Canvas,rect(0,0,Width,Height),False);
|
||||
bmp.Free;
|
||||
end;
|
||||
|
||||
constructor TCustomBCTrackbarUpdown.Create(AOwner: TComponent);
|
||||
begin
|
||||
inherited Create(AOwner);
|
||||
with GetControlClassDefaultSize do
|
||||
SetInitialBounds(0, 0, CX, CY);
|
||||
FMinValue:= 0;
|
||||
FMaxValue := 100;
|
||||
FValue := 50;
|
||||
FIncrement := 1;
|
||||
FBarExponent:= 1;
|
||||
FCanvasScaling:= 1;
|
||||
FTimer := TTimer.Create(self);
|
||||
FTimer.Enabled := false;
|
||||
FTimer.OnTimer:=Timer;
|
||||
FLongTimeInterval:= 400;
|
||||
FShortTimeInterval:= 100;
|
||||
FHasTrackBar:= true;
|
||||
FBCBorder := TBCBorder.Create(self);
|
||||
FBCBorder.Color := clWindowText;
|
||||
FBCBorder.Width := 1;
|
||||
FBCBorder.Style := bboSolid;
|
||||
FBCBorder.OnChange := OnChangeProperty;
|
||||
FBCRounding := TBCRounding.Create(self);
|
||||
FBCRounding.RoundX := 1;
|
||||
FBCRounding.RoundY := 1;
|
||||
FBCRounding.OnChange := OnChangeProperty;
|
||||
FBCBackground := TBCBackground.Create(self);
|
||||
FBCBackground.Style := bbsColor;
|
||||
FBCBackground.Color := clWindow;
|
||||
FBCBackground.OnChange := OnChangeProperty;
|
||||
FBCButtonBackground := TBCBackground.Create(self);
|
||||
FBCButtonBackground.Style := bbsGradient;
|
||||
FBCButtonBackground.Gradient1EndPercent := 50;
|
||||
FBCButtonBackground.Gradient1.Point1YPercent := -50;
|
||||
FBCButtonBackground.Gradient1.Point2YPercent := 50;
|
||||
FBCButtonBackground.Gradient1.StartColor := clBtnShadow;
|
||||
FBCButtonBackground.Gradient1.EndColor := clBtnFace;
|
||||
FBCButtonBackground.Gradient2.Point1YPercent := 50;
|
||||
FBCButtonBackground.Gradient2.Point2YPercent := 150;
|
||||
FBCButtonBackground.Gradient2.StartColor := clBtnFace;
|
||||
FBCButtonBackground.Gradient2.EndColor := clBtnShadow;
|
||||
FBCButtonBackground.OnChange := OnChangeProperty;
|
||||
FBCButtonDownBackground := TBCBackground.Create(self);
|
||||
FBCButtonDownBackground.Style := bbsColor;
|
||||
FBCButtonDownBackground.Color := clBtnShadow;
|
||||
FBCButtonDownBackground.OnChange := OnChangeProperty;
|
||||
FArrowColor:= clBtnText;
|
||||
Font.Color := clWindowText;
|
||||
Font.Name := 'Arial';
|
||||
|
||||
DoSelectAll;
|
||||
TabStop := true;
|
||||
end;
|
||||
|
||||
procedure TCustomBCTrackbarUpdown.DoSelectAll;
|
||||
begin
|
||||
FSelStart := 0;
|
||||
FSelLength := length(Text);
|
||||
end;
|
||||
|
||||
procedure TCustomBCTrackbarUpdown.SelectAll;
|
||||
begin
|
||||
DoSelectAll;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
function TCustomBCTrackbarUpdown.RemoveSelection: boolean;
|
||||
var
|
||||
tempText: string;
|
||||
len:integer;
|
||||
begin
|
||||
if SelLength > 0 then
|
||||
begin
|
||||
tempText := Text;
|
||||
len := FSelLength;
|
||||
FSelLength := 0;
|
||||
Delete(tempText,SelStart+1,len);
|
||||
Text := tempText;
|
||||
Invalidate;
|
||||
result := true
|
||||
end else
|
||||
result := false;
|
||||
end;
|
||||
|
||||
procedure TCustomBCTrackbarUpdown.DelayTimer;
|
||||
begin
|
||||
if FTimer.Enabled then
|
||||
begin
|
||||
FTimer.Enabled:= false;
|
||||
FTimer.Enabled:= true;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TCustomBCTrackbarUpdown.SetFocus;
|
||||
begin
|
||||
try
|
||||
inherited SetFocus;
|
||||
except
|
||||
//in some cases, it is impossible to set the focus
|
||||
//but that's not a reason to crash the program
|
||||
end;
|
||||
end;
|
||||
|
||||
destructor TCustomBCTrackbarUpdown.Destroy;
|
||||
begin
|
||||
FreeAndNil(FTimer);
|
||||
FreeAndNil(FBCBackground);
|
||||
FreeAndNil(FBCButtonBackground);
|
||||
FreeAndNil(FBCButtonDownBackground);
|
||||
FreeAndNil(FBCBorder);
|
||||
FreeAndNil(FBCRounding);
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
end.
|
||||
1126
bgracontrols/bctypes.pas
Normal file
1126
bgracontrols/bctypes.pas
Normal file
File diff suppressed because it is too large
Load Diff
@@ -0,0 +1,161 @@
|
||||
<?xml version="1.0" encoding="UTF-8"?>
|
||||
<CONFIG>
|
||||
<ProjectOptions>
|
||||
<Version Value="9"/>
|
||||
<PathDelim Value="\"/>
|
||||
<General>
|
||||
<Flags>
|
||||
<MainUnitHasCreateFormStatements Value="False"/>
|
||||
<MainUnitHasTitleStatement Value="False"/>
|
||||
</Flags>
|
||||
<SessionStorage Value="InProjectDir"/>
|
||||
<MainUnit Value="0"/>
|
||||
<Title Value="bgra_pascalscript_library"/>
|
||||
<UseAppBundle Value="False"/>
|
||||
<ResourceType Value="res"/>
|
||||
</General>
|
||||
<i18n>
|
||||
<EnableI18N LFM="False"/>
|
||||
</i18n>
|
||||
<BuildModes Count="3">
|
||||
<Item1 Name="Debug" Default="True"/>
|
||||
<Item2 Name="Release">
|
||||
<CompilerOptions>
|
||||
<Version Value="11"/>
|
||||
<PathDelim Value="\"/>
|
||||
<Target>
|
||||
<Filename Value="bgrabitmap"/>
|
||||
</Target>
|
||||
<SearchPaths>
|
||||
<IncludeFiles Value="$(ProjOutDir)"/>
|
||||
<OtherUnitFiles Value=".."/>
|
||||
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
|
||||
</SearchPaths>
|
||||
<CodeGeneration>
|
||||
<SmartLinkUnit Value="True"/>
|
||||
<RelocatableUnit Value="True"/>
|
||||
<Optimizations>
|
||||
<OptimizationLevel Value="3"/>
|
||||
</Optimizations>
|
||||
</CodeGeneration>
|
||||
<Linking>
|
||||
<Debugging>
|
||||
<GenerateDebugInfo Value="False"/>
|
||||
</Debugging>
|
||||
<LinkSmart Value="True"/>
|
||||
<Options>
|
||||
<ExecutableType Value="Library"/>
|
||||
</Options>
|
||||
</Linking>
|
||||
</CompilerOptions>
|
||||
</Item2>
|
||||
<Item3 Name="Release_Win64">
|
||||
<CompilerOptions>
|
||||
<Version Value="11"/>
|
||||
<PathDelim Value="\"/>
|
||||
<Target>
|
||||
<Filename Value="bgrabitmap"/>
|
||||
</Target>
|
||||
<SearchPaths>
|
||||
<IncludeFiles Value="$(ProjOutDir)"/>
|
||||
<OtherUnitFiles Value=".."/>
|
||||
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
|
||||
</SearchPaths>
|
||||
<CodeGeneration>
|
||||
<SmartLinkUnit Value="True"/>
|
||||
<RelocatableUnit Value="True"/>
|
||||
<TargetCPU Value="x86_64"/>
|
||||
<TargetOS Value="win64"/>
|
||||
<Optimizations>
|
||||
<OptimizationLevel Value="3"/>
|
||||
</Optimizations>
|
||||
</CodeGeneration>
|
||||
<Linking>
|
||||
<Debugging>
|
||||
<GenerateDebugInfo Value="False"/>
|
||||
</Debugging>
|
||||
<LinkSmart Value="True"/>
|
||||
<Options>
|
||||
<ExecutableType Value="Library"/>
|
||||
</Options>
|
||||
</Linking>
|
||||
</CompilerOptions>
|
||||
</Item3>
|
||||
</BuildModes>
|
||||
<PublishOptions>
|
||||
<Version Value="2"/>
|
||||
</PublishOptions>
|
||||
<RunParams>
|
||||
<local>
|
||||
<FormatVersion Value="1"/>
|
||||
</local>
|
||||
</RunParams>
|
||||
<RequiredPackages Count="2">
|
||||
<Item1>
|
||||
<PackageName Value="bgrapascalscriptcomponent"/>
|
||||
</Item1>
|
||||
<Item2>
|
||||
<PackageName Value="BGRABitmapPack4NoGUI"/>
|
||||
</Item2>
|
||||
</RequiredPackages>
|
||||
<Units Count="2">
|
||||
<Unit0>
|
||||
<Filename Value="bgra_pascalscript_library.lpr"/>
|
||||
<IsPartOfProject Value="True"/>
|
||||
</Unit0>
|
||||
<Unit1>
|
||||
<Filename Value="..\bgrapascalscript.pas"/>
|
||||
<IsPartOfProject Value="True"/>
|
||||
</Unit1>
|
||||
</Units>
|
||||
</ProjectOptions>
|
||||
<CompilerOptions>
|
||||
<Version Value="11"/>
|
||||
<PathDelim Value="\"/>
|
||||
<Target>
|
||||
<Filename Value="bgrabitmap"/>
|
||||
</Target>
|
||||
<SearchPaths>
|
||||
<IncludeFiles Value="$(ProjOutDir)"/>
|
||||
<OtherUnitFiles Value=".."/>
|
||||
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
|
||||
</SearchPaths>
|
||||
<Parsing>
|
||||
<SyntaxOptions>
|
||||
<IncludeAssertionCode Value="True"/>
|
||||
</SyntaxOptions>
|
||||
</Parsing>
|
||||
<CodeGeneration>
|
||||
<RelocatableUnit Value="True"/>
|
||||
<Checks>
|
||||
<IOChecks Value="True"/>
|
||||
<RangeChecks Value="True"/>
|
||||
<OverflowChecks Value="True"/>
|
||||
<StackChecks Value="True"/>
|
||||
</Checks>
|
||||
</CodeGeneration>
|
||||
<Linking>
|
||||
<Debugging>
|
||||
<DebugInfoType Value="dsDwarf2Set"/>
|
||||
<UseHeaptrc Value="True"/>
|
||||
<UseExternalDbgSyms Value="True"/>
|
||||
</Debugging>
|
||||
<Options>
|
||||
<ExecutableType Value="Library"/>
|
||||
</Options>
|
||||
</Linking>
|
||||
</CompilerOptions>
|
||||
<Debugging>
|
||||
<Exceptions Count="3">
|
||||
<Item1>
|
||||
<Name Value="EAbort"/>
|
||||
</Item1>
|
||||
<Item2>
|
||||
<Name Value="ECodetoolError"/>
|
||||
</Item2>
|
||||
<Item3>
|
||||
<Name Value="EFOpenError"/>
|
||||
</Item3>
|
||||
</Exceptions>
|
||||
</Debugging>
|
||||
</CONFIG>
|
||||
@@ -0,0 +1,431 @@
|
||||
{
|
||||
Created by BGRA Controls Team
|
||||
Circular, lainz (007) and Fred vS.
|
||||
For detailed information see readme.txt
|
||||
|
||||
Site: https://sourceforge.net/p/bgra-controls/
|
||||
Wiki: http://wiki.lazarus.freepascal.org/BGRAControls
|
||||
Forum: http://forum.lazarus.freepascal.org/index.php/board,46.0.html
|
||||
|
||||
This library is free software; you can redistribute it and/or modify it
|
||||
under the terms of the GNU Library General Public License as published by
|
||||
the Free Software Foundation; either version 2 of the License, or (at your
|
||||
option) any later version with the following modification:
|
||||
|
||||
As a special exception, the copyright holders of this library give you
|
||||
permission to link this library with independent modules to produce an
|
||||
executable, regardless of the license terms of these independent modules,and
|
||||
to copy and distribute the resulting executable under terms of your choice,
|
||||
provided that you also meet, for each linked independent module, the terms
|
||||
and conditions of the license of that module. An independent module is a
|
||||
module which is not derived from or based on this library. If you modify
|
||||
this library, you may extend this exception to your version of the library,
|
||||
but you are not obligated to do so. If you do not wish to do so, delete this
|
||||
exception statement from your version.
|
||||
|
||||
This program is distributed in the hope that it will be useful, but WITHOUT
|
||||
ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
|
||||
FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License
|
||||
for more details.
|
||||
|
||||
You should have received a copy of the GNU Library General Public License
|
||||
along with this library; if not, write to the Free Software Foundation,
|
||||
Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
|
||||
}
|
||||
|
||||
|
||||
library bgra_pascalscript_library;
|
||||
|
||||
{$mode objfpc}{$H+}
|
||||
|
||||
{.$DEFINE Java} //// uncomment if you want a Java-compatible library
|
||||
|
||||
uses
|
||||
{$IF DEFINED(Java)}
|
||||
jni,
|
||||
{$endif}
|
||||
Classes,
|
||||
BGRAPascalScript,
|
||||
BGRABitmapTypes;
|
||||
|
||||
{ String Utility }
|
||||
function PWideCharToUTF8(const str: PWideChar): string;
|
||||
begin
|
||||
result := UTF8Encode(WideString(str));
|
||||
end;
|
||||
|
||||
{ Library }
|
||||
|
||||
function GetHighestID({$IF DEFINED(Java)}PEnv: PJNIEnv; Obj: JObject {$endif}): integer; {$IFDEF windows}stdcall;{$ELSE}cdecl;{$ENDIF}
|
||||
begin
|
||||
Result := BGRAPascalScript.bgra_GetHighestID;
|
||||
end;
|
||||
|
||||
function rgb({$IF DEFINED(Java)}PEnv: PJNIEnv; Obj: JObject ; {$endif} red, green, blue: byte): TBGRAColor; {$IFDEF windows}stdcall;{$ELSE}cdecl;{$ENDIF}
|
||||
begin
|
||||
Result := BGRAPascalScript.rgb(red, green, blue);
|
||||
end;
|
||||
|
||||
function rgba({$IF DEFINED(Java)}PEnv: PJNIEnv; Obj: JObject ; {$endif} red, green, blue, alpha: byte): TBGRAColor; {$IFDEF windows}stdcall;{$ELSE}cdecl;{$ENDIF}
|
||||
begin
|
||||
Result := BGRAPascalScript.rgba(red, green, blue, alpha);
|
||||
end;
|
||||
|
||||
function getBlue({$IF DEFINED(Java)}PEnv: PJNIEnv; Obj: JObject ; {$endif} AColor: TBGRAColor): byte; {$IFDEF windows}stdcall;{$ELSE}cdecl;{$ENDIF}
|
||||
begin
|
||||
Result := BGRAPascalScript.getBlue(aColor);
|
||||
end;
|
||||
|
||||
function getGreen({$IF DEFINED(Java)}PEnv: PJNIEnv; Obj: JObject ; {$endif} AColor: TBGRAColor): byte; {$IFDEF windows}stdcall;{$ELSE}cdecl;{$ENDIF}
|
||||
begin
|
||||
Result := BGRAPascalScript.getGreen(AColor);
|
||||
end;
|
||||
|
||||
function getRed({$IF DEFINED(Java)}PEnv: PJNIEnv; Obj: JObject ; {$endif} AColor: TBGRAColor): byte; {$IFDEF windows}stdcall;{$ELSE}cdecl;{$ENDIF}
|
||||
begin
|
||||
Result := BGRAPascalScript.getRed(AColor);
|
||||
end;
|
||||
|
||||
function getAlpha({$IF DEFINED(Java)}PEnv: PJNIEnv; Obj: JObject ; {$endif} AColor: TBGRAColor): byte; {$IFDEF windows}stdcall;{$ELSE}cdecl;{$ENDIF}
|
||||
begin
|
||||
Result := BGRAPascalScript.getAlpha(AColor);
|
||||
end;
|
||||
|
||||
function setBlue({$IF DEFINED(Java)}PEnv: PJNIEnv; Obj: JObject ; {$endif} AColor: TBGRAColor; AValue: byte): TBGRAColor; {$IFDEF windows}stdcall;{$ELSE}cdecl;{$ENDIF}
|
||||
begin
|
||||
Result := BGRAPascalScript.setBlue(AColor, AValue);
|
||||
end;
|
||||
|
||||
function setGreen({$IF DEFINED(Java)}PEnv: PJNIEnv; Obj: JObject ; {$endif} AColor: TBGRAColor; AValue: byte): TBGRAColor; {$IFDEF windows}stdcall;{$ELSE}cdecl;{$ENDIF}
|
||||
begin
|
||||
Result := BGRAPascalScript.setGreen(AColor, AValue);
|
||||
end;
|
||||
|
||||
function setRed({$IF DEFINED(Java)}PEnv: PJNIEnv; Obj: JObject ; {$endif} AColor: TBGRAColor; AValue: byte): TBGRAColor; {$IFDEF windows}stdcall;{$ELSE}cdecl;{$ENDIF}
|
||||
begin
|
||||
Result := BGRAPascalScript.setRed(AColor, AValue);
|
||||
end;
|
||||
|
||||
function setAlpha({$IF DEFINED(Java)}PEnv: PJNIEnv; Obj: JObject ; {$endif} AColor: TBGRAColor; AValue: byte): TBGRAColor; {$IFDEF windows}stdcall;{$ELSE}cdecl;{$ENDIF}
|
||||
begin
|
||||
Result := BGRAPascalScript.setAlpha(AColor, AValue);
|
||||
end;
|
||||
|
||||
{Constructors}
|
||||
procedure Create({$IF DEFINED(Java)}PEnv: PJNIEnv; Obj: JObject ; {$endif} id: integer); {$IFDEF windows}stdcall;{$ELSE}cdecl;{$ENDIF}
|
||||
begin
|
||||
BGRAPascalScript.bgra_Create(id);
|
||||
end;
|
||||
|
||||
procedure CreateWithSize({$IF DEFINED(Java)}PEnv: PJNIEnv; Obj: JObject ; {$endif} id: integer; AWidth, AHeight: integer); {$IFDEF windows}stdcall;{$ELSE}cdecl;{$ENDIF}
|
||||
begin
|
||||
BGRAPascalScript.bgra_CreateWithSize(id, AWidth, AHeight);
|
||||
end;
|
||||
|
||||
procedure Fill({$IF DEFINED(Java)}PEnv: PJNIEnv; Obj: JObject ; {$endif} id: integer; AColor: TBGRAColor); {$IFDEF windows}stdcall;{$ELSE}cdecl;{$ENDIF}
|
||||
begin
|
||||
BGRAPascalScript.bgra_Fill(id, AColor);
|
||||
end;
|
||||
|
||||
procedure SetPixel({$IF DEFINED(Java)}PEnv: PJNIEnv; Obj: JObject ; {$endif} id: integer; x, y: integer; AColor: TBGRAColor); {$IFDEF windows}stdcall;{$ELSE}cdecl;{$ENDIF}
|
||||
begin
|
||||
BGRAPascalScript.bgra_SetPixel(id, x, y, AColor);
|
||||
end;
|
||||
|
||||
function GetPixel({$IF DEFINED(Java)}PEnv: PJNIEnv; Obj: JObject ; {$endif} id: integer; x, y: integer): TBGRAColor; {$IFDEF windows}stdcall;{$ELSE}cdecl;{$ENDIF}
|
||||
begin
|
||||
Result := BGRAPascalScript.bgra_GetPixel(id, x, y);
|
||||
end;
|
||||
|
||||
{$IF DEFINED(Java)}
|
||||
procedure CreateFromFile(PEnv: PJNIEnv; Obj: JObject ; id: integer; AFilename: JString); {$IFDEF windows}stdcall;{$ELSE}cdecl;{$ENDIF}
|
||||
begin
|
||||
BGRAPascalScript.bgra_CreateFromFile(id, (PEnv^^).GetStringUTFChars(PEnv, AFilename, nil));
|
||||
(PEnv^^).ReleaseStringUTFChars(PEnv, AFilename, nil);
|
||||
end;
|
||||
{$else}
|
||||
procedure CreateFromFile(id: integer; AFilename: PWideChar); {$IFDEF windows}stdcall;{$ELSE}cdecl;{$ENDIF}
|
||||
begin
|
||||
BGRAPascalScript.bgra_CreateFromFile(id, PWideCharToUTF8(AFilename));
|
||||
end;
|
||||
{$endif}
|
||||
|
||||
procedure Destroy({$IF DEFINED(Java)}PEnv: PJNIEnv; Obj: JObject ; {$endif} id: integer); {$IFDEF windows}stdcall;{$ELSE}cdecl;{$ENDIF}
|
||||
begin
|
||||
BGRAPascalScript.bgra_Destroy(id);
|
||||
end;
|
||||
|
||||
procedure DestroyAll({$IF DEFINED(Java)}PEnv: PJNIEnv; Obj: JObject{$endif}); {$IFDEF windows}stdcall;{$ELSE}cdecl;{$ENDIF}
|
||||
begin
|
||||
BGRAPascalScript.bgra_DestroyAll;
|
||||
end;
|
||||
|
||||
{$IF DEFINED(Java)}
|
||||
procedure SaveToFile(PEnv: PJNIEnv; Obj: JObject ; id: integer; Filename: JString); {$IFDEF windows}stdcall;{$ELSE}cdecl;{$ENDIF}
|
||||
begin
|
||||
BGRAPascalScript.bgra_SaveToFile(id, (PEnv^^).GetStringUTFChars(PEnv, Filename, nil));
|
||||
(PEnv^^).ReleaseStringUTFChars(PEnv, Filename, nil);
|
||||
end;
|
||||
{$else}
|
||||
procedure SaveToFile(id: integer; filename: PWideChar); {$IFDEF windows}stdcall;{$ELSE}cdecl;{$ENDIF}
|
||||
begin
|
||||
BGRAPascalScript.bgra_SaveToFile(id, PWideCharToUTF8(filename));
|
||||
end;
|
||||
{$endif}
|
||||
|
||||
{ Filters }
|
||||
|
||||
procedure FilterSmartZoom3({$IF DEFINED(Java)}PEnv: PJNIEnv; Obj: JObject ; {$endif} id: integer; Option: TMedianOption); {$IFDEF windows}stdcall;{$ELSE}cdecl;{$ENDIF}
|
||||
begin
|
||||
BGRAPascalScript.bgra_FilterSmartZoom3(id, Option);
|
||||
end;
|
||||
|
||||
procedure FilterMedian({$IF DEFINED(Java)}PEnv: PJNIEnv; Obj: JObject ; {$endif} id: integer; Option: TMedianOption); {$IFDEF windows}stdcall;{$ELSE}cdecl;{$ENDIF}
|
||||
begin
|
||||
BGRAPascalScript.bgra_FilterMedian(id, Option);
|
||||
end;
|
||||
|
||||
procedure FilterSmooth({$IF DEFINED(Java)}PEnv: PJNIEnv; Obj: JObject ; {$endif} id: integer); {$IFDEF windows}stdcall;{$ELSE}cdecl;{$ENDIF}
|
||||
begin
|
||||
BGRAPascalScript.bgra_FilterSmooth(id);
|
||||
end;
|
||||
|
||||
procedure FilterSharpen({$IF DEFINED(Java)}PEnv: PJNIEnv; Obj: JObject ; {$endif} id: integer; Amount: single); {$IFDEF stdcall}stdcall;{$ELSE}cdecl;{$ENDIF}
|
||||
begin
|
||||
BGRAPascalScript.bgra_FilterSharpen(id, Amount);
|
||||
end;
|
||||
|
||||
procedure FilterSharpenRect({$IF DEFINED(Java)}PEnv: PJNIEnv; Obj: JObject ; {$endif} id: integer; ABounds: TRect; Amount: single); {$IFDEF windows}stdcall;{$ELSE}cdecl;{$ENDIF}
|
||||
begin
|
||||
BGRAPascalScript.bgra_FilterSharpenRect(id, ABounds, Amount);
|
||||
end;
|
||||
|
||||
procedure FilterContour({$IF DEFINED(Java)}PEnv: PJNIEnv; Obj: JObject ; {$endif} id: integer); {$IFDEF windows}stdcall;{$ELSE}cdecl;{$ENDIF}
|
||||
begin
|
||||
BGRAPascalScript.bgra_FilterContour(id);
|
||||
end;
|
||||
|
||||
procedure FilterPixelate({$IF DEFINED(Java)}PEnv: PJNIEnv; Obj: JObject ; {$endif} id: integer; pixelSize: integer;
|
||||
useResample: boolean; filter: TResampleFilter); {$IFDEF windows}stdcall;{$ELSE}cdecl;{$ENDIF}
|
||||
begin
|
||||
BGRAPascalScript.bgra_FilterPixelate(id, pixelSize, useResample, filter);
|
||||
end;
|
||||
|
||||
procedure FilterBlurRadial({$IF DEFINED(Java)}PEnv: PJNIEnv; Obj: JObject ; {$endif} id: integer; radius: integer; blurType: TRadialBlurType); {$IFDEF windows}stdcall;{$ELSE}cdecl;{$ENDIF}
|
||||
begin
|
||||
BGRAPascalScript.bgra_FilterBlurRadial(id, radius, blurType);
|
||||
end;
|
||||
|
||||
procedure FilterBlurRadialRect({$IF DEFINED(Java)}PEnv: PJNIEnv; Obj: JObject ; {$endif} id: integer; ABounds: TRect;
|
||||
radius: integer; blurType: TRadialBlurType); {$IFDEF windows}stdcall;{$ELSE}cdecl;{$ENDIF}
|
||||
begin
|
||||
BGRAPascalScript.bgra_FilterBlurRadialRect(id, ABounds, radius, blurType);
|
||||
end;
|
||||
|
||||
procedure FilterBlurMotion({$IF DEFINED(Java)}PEnv: PJNIEnv; Obj: JObject ; {$endif} id: integer; distance: integer;
|
||||
angle: single; oriented: boolean); {$IFDEF windows}stdcall;{$ELSE}cdecl;{$ENDIF}
|
||||
begin
|
||||
BGRAPascalScript.bgra_FilterBlurMotion(id, distance, angle, oriented);
|
||||
end;
|
||||
|
||||
procedure FilterBlurMotionRect({$IF DEFINED(Java)}PEnv: PJNIEnv; Obj: JObject ; {$endif} id: integer; ABounds: TRect;
|
||||
distance: integer; angle: single; oriented: boolean); {$IFDEF windows}stdcall;{$ELSE}cdecl;{$ENDIF}
|
||||
begin
|
||||
BGRAPascalScript.bgra_FilterBlurMotionRect(id, ABounds, distance, angle, oriented);
|
||||
end;
|
||||
|
||||
procedure FilterCustomBlur({$IF DEFINED(Java)}PEnv: PJNIEnv; Obj: JObject ; {$endif} id: integer; mask: integer); {$IFDEF windows}stdcall;{$ELSE}cdecl;{$ENDIF}
|
||||
begin
|
||||
BGRAPascalScript.bgra_FilterCustomBlur(id, mask);
|
||||
end;
|
||||
|
||||
procedure FilterCustomBlurRect({$IF DEFINED(Java)}PEnv: PJNIEnv; Obj: JObject ; {$endif} id: integer; ABounds: TRect; mask: integer); {$IFDEF windows}stdcall;{$ELSE}cdecl;{$ENDIF}
|
||||
begin
|
||||
BGRAPascalScript.bgra_FilterCustomBlurRect(id, ABounds, mask);
|
||||
end;
|
||||
|
||||
procedure FilterEmboss({$IF DEFINED(Java)}PEnv: PJNIEnv; Obj: JObject ; {$endif} id: integer; angle: single); {$IFDEF windows}stdcall;{$ELSE}cdecl;{$ENDIF}
|
||||
begin
|
||||
BGRAPascalScript.bgra_FilterEmboss(id, angle);
|
||||
end;
|
||||
|
||||
procedure FilterEmbossRect({$IF DEFINED(Java)}PEnv: PJNIEnv; Obj: JObject ; {$endif} id: integer; angle: single; ABounds: TRect); {$IFDEF windows}stdcall;{$ELSE}cdecl;{$ENDIF}
|
||||
begin
|
||||
BGRAPascalScript.bgra_FilterEmbossRect(id, angle, ABounds);
|
||||
end;
|
||||
|
||||
procedure FilterEmbossHighlight({$IF DEFINED(Java)}PEnv: PJNIEnv; Obj: JObject ; {$endif} id: integer; FillSelection: boolean); {$IFDEF windows}stdcall;{$ELSE}cdecl;{$ENDIF}
|
||||
begin
|
||||
BGRAPascalScript.bgra_FilterEmbossHighlight(id, FillSelection);
|
||||
end;
|
||||
|
||||
procedure FilterEmbossHighlightBorder({$IF DEFINED(Java)}PEnv: PJNIEnv; Obj: JObject ; {$endif} id: integer; FillSelection: boolean;
|
||||
BorderColor: TBGRAColor); {$IFDEF windows}stdcall;{$ELSE}cdecl;{$ENDIF}
|
||||
begin
|
||||
BGRAPascalScript.bgra_FilterEmbossHighlightBorder(id, FillSelection, BorderColor);
|
||||
end;
|
||||
|
||||
procedure FilterEmbossHighlightBorderAndOffset({$IF DEFINED(Java)}PEnv: PJNIEnv; Obj: JObject ; {$endif} id: integer;
|
||||
FillSelection: boolean; BorderColor: TBGRAColor; Offset: TPoint); {$IFDEF windows}stdcall;{$ELSE}cdecl;{$ENDIF}
|
||||
begin
|
||||
BGRAPascalScript.bgra_FilterEmbossHighlightBorderAndOffset(id, FillSelection, BorderColor, Offset);
|
||||
end;
|
||||
|
||||
procedure FilterGrayscale({$IF DEFINED(Java)}PEnv: PJNIEnv; Obj: JObject ; {$endif} id: integer); {$IFDEF windows}stdcall;{$ELSE}cdecl;{$ENDIF}
|
||||
begin
|
||||
BGRAPascalScript.bgra_FilterGrayscale(id);
|
||||
end;
|
||||
|
||||
procedure FilterGrayscaleRect({$IF DEFINED(Java)}PEnv: PJNIEnv; Obj: JObject ; {$endif} id: integer; ABounds: TRect); {$IFDEF windows}stdcall;{$ELSE}cdecl;{$ENDIF}
|
||||
begin
|
||||
BGRAPascalScript.bgra_FilterGrayscaleRect(id, ABounds);
|
||||
end;
|
||||
|
||||
procedure FilterNormalize({$IF DEFINED(Java)}PEnv: PJNIEnv; Obj: JObject ; {$endif} id: integer; eachChannel: boolean); {$IFDEF windows}stdcall;{$ELSE}cdecl;{$ENDIF}
|
||||
begin
|
||||
BGRAPascalScript.bgra_FilterNormalize(id, eachChannel);
|
||||
end;
|
||||
|
||||
procedure FilterNormalizeRect({$IF DEFINED(Java)}PEnv: PJNIEnv; Obj: JObject ; {$endif} id: integer; ABounds: TRect; eachChannel: boolean); {$IFDEF windows}stdcall;{$ELSE}cdecl;{$ENDIF}
|
||||
begin
|
||||
BGRAPascalScript.bgra_FilterNormalizeRect(id, ABounds, eachChannel);
|
||||
end;
|
||||
|
||||
procedure FilterRotate({$IF DEFINED(Java)}PEnv: PJNIEnv; Obj: JObject ; {$endif} id: integer; origin: TPointF; angle: single;
|
||||
correctBlur: boolean); {$IFDEF windows}stdcall;{$ELSE}cdecl;{$ENDIF}
|
||||
begin
|
||||
BGRAPascalScript.bgra_FilterRotate(id, origin, angle, correctBlur);
|
||||
end;
|
||||
|
||||
procedure FilterSphere({$IF DEFINED(Java)}PEnv: PJNIEnv; Obj: JObject ; {$endif} id: integer); {$IFDEF windows}stdcall;{$ELSE}cdecl;{$ENDIF}
|
||||
begin
|
||||
BGRAPascalScript.bgra_FilterSphere(id);
|
||||
end;
|
||||
|
||||
procedure FilterTwirl({$IF DEFINED(Java)}PEnv: PJNIEnv; Obj: JObject ; {$endif} id: integer; ACenter: TPoint; ARadius: single;
|
||||
ATurn: single; AExponent: single); {$IFDEF windows}stdcall;{$ELSE}cdecl;{$ENDIF}
|
||||
begin
|
||||
BGRAPascalScript.bgra_FilterTwirl(id, ACenter, ARadius, ATurn, AExponent);
|
||||
end;
|
||||
|
||||
procedure FilterTwirlRect({$IF DEFINED(Java)}PEnv: PJNIEnv; Obj: JObject ; {$endif} id: integer; ABounds: TRect; ACenter: TPoint;
|
||||
ARadius: single; ATurn: single; AExponent: single); {$IFDEF windows}stdcall;{$ELSE}cdecl;{$ENDIF}
|
||||
begin
|
||||
BGRAPascalScript.bgra_FilterTwirlRect(id, ABounds, ACenter, ARadius, ATurn, AExponent);
|
||||
end;
|
||||
|
||||
procedure FilterCylinder({$IF DEFINED(Java)}PEnv: PJNIEnv; Obj: JObject ; {$endif} id: integer); {$IFDEF windows}stdcall;{$ELSE}cdecl;{$ENDIF}
|
||||
begin
|
||||
BGRAPascalScript.bgra_FilterCylinder(id);
|
||||
end;
|
||||
|
||||
procedure FilterPlane({$IF DEFINED(Java)}PEnv: PJNIEnv; Obj: JObject ; {$endif} id: integer); {$IFDEF windows}stdcall;{$ELSE}cdecl;{$ENDIF}
|
||||
begin
|
||||
BGRAPascalScript.bgra_FilterPlane(id);
|
||||
end;
|
||||
|
||||
exports
|
||||
{$IF DEFINED(Java)}
|
||||
GetHighestID name 'Java_bgra_gethighestid',
|
||||
rgb name 'Java_bgra_rgb',
|
||||
rgba name 'Java_bgra_rgba',
|
||||
getBlue name 'Java_bgra_getblue',
|
||||
getGreen name 'Java_bgra_getgreen',
|
||||
getRed name 'Java_bgra_getred',
|
||||
getAlpha name 'Java_bgra_getalpha',
|
||||
setBlue name 'Java_bgra_setblue',
|
||||
setGreen name 'Java_bgra_setgreen',
|
||||
setRed name 'Java_bgra_setred',
|
||||
setAlpha name 'Java_bgra_setalpha',
|
||||
Create name 'Java_bgra_create',
|
||||
CreateWithSize name 'Java_bgra_createwithsize',
|
||||
Fill name 'Java_bgra_fill',
|
||||
SetPixel name 'Java_bgra_setpixel',
|
||||
GetPixel name 'Java_bgra_getpixel',
|
||||
CreateFromFile name 'Java_bgra_createfromfile',
|
||||
Destroy name 'Java_bgra_destroy',
|
||||
DestroyAll name 'Java_bgra_destroyall',
|
||||
SaveToFile name 'Java_bgra_savetofile',
|
||||
{ Filters }
|
||||
FilterSmartZoom3 name 'Java_bgra_filtersmartzoom3',
|
||||
FilterMedian name 'Java_bgra_filtermedian',
|
||||
FilterSmooth name 'Java_bgra_filtersmooth',
|
||||
FilterSharpen name 'Java_bgra_filtersharpen',
|
||||
FilterSharpenRect name 'Java_bgra_filtersharpenrect',
|
||||
FilterContour name 'Java_bgra_filtercontour',
|
||||
FilterPixelate name 'Java_bgra_filterpixelate',
|
||||
FilterBlurRadial name 'Java_bgra_filterblurradial',
|
||||
FilterBlurRadialRect name 'Java_bgra_filterblurradialrect',
|
||||
FilterBlurMotion name 'Java_bgra_filterblurmotion',
|
||||
FilterBlurMotionRect name 'Java_bgra_filterblurmotionrect',
|
||||
FilterCustomBlur name 'Java_bgra_filtercustomblur',
|
||||
FilterCustomBlurRect name 'Java_bgra_filtercustomblurrect',
|
||||
FilterEmboss name 'Java_bgra_filteremboss',
|
||||
FilterEmbossRect name 'Java_bgra_filterembossrect',
|
||||
FilterEmbossHighlight name 'Java_bgra_filterembosshighlight',
|
||||
FilterEmbossHighlightBorder name 'Java_bgra_filterembosshighlightborder',
|
||||
FilterEmbossHighlightBorderAndOffset name 'Java_bgra_filterembosshighlightborderandoffset',
|
||||
FilterGrayscale name 'Java_bgra_filtergrayscale',
|
||||
FilterGrayscaleRect name 'Java_bgra_filtergrayscalerect',
|
||||
FilterNormalize name 'Java_bgra_filternormalize',
|
||||
FilterNormalizeRect name 'Java_bgra_filternormalizerect',
|
||||
FilterRotate name 'Java_bgra_filterrotate',
|
||||
FilterSphere name 'Java_bgra_filtersphere',
|
||||
FilterTwirl name 'filtertwirl',
|
||||
FilterTwirlRect name 'Java_bgra_filtertwirlrect',
|
||||
FilterCylinder name 'Java_bgra_filtercylinder',
|
||||
FilterPlane name 'Java_bgra_filterplane';
|
||||
{$else}
|
||||
GetHighestID name 'gethighestid',
|
||||
rgb name 'rgb',
|
||||
rgba name 'rgba',
|
||||
getBlue name 'getblue',
|
||||
getGreen name 'getgreen',
|
||||
getRed name 'getred',
|
||||
getAlpha name 'getalpha',
|
||||
setBlue name 'setblue',
|
||||
setGreen name 'setgreen',
|
||||
setRed name 'setred',
|
||||
setAlpha name 'setalpha',
|
||||
Create name 'create',
|
||||
CreateWithSize name 'createwithsize',
|
||||
Fill name 'fill',
|
||||
SetPixel name 'setpixel',
|
||||
GetPixel name 'getpixel',
|
||||
CreateFromFile name 'createfromfile',
|
||||
Destroy name 'destroy',
|
||||
DestroyAll name 'destroyall',
|
||||
SaveToFile name 'savetofile',
|
||||
{ Filters }
|
||||
FilterSmartZoom3 name 'filtersmartzoom3',
|
||||
FilterMedian name 'filtermedian',
|
||||
FilterSmooth name 'filtersmooth',
|
||||
FilterSharpen name 'filtersharpen',
|
||||
FilterSharpenRect name 'filtersharpenrect',
|
||||
FilterContour name 'filtercontour',
|
||||
FilterPixelate name 'filterpixelate',
|
||||
FilterBlurRadial name 'filterblurradial',
|
||||
FilterBlurRadialRect name 'filterblurradialrect',
|
||||
FilterBlurMotion name 'filterblurmotion',
|
||||
FilterBlurMotionRect name 'filterblurmotionrect',
|
||||
FilterCustomBlur name 'filtercustomblur',
|
||||
FilterCustomBlurRect name 'filtercustomblurrect',
|
||||
FilterEmboss name 'filteremboss',
|
||||
FilterEmbossRect name 'filterembossrect',
|
||||
FilterEmbossHighlight name 'filterembosshighlight',
|
||||
FilterEmbossHighlightBorder name 'filterembosshighlightborder',
|
||||
FilterEmbossHighlightBorderAndOffset name 'filterembosshighlightborderandoffset',
|
||||
FilterGrayscale name 'filtergrayscale',
|
||||
FilterGrayscaleRect name 'filtergrayscalerect',
|
||||
FilterNormalize name 'filternormalize',
|
||||
FilterNormalizeRect name 'filternormalizerect',
|
||||
FilterRotate name 'filterrotate',
|
||||
FilterSphere name 'filtersphere',
|
||||
FilterTwirl name 'filtertwirl',
|
||||
FilterTwirlRect name 'filtertwirlrect',
|
||||
FilterCylinder name 'filtercylinder',
|
||||
FilterPlane name 'filterplane';
|
||||
{$endif}
|
||||
|
||||
begin
|
||||
end.
|
||||
171
bgracontrols/bgra_pascalscript_library/c#/BGRABitmap.cs
Normal file
171
bgracontrols/bgra_pascalscript_library/c#/BGRABitmap.cs
Normal file
@@ -0,0 +1,171 @@
|
||||
using System;
|
||||
using System.Drawing;
|
||||
using System.Runtime.InteropServices;
|
||||
|
||||
namespace BGRABitmapLibrary
|
||||
{
|
||||
public static class BGRABitmap
|
||||
{
|
||||
/* Types */
|
||||
|
||||
public enum MedianOption : byte { None, LowSmooth, MediumSmooth, HighSmooth };
|
||||
|
||||
public enum ResampleFilter : byte { Box, Linear, HalfCosine, Cosine, Bicubic, Mitchell, Spline, Lanczos2, Lanczos3, Lanczos4, BestQuality };
|
||||
|
||||
public enum RadialBlurType : byte { Normal, Disk, Corona, Precise, Fast, Box };
|
||||
|
||||
/* Constructors */
|
||||
|
||||
[DllImport("bgrabitmap", EntryPoint = "create")]
|
||||
public static extern void Create(int id);
|
||||
|
||||
[DllImport("bgrabitmap", EntryPoint = "createwithsize")]
|
||||
public static extern void CreateWithSize(int id, int AWidth, int AHeight);
|
||||
|
||||
[DllImport("bgrabitmap", EntryPoint = "destroy")]
|
||||
public static extern void Destroy(int id);
|
||||
|
||||
[DllImport("bgrabitmap", EntryPoint = "destroyall")]
|
||||
public static extern void DestroyAll();
|
||||
|
||||
[DllImport("bgrabitmap", EntryPoint = "gethighestid")]
|
||||
public static extern int GetHighestID();
|
||||
|
||||
/* Files */
|
||||
|
||||
[DllImport("bgrabitmap", EntryPoint = "createfromfile")]
|
||||
public static extern void CreateFromFile(int id, [MarshalAs(UnmanagedType.LPWStr)]string AFileName);
|
||||
|
||||
[DllImport("bgrabitmap", EntryPoint = "savetofile")]
|
||||
public static extern void SaveToFile(int id, [MarshalAs(UnmanagedType.LPWStr)]string AFileName);
|
||||
|
||||
/* Color */
|
||||
|
||||
[DllImport("bgrabitmap", EntryPoint = "rgb")]
|
||||
public static extern uint rgb(byte red, byte green, byte blue);
|
||||
|
||||
[DllImport("bgrabitmap", EntryPoint = "rgba")]
|
||||
public static extern uint rgba(byte red, byte green, byte blue, byte alpha);
|
||||
|
||||
[DllImport("bgrabitmap", EntryPoint = "getblue")]
|
||||
public static extern byte getBlue(uint AColor);
|
||||
|
||||
[DllImport("bgrabitmap", EntryPoint = "getgreen")]
|
||||
public static extern byte getGreen(uint AColor);
|
||||
|
||||
[DllImport("bgrabitmap", EntryPoint = "getred")]
|
||||
public static extern byte getRed(uint AColor);
|
||||
|
||||
[DllImport("bgrabitmap", EntryPoint = "getalpha")]
|
||||
public static extern byte getAlpha(uint AColor);
|
||||
|
||||
[DllImport("bgrabitmap", EntryPoint = "setblue")]
|
||||
public static extern uint setBlue(uint AColor, byte AValue);
|
||||
|
||||
[DllImport("bgrabitmap", EntryPoint = "setgreen")]
|
||||
public static extern uint setGreen(uint AColor, byte AValue);
|
||||
|
||||
[DllImport("bgrabitmap", EntryPoint = "setred")]
|
||||
public static extern uint setRed(uint AColor, byte AValue);
|
||||
|
||||
[DllImport("bgrabitmap", EntryPoint = "setalpha")]
|
||||
public static extern uint setAlpha(uint AColor, byte AValue);
|
||||
|
||||
/* Pixels */
|
||||
|
||||
[DllImport("bgrabitmap", EntryPoint = "fill")]
|
||||
public static extern void Fill(int id, uint AColor);
|
||||
|
||||
[DllImport("bgrabitmap", EntryPoint = "setpixel")]
|
||||
public static extern void SetPixel(int id, int x, int y, uint AColor);
|
||||
|
||||
[DllImport("bgrabitmap", EntryPoint = "getpixel")]
|
||||
public static extern uint GetPixel(int id, int x, int y);
|
||||
|
||||
/* Filters */
|
||||
|
||||
[DllImport("bgrabitmap", EntryPoint = "filtersmartzoom3")]
|
||||
public static extern void FilterSmartZoom3(int id, MedianOption Option);
|
||||
|
||||
[DllImport("bgrabitmap", EntryPoint = "filtermedian")]
|
||||
public static extern void FilterMedian(int id, MedianOption Option);
|
||||
|
||||
[DllImport("bgrabitmap", EntryPoint = "filtersmooth")]
|
||||
public static extern void FilterSmooth(int id);
|
||||
|
||||
[DllImport("bgrabitmap", EntryPoint = "filtersharpen")]
|
||||
public static extern void FilterSharpen(int id, Single Amount);
|
||||
|
||||
[DllImport("bgrabitmap", EntryPoint = "filtersharpenrect")]
|
||||
public static extern void FilterSharpen(int id, Rectangle ABounds, Single Amount);
|
||||
|
||||
[DllImport("bgrabitmap", EntryPoint = "filtercontour")]
|
||||
public static extern void FilterContour(int id);
|
||||
|
||||
[DllImport("bgrabitmap", EntryPoint = "filterpixelate")]
|
||||
public static extern void FilterPixelate(int id, int pixelSize, bool useResample, ResampleFilter filter);
|
||||
|
||||
[DllImport("bgrabitmap", EntryPoint = "filterblurradial")]
|
||||
public static extern void FilterBlurRadial(int id, int radius, RadialBlurType blurType);
|
||||
|
||||
[DllImport("bgrabitmap", EntryPoint = "filterblurradialrect")]
|
||||
public static extern void FilterBlurRadial(int id, Rectangle ABounds, int radius, RadialBlurType blurType);
|
||||
|
||||
[DllImport("bgrabitmap", EntryPoint = "filterblurmotion")]
|
||||
public static extern void FilterBlurMotion(int id, int distance, Single angle, bool oriented);
|
||||
|
||||
[DllImport("bgrabitmap", EntryPoint = "filterblurmotionrect")]
|
||||
public static extern void FilterBlurMotion(int id, Rectangle ABounds, int distance, Single angle, bool oriented);
|
||||
|
||||
[DllImport("bgrabitmap", EntryPoint = "filtercustomblur")]
|
||||
public static extern void FilterCustomBlur(int id, int mask);
|
||||
|
||||
[DllImport("bgrabitmap", EntryPoint = "filtercustomblur")]
|
||||
public static extern void FilterCustomBlur(int id, Rectangle ABounds, int mask);
|
||||
|
||||
[DllImport("bgrabitmap", EntryPoint = "filteremboss")]
|
||||
public static extern void FilterEmboss(int id, Single angle);
|
||||
|
||||
[DllImport("bgrabitmap", EntryPoint = "filterembossrect")]
|
||||
public static extern void FilterEmboss(int id, Single angle, Rectangle ABounds);
|
||||
|
||||
[DllImport("bgrabitmap", EntryPoint = "filterembosshighlight")]
|
||||
public static extern void FilterEmboss(int id, bool FillSelection);
|
||||
|
||||
[DllImport("bgrabitmap", EntryPoint = "filterembosshighlightborder")]
|
||||
public static extern void FilterEmboss(int id, bool FillSelection, uint BorderColor);
|
||||
|
||||
[DllImport("bgrabitmap", EntryPoint = "filterembosshighlightborderandoffset")]
|
||||
public static extern void FilterEmboss(int id, bool FillSelection, uint BorderColor, Point Offset);
|
||||
|
||||
[DllImport("bgrabitmap", EntryPoint = "filtergrayscale")]
|
||||
public static extern void FilterGrayscale(int id);
|
||||
|
||||
[DllImport("bgrabitmap", EntryPoint = "filtergrayscalerect")]
|
||||
public static extern void FilterGrayscale(int id, Rectangle ABounds);
|
||||
|
||||
[DllImport("bgrabitmap", EntryPoint = "filternormalize")]
|
||||
public static extern void FilterNormalize(int id, bool eachChannel);
|
||||
|
||||
[DllImport("bgrabitmap", EntryPoint = "filternormalizerect")]
|
||||
public static extern void FilterNormalize(int id, Rectangle ABounds, bool eachChannel);
|
||||
|
||||
[DllImport("bgrabitmap", EntryPoint = "filterrotate")]
|
||||
public static extern void FilterRotate(int id, PointF origin, Single angle, bool correctBlur);
|
||||
|
||||
[DllImport("bgrabitmap", EntryPoint = "filtersphere")]
|
||||
public static extern void FilterSphere(int id);
|
||||
|
||||
[DllImport("bgrabitmap", EntryPoint = "filtertwirl")]
|
||||
public static extern void FilterTwirl(int id, Point ACenter, Single ARadius, Single ATurn, Single AExponent);
|
||||
|
||||
[DllImport("bgrabitmap", EntryPoint = "filtertwirlrect")]
|
||||
public static extern void FilterTwirl(int id, Rectangle ABounds, Point ACenter, Single ARadius, Single ATurn, Single AExponent);
|
||||
|
||||
[DllImport("bgrabitmap", EntryPoint = "filtercylinder")]
|
||||
public static extern void FilterCylinder(int id);
|
||||
|
||||
[DllImport("bgrabitmap", EntryPoint = "filterplane")]
|
||||
public static extern void FilterPlane(int id);
|
||||
}
|
||||
}
|
||||
13
bgracontrols/bgra_pascalscript_library/java/bgra.java
Normal file
13
bgracontrols/bgra_pascalscript_library/java/bgra.java
Normal file
@@ -0,0 +1,13 @@
|
||||
public class bgra {
|
||||
/////////////////////// the bgra library declarations ///////////////
|
||||
public static native void create(int num);
|
||||
public static native void createwithsize(int num, int left, int top);
|
||||
|
||||
public static native void fill(int num, int color);
|
||||
public static native int rgb(int r, int g, int b);
|
||||
public static native void filtersmartzoom3(int num, int typ);
|
||||
public static native void savetofile(int num, String fn);
|
||||
public static native void destroy(int num);
|
||||
|
||||
}
|
||||
|
||||
23
bgracontrols/bgra_pascalscript_library/java/test.java
Normal file
23
bgracontrols/bgra_pascalscript_library/java/test.java
Normal file
@@ -0,0 +1,23 @@
|
||||
import static java.lang.System.out;
|
||||
import javax.swing.JOptionPane;
|
||||
|
||||
public class test {
|
||||
|
||||
public static void main(String[] args)
|
||||
{
|
||||
System.loadLibrary("bgrabitmap");
|
||||
|
||||
out.println("Library is loaded...");
|
||||
out.println("______________________________________________________________________");
|
||||
out.println();
|
||||
|
||||
bgra.createwithsize(0,100,100);
|
||||
bgra.fill(0, bgra.rgb(0, 255, 0));
|
||||
bgra.savetofile(0, "test.png");
|
||||
bgra.destroy(0);
|
||||
out.println("Bitmap is saved...");
|
||||
out.println("______________________________________________________________________");
|
||||
out.println();
|
||||
|
||||
}
|
||||
}
|
||||
573
bgracontrols/bgra_pascalscript_library/jni.pas
Normal file
573
bgracontrols/bgra_pascalscript_library/jni.pas
Normal file
@@ -0,0 +1,573 @@
|
||||
unit jni;
|
||||
|
||||
{$ifdef fpc}
|
||||
{$mode delphi}
|
||||
{$packrecords c}
|
||||
{$endif}
|
||||
|
||||
{$macro on}
|
||||
{$ifdef mswindows}
|
||||
{$define jnicall:=stdcall}
|
||||
{$else}
|
||||
{$define jnicall:=cdecl}
|
||||
{$endif}
|
||||
|
||||
interface
|
||||
|
||||
(*
|
||||
* Manifest constants.
|
||||
*)
|
||||
const JNI_FALSE=0;
|
||||
JNI_TRUE=1;
|
||||
|
||||
JNI_VERSION_1_1=$00010001;
|
||||
JNI_VERSION_1_2=$00010002;
|
||||
JNI_VERSION_1_4=$00010004;
|
||||
JNI_VERSION_1_6=$00010006;
|
||||
|
||||
JNI_OK=0; // no error
|
||||
JNI_ERR=-1; // generic error
|
||||
JNI_EDETACHED=-2; // thread detached from the VM
|
||||
JNI_EVERSION=-3; // JNI version error
|
||||
|
||||
JNI_COMMIT=1; // copy content, do not free buffer
|
||||
JNI_ABORT=2; // free buffer w/o copying back
|
||||
|
||||
(*
|
||||
* Type definitions.
|
||||
*)
|
||||
type va_list=pointer;
|
||||
|
||||
jboolean=byte; // unsigned 8 bits
|
||||
jbyte=shortint; // signed 8 bits
|
||||
jchar=word; // unsigned 16 bits
|
||||
jshort=smallint; // signed 16 bits
|
||||
jint=longint; // signed 32 bits
|
||||
jlong=int64; // signed 64 bits
|
||||
jfloat=single; // 32-bit IEEE 754
|
||||
jdouble=double; // 64-bit IEEE 754
|
||||
|
||||
jsize=jint; // "cardinal indices and sizes"
|
||||
|
||||
Pjboolean=^jboolean;
|
||||
Pjbyte=^jbyte;
|
||||
Pjchar=^jchar;
|
||||
Pjshort=^jshort;
|
||||
Pjint=^jint;
|
||||
Pjlong=^jlong;
|
||||
Pjfloat=^jfloat;
|
||||
Pjdouble=^jdouble;
|
||||
|
||||
Pjsize=^jsize;
|
||||
|
||||
// Reference type
|
||||
jobject=pointer;
|
||||
jclass=jobject;
|
||||
jstring=jobject;
|
||||
jarray=jobject;
|
||||
jobjectArray=jarray;
|
||||
jbooleanArray=jarray;
|
||||
jbyteArray=jarray;
|
||||
jcharArray=jarray;
|
||||
jshortArray=jarray;
|
||||
jintArray=jarray;
|
||||
jlongArray=jarray;
|
||||
jfloatArray=jarray;
|
||||
jdoubleArray=jarray;
|
||||
jthrowable=jobject;
|
||||
jweak=jobject;
|
||||
jref=jobject;
|
||||
|
||||
PPointer=^pointer;
|
||||
Pjobject=^jobject;
|
||||
Pjclass=^jclass;
|
||||
Pjstring=^jstring;
|
||||
Pjarray=^jarray;
|
||||
PjobjectArray=^jobjectArray;
|
||||
PjbooleanArray=^jbooleanArray;
|
||||
PjbyteArray=^jbyteArray;
|
||||
PjcharArray=^jcharArray;
|
||||
PjshortArray=^jshortArray;
|
||||
PjintArray=^jintArray;
|
||||
PjlongArray=^jlongArray;
|
||||
PjfloatArray=^jfloatArray;
|
||||
PjdoubleArray=^jdoubleArray;
|
||||
Pjthrowable=^jthrowable;
|
||||
Pjweak=^jweak;
|
||||
Pjref=^jref;
|
||||
|
||||
_jfieldID=record // opaque structure
|
||||
end;
|
||||
jfieldID=^_jfieldID;// field IDs
|
||||
PjfieldID=^jfieldID;
|
||||
|
||||
_jmethodID=record // opaque structure
|
||||
end;
|
||||
jmethodID=^_jmethodID;// method IDs
|
||||
PjmethodID=^jmethodID;
|
||||
|
||||
PJNIInvokeInterface=^JNIInvokeInterface;
|
||||
|
||||
Pjvalue=^jvalue;
|
||||
jvalue={$ifdef packedrecords}packed{$endif} record
|
||||
case integer of
|
||||
0:(z:jboolean);
|
||||
1:(b:jbyte);
|
||||
2:(c:jchar);
|
||||
3:(s:jshort);
|
||||
4:(i:jint);
|
||||
5:(j:jlong);
|
||||
6:(f:jfloat);
|
||||
7:(d:jdouble);
|
||||
8:(l:jobject);
|
||||
end;
|
||||
|
||||
jobjectRefType=(
|
||||
JNIInvalidRefType=0,
|
||||
JNILocalRefType=1,
|
||||
JNIGlobalRefType=2,
|
||||
JNIWeakGlobalRefType=3);
|
||||
|
||||
PJNINativeMethod=^JNINativeMethod;
|
||||
JNINativeMethod={$ifdef packedrecords}packed{$endif} record
|
||||
name:pchar;
|
||||
signature:pchar;
|
||||
fnPtr:pointer;
|
||||
end;
|
||||
|
||||
PJNINativeInterface=^JNINativeInterface;
|
||||
|
||||
_JNIEnv={$ifdef packedrecords}packed{$endif} record
|
||||
functions:PJNINativeInterface;
|
||||
end;
|
||||
|
||||
_JavaVM={$ifdef packedrecords}packed{$endif} record
|
||||
functions:PJNIInvokeInterface;
|
||||
end;
|
||||
|
||||
C_JNIEnv=^JNINativeInterface;
|
||||
JNIEnv=^JNINativeInterface;
|
||||
JavaVM=^JNIInvokeInterface;
|
||||
|
||||
PPJNIEnv=^PJNIEnv;
|
||||
PJNIEnv=^JNIEnv;
|
||||
|
||||
PPJavaVM=^PJavaVM;
|
||||
PJavaVM=^JavaVM;
|
||||
|
||||
JNINativeInterface={$ifdef packedrecords}packed{$endif} record
|
||||
reserved0:pointer;
|
||||
reserved1:pointer;
|
||||
reserved2:pointer;
|
||||
reserved3:pointer;
|
||||
|
||||
GetVersion:function(Env:PJNIEnv):JInt; jnicall;
|
||||
DefineClass:function(Env:PJNIEnv;const Name:pchar;Loader:JObject;const Buf:PJByte;Len:JSize):JClass; jnicall;
|
||||
FindClass:function(Env:PJNIEnv;const Name:pchar):JClass; jnicall;
|
||||
|
||||
// Reflection Support
|
||||
FromReflectedMethod:function(Env:PJNIEnv;Method:JObject):JMethodID; jnicall;
|
||||
FromReflectedField:function(Env:PJNIEnv;Field:JObject):JFieldID; jnicall;
|
||||
ToReflectedMethod:function(Env:PJNIEnv;AClass:JClass;MethodID:JMethodID;IsStatic:JBoolean):JObject; jnicall;
|
||||
|
||||
GetSuperclass:function(Env:PJNIEnv;Sub:JClass):JClass; jnicall;
|
||||
IsAssignableFrom:function(Env:PJNIEnv;Sub:JClass;Sup:JClass):JBoolean; jnicall;
|
||||
|
||||
// Reflection Support
|
||||
ToReflectedField:function(Env:PJNIEnv;AClass:JClass;FieldID:JFieldID;IsStatic:JBoolean):JObject; jnicall;
|
||||
|
||||
Throw:function(Env:PJNIEnv;Obj:JThrowable):JInt; jnicall;
|
||||
ThrowNew:function(Env:PJNIEnv;AClass:JClass;const Msg:pchar):JInt; jnicall;
|
||||
ExceptionOccurred:function(Env:PJNIEnv):JThrowable; jnicall;
|
||||
ExceptionDescribe:procedure(Env:PJNIEnv); jnicall;
|
||||
ExceptionClear:procedure(Env:PJNIEnv); jnicall;
|
||||
FatalError:procedure(Env:PJNIEnv;const Msg:pchar); jnicall;
|
||||
|
||||
// Local Reference Management
|
||||
PushLocalFrame:function(Env:PJNIEnv;Capacity:JInt):JInt; jnicall;
|
||||
PopLocalFrame:function(Env:PJNIEnv;Result:JObject):JObject; jnicall;
|
||||
|
||||
NewGlobalRef:function(Env:PJNIEnv;LObj:JObject):JObject; jnicall;
|
||||
DeleteGlobalRef:procedure(Env:PJNIEnv;GRef:JObject); jnicall;
|
||||
DeleteLocalRef:procedure(Env:PJNIEnv;Obj:JObject); jnicall;
|
||||
IsSameObject:function(Env:PJNIEnv;Obj1:JObject;Obj2:JObject):JBoolean; jnicall;
|
||||
|
||||
// Local Reference Management
|
||||
NewLocalRef:function(Env:PJNIEnv;Ref:JObject):JObject; jnicall;
|
||||
EnsureLocalCapacity:function(Env:PJNIEnv;Capacity:JInt):JObject; jnicall;
|
||||
|
||||
AllocObject:function(Env:PJNIEnv;AClass:JClass):JObject; jnicall;
|
||||
NewObject:function(Env:PJNIEnv;AClass:JClass;MethodID:JMethodID):JObject; jnicall;
|
||||
NewObjectV:function(Env:PJNIEnv;AClass:JClass;MethodID:JMethodID;Args:va_list):JObject; jnicall;
|
||||
NewObjectA:function(Env:PJNIEnv;AClass:JClass;MethodID:JMethodID;Args:PJValue):JObject; jnicall;
|
||||
|
||||
GetObjectClass:function(Env:PJNIEnv;Obj:JObject):JClass; jnicall;
|
||||
IsInstanceOf:function(Env:PJNIEnv;Obj:JObject;AClass:JClass):JBoolean; jnicall;
|
||||
|
||||
GetMethodID:function(Env:PJNIEnv;AClass:JClass;const Name:pchar;const Sig:pchar):JMethodID; jnicall;
|
||||
|
||||
CallObjectMethod:function(Env:PJNIEnv;Obj:JObject;MethodID:JMethodID):JObject; jnicall;
|
||||
CallObjectMethodV:function(Env:PJNIEnv;Obj:JObject;MethodID:JMethodID;Args:va_list):JObject; jnicall;
|
||||
CallObjectMethodA:function(Env:PJNIEnv;Obj:JObject;MethodID:JMethodID;Args:PJValue):JObject; jnicall;
|
||||
|
||||
CallBooleanMethod:function(Env:PJNIEnv;Obj:JObject;MethodID:JMethodID):JBoolean; jnicall;
|
||||
CallBooleanMethodV:function(Env:PJNIEnv;Obj:JObject;MethodID:JMethodID;Args:va_list):JBoolean; jnicall;
|
||||
CallBooleanMethodA:function(Env:PJNIEnv;Obj:JObject;MethodID:JMethodID;Args:PJValue):JBoolean; jnicall;
|
||||
|
||||
CallByteMethod:function(Env:PJNIEnv;Obj:JObject;MethodID:JMethodID):JByte; jnicall;
|
||||
CallByteMethodV:function(Env:PJNIEnv;Obj:JObject;MethodID:JMethodID;Args:va_list):JByte; jnicall;
|
||||
CallByteMethodA:function(Env:PJNIEnv;Obj:JObject;MethodID:JMethodID;Args:PJValue):JByte; jnicall;
|
||||
|
||||
CallCharMethod:function(Env:PJNIEnv;Obj:JObject;MethodID:JMethodID):JChar; jnicall;
|
||||
CallCharMethodV:function(Env:PJNIEnv;Obj:JObject;MethodID:JMethodID;Args:va_list):JChar; jnicall;
|
||||
CallCharMethodA:function(Env:PJNIEnv;Obj:JObject;MethodID:JMethodID;Args:PJValue):JChar; jnicall;
|
||||
|
||||
CallShortMethod:function(Env:PJNIEnv;Obj:JObject;MethodID:JMethodID):JShort; jnicall;
|
||||
CallShortMethodV:function(Env:PJNIEnv;Obj:JObject;MethodID:JMethodID;Args:va_list):JShort; jnicall;
|
||||
CallShortMethodA:function(Env:PJNIEnv;Obj:JObject;MethodID:JMethodID;Args:PJValue):JShort; jnicall;
|
||||
|
||||
CallIntMethod:function(Env:PJNIEnv;Obj:JObject;MethodID:JMethodID):JInt; jnicall;
|
||||
CallIntMethodV:function(Env:PJNIEnv;Obj:JObject;MethodID:JMethodID;Args:va_list):JInt; jnicall;
|
||||
CallIntMethodA:function(Env:PJNIEnv;Obj:JObject;MethodID:JMethodID;Args:PJValue):JInt; jnicall;
|
||||
|
||||
CallLongMethod:function(Env:PJNIEnv;Obj:JObject;MethodID:JMethodID):JLong; jnicall;
|
||||
CallLongMethodV:function(Env:PJNIEnv;Obj:JObject;MethodID:JMethodID;Args:va_list):JLong; jnicall;
|
||||
CallLongMethodA:function(Env:PJNIEnv;Obj:JObject;MethodID:JMethodID;Args:PJValue):JLong; jnicall;
|
||||
|
||||
CallFloatMethod:function(Env:PJNIEnv;Obj:JObject;MethodID:JMethodID):JFloat; jnicall;
|
||||
CallFloatMethodV:function(Env:PJNIEnv;Obj:JObject;MethodID:JMethodID;Args:va_list):JFloat; jnicall;
|
||||
CallFloatMethodA:function(Env:PJNIEnv;Obj:JObject;MethodID:JMethodID;Args:PJValue):JFloat; jnicall;
|
||||
|
||||
CallDoubleMethod:function(Env:PJNIEnv;Obj:JObject;MethodID:JMethodID):JDouble; jnicall;
|
||||
CallDoubleMethodV:function(Env:PJNIEnv;Obj:JObject;MethodID:JMethodID;Args:va_list):JDouble; jnicall;
|
||||
CallDoubleMethodA:function(Env:PJNIEnv;Obj:JObject;MethodID:JMethodID;Args:PJValue):JDouble; jnicall;
|
||||
|
||||
CallVoidMethod:procedure(Env:PJNIEnv;Obj:JObject;MethodID:JMethodID); jnicall;
|
||||
CallVoidMethodV:procedure(Env:PJNIEnv;Obj:JObject;MethodID:JMethodID;Args:va_list); jnicall;
|
||||
CallVoidMethodA:procedure(Env:PJNIEnv;Obj:JObject;MethodID:JMethodID;Args:PJValue); jnicall;
|
||||
|
||||
CallNonvirtualObjectMethod:function(Env:PJNIEnv;Obj:JObject;AClass:JClass;MethodID:JMethodID):JObject; jnicall;
|
||||
CallNonvirtualObjectMethodV:function(Env:PJNIEnv;Obj:JObject;AClass:JClass;MethodID:JMethodID;Args:va_list):JObject; jnicall;
|
||||
CallNonvirtualObjectMethodA:function(Env:PJNIEnv;Obj:JObject;AClass:JClass;MethodID:JMethodID;Args:PJValue):JObject; jnicall;
|
||||
|
||||
CallNonvirtualBooleanMethod:function(Env:PJNIEnv;Obj:JObject;AClass:JClass;MethodID:JMethodID):JBoolean; jnicall;
|
||||
CallNonvirtualBooleanMethodV:function(Env:PJNIEnv;Obj:JObject;AClass:JClass;MethodID:JMethodID;Args:va_list):JBoolean; jnicall;
|
||||
CallNonvirtualBooleanMethodA:function(Env:PJNIEnv;Obj:JObject;AClass:JClass;MethodID:JMethodID;Args:PJValue):JBoolean; jnicall;
|
||||
|
||||
CallNonvirtualByteMethod:function(Env:PJNIEnv;Obj:JObject;AClass:JClass;MethodID:JMethodID):JByte; jnicall;
|
||||
CallNonvirtualByteMethodV:function(Env:PJNIEnv;Obj:JObject;AClass:JClass;MethodID:JMethodID;Args:va_list):JByte; jnicall;
|
||||
CallNonvirtualByteMethodA:function(Env:PJNIEnv;Obj:JObject;AClass:JClass;MethodID:JMethodID;Args:PJValue):JByte; jnicall;
|
||||
|
||||
CallNonvirtualCharMethod:function(Env:PJNIEnv;Obj:JObject;AClass:JClass;MethodID:JMethodID):JChar; jnicall;
|
||||
CallNonvirtualCharMethodV:function(Env:PJNIEnv;Obj:JObject;AClass:JClass;MethodID:JMethodID;Args:va_list):JChar; jnicall;
|
||||
CallNonvirtualCharMethodA:function(Env:PJNIEnv;Obj:JObject;AClass:JClass;MethodID:JMethodID;Args:PJValue):JChar; jnicall;
|
||||
|
||||
CallNonvirtualShortMethod:function(Env:PJNIEnv;Obj:JObject;AClass:JClass;MethodID:JMethodID):JShort; jnicall;
|
||||
CallNonvirtualShortMethodV:function(Env:PJNIEnv;Obj:JObject;AClass:JClass;MethodID:JMethodID;Args:va_list):JShort; jnicall;
|
||||
CallNonvirtualShortMethodA:function(Env:PJNIEnv;Obj:JObject;AClass:JClass;MethodID:JMethodID;Args:PJValue):JShort; jnicall;
|
||||
|
||||
CallNonvirtualIntMethod:function(Env:PJNIEnv;Obj:JObject;AClass:JClass;MethodID:JMethodID):JInt; jnicall;
|
||||
CallNonvirtualIntMethodV:function(Env:PJNIEnv;Obj:JObject;AClass:JClass;MethodID:JMethodID;Args:va_list):JInt; jnicall;
|
||||
CallNonvirtualIntMethodA:function(Env:PJNIEnv;Obj:JObject;AClass:JClass;MethodID:JMethodID;Args:PJValue):JInt; jnicall;
|
||||
|
||||
CallNonvirtualLongMethod:function(Env:PJNIEnv;Obj:JObject;AClass:JClass;MethodID:JMethodID):JLong; jnicall;
|
||||
CallNonvirtualLongMethodV:function(Env:PJNIEnv;Obj:JObject;AClass:JClass;MethodID:JMethodID;Args:va_list):JLong; jnicall;
|
||||
CallNonvirtualLongMethodA:function(Env:PJNIEnv;Obj:JObject;AClass:JClass;MethodID:JMethodID;Args:PJValue):JLong; jnicall;
|
||||
|
||||
CallNonvirtualFloatMethod:function(Env:PJNIEnv;Obj:JObject;AClass:JClass;MethodID:JMethodID):JFloat; jnicall;
|
||||
CallNonvirtualFloatMethodV:function(Env:PJNIEnv;Obj:JObject;AClass:JClass;MethodID:JMethodID;Args:va_list):JFloat; jnicall;
|
||||
CallNonvirtualFloatMethodA:function(Env:PJNIEnv;Obj:JObject;AClass:JClass;MethodID:JMethodID;Args:PJValue):JFloat; jnicall;
|
||||
|
||||
CallNonvirtualDoubleMethod:function(Env:PJNIEnv;Obj:JObject;AClass:JClass;MethodID:JMethodID):JDouble; jnicall;
|
||||
CallNonvirtualDoubleMethodV:function(Env:PJNIEnv;Obj:JObject;AClass:JClass;MethodID:JMethodID;Args:va_list):JDouble; jnicall;
|
||||
CallNonvirtualDoubleMethodA:function(Env:PJNIEnv;Obj:JObject;AClass:JClass;MethodID:JMethodID;Args:PJValue):JDouble; jnicall;
|
||||
|
||||
CallNonvirtualVoidMethod:procedure(Env:PJNIEnv;Obj:JObject;AClass:JClass;MethodID:JMethodID); jnicall;
|
||||
CallNonvirtualVoidMethodV:procedure(Env:PJNIEnv;Obj:JObject;AClass:JClass;MethodID:JMethodID;Args:va_list); jnicall;
|
||||
CallNonvirtualVoidMethodA:procedure(Env:PJNIEnv;Obj:JObject;AClass:JClass;MethodID:JMethodID;Args:PJValue); jnicall;
|
||||
|
||||
GetFieldID:function(Env:PJNIEnv;AClass:JClass;const Name:pchar;const Sig:pchar):JFieldID; jnicall;
|
||||
|
||||
GetObjectField:function(Env:PJNIEnv;Obj:JObject;FieldID:JFieldID):JObject; jnicall;
|
||||
GetBooleanField:function(Env:PJNIEnv;Obj:JObject;FieldID:JFieldID):JBoolean; jnicall;
|
||||
GetByteField:function(Env:PJNIEnv;Obj:JObject;FieldID:JFieldID):JByte; jnicall;
|
||||
GetCharField:function(Env:PJNIEnv;Obj:JObject;FieldID:JFieldID):JChar; jnicall;
|
||||
GetShortField:function(Env:PJNIEnv;Obj:JObject;FieldID:JFieldID):JShort; jnicall;
|
||||
GetIntField:function(Env:PJNIEnv;Obj:JObject;FieldID:JFieldID):JInt; jnicall;
|
||||
GetLongField:function(Env:PJNIEnv;Obj:JObject;FieldID:JFieldID):JLong; jnicall;
|
||||
GetFloatField:function(Env:PJNIEnv;Obj:JObject;FieldID:JFieldID):JFloat; jnicall;
|
||||
GetDoubleField:function(Env:PJNIEnv;Obj:JObject;FieldID:JFieldID):JDouble; jnicall;
|
||||
|
||||
SetObjectField:procedure(Env:PJNIEnv;Obj:JObject;FieldID:JFieldID;Val:JObject); jnicall;
|
||||
SetBooleanField:procedure(Env:PJNIEnv;Obj:JObject;FieldID:JFieldID;Val:JBoolean); jnicall;
|
||||
SetByteField:procedure(Env:PJNIEnv;Obj:JObject;FieldID:JFieldID;Val:JByte); jnicall;
|
||||
SetCharField:procedure(Env:PJNIEnv;Obj:JObject;FieldID:JFieldID;Val:JChar); jnicall;
|
||||
SetShortField:procedure(Env:PJNIEnv;Obj:JObject;FieldID:JFieldID;Val:JShort); jnicall;
|
||||
SetIntField:procedure(Env:PJNIEnv;Obj:JObject;FieldID:JFieldID;Val:JInt); jnicall;
|
||||
SetLongField:procedure(Env:PJNIEnv;Obj:JObject;FieldID:JFieldID;Val:JLong); jnicall;
|
||||
SetFloatField:procedure(Env:PJNIEnv;Obj:JObject;FieldID:JFieldID;Val:JFloat); jnicall;
|
||||
SetDoubleField:procedure(Env:PJNIEnv;Obj:JObject;FieldID:JFieldID;Val:JDouble); jnicall;
|
||||
|
||||
GetStaticMethodID:function(Env:PJNIEnv;AClass:JClass;const Name:pchar;const Sig:pchar):JMethodID; jnicall;
|
||||
|
||||
CallStaticObjectMethod:function(Env:PJNIEnv;AClass:JClass;MethodID:JMethodID):JObject; jnicall;
|
||||
CallStaticObjectMethodV:function(Env:PJNIEnv;AClass:JClass;MethodID:JMethodID;Args:va_list):JObject; jnicall;
|
||||
CallStaticObjectMethodA:function(Env:PJNIEnv;AClass:JClass;MethodID:JMethodID;Args:PJValue):JObject; jnicall;
|
||||
|
||||
CallStaticBooleanMethod:function(Env:PJNIEnv;AClass:JClass;MethodID:JMethodID):JBoolean; jnicall;
|
||||
CallStaticBooleanMethodV:function(Env:PJNIEnv;AClass:JClass;MethodID:JMethodID;Args:va_list):JBoolean; jnicall;
|
||||
CallStaticBooleanMethodA:function(Env:PJNIEnv;AClass:JClass;MethodID:JMethodID;Args:PJValue):JBoolean; jnicall;
|
||||
|
||||
CallStaticByteMethod:function(Env:PJNIEnv;AClass:JClass;MethodID:JMethodID):JByte; jnicall;
|
||||
CallStaticByteMethodV:function(Env:PJNIEnv;AClass:JClass;MethodID:JMethodID;Args:va_list):JByte; jnicall;
|
||||
CallStaticByteMethodA:function(Env:PJNIEnv;AClass:JClass;MethodID:JMethodID;Args:PJValue):JByte; jnicall;
|
||||
|
||||
CallStaticCharMethod:function(Env:PJNIEnv;AClass:JClass;MethodID:JMethodID):JChar; jnicall;
|
||||
CallStaticCharMethodV:function(Env:PJNIEnv;AClass:JClass;MethodID:JMethodID;Args:va_list):JChar; jnicall;
|
||||
CallStaticCharMethodA:function(Env:PJNIEnv;AClass:JClass;MethodID:JMethodID;Args:PJValue):JChar; jnicall;
|
||||
|
||||
CallStaticShortMethod:function(Env:PJNIEnv;AClass:JClass;MethodID:JMethodID):JShort; jnicall;
|
||||
CallStaticShortMethodV:function(Env:PJNIEnv;AClass:JClass;MethodID:JMethodID;Args:va_list):JShort; jnicall;
|
||||
CallStaticShortMethodA:function(Env:PJNIEnv;AClass:JClass;MethodID:JMethodID;Args:PJValue):JShort; jnicall;
|
||||
|
||||
CallStaticIntMethod:function(Env:PJNIEnv;AClass:JClass;MethodID:JMethodID):JInt; jnicall;
|
||||
CallStaticIntMethodV:function(Env:PJNIEnv;AClass:JClass;MethodID:JMethodID;Args:va_list):JInt; jnicall;
|
||||
CallStaticIntMethodA:function(Env:PJNIEnv;AClass:JClass;MethodID:JMethodID;Args:PJValue):JInt; jnicall;
|
||||
|
||||
CallStaticLongMethod:function(Env:PJNIEnv;AClass:JClass;MethodID:JMethodID):JLong; jnicall;
|
||||
CallStaticLongMethodV:function(Env:PJNIEnv;AClass:JClass;MethodID:JMethodID;Args:va_list):JLong; jnicall;
|
||||
CallStaticLongMethodA:function(Env:PJNIEnv;AClass:JClass;MethodID:JMethodID;Args:PJValue):JLong; jnicall;
|
||||
|
||||
CallStaticFloatMethod:function(Env:PJNIEnv;AClass:JClass;MethodID:JMethodID):JFloat; jnicall;
|
||||
CallStaticFloatMethodV:function(Env:PJNIEnv;AClass:JClass;MethodID:JMethodID;Args:va_list):JFloat; jnicall;
|
||||
CallStaticFloatMethodA:function(Env:PJNIEnv;AClass:JClass;MethodID:JMethodID;Args:PJValue):JFloat; jnicall;
|
||||
|
||||
CallStaticDoubleMethod:function(Env:PJNIEnv;AClass:JClass;MethodID:JMethodID):JDouble; jnicall;
|
||||
CallStaticDoubleMethodV:function(Env:PJNIEnv;AClass:JClass;MethodID:JMethodID;Args:va_list):JDouble; jnicall;
|
||||
CallStaticDoubleMethodA:function(Env:PJNIEnv;AClass:JClass;MethodID:JMethodID;Args:PJValue):JDouble; jnicall;
|
||||
|
||||
CallStaticVoidMethod:procedure(Env:PJNIEnv;AClass:JClass;MethodID:JMethodID); jnicall;
|
||||
CallStaticVoidMethodV:procedure(Env:PJNIEnv;AClass:JClass;MethodID:JMethodID;Args:va_list); jnicall;
|
||||
CallStaticVoidMethodA:procedure(Env:PJNIEnv;AClass:JClass;MethodID:JMethodID;Args:PJValue); jnicall;
|
||||
|
||||
GetStaticFieldID:function(Env:PJNIEnv;AClass:JClass;const Name:pchar;const Sig:pchar):JFieldID; jnicall;
|
||||
GetStaticObjectField:function(Env:PJNIEnv;AClass:JClass;FieldID:JFieldID):JObject; jnicall;
|
||||
GetStaticBooleanField:function(Env:PJNIEnv;AClass:JClass;FieldID:JFieldID):JBoolean; jnicall;
|
||||
GetStaticByteField:function(Env:PJNIEnv;AClass:JClass;FieldID:JFieldID):JByte; jnicall;
|
||||
GetStaticCharField:function(Env:PJNIEnv;AClass:JClass;FieldID:JFieldID):JChar; jnicall;
|
||||
GetStaticShortField:function(Env:PJNIEnv;AClass:JClass;FieldID:JFieldID):JShort; jnicall;
|
||||
GetStaticIntField:function(Env:PJNIEnv;AClass:JClass;FieldID:JFieldID):JInt; jnicall;
|
||||
GetStaticLongField:function(Env:PJNIEnv;AClass:JClass;FieldID:JFieldID):JLong; jnicall;
|
||||
GetStaticFloatField:function(Env:PJNIEnv;AClass:JClass;FieldID:JFieldID):JFloat; jnicall;
|
||||
GetStaticDoubleField:function(Env:PJNIEnv;AClass:JClass;FieldID:JFieldID):JDouble; jnicall;
|
||||
|
||||
SetStaticObjectField:procedure(Env:PJNIEnv;AClass:JClass;FieldID:JFieldID;Val:JObject); jnicall;
|
||||
SetStaticBooleanField:procedure(Env:PJNIEnv;AClass:JClass;FieldID:JFieldID;Val:JBoolean); jnicall;
|
||||
SetStaticByteField:procedure(Env:PJNIEnv;AClass:JClass;FieldID:JFieldID;Val:JByte); jnicall;
|
||||
SetStaticCharField:procedure(Env:PJNIEnv;AClass:JClass;FieldID:JFieldID;Val:JChar); jnicall;
|
||||
SetStaticShortField:procedure(Env:PJNIEnv;AClass:JClass;FieldID:JFieldID;Val:JShort); jnicall;
|
||||
SetStaticIntField:procedure(Env:PJNIEnv;AClass:JClass;FieldID:JFieldID;Val:JInt); jnicall;
|
||||
SetStaticLongField:procedure(Env:PJNIEnv;AClass:JClass;FieldID:JFieldID;Val:JLong); jnicall;
|
||||
SetStaticFloatField:procedure(Env:PJNIEnv;AClass:JClass;FieldID:JFieldID;Val:JFloat); jnicall;
|
||||
SetStaticDoubleField:procedure(Env:PJNIEnv;AClass:JClass;FieldID:JFieldID;Val:JDouble); jnicall;
|
||||
|
||||
NewString:function(Env:PJNIEnv;const Unicode:PJChar;Len:JSize):JString; jnicall;
|
||||
GetStringLength:function(Env:PJNIEnv;Str:JString):JSize; jnicall;
|
||||
GetStringChars:function(Env:PJNIEnv;Str:JString;IsCopy:PJBoolean):PJChar; jnicall;
|
||||
ReleaseStringChars:procedure(Env:PJNIEnv;Str:JString;const Chars:PJChar); jnicall;
|
||||
|
||||
NewStringUTF:function(Env:PJNIEnv;const UTF:pchar):JString; jnicall;
|
||||
GetStringUTFLength:function(Env:PJNIEnv;Str:JString):JSize; jnicall;
|
||||
GetStringUTFChars:function(Env:PJNIEnv;Str:JString;IsCopy:PJBoolean):pchar; jnicall;
|
||||
ReleaseStringUTFChars:procedure(Env:PJNIEnv;Str:JString;const Chars:pchar); jnicall;
|
||||
|
||||
GetArrayLength:function(Env:PJNIEnv;AArray:JArray):JSize; jnicall;
|
||||
|
||||
NewObjectArray:function(Env:PJNIEnv;Len:JSize;AClass:JClass;Init:JObject):JObjectArray; jnicall;
|
||||
GetObjectArrayElement:function(Env:PJNIEnv;AArray:JObjectArray;Index:JSize):JObject; jnicall;
|
||||
SetObjectArrayElement:procedure(Env:PJNIEnv;AArray:JObjectArray;Index:JSize;Val:JObject); jnicall;
|
||||
|
||||
NewBooleanArray:function(Env:PJNIEnv;Len:JSize):JBooleanArray; jnicall;
|
||||
NewByteArray:function(Env:PJNIEnv;Len:JSize):JByteArray; jnicall;
|
||||
NewCharArray:function(Env:PJNIEnv;Len:JSize):JCharArray; jnicall;
|
||||
NewShortArray:function(Env:PJNIEnv;Len:JSize):JShortArray; jnicall;
|
||||
NewIntArray:function(Env:PJNIEnv;Len:JSize):JIntArray; jnicall;
|
||||
NewLongArray:function(Env:PJNIEnv;Len:JSize):JLongArray; jnicall;
|
||||
NewFloatArray:function(Env:PJNIEnv;Len:JSize):JFloatArray; jnicall;
|
||||
NewDoubleArray:function(Env:PJNIEnv;Len:JSize):JDoubleArray; jnicall;
|
||||
|
||||
GetBooleanArrayElements:function(Env:PJNIEnv;AArray:JBooleanArray;IsCopy:PJBoolean):PJBoolean; jnicall;
|
||||
GetByteArrayElements:function(Env:PJNIEnv;AArray:JByteArray;IsCopy:PJBoolean):PJByte; jnicall;
|
||||
GetCharArrayElements:function(Env:PJNIEnv;AArray:JCharArray;IsCopy:PJBoolean):PJChar; jnicall;
|
||||
GetShortArrayElements:function(Env:PJNIEnv;AArray:JShortArray;IsCopy:PJBoolean):PJShort; jnicall;
|
||||
GetIntArrayElements:function(Env:PJNIEnv;AArray:JIntArray;IsCopy:PJBoolean):PJInt; jnicall;
|
||||
GetLongArrayElements:function(Env:PJNIEnv;AArray:JLongArray;IsCopy:PJBoolean):PJLong; jnicall;
|
||||
GetFloatArrayElements:function(Env:PJNIEnv;AArray:JFloatArray;IsCopy:PJBoolean):PJFloat; jnicall;
|
||||
GetDoubleArrayElements:function(Env:PJNIEnv;AArray:JDoubleArray;IsCopy:PJBoolean):PJDouble; jnicall;
|
||||
|
||||
ReleaseBooleanArrayElements:procedure(Env:PJNIEnv;AArray:JBooleanArray;Elems:PJBoolean;Mode:JInt); jnicall;
|
||||
ReleaseByteArrayElements:procedure(Env:PJNIEnv;AArray:JByteArray;Elems:PJByte;Mode:JInt); jnicall;
|
||||
ReleaseCharArrayElements:procedure(Env:PJNIEnv;AArray:JCharArray;Elems:PJChar;Mode:JInt); jnicall;
|
||||
ReleaseShortArrayElements:procedure(Env:PJNIEnv;AArray:JShortArray;Elems:PJShort;Mode:JInt); jnicall;
|
||||
ReleaseIntArrayElements:procedure(Env:PJNIEnv;AArray:JIntArray;Elems:PJInt;Mode:JInt); jnicall;
|
||||
ReleaseLongArrayElements:procedure(Env:PJNIEnv;AArray:JLongArray;Elems:PJLong;Mode:JInt); jnicall;
|
||||
ReleaseFloatArrayElements:procedure(Env:PJNIEnv;AArray:JFloatArray;Elems:PJFloat;Mode:JInt); jnicall;
|
||||
ReleaseDoubleArrayElements:procedure(Env:PJNIEnv;AArray:JDoubleArray;Elems:PJDouble;Mode:JInt); jnicall;
|
||||
|
||||
GetBooleanArrayRegion:procedure(Env:PJNIEnv;AArray:JBooleanArray;Start:JSize;Len:JSize;Buf:PJBoolean); jnicall;
|
||||
GetByteArrayRegion:procedure(Env:PJNIEnv;AArray:JByteArray;Start:JSize;Len:JSize;Buf:PJByte); jnicall;
|
||||
GetCharArrayRegion:procedure(Env:PJNIEnv;AArray:JCharArray;Start:JSize;Len:JSize;Buf:PJChar); jnicall;
|
||||
GetShortArrayRegion:procedure(Env:PJNIEnv;AArray:JShortArray;Start:JSize;Len:JSize;Buf:PJShort); jnicall;
|
||||
GetIntArrayRegion:procedure(Env:PJNIEnv;AArray:JIntArray;Start:JSize;Len:JSize;Buf:PJInt); jnicall;
|
||||
GetLongArrayRegion:procedure(Env:PJNIEnv;AArray:JLongArray;Start:JSize;Len:JSize;Buf:PJLong); jnicall;
|
||||
GetFloatArrayRegion:procedure(Env:PJNIEnv;AArray:JFloatArray;Start:JSize;Len:JSize;Buf:PJFloat); jnicall;
|
||||
GetDoubleArrayRegion:procedure(Env:PJNIEnv;AArray:JDoubleArray;Start:JSize;Len:JSize;Buf:PJDouble); jnicall;
|
||||
|
||||
SetBooleanArrayRegion:procedure(Env:PJNIEnv;AArray:JBooleanArray;Start:JSize;Len:JSize;Buf:PJBoolean); jnicall;
|
||||
SetByteArrayRegion:procedure(Env:PJNIEnv;AArray:JByteArray;Start:JSize;Len:JSize;Buf:PJByte); jnicall;
|
||||
SetCharArrayRegion:procedure(Env:PJNIEnv;AArray:JCharArray;Start:JSize;Len:JSize;Buf:PJChar); jnicall;
|
||||
SetShortArrayRegion:procedure(Env:PJNIEnv;AArray:JShortArray;Start:JSize;Len:JSize;Buf:PJShort); jnicall;
|
||||
SetIntArrayRegion:procedure(Env:PJNIEnv;AArray:JIntArray;Start:JSize;Len:JSize;Buf:PJInt); jnicall;
|
||||
SetLongArrayRegion:procedure(Env:PJNIEnv;AArray:JLongArray;Start:JSize;Len:JSize;Buf:PJLong); jnicall;
|
||||
SetFloatArrayRegion:procedure(Env:PJNIEnv;AArray:JFloatArray;Start:JSize;Len:JSize;Buf:PJFloat); jnicall;
|
||||
SetDoubleArrayRegion:procedure(Env:PJNIEnv;AArray:JDoubleArray;Start:JSize;Len:JSize;Buf:PJDouble); jnicall;
|
||||
|
||||
RegisterNatives:function(Env:PJNIEnv;AClass:JClass;const Methods:PJNINativeMethod;NMethods:JInt):JInt; jnicall;
|
||||
UnregisterNatives:function(Env:PJNIEnv;AClass:JClass):JInt; jnicall;
|
||||
|
||||
MonitorEnter:function(Env:PJNIEnv;Obj:JObject):JInt; jnicall;
|
||||
MonitorExit:function(Env:PJNIEnv;Obj:JObject):JInt; jnicall;
|
||||
|
||||
GetJavaVM:function(Env:PJNIEnv;VM:PJavaVM):JInt; jnicall;
|
||||
|
||||
// String Operations
|
||||
GetStringRegion:procedure(Env:PJNIEnv;Str:JString;Start:JSize;Len:JSize;Buf:PJChar); jnicall;
|
||||
GetStringUTFRegion:procedure(Env:PJNIEnv;Str:JString;Start:JSize;Len:JSize;Buf:pchar); jnicall;
|
||||
|
||||
// Array Operations
|
||||
GetPrimitiveArrayCritical:function(Env:PJNIEnv;AArray:JArray;IsCopy:PJBoolean):pointer; jnicall;
|
||||
ReleasePrimitiveArrayCritical:procedure(Env:PJNIEnv;AArray:JArray;CArray:pointer;Mode:JInt); jnicall;
|
||||
|
||||
// String Operations
|
||||
GetStringCritical:function(Env:PJNIEnv;Str:JString;IsCopy:PJBoolean):PJChar; jnicall;
|
||||
ReleaseStringCritical:procedure(Env:PJNIEnv;Str:JString;CString:PJChar); jnicall;
|
||||
|
||||
// Weak Global References
|
||||
NewWeakGlobalRef:function(Env:PJNIEnv;Obj:JObject):JWeak; jnicall;
|
||||
DeleteWeakGlobalRef:procedure(Env:PJNIEnv;Ref:JWeak); jnicall;
|
||||
|
||||
// Exceptions
|
||||
ExceptionCheck:function(Env:PJNIEnv):JBoolean; jnicall;
|
||||
|
||||
// J2SDK1_4
|
||||
NewDirectByteBuffer:function(Env:PJNIEnv;Address:pointer;Capacity:JLong):JObject; jnicall;
|
||||
GetDirectBufferAddress:function(Env:PJNIEnv;Buf:JObject):pointer; jnicall;
|
||||
GetDirectBufferCapacity:function(Env:PJNIEnv;Buf:JObject):JLong; jnicall;
|
||||
|
||||
// added in JNI 1.6
|
||||
GetObjectRefType:function(Env:PJNIEnv;AObject:JObject):jobjectRefType; jnicall;
|
||||
end;
|
||||
|
||||
JNIInvokeInterface={$ifdef packedrecords}packed{$endif} record
|
||||
reserved0:pointer;
|
||||
reserved1:pointer;
|
||||
reserved2:pointer;
|
||||
|
||||
DestroyJavaVM:function(PVM:PJavaVM):JInt; jnicall;
|
||||
AttachCurrentThread:function(PVM:PJavaVM;PEnv:PPJNIEnv;Args:pointer):JInt; jnicall;
|
||||
DetachCurrentThread:function(PVM:PJavaVM):JInt; jnicall;
|
||||
GetEnv:function(PVM:PJavaVM;PEnv:Ppointer;Version:JInt):JInt; jnicall;
|
||||
AttachCurrentThreadAsDaemon:function(PVM:PJavaVM;PEnv:PPJNIEnv;Args:pointer):JInt; jnicall;
|
||||
end;
|
||||
|
||||
JavaVMAttachArgs={$ifdef packedrecords}packed{$endif} record
|
||||
version:jint; // must be >= JNI_VERSION_1_2
|
||||
name:pchar; // NULL or name of thread as modified UTF-8 str
|
||||
group:jobject; // global ref of a ThreadGroup object, or NULL
|
||||
end;
|
||||
|
||||
(**
|
||||
* JNI 1.2+ initialization. (As of 1.6, the pre-1.2 structures are no
|
||||
* longer supported.)
|
||||
*)
|
||||
|
||||
PJavaVMOption=^JavaVMOption;
|
||||
JavaVMOption={$ifdef packedrecords}packed{$endif} record
|
||||
optionString:pchar;
|
||||
extraInfo:pointer;
|
||||
end;
|
||||
|
||||
JavaVMInitArgs={$ifdef packedrecords}packed{$endif} record
|
||||
version:jint; // use JNI_VERSION_1_2 or later
|
||||
nOptions:jint;
|
||||
options:PJavaVMOption;
|
||||
ignoreUnrecognized:Pjboolean;
|
||||
end;
|
||||
|
||||
(*
|
||||
* VM initialization functions.
|
||||
*
|
||||
* Note these are the only symbols exported for JNI by the VM.
|
||||
*)
|
||||
{$ifdef jniexternals}
|
||||
function JNI_GetDefaultJavaVMInitArgs(p:pointer):jint; jnicall;external 'jni' name 'JNI_GetDefaultJavaVMInitArgs';
|
||||
function JNI_CreateJavaVM(vm:PPJavaVM;AEnv:PPJNIEnv;p:pointer):jint; jnicall;external 'jni' name 'JNI_CreateJavaVM';
|
||||
function JNI_GetCreatedJavaVMs(vm:PPJavaVM;ASize:jsize;p:Pjsize):jint; jnicall;external 'jni' name 'JNI_GetCreatedJavaVMs';
|
||||
{$endif}
|
||||
|
||||
(*
|
||||
* Prototypes for functions exported by loadable shared libs. These are
|
||||
* called by JNI, not provided by JNI.
|
||||
*)
|
||||
|
||||
const curVM:PJavaVM=nil;
|
||||
curEnv:PJNIEnv=nil;
|
||||
|
||||
(*
|
||||
function JNI_OnLoad(vm:PJavaVM;reserved:pointer):jint; jnicall;
|
||||
procedure JNI_OnUnload(vm:PJavaVM;reserved:pointer); jnicall;
|
||||
*)
|
||||
|
||||
(* Helper Routines *)
|
||||
function JNI_JStringToString( PEnv : PJNIEnv; JStr : JString ) : string;
|
||||
function JNI_StringToJString( PEnv : PJNIEnv; const AString : PAnsiChar ) : JString;
|
||||
|
||||
implementation
|
||||
|
||||
function JNI_OnLoad(vm:PJavaVM;reserved:pointer):jint; jnicall;
|
||||
begin
|
||||
curVM:=vm;
|
||||
result:=JNI_VERSION_1_6;
|
||||
end;
|
||||
|
||||
procedure JNI_OnUnload(vm:PJavaVM;reserved:pointer); jnicall;
|
||||
begin
|
||||
end;
|
||||
|
||||
function JNI_JStringToString( PEnv : PJNIEnv; JStr : JString ) : string;
|
||||
var
|
||||
IsCopy: PJBoolean;
|
||||
Chars: PAnsiChar;
|
||||
begin
|
||||
if JStr = nil then
|
||||
begin
|
||||
Result := '';
|
||||
Exit;
|
||||
end;
|
||||
|
||||
Chars := PEnv^.GetStringUTFChars(PEnv, JStr, IsCopy);
|
||||
if Chars = nil then
|
||||
Result := ''
|
||||
else
|
||||
begin
|
||||
Result := string(Chars);
|
||||
PEnv^.ReleaseStringUTFChars(PEnv, JStr, Chars);
|
||||
end;
|
||||
end;
|
||||
|
||||
function JNI_StringToJString( PEnv : PJNIEnv; const AString : PAnsiChar ) : JString;
|
||||
begin
|
||||
Result := PEnv^.NewStringUTF( PEnv, PAnsiChar( AString ) );
|
||||
end;
|
||||
|
||||
end.
|
||||
@@ -0,0 +1,87 @@
|
||||
// SPDX-License-Identifier: LGPL-3.0-linking-exception
|
||||
unit BGRABitmapLibrary;
|
||||
|
||||
{$mode objfpc}{$H+}
|
||||
|
||||
{$IFDEF Windows}
|
||||
{$DEFINE stdcall}
|
||||
{$ENDIF}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils;
|
||||
|
||||
type
|
||||
TBGRAColor = longword;
|
||||
TMedianOption = (moNone, moLowSmooth, moMediumSmooth, moHighSmooth);
|
||||
TResampleFilter = (rfBox, rfLinear, rfHalfCosine, rfCosine, rfBicubic, rfMitchell, rfSpline, rfLanczos2, rfLanczos3, rfLanczos4, rfBestQuality);
|
||||
TRadialBlurType = (rbNormal, rbDisk, rbCorona, rbPrecise, rbFast, rbBox);
|
||||
TPointF = packed record x, y: single;end;
|
||||
|
||||
function GetHighestID(): integer; {$IFDEF stdcall}stdcall;{$ELSE}cdecl;{$ENDIF} external 'bgrabitmap' Name 'gethighestid';
|
||||
function rgb(red, green, blue: byte): TBGRAColor; {$IFDEF stdcall}stdcall;{$ELSE}cdecl;{$ENDIF} external 'bgrabitmap' Name 'rgb';
|
||||
function rgba(red, green, blue, alpha: byte): TBGRAColor; {$IFDEF stdcall}stdcall;{$ELSE}cdecl;{$ENDIF} external 'bgrabitmap' Name 'rgba';
|
||||
function getBlue(AColor: TBGRAColor): byte; {$IFDEF stdcall}stdcall;{$ELSE}cdecl;{$ENDIF} external 'bgrabitmap' Name 'getblue';
|
||||
function getGreen(AColor: TBGRAColor): byte; {$IFDEF stdcall}stdcall;{$ELSE}cdecl;{$ENDIF} external 'bgrabitmap' Name 'getgreen';
|
||||
function getRed(AColor: TBGRAColor): byte; {$IFDEF stdcall}stdcall;{$ELSE}cdecl;{$ENDIF} external 'bgrabitmap' Name 'getred';
|
||||
function getAlpha(AColor: TBGRAColor): byte; {$IFDEF stdcall}stdcall;{$ELSE}cdecl;{$ENDIF} external 'bgrabitmap' Name 'getalpha';
|
||||
function setBlue(AColor: TBGRAColor; AValue: byte): TBGRAColor; {$IFDEF stdcall}stdcall;{$ELSE}cdecl;{$ENDIF} external 'bgrabitmap' Name 'setblue';
|
||||
function setGreen(AColor: TBGRAColor; AValue: byte): TBGRAColor; {$IFDEF stdcall}stdcall;{$ELSE}cdecl;{$ENDIF} external 'bgrabitmap' Name 'setgreen';
|
||||
function setRed(AColor: TBGRAColor; AValue: byte): TBGRAColor; {$IFDEF stdcall}stdcall;{$ELSE}cdecl;{$ENDIF} external 'bgrabitmap' Name 'setred';
|
||||
function setAlpha(AColor: TBGRAColor; AValue: byte): TBGRAColor; {$IFDEF stdcall}stdcall;{$ELSE}cdecl;{$ENDIF} external 'bgrabitmap' Name 'setalpha';
|
||||
procedure Create(id: integer); {$IFDEF stdcall}stdcall;{$ELSE}cdecl;{$ENDIF} external 'bgrabitmap' Name 'create';
|
||||
procedure CreateWithSize(id: integer; AWidth, AHeight: integer); {$IFDEF stdcall}stdcall;{$ELSE}cdecl;{$ENDIF} external 'bgrabitmap' Name 'createwithsize';
|
||||
procedure Fill(id: integer; AColor: TBGRAColor); {$IFDEF stdcall}stdcall;{$ELSE}cdecl;{$ENDIF} external 'bgrabitmap' Name 'fill';
|
||||
procedure SetPixel(id: integer; x, y: integer; AColor: TBGRAColor); {$IFDEF stdcall}stdcall;{$ELSE}cdecl;{$ENDIF} external 'bgrabitmap' Name 'setpixel';
|
||||
function GetPixel(id: integer; x, y: integer): TBGRAColor; {$IFDEF stdcall}stdcall;{$ELSE}cdecl;{$ENDIF} external 'bgrabitmap' Name 'getpixel';
|
||||
procedure CreateFromFile(id: integer; AFilename: PWideChar); {$IFDEF stdcall}stdcall;{$ELSE}cdecl;{$ENDIF} external 'bgrabitmap' Name 'createfromfile';
|
||||
procedure Destroy(id: integer); {$IFDEF stdcall}stdcall;{$ELSE}cdecl;{$ENDIF} external 'bgrabitmap' Name 'destroy';
|
||||
procedure DestroyAll; {$IFDEF stdcall}stdcall;{$ELSE}cdecl;{$ENDIF} external 'bgrabitmap' Name 'destroyall';
|
||||
procedure SaveToFile(id: integer; filename: PWideChar); {$IFDEF stdcall}stdcall;{$ELSE}cdecl;{$ENDIF} external 'bgrabitmap' Name 'savetofile';
|
||||
{ Filters }
|
||||
procedure FilterSmartZoom3(id: integer; Option: TMedianOption); {$IFDEF stdcall}stdcall;{$ELSE}cdecl;{$ENDIF} external 'bgrabitmap' Name 'filtersmartzoom3';
|
||||
procedure FilterMedian(id: integer; Option: TMedianOption); {$IFDEF stdcall}stdcall;{$ELSE}cdecl;{$ENDIF} external 'bgrabitmap' Name 'filtermedian';
|
||||
procedure FilterSmooth(id: integer); {$IFDEF stdcall}stdcall;{$ELSE}cdecl;{$ENDIF} external 'bgrabitmap' Name 'filtersmooth';
|
||||
procedure FilterSharpen(id: integer; Amount: single); {$IFDEF stdcall}stdcall;{$ELSE}cdecl;{$ENDIF} external 'bgrabitmap' Name 'filtersharpen';
|
||||
procedure FilterSharpenRect(id: integer; ABounds: TRect; Amount: single); {$IFDEF stdcall}stdcall;{$ELSE}cdecl;{$ENDIF} external 'bgrabitmap' Name 'filtersharpenrect';
|
||||
procedure FilterContour(id: integer); {$IFDEF stdcall}stdcall;{$ELSE}cdecl;{$ENDIF} external 'bgrabitmap' Name 'filtercontour';
|
||||
procedure FilterPixelate(id: integer; pixelSize: integer;
|
||||
useResample: boolean; filter: TResampleFilter); {$IFDEF stdcall}stdcall;{$ELSE}cdecl;{$ENDIF} external 'bgrabitmap' Name 'filterpixelate';
|
||||
procedure FilterBlurRadial(id: integer; radius: integer; blurType: TRadialBlurType); {$IFDEF stdcall}stdcall;{$ELSE}cdecl;{$ENDIF} external 'bgrabitmap' Name 'filterblurradial';
|
||||
procedure FilterBlurRadialRect(id: integer; ABounds: TRect;
|
||||
radius: integer; blurType: TRadialBlurType); {$IFDEF stdcall}stdcall;{$ELSE}cdecl;{$ENDIF} external 'bgrabitmap' Name 'filterblurradialrect';
|
||||
procedure FilterBlurMotion(id: integer; distance: integer;
|
||||
angle: single; oriented: boolean); {$IFDEF stdcall}stdcall;{$ELSE}cdecl;{$ENDIF} external 'bgrabitmap' Name 'filterblurmotion';
|
||||
procedure FilterBlurMotionRect(id: integer; ABounds: TRect;
|
||||
distance: integer; angle: single; oriented: boolean); {$IFDEF stdcall}stdcall;{$ELSE}cdecl;{$ENDIF} external 'bgrabitmap' Name 'filterblurmotionrect';
|
||||
procedure FilterCustomBlur(id: integer; mask: integer); {$IFDEF stdcall}stdcall;{$ELSE}cdecl;{$ENDIF} external 'bgrabitmap' Name 'filtercustomblur';
|
||||
procedure FilterCustomBlurRect(id: integer; ABounds: TRect; mask: integer); {$IFDEF stdcall}stdcall;{$ELSE}cdecl;{$ENDIF} external 'bgrabitmap' Name 'filtercustomblurrect';
|
||||
procedure FilterEmboss(id: integer; angle: single); {$IFDEF stdcall}stdcall;{$ELSE}cdecl;{$ENDIF} external 'bgrabitmap' Name 'filteremboss';
|
||||
procedure FilterEmbossRect(id: integer; angle: single; ABounds: TRect); {$IFDEF stdcall}stdcall;{$ELSE}cdecl;{$ENDIF} external 'bgrabitmap' Name 'filterembossrect';
|
||||
procedure FilterEmbossHighlight(id: integer; FillSelection: boolean); {$IFDEF stdcall}stdcall;{$ELSE}cdecl;{$ENDIF} external 'bgrabitmap' Name 'filterembosshighlight';
|
||||
procedure FilterEmbossHighlightBorder(id: integer; FillSelection: boolean;
|
||||
BorderColor: TBGRAColor); {$IFDEF stdcall}stdcall;{$ELSE}cdecl;{$ENDIF} external 'bgrabitmap' Name 'filterembosshighlightborder';
|
||||
procedure FilterEmbossHighlightBorderAndOffset(id: integer;
|
||||
FillSelection: boolean; BorderColor: TBGRAColor; Offset: TPoint); {$IFDEF stdcall}stdcall;{$ELSE}cdecl;{$ENDIF} external 'bgrabitmap' Name 'filterembosshighlightborderandoffset';
|
||||
procedure FilterGrayscale(id: integer); {$IFDEF stdcall}stdcall;{$ELSE}cdecl;{$ENDIF} external 'bgrabitmap' Name 'filtergrayscale';
|
||||
procedure FilterGrayscaleRect(id: integer; ABounds: TRect); {$IFDEF stdcall}stdcall;{$ELSE}cdecl;{$ENDIF} external 'bgrabitmap' Name 'filtergrayscalerect';
|
||||
procedure FilterNormalize(id: integer; eachChannel: boolean); {$IFDEF stdcall}stdcall;{$ELSE}cdecl;{$ENDIF} external 'bgrabitmap' Name 'filternormalize';
|
||||
procedure FilterNormalizeRect(id: integer; ABounds: TRect; eachChannel: boolean); {$IFDEF stdcall}stdcall;{$ELSE}cdecl;{$ENDIF} external 'bgrabitmap' Name 'filternormalizerect';
|
||||
procedure FilterRotate(id: integer; origin: TPointF; angle: single;
|
||||
correctBlur: boolean); {$IFDEF stdcall}stdcall;{$ELSE}cdecl;{$ENDIF} external 'bgrabitmap' Name 'filterrotate';
|
||||
procedure FilterSphere(id: integer); {$IFDEF stdcall}stdcall;{$ELSE}cdecl;{$ENDIF} external 'bgrabitmap' Name 'filtersphere';
|
||||
procedure FilterTwirl(id: integer; ACenter: TPoint; ARadius: single;
|
||||
ATurn: single; AExponent: single); {$IFDEF stdcall}stdcall;{$ELSE}cdecl;{$ENDIF} external 'bgrabitmap' Name 'filtertwirl';
|
||||
procedure FilterTwirlRect(id: integer; ABounds: TRect; ACenter: TPoint;
|
||||
ARadius: single; ATurn: single; AExponent: single); {$IFDEF stdcall}stdcall;{$ELSE}cdecl;{$ENDIF} external 'bgrabitmap' Name 'filtertwirlrect';
|
||||
procedure FilterCylinder(id: integer); {$IFDEF stdcall}stdcall;{$ELSE}cdecl;{$ENDIF} external 'bgrabitmap' Name 'filtercylinder';
|
||||
procedure FilterPlane(id: integer); {$IFDEF stdcall}stdcall;{$ELSE}cdecl;{$ENDIF} external 'bgrabitmap' Name 'filterplane';
|
||||
|
||||
|
||||
|
||||
|
||||
implementation
|
||||
|
||||
end.
|
||||
|
||||
@@ -0,0 +1,81 @@
|
||||
<?xml version="1.0" encoding="UTF-8"?>
|
||||
<CONFIG>
|
||||
<ProjectOptions>
|
||||
<Version Value="9"/>
|
||||
<PathDelim Value="\"/>
|
||||
<General>
|
||||
<SessionStorage Value="InProjectDir"/>
|
||||
<MainUnit Value="0"/>
|
||||
<Title Value="test_library"/>
|
||||
<ResourceType Value="res"/>
|
||||
<UseXPManifest Value="True"/>
|
||||
</General>
|
||||
<i18n>
|
||||
<EnableI18N LFM="False"/>
|
||||
</i18n>
|
||||
<VersionInfo>
|
||||
<StringTable ProductVersion=""/>
|
||||
</VersionInfo>
|
||||
<BuildModes Count="1">
|
||||
<Item1 Name="Default" Default="True"/>
|
||||
</BuildModes>
|
||||
<PublishOptions>
|
||||
<Version Value="2"/>
|
||||
</PublishOptions>
|
||||
<RunParams>
|
||||
<local>
|
||||
<FormatVersion Value="1"/>
|
||||
</local>
|
||||
</RunParams>
|
||||
<RequiredPackages Count="1">
|
||||
<Item1>
|
||||
<PackageName Value="LCL"/>
|
||||
</Item1>
|
||||
</RequiredPackages>
|
||||
<Units Count="2">
|
||||
<Unit0>
|
||||
<Filename Value="test_library.lpr"/>
|
||||
<IsPartOfProject Value="True"/>
|
||||
</Unit0>
|
||||
<Unit1>
|
||||
<Filename Value="utest.pas"/>
|
||||
<IsPartOfProject Value="True"/>
|
||||
<ComponentName Value="Form1"/>
|
||||
<HasResources Value="True"/>
|
||||
<ResourceBaseClass Value="Form"/>
|
||||
<UnitName Value="utest"/>
|
||||
</Unit1>
|
||||
</Units>
|
||||
</ProjectOptions>
|
||||
<CompilerOptions>
|
||||
<Version Value="11"/>
|
||||
<PathDelim Value="\"/>
|
||||
<Target>
|
||||
<Filename Value="test_library"/>
|
||||
</Target>
|
||||
<SearchPaths>
|
||||
<IncludeFiles Value="$(ProjOutDir)"/>
|
||||
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
|
||||
</SearchPaths>
|
||||
<Linking>
|
||||
<Options>
|
||||
<Win32>
|
||||
<GraphicApplication Value="True"/>
|
||||
</Win32>
|
||||
</Options>
|
||||
</Linking>
|
||||
</CompilerOptions>
|
||||
<Debugging>
|
||||
<Exceptions Count="3">
|
||||
<Item1>
|
||||
<Name Value="EAbort"/>
|
||||
</Item1>
|
||||
<Item2>
|
||||
<Name Value="ECodetoolError"/>
|
||||
</Item2>
|
||||
<Item3>
|
||||
<Name Value="EFOpenError"/>
|
||||
</Item3>
|
||||
</Exceptions>
|
||||
</Debugging>
|
||||
</CONFIG>
|
||||
@@ -0,0 +1,20 @@
|
||||
program test_library;
|
||||
|
||||
{$mode objfpc}{$H+}
|
||||
|
||||
uses
|
||||
{$IFDEF UNIX}{$IFDEF UseCThreads}
|
||||
cthreads,
|
||||
{$ENDIF}{$ENDIF}
|
||||
Interfaces, // this includes the LCL widgetset
|
||||
Forms, utest;
|
||||
|
||||
{$R *.res}
|
||||
|
||||
begin
|
||||
RequireDerivedFormResource := True;
|
||||
Application.Initialize;
|
||||
Application.CreateForm(TForm1, Form1);
|
||||
Application.Run;
|
||||
end.
|
||||
|
||||
19
bgracontrols/bgra_pascalscript_library/pascal/utest.lfm
Normal file
19
bgracontrols/bgra_pascalscript_library/pascal/utest.lfm
Normal file
@@ -0,0 +1,19 @@
|
||||
object Form1: TForm1
|
||||
Left = 383
|
||||
Height = 240
|
||||
Top = 173
|
||||
Width = 320
|
||||
Caption = 'Form1'
|
||||
ClientHeight = 240
|
||||
ClientWidth = 320
|
||||
LCLVersion = '1.4.0.4'
|
||||
object Button1: TButton
|
||||
Left = 8
|
||||
Height = 25
|
||||
Top = 8
|
||||
Width = 75
|
||||
Caption = 'Test'
|
||||
OnClick = Button1Click
|
||||
TabOrder = 0
|
||||
end
|
||||
end
|
||||
47
bgracontrols/bgra_pascalscript_library/pascal/utest.pas
Normal file
47
bgracontrols/bgra_pascalscript_library/pascal/utest.pas
Normal file
@@ -0,0 +1,47 @@
|
||||
// SPDX-License-Identifier: LGPL-3.0-linking-exception
|
||||
unit utest;
|
||||
|
||||
{$mode objfpc}{$H+}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls,
|
||||
BGRABitmapLibrary;
|
||||
|
||||
type
|
||||
|
||||
{ TForm1 }
|
||||
|
||||
TForm1 = class(TForm)
|
||||
Button1: TButton;
|
||||
procedure Button1Click(Sender: TObject);
|
||||
private
|
||||
{ private declarations }
|
||||
public
|
||||
{ public declarations }
|
||||
end;
|
||||
|
||||
var
|
||||
Form1: TForm1;
|
||||
|
||||
implementation
|
||||
|
||||
{$R *.lfm}
|
||||
|
||||
{ TForm1 }
|
||||
|
||||
procedure TForm1.Button1Click(Sender: TObject);
|
||||
begin
|
||||
BGRABitmapLibrary.Create(0);
|
||||
BGRABitmapLibrary.CreateWithSize(1,100,100);
|
||||
ShowMessage(IntToStr(BGRABitmapLibrary.GetHighestID()));
|
||||
BGRABitmapLibrary.Fill(1, BGRABitmapLibrary.rgb(0, 255, 0));
|
||||
BGRABitmapLibrary.FilterSmartZoom3(0, moNone);
|
||||
BGRABitmapLibrary.SaveToFile(1, 'test.png');
|
||||
BGRABitmapLibrary.Destroy(1);
|
||||
BGRABitmapLibrary.Destroy(0);
|
||||
end;
|
||||
|
||||
end.
|
||||
|
||||
233
bgracontrols/bgracolortheme.pas
Normal file
233
bgracontrols/bgracolortheme.pas
Normal file
@@ -0,0 +1,233 @@
|
||||
// SPDX-License-Identifier: LGPL-3.0-linking-exception
|
||||
unit BGRAColorTheme;
|
||||
|
||||
{$mode objfpc}{$H+}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, BGRATheme,
|
||||
BGRABitmap, BGRABitmapTypes, BGRASVGImageList;
|
||||
|
||||
type
|
||||
|
||||
{ TBGRAColorTheme }
|
||||
|
||||
TBGRAColorTheme = class(TBGRATheme)
|
||||
private
|
||||
FColorActive: TColor;
|
||||
FColorDisabled: TColor;
|
||||
FColorFocused: TColor;
|
||||
FColorHover: TColor;
|
||||
FColorNormal: TColor;
|
||||
FColorText: TColor;
|
||||
procedure SetFColorActive(AValue: TColor);
|
||||
procedure SetFColorDisabled(AValue: TColor);
|
||||
procedure SetFColorFocused(AValue: TColor);
|
||||
procedure SetFColorHover(AValue: TColor);
|
||||
procedure SetFColorNormal(AValue: TColor);
|
||||
procedure SetFColorText(AValue: TColor);
|
||||
|
||||
protected
|
||||
|
||||
public
|
||||
procedure DrawButton(Caption: string; State: TBGRAThemeButtonState;
|
||||
Focused: boolean; ARect: TRect; ASurface: TBGRAThemeSurface; AImageIndex: Integer = -1; AImageList: TBGRASVGImageList = nil); override;
|
||||
procedure DrawRadioButton(Caption: string; State: TBGRAThemeButtonState;
|
||||
{%H-}Focused: boolean; Checked: boolean; ARect: TRect; ASurface: TBGRAThemeSurface); override;
|
||||
procedure DrawCheckBox(Caption: string; State: TBGRAThemeButtonState;
|
||||
{%H-}Focused: boolean; Checked: boolean; ARect: TRect; ASurface: TBGRAThemeSurface); override;
|
||||
published
|
||||
property ColorNormal: TColor read FColorNormal write SetFColorNormal;
|
||||
property ColorHover: TColor read FColorHover write SetFColorHover;
|
||||
property ColorActive: TColor read FColorActive write SetFColorActive;
|
||||
property ColorDisabled: TColor read FColorDisabled write SetFColorDisabled;
|
||||
property ColorFocused: TColor read FColorFocused write SetFColorFocused;
|
||||
property ColorText: TColor read FColorText write SetFColorText;
|
||||
end;
|
||||
|
||||
procedure Register;
|
||||
|
||||
implementation
|
||||
|
||||
procedure Register;
|
||||
begin
|
||||
RegisterComponents('BGRA Themes', [TBGRAColorTheme]);
|
||||
end;
|
||||
|
||||
{ TBGRAColorTheme }
|
||||
|
||||
procedure TBGRAColorTheme.SetFColorActive(AValue: TColor);
|
||||
begin
|
||||
if FColorActive = AValue then
|
||||
Exit;
|
||||
FColorActive := AValue;
|
||||
end;
|
||||
|
||||
procedure TBGRAColorTheme.SetFColorDisabled(AValue: TColor);
|
||||
begin
|
||||
if FColorDisabled = AValue then
|
||||
Exit;
|
||||
FColorDisabled := AValue;
|
||||
end;
|
||||
|
||||
procedure TBGRAColorTheme.SetFColorFocused(AValue: TColor);
|
||||
begin
|
||||
if FColorFocused = AValue then
|
||||
Exit;
|
||||
FColorFocused := AValue;
|
||||
end;
|
||||
|
||||
procedure TBGRAColorTheme.SetFColorHover(AValue: TColor);
|
||||
begin
|
||||
if FColorHover = AValue then
|
||||
Exit;
|
||||
FColorHover := AValue;
|
||||
end;
|
||||
|
||||
procedure TBGRAColorTheme.SetFColorNormal(AValue: TColor);
|
||||
begin
|
||||
if FColorNormal = AValue then
|
||||
Exit;
|
||||
FColorNormal := AValue;
|
||||
end;
|
||||
|
||||
procedure TBGRAColorTheme.SetFColorText(AValue: TColor);
|
||||
begin
|
||||
if FColorText = AValue then
|
||||
Exit;
|
||||
FColorText := AValue;
|
||||
end;
|
||||
|
||||
procedure TBGRAColorTheme.DrawButton(Caption: string;
|
||||
State: TBGRAThemeButtonState; Focused: boolean; ARect: TRect;
|
||||
ASurface: TBGRAThemeSurface; AImageIndex: Integer;
|
||||
AImageList: TBGRASVGImageList);
|
||||
var
|
||||
Style: TTextStyle;
|
||||
begin
|
||||
with ASurface do
|
||||
begin
|
||||
case State of
|
||||
btbsNormal: DestCanvas.Brush.Color := ColorNormal;
|
||||
btbsHover: DestCanvas.Brush.Color := ColorHover;
|
||||
btbsActive: DestCanvas.Brush.Color := ColorActive;
|
||||
btbsDisabled: DestCanvas.Brush.Color := ColorDisabled;
|
||||
end;
|
||||
|
||||
DestCanvas.Pen.Color := DestCanvas.Brush.Color;
|
||||
DestCanvas.Rectangle(ARect);
|
||||
|
||||
if Focused then
|
||||
begin
|
||||
DestCanvas.Pen.Color := ColorFocused;
|
||||
DestCanvas.Rectangle(ARect);
|
||||
end;
|
||||
|
||||
if Caption <> '' then
|
||||
begin
|
||||
fillchar(Style, sizeof(Style), 0);
|
||||
Style.Alignment := taCenter;
|
||||
Style.Layout := tlCenter;
|
||||
Style.Wordbreak := True;
|
||||
if ColorText <> clDefault then
|
||||
DestCanvas.Font.Color := ColorText;
|
||||
DestCanvas.TextRect(ARect, 0, 0, Caption, Style);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TBGRAColorTheme.DrawRadioButton(Caption: string;
|
||||
State: TBGRAThemeButtonState; Focused: boolean; Checked: boolean;
|
||||
ARect: TRect; ASurface: TBGRAThemeSurface);
|
||||
var
|
||||
Style: TTextStyle;
|
||||
Color: TBGRAPixel;
|
||||
begin
|
||||
with ASurface do
|
||||
begin
|
||||
DestCanvas.Font.Color := ColorText;
|
||||
case State of
|
||||
btbsHover: Color := ColorHover;
|
||||
btbsActive: Color := ColorActive;
|
||||
btbsDisabled:
|
||||
begin
|
||||
DestCanvas.Font.Color := ColorDisabled;
|
||||
Color := ColorDisabled;
|
||||
end;
|
||||
else {btbsNormal}
|
||||
Color := ColorNormal;
|
||||
end;
|
||||
|
||||
BitmapRect := RectWithSize(ARect.Left, ARect.Top, ARect.Height, ARect.Height);
|
||||
Bitmap.FillEllipseAntialias(Bitmap.Height / 2, Bitmap.Height / 2,
|
||||
Bitmap.Height / 2 - 2, Bitmap.Height / 2 - 2, BGRAWhite);
|
||||
Bitmap.EllipseAntialias(Bitmap.Height / 2, Bitmap.Height / 2,
|
||||
Bitmap.Height / 2 - 2, Bitmap.Height / 2 - 2, Color{%H-}, 1);
|
||||
if Checked then
|
||||
Bitmap.FillEllipseAntialias(Bitmap.Height / 2, Bitmap.Height /
|
||||
2, Bitmap.Height / 4, Bitmap.Height / 4, Color);
|
||||
DrawBitmap;
|
||||
|
||||
if Caption <> '' then
|
||||
begin
|
||||
fillchar(Style, sizeof(Style), 0);
|
||||
Style.Alignment := taLeftJustify;
|
||||
Style.Layout := tlCenter;
|
||||
Style.Wordbreak := True;
|
||||
DestCanvas.TextRect(Rect(Arect.Height, 0, ARect.Right, ARect.Bottom),
|
||||
ARect.Height, 0, Caption, Style);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TBGRAColorTheme.DrawCheckBox(Caption: string;
|
||||
State: TBGRAThemeButtonState; Focused: boolean; Checked: boolean;
|
||||
ARect: TRect; ASurface: TBGRAThemeSurface);
|
||||
var
|
||||
Style: TTextStyle;
|
||||
Color: TBGRAPixel;
|
||||
aleft, atop, aright, abottom: integer;
|
||||
begin
|
||||
with ASurface do
|
||||
begin
|
||||
DestCanvas.Font.Color := ColorText;
|
||||
case State of
|
||||
btbsHover: Color := ColorHover;
|
||||
btbsActive: Color := ColorActive;
|
||||
btbsDisabled:
|
||||
begin
|
||||
DestCanvas.Font.Color := ColorDisabled;
|
||||
Color := ColorDisabled;
|
||||
end;
|
||||
else {btbsNormal}
|
||||
Color := ColorNormal;
|
||||
end;
|
||||
|
||||
BitmapRect := RectWithSize(ARect.Left, ARect.Top, ARect.Height, ARect.Height);
|
||||
Bitmap.Rectangle(0, 0, Bitmap.Height, Bitmap.Height, Color, BGRAWhite);
|
||||
aleft := 0;
|
||||
aright := Bitmap.Height;
|
||||
atop := 0;
|
||||
abottom := Bitmap.Height;
|
||||
if Checked then
|
||||
Bitmap.DrawPolyLineAntialias(Bitmap.ComputeBezierSpline(
|
||||
[BezierCurve(pointF(aleft + 2, atop + 3), PointF((aleft + aright - 1) / 2, abottom - 3)),
|
||||
BezierCurve(PointF((aleft + aright - 1) / 2, abottom - 3), PointF(
|
||||
(aleft + aright - 1) / 2, (atop * 2 + abottom - 1) / 3), PointF(aright - 2, atop - 2))]),
|
||||
Color, 1.5);
|
||||
DrawBitmap;
|
||||
|
||||
if Caption <> '' then
|
||||
begin
|
||||
fillchar(Style, sizeof(Style), 0);
|
||||
Style.Alignment := taLeftJustify;
|
||||
Style.Layout := tlCenter;
|
||||
Style.Wordbreak := True;
|
||||
DestCanvas.TextRect(Rect(Arect.Height, 0, ARect.Right, ARect.Bottom),
|
||||
ARect.Height, 0, Caption, Style);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
end.
|
||||
93
bgracontrols/bgracontrols.dpk
Normal file
93
bgracontrols/bgracontrols.dpk
Normal file
@@ -0,0 +1,93 @@
|
||||
package bgracontrols;
|
||||
|
||||
{$R *.res}
|
||||
{$R 'icons\BGRAImageManipulation_icon.res'}
|
||||
{$R 'icons\bcsvgbutton.res'}
|
||||
{$R 'icons\bcimagebutton_icon.res'}
|
||||
{$R 'icons\bcgamegrid_icon.res'}
|
||||
{$R 'icons\bcradialprogressbar_icon.res'}
|
||||
{$IFDEF IMPLICITBUILDING This IFDEF should not be used by users}
|
||||
{$ALIGN 8}
|
||||
{$ASSERTIONS ON}
|
||||
{$BOOLEVAL OFF}
|
||||
{$DEBUGINFO ON}
|
||||
{$EXTENDEDSYNTAX ON}
|
||||
{$IMPORTEDDATA ON}
|
||||
{$IOCHECKS ON}
|
||||
{$LOCALSYMBOLS ON}
|
||||
{$LONGSTRINGS ON}
|
||||
{$OPENSTRINGS ON}
|
||||
{$OPTIMIZATION OFF}
|
||||
{$OVERFLOWCHECKS OFF}
|
||||
{$RANGECHECKS OFF}
|
||||
{$REFERENCEINFO ON}
|
||||
{$SAFEDIVIDE OFF}
|
||||
{$STACKFRAMES ON}
|
||||
{$TYPEDADDRESS OFF}
|
||||
{$VARSTRINGCHECKS ON}
|
||||
{$WRITEABLECONST OFF}
|
||||
{$MINENUMSIZE 1}
|
||||
{$IMAGEBASE $400000}
|
||||
{$DEFINE DEBUG}
|
||||
{$ENDIF IMPLICITBUILDING}
|
||||
{$DESIGNONLY}
|
||||
{$IMPLICITBUILD ON}
|
||||
|
||||
requires
|
||||
designide,
|
||||
rtl,
|
||||
vcl,
|
||||
vcldesigner,
|
||||
vclimg,
|
||||
bgrabitmappack;
|
||||
|
||||
contains
|
||||
bcbasectrls in 'bcbasectrls.pas',
|
||||
bcbrightandcontrast in 'bcbrightandcontrast.pas',
|
||||
bcbutton in 'bcbutton.pas',
|
||||
bcbuttonfocus in 'bcbuttonfocus.pas',
|
||||
bceffect in 'bceffect.pas',
|
||||
bcfilters in 'bcfilters.pas',
|
||||
bcgamegrid in 'bcgamegrid.pas',
|
||||
bcimagebutton in 'bcimagebutton.pas',
|
||||
bckeyboard in 'bckeyboard.pas',
|
||||
bclabel in 'bclabel.pas',
|
||||
bcmaterialdesignbutton in 'bcmaterialdesignbutton.pas',
|
||||
bcmdbutton in 'bcmdbutton.pas',
|
||||
bcmdbuttonfocus in 'bcmdbuttonfocus.pas',
|
||||
bcnumerickeyboard in 'bcnumerickeyboard.pas',
|
||||
bcpanel in 'bcpanel.pas',
|
||||
bcradialprogressbar in 'bcradialprogressbar.pas',
|
||||
bcrtti in 'bcrtti.pas',
|
||||
bcsamples in 'bcsamples.pas',
|
||||
bcstylesform in 'bcstylesform.pas',
|
||||
bcsvgbutton in 'bcsvgbutton.pas',
|
||||
bcsvgviewer in 'bcsvgviewer.pas',
|
||||
bcthememanager in 'bcthememanager.pas',
|
||||
bctoolbar in 'bctoolbar.pas',
|
||||
bctools in 'bctools.pas',
|
||||
bctrackbarupdown in 'bctrackbarupdown.pas',
|
||||
bctypes in 'bctypes.pas',
|
||||
bgraflashprogressbar in 'bgraflashprogressbar.pas',
|
||||
bgragraphiccontrol in 'bgragraphiccontrol.pas',
|
||||
bgraimagelist in 'bgraimagelist.pas',
|
||||
bgraimagemanipulation in 'bgraimagemanipulation.pas',
|
||||
bgraknob in 'bgraknob.pas',
|
||||
bgraresizespeedbutton in 'bgraresizespeedbutton.pas',
|
||||
bgrashape in 'bgrashape.pas',
|
||||
bgraspeedbutton in 'bgraspeedbutton.pas',
|
||||
bgraspriteanimation in 'bgraspriteanimation.pas',
|
||||
bgravirtualscreen in 'bgravirtualscreen.pas',
|
||||
colorspeedbutton in 'colorspeedbutton.pas',
|
||||
dtanalogclock in 'dtanalogclock.pas',
|
||||
dtthemedclock in 'dtthemedclock.pas',
|
||||
materialcolors in 'materialcolors.pas',
|
||||
MouseAndKeyInput in 'lcl\MouseAndKeyInput.pas',
|
||||
MouseInputIntf in 'lcl\MouseInputIntf.pas',
|
||||
KeyInputIntf in 'lcl\KeyInputIntf.pas',
|
||||
WinMouseInput in 'lcl\WinMouseInput.pas',
|
||||
WinKeyInput in 'lcl\WinKeyInput.pas',
|
||||
bcreg in 'bcreg.pas';
|
||||
|
||||
end.
|
||||
|
||||
225
bgracontrols/bgracontrols.dproj
Normal file
225
bgracontrols/bgracontrols.dproj
Normal file
@@ -0,0 +1,225 @@
|
||||
<Project xmlns="http://schemas.microsoft.com/developer/msbuild/2003">
|
||||
<PropertyGroup>
|
||||
<ProjectGuid>{D31721D7-6E5F-4AB7-922D-D08C063CA1B6}</ProjectGuid>
|
||||
<MainSource>bgracontrols.dpk</MainSource>
|
||||
<ProjectVersion>18.4</ProjectVersion>
|
||||
<FrameworkType>VCL</FrameworkType>
|
||||
<Base>True</Base>
|
||||
<Config Condition="'$(Config)'==''">Debug</Config>
|
||||
<Platform Condition="'$(Platform)'==''">Win32</Platform>
|
||||
<TargetedPlatforms>1</TargetedPlatforms>
|
||||
<AppType>Package</AppType>
|
||||
</PropertyGroup>
|
||||
<PropertyGroup Condition="'$(Config)'=='Base' or '$(Base)'!=''">
|
||||
<Base>true</Base>
|
||||
</PropertyGroup>
|
||||
<PropertyGroup Condition="('$(Platform)'=='Android' and '$(Base)'=='true') or '$(Base_Android)'!=''">
|
||||
<Base_Android>true</Base_Android>
|
||||
<CfgParent>Base</CfgParent>
|
||||
<Base>true</Base>
|
||||
</PropertyGroup>
|
||||
<PropertyGroup Condition="('$(Platform)'=='Win32' and '$(Base)'=='true') or '$(Base_Win32)'!=''">
|
||||
<Base_Win32>true</Base_Win32>
|
||||
<CfgParent>Base</CfgParent>
|
||||
<Base>true</Base>
|
||||
</PropertyGroup>
|
||||
<PropertyGroup Condition="('$(Platform)'=='Win64' and '$(Base)'=='true') or '$(Base_Win64)'!=''">
|
||||
<Base_Win64>true</Base_Win64>
|
||||
<CfgParent>Base</CfgParent>
|
||||
<Base>true</Base>
|
||||
</PropertyGroup>
|
||||
<PropertyGroup Condition="'$(Config)'=='Debug' or '$(Cfg_1)'!=''">
|
||||
<Cfg_1>true</Cfg_1>
|
||||
<CfgParent>Base</CfgParent>
|
||||
<Base>true</Base>
|
||||
</PropertyGroup>
|
||||
<PropertyGroup Condition="('$(Platform)'=='Win32' and '$(Cfg_1)'=='true') or '$(Cfg_1_Win32)'!=''">
|
||||
<Cfg_1_Win32>true</Cfg_1_Win32>
|
||||
<CfgParent>Cfg_1</CfgParent>
|
||||
<Cfg_1>true</Cfg_1>
|
||||
<Base>true</Base>
|
||||
</PropertyGroup>
|
||||
<PropertyGroup Condition="'$(Config)'=='Release' or '$(Cfg_2)'!=''">
|
||||
<Cfg_2>true</Cfg_2>
|
||||
<CfgParent>Base</CfgParent>
|
||||
<Base>true</Base>
|
||||
</PropertyGroup>
|
||||
<PropertyGroup Condition="'$(Base)'!=''">
|
||||
<DesignOnlyPackage>true</DesignOnlyPackage>
|
||||
<DCC_UsePackage>rtl;$(DCC_UsePackage)</DCC_UsePackage>
|
||||
<DCC_CBuilderOutput>All</DCC_CBuilderOutput>
|
||||
<DCC_Namespace>System;Xml;Data;Datasnap;Web;Soap;Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;$(DCC_Namespace)</DCC_Namespace>
|
||||
<GenPackage>true</GenPackage>
|
||||
<GenDll>true</GenDll>
|
||||
<DCC_DcuOutput>.\$(Platform)\$(Config)</DCC_DcuOutput>
|
||||
<DCC_ExeOutput>.\$(Platform)\$(Config)</DCC_ExeOutput>
|
||||
<SanitizedProjectName>bgracontrols</SanitizedProjectName>
|
||||
</PropertyGroup>
|
||||
<PropertyGroup Condition="'$(Base_Android)'!=''">
|
||||
<VerInfo_Keys>package=com.embarcadero.$(MSBuildProjectName);label=$(MSBuildProjectName);versionCode=1;versionName=1.0.0;persistent=False;restoreAnyVersion=False;installLocation=auto;largeHeap=False;theme=TitleBar;hardwareAccelerated=true;apiKey=</VerInfo_Keys>
|
||||
<BT_BuildType>Debug</BT_BuildType>
|
||||
<EnabledSysJars>android-support-v4.dex.jar;cloud-messaging.dex.jar;fmx.dex.jar;google-analytics-v2.dex.jar;google-play-billing.dex.jar;google-play-licensing.dex.jar;google-play-services-ads-7.0.0.dex.jar;google-play-services-analytics-7.0.0.dex.jar;google-play-services-base-7.0.0.dex.jar;google-play-services-identity-7.0.0.dex.jar;google-play-services-maps-7.0.0.dex.jar;google-play-services-panorama-7.0.0.dex.jar;google-play-services-plus-7.0.0.dex.jar;google-play-services-wallet-7.0.0.dex.jar</EnabledSysJars>
|
||||
</PropertyGroup>
|
||||
<PropertyGroup Condition="'$(Base_Win32)'!=''">
|
||||
<DCC_UsePackage>vclimg;vcl;bgrabitmappack;$(DCC_UsePackage)</DCC_UsePackage>
|
||||
<VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo>
|
||||
<DCC_Namespace>Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace)</DCC_Namespace>
|
||||
<VerInfo_Locale>1033</VerInfo_Locale>
|
||||
<VerInfo_Keys>CompanyName=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(MSBuildProjectName);FileDescription=$(MSBuildProjectName);ProductName=$(MSBuildProjectName)</VerInfo_Keys>
|
||||
</PropertyGroup>
|
||||
<PropertyGroup Condition="'$(Base_Win64)'!=''">
|
||||
<DCC_UsePackage>vclimg;vcl;$(DCC_UsePackage)</DCC_UsePackage>
|
||||
</PropertyGroup>
|
||||
<PropertyGroup Condition="'$(Cfg_1)'!=''">
|
||||
<DCC_Define>DEBUG;$(DCC_Define)</DCC_Define>
|
||||
<DCC_Optimize>false</DCC_Optimize>
|
||||
<DCC_GenerateStackFrames>true</DCC_GenerateStackFrames>
|
||||
<DCC_DebugInfoInExe>true</DCC_DebugInfoInExe>
|
||||
<DCC_RemoteDebug>true</DCC_RemoteDebug>
|
||||
</PropertyGroup>
|
||||
<PropertyGroup Condition="'$(Cfg_1_Win32)'!=''">
|
||||
<DCC_UnitSearchPath>C:\BGRABitmap\Win32\Debug;$(DCC_UnitSearchPath)</DCC_UnitSearchPath>
|
||||
<DCC_CBuilderOutput>None</DCC_CBuilderOutput>
|
||||
<VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo>
|
||||
<VerInfo_Locale>1033</VerInfo_Locale>
|
||||
<DCC_RemoteDebug>false</DCC_RemoteDebug>
|
||||
</PropertyGroup>
|
||||
<PropertyGroup Condition="'$(Cfg_2)'!=''">
|
||||
<DCC_LocalDebugSymbols>false</DCC_LocalDebugSymbols>
|
||||
<DCC_Define>RELEASE;$(DCC_Define)</DCC_Define>
|
||||
<DCC_SymbolReferenceInfo>0</DCC_SymbolReferenceInfo>
|
||||
<DCC_DebugInformation>0</DCC_DebugInformation>
|
||||
</PropertyGroup>
|
||||
<ItemGroup>
|
||||
<DelphiCompile Include="$(MainSource)">
|
||||
<MainSource>MainSource</MainSource>
|
||||
</DelphiCompile>
|
||||
<DCCReference Include="icons\BGRAImageManipulation_icon.res"/>
|
||||
<DCCReference Include="icons\bcsvgbutton.res"/>
|
||||
<DCCReference Include="icons\bcimagebutton_icon.res"/>
|
||||
<DCCReference Include="icons\bcgamegrid_icon.res"/>
|
||||
<DCCReference Include="icons\bcradialprogressbar_icon.res"/>
|
||||
<DCCReference Include="designide.dcp"/>
|
||||
<DCCReference Include="rtl.dcp"/>
|
||||
<DCCReference Include="vcl.dcp"/>
|
||||
<DCCReference Include="vcldesigner.dcp"/>
|
||||
<DCCReference Include="vclimg.dcp"/>
|
||||
<DCCReference Include="bgrabitmappack.dcp"/>
|
||||
<DCCReference Include="bcbasectrls.pas"/>
|
||||
<DCCReference Include="bcbrightandcontrast.pas"/>
|
||||
<DCCReference Include="bcbutton.pas"/>
|
||||
<DCCReference Include="bcbuttonfocus.pas"/>
|
||||
<DCCReference Include="bceffect.pas"/>
|
||||
<DCCReference Include="bcfilters.pas"/>
|
||||
<DCCReference Include="bcgamegrid.pas"/>
|
||||
<DCCReference Include="bcimagebutton.pas"/>
|
||||
<DCCReference Include="bckeyboard.pas"/>
|
||||
<DCCReference Include="bclabel.pas"/>
|
||||
<DCCReference Include="bcmaterialdesignbutton.pas"/>
|
||||
<DCCReference Include="bcmdbutton.pas"/>
|
||||
<DCCReference Include="bcmdbuttonfocus.pas"/>
|
||||
<DCCReference Include="bcnumerickeyboard.pas"/>
|
||||
<DCCReference Include="bcpanel.pas"/>
|
||||
<DCCReference Include="bcradialprogressbar.pas"/>
|
||||
<DCCReference Include="bcrtti.pas"/>
|
||||
<DCCReference Include="bcsamples.pas"/>
|
||||
<DCCReference Include="bcstylesform.pas"/>
|
||||
<DCCReference Include="bcsvgbutton.pas"/>
|
||||
<DCCReference Include="bcsvgviewer.pas"/>
|
||||
<DCCReference Include="bcthememanager.pas"/>
|
||||
<DCCReference Include="bctoolbar.pas"/>
|
||||
<DCCReference Include="bctools.pas"/>
|
||||
<DCCReference Include="bctrackbarupdown.pas"/>
|
||||
<DCCReference Include="bctypes.pas"/>
|
||||
<DCCReference Include="bgraflashprogressbar.pas"/>
|
||||
<DCCReference Include="bgragraphiccontrol.pas"/>
|
||||
<DCCReference Include="bgraimagelist.pas"/>
|
||||
<DCCReference Include="bgraimagemanipulation.pas"/>
|
||||
<DCCReference Include="bgraknob.pas"/>
|
||||
<DCCReference Include="bgraresizespeedbutton.pas"/>
|
||||
<DCCReference Include="bgrashape.pas"/>
|
||||
<DCCReference Include="bgraspeedbutton.pas"/>
|
||||
<DCCReference Include="bgraspriteanimation.pas"/>
|
||||
<DCCReference Include="bgravirtualscreen.pas"/>
|
||||
<DCCReference Include="colorspeedbutton.pas"/>
|
||||
<DCCReference Include="dtanalogclock.pas"/>
|
||||
<DCCReference Include="dtthemedclock.pas"/>
|
||||
<DCCReference Include="materialcolors.pas"/>
|
||||
<DCCReference Include="lcl\MouseAndKeyInput.pas"/>
|
||||
<DCCReference Include="lcl\MouseInputIntf.pas"/>
|
||||
<DCCReference Include="lcl\KeyInputIntf.pas"/>
|
||||
<DCCReference Include="lcl\WinMouseInput.pas"/>
|
||||
<DCCReference Include="lcl\WinKeyInput.pas"/>
|
||||
<DCCReference Include="bcreg.pas"/>
|
||||
<None Include="dtanalogcommon.pas"/>
|
||||
<None Include="dtanaloggauge.pas"/>
|
||||
<None Include="dtthemedgauge.pas"/>
|
||||
<BuildConfiguration Include="Release">
|
||||
<Key>Cfg_2</Key>
|
||||
<CfgParent>Base</CfgParent>
|
||||
</BuildConfiguration>
|
||||
<BuildConfiguration Include="Base">
|
||||
<Key>Base</Key>
|
||||
</BuildConfiguration>
|
||||
<BuildConfiguration Include="Debug">
|
||||
<Key>Cfg_1</Key>
|
||||
<CfgParent>Base</CfgParent>
|
||||
</BuildConfiguration>
|
||||
</ItemGroup>
|
||||
<ProjectExtensions>
|
||||
<Borland.Personality>Delphi.Personality.12</Borland.Personality>
|
||||
<Borland.ProjectType>Package</Borland.ProjectType>
|
||||
<BorlandProject>
|
||||
<Delphi.Personality>
|
||||
<Source>
|
||||
<Source Name="MainSource">bgracontrols.dpk</Source>
|
||||
</Source>
|
||||
<VersionInfo>
|
||||
<VersionInfo Name="IncludeVerInfo">True</VersionInfo>
|
||||
<VersionInfo Name="AutoIncBuild">False</VersionInfo>
|
||||
<VersionInfo Name="MajorVer">1</VersionInfo>
|
||||
<VersionInfo Name="MinorVer">0</VersionInfo>
|
||||
<VersionInfo Name="Release">0</VersionInfo>
|
||||
<VersionInfo Name="Build">0</VersionInfo>
|
||||
<VersionInfo Name="Debug">False</VersionInfo>
|
||||
<VersionInfo Name="PreRelease">False</VersionInfo>
|
||||
<VersionInfo Name="Special">False</VersionInfo>
|
||||
<VersionInfo Name="Private">False</VersionInfo>
|
||||
<VersionInfo Name="DLL">False</VersionInfo>
|
||||
<VersionInfo Name="Locale">1046</VersionInfo>
|
||||
<VersionInfo Name="CodePage">1252</VersionInfo>
|
||||
</VersionInfo>
|
||||
<VersionInfoKeys>
|
||||
<VersionInfoKeys Name="CompanyName"/>
|
||||
<VersionInfoKeys Name="FileDescription"/>
|
||||
<VersionInfoKeys Name="FileVersion">1.0.0.0</VersionInfoKeys>
|
||||
<VersionInfoKeys Name="InternalName"/>
|
||||
<VersionInfoKeys Name="LegalCopyright"/>
|
||||
<VersionInfoKeys Name="LegalTrademarks"/>
|
||||
<VersionInfoKeys Name="OriginalFilename"/>
|
||||
<VersionInfoKeys Name="ProductName"/>
|
||||
<VersionInfoKeys Name="ProductVersion">1.0.0.0</VersionInfoKeys>
|
||||
<VersionInfoKeys Name="Comments"/>
|
||||
</VersionInfoKeys>
|
||||
<Excluded_Packages>
|
||||
<Excluded_Packages Name="$(BDSBIN)\dcloffice2k160.bpl">Microsoft Office 2000 Sample Automation Server Wrapper Components</Excluded_Packages>
|
||||
<Excluded_Packages Name="$(BDSBIN)\dclofficexp160.bpl">Microsoft Office XP Sample Automation Server Wrapper Components</Excluded_Packages>
|
||||
<Excluded_Packages Name="$(BDSBIN)\dclIPIndyImpl160.bpl">IP Abstraction Indy Implementation Design Time</Excluded_Packages>
|
||||
</Excluded_Packages>
|
||||
</Delphi.Personality>
|
||||
<Deployment Version="3"/>
|
||||
<Platforms>
|
||||
<Platform value="Android">False</Platform>
|
||||
<Platform value="iOSDevice32">False</Platform>
|
||||
<Platform value="iOSSimulator">False</Platform>
|
||||
<Platform value="OSX32">False</Platform>
|
||||
<Platform value="Win32">True</Platform>
|
||||
<Platform value="Win64">False</Platform>
|
||||
</Platforms>
|
||||
</BorlandProject>
|
||||
<ProjectFileVersion>12</ProjectFileVersion>
|
||||
</ProjectExtensions>
|
||||
<Import Condition="Exists('$(BDS)\Bin\CodeGear.Delphi.Targets')" Project="$(BDS)\Bin\CodeGear.Delphi.Targets"/>
|
||||
<Import Condition="Exists('$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj')" Project="$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj"/>
|
||||
<Import Project="$(MSBuildProjectName).deployproj" Condition="Exists('$(MSBuildProjectName).deployproj')"/>
|
||||
</Project>
|
||||
13
bgracontrols/bgracontrols.inc
Normal file
13
bgracontrols/bgracontrols.inc
Normal file
@@ -0,0 +1,13 @@
|
||||
{$IFDEF FPC}
|
||||
{.$B-} // Boolean short-circuit evaluation ON
|
||||
{$H+} // Long strings ON
|
||||
{.$T-} // Type-checked pointers OFF
|
||||
{.$X+} // Extended syntax ON
|
||||
|
||||
{$IFNDEF RO_FPC_MODE_SET}
|
||||
{$MODE Delphi}
|
||||
{$ENDIF}
|
||||
{.$DEFINE INDEBUG}
|
||||
{$ELSE}
|
||||
{.$DEFINE INDEBUG}
|
||||
{$ENDIF}
|
||||
5
bgracontrols/bgracontrols.logic
Normal file
5
bgracontrols/bgracontrols.logic
Normal file
@@ -0,0 +1,5 @@
|
||||
manager update_bgracontrols_force.json
|
||||
archive https://github.com/bgrabitmap/bgracontrols/archive/master.zip
|
||||
package bgracontrols.lpk
|
||||
package bgrapascalscriptcomponent.lpk
|
||||
const bgracontrolsinfo.pas BGRAControlsVersion
|
||||
396
bgracontrols/bgracontrols.lpk
Normal file
396
bgracontrols/bgracontrols.lpk
Normal file
@@ -0,0 +1,396 @@
|
||||
<?xml version="1.0" encoding="UTF-8"?>
|
||||
<CONFIG>
|
||||
<Package Version="5">
|
||||
<Name Value="bgracontrols"/>
|
||||
<Type Value="RunAndDesignTime"/>
|
||||
<Author Value="Dibo, Circular, Lainz and others"/>
|
||||
<CompilerOptions>
|
||||
<Version Value="11"/>
|
||||
<SearchPaths>
|
||||
<OtherUnitFiles Value="mouseandkeyinput;bgrasvgimagelistform"/>
|
||||
<UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)-$(LCLWidgetType)-$(FPCVer)"/>
|
||||
</SearchPaths>
|
||||
<Parsing>
|
||||
<SyntaxOptions>
|
||||
<SyntaxMode Value="Delphi"/>
|
||||
<CStyleOperator Value="False"/>
|
||||
<AllowLabel Value="False"/>
|
||||
<CPPInline Value="False"/>
|
||||
<UseAnsiStrings Value="False"/>
|
||||
</SyntaxOptions>
|
||||
</Parsing>
|
||||
<CodeGeneration>
|
||||
<Optimizations>
|
||||
<OptimizationLevel Value="0"/>
|
||||
<VariablesInRegisters Value="True"/>
|
||||
</Optimizations>
|
||||
</CodeGeneration>
|
||||
<Linking>
|
||||
<Debugging>
|
||||
<UseHeaptrc Value="True"/>
|
||||
</Debugging>
|
||||
</Linking>
|
||||
</CompilerOptions>
|
||||
<Description Value="BGRA Controls is a set of graphical UI elements that you can use with Lazarus LCL applications."/>
|
||||
<License Value="Modified LGPL"/>
|
||||
<Version Major="9"/>
|
||||
<Files Count="69">
|
||||
<Item1>
|
||||
<Filename Value="atshapelinebgra.pas"/>
|
||||
<HasRegisterProc Value="True"/>
|
||||
<UnitName Value="atshapelinebgra"/>
|
||||
</Item1>
|
||||
<Item2>
|
||||
<Filename Value="bcbasectrls.pas"/>
|
||||
<AddToUsesPkgSection Value="False"/>
|
||||
<UnitName Value="BCBaseCtrls"/>
|
||||
</Item2>
|
||||
<Item3>
|
||||
<Filename Value="bcbrightandcontrast.pas"/>
|
||||
<AddToUsesPkgSection Value="False"/>
|
||||
<UnitName Value="BCBrightAndContrast"/>
|
||||
</Item3>
|
||||
<Item4>
|
||||
<Filename Value="bcbutton.pas"/>
|
||||
<HasRegisterProc Value="True"/>
|
||||
<UnitName Value="BCButton"/>
|
||||
</Item4>
|
||||
<Item5>
|
||||
<Filename Value="bcbuttonfocus.pas"/>
|
||||
<HasRegisterProc Value="True"/>
|
||||
<UnitName Value="BCButtonFocus"/>
|
||||
</Item5>
|
||||
<Item6>
|
||||
<Filename Value="bccheckcombobox.pas"/>
|
||||
<HasRegisterProc Value="True"/>
|
||||
<UnitName Value="BCCheckComboBox"/>
|
||||
</Item6>
|
||||
<Item7>
|
||||
<Filename Value="bccombobox.pas"/>
|
||||
<HasRegisterProc Value="True"/>
|
||||
<UnitName Value="BCComboBox"/>
|
||||
</Item7>
|
||||
<Item8>
|
||||
<Filename Value="bcdefaultthememanager.pas"/>
|
||||
<AddToUsesPkgSection Value="False"/>
|
||||
<UnitName Value="BCDefaultThemeManager"/>
|
||||
</Item8>
|
||||
<Item9>
|
||||
<Filename Value="bceffect.pas"/>
|
||||
<UnitName Value="BCEffect"/>
|
||||
</Item9>
|
||||
<Item10>
|
||||
<Filename Value="bcfilters.pas"/>
|
||||
<UnitName Value="bcfilters"/>
|
||||
</Item10>
|
||||
<Item11>
|
||||
<Filename Value="bcfluentprogressring.pas"/>
|
||||
<HasRegisterProc Value="True"/>
|
||||
<UnitName Value="BCFluentProgressRing"/>
|
||||
</Item11>
|
||||
<Item12>
|
||||
<Filename Value="bcgamegrid.pas"/>
|
||||
<HasRegisterProc Value="True"/>
|
||||
<UnitName Value="BCGameGrid"/>
|
||||
</Item12>
|
||||
<Item13>
|
||||
<Filename Value="bcgradientbutton.pas"/>
|
||||
<HasRegisterProc Value="True"/>
|
||||
<UnitName Value="BCGradientButton"/>
|
||||
</Item13>
|
||||
<Item14>
|
||||
<Filename Value="bcimagebutton.pas"/>
|
||||
<HasRegisterProc Value="True"/>
|
||||
<UnitName Value="BCImageButton"/>
|
||||
</Item14>
|
||||
<Item15>
|
||||
<Filename Value="bckeyboard.pas"/>
|
||||
<AddToUsesPkgSection Value="False"/>
|
||||
<UnitName Value="BCKeyboard"/>
|
||||
</Item15>
|
||||
<Item16>
|
||||
<Filename Value="bclabel.pas"/>
|
||||
<HasRegisterProc Value="True"/>
|
||||
<UnitName Value="BCLabel"/>
|
||||
</Item16>
|
||||
<Item17>
|
||||
<Filename Value="bclistbox.pas"/>
|
||||
<HasRegisterProc Value="True"/>
|
||||
<UnitName Value="BCListBox"/>
|
||||
</Item17>
|
||||
<Item18>
|
||||
<Filename Value="bclistboxex.pas"/>
|
||||
<UnitName Value="BCListBoxEx"/>
|
||||
</Item18>
|
||||
<Item19>
|
||||
<Filename Value="bcmaterialdesignbutton.pas"/>
|
||||
<HasRegisterProc Value="True"/>
|
||||
<UnitName Value="BCMaterialDesignButton"/>
|
||||
</Item19>
|
||||
<Item20>
|
||||
<Filename Value="bcmaterialedit.pas"/>
|
||||
<HasRegisterProc Value="True"/>
|
||||
<UnitName Value="BCMaterialEdit"/>
|
||||
</Item20>
|
||||
<Item21>
|
||||
<Filename Value="bcmaterialfloatspinedit.pas"/>
|
||||
<HasRegisterProc Value="True"/>
|
||||
<UnitName Value="BCMaterialFloatSpinEdit"/>
|
||||
</Item21>
|
||||
<Item22>
|
||||
<Filename Value="bcmaterialprogressbarmarquee.pas"/>
|
||||
<HasRegisterProc Value="True"/>
|
||||
<UnitName Value="BCMaterialProgressBarMarquee"/>
|
||||
</Item22>
|
||||
<Item23>
|
||||
<Filename Value="bcmaterialspinedit.pas"/>
|
||||
<HasRegisterProc Value="True"/>
|
||||
<UnitName Value="BCMaterialSpinEdit"/>
|
||||
</Item23>
|
||||
<Item24>
|
||||
<Filename Value="bcmdbutton.pas"/>
|
||||
<HasRegisterProc Value="True"/>
|
||||
<UnitName Value="BCMDButton"/>
|
||||
</Item24>
|
||||
<Item25>
|
||||
<Filename Value="bcmdbuttonfocus.pas"/>
|
||||
<HasRegisterProc Value="True"/>
|
||||
<UnitName Value="BCMDButtonFocus"/>
|
||||
</Item25>
|
||||
<Item26>
|
||||
<Filename Value="bcnumerickeyboard.pas"/>
|
||||
<AddToUsesPkgSection Value="False"/>
|
||||
<UnitName Value="BCNumericKeyboard"/>
|
||||
</Item26>
|
||||
<Item27>
|
||||
<Filename Value="bcpanel.pas"/>
|
||||
<HasRegisterProc Value="True"/>
|
||||
<UnitName Value="BCPanel"/>
|
||||
</Item27>
|
||||
<Item28>
|
||||
<Filename Value="bcradialprogressbar.pas"/>
|
||||
<HasRegisterProc Value="True"/>
|
||||
<UnitName Value="BCRadialProgressBar"/>
|
||||
</Item28>
|
||||
<Item29>
|
||||
<Filename Value="bcroundedimage.pas"/>
|
||||
<HasRegisterProc Value="True"/>
|
||||
<UnitName Value="BCRoundedImage"/>
|
||||
</Item29>
|
||||
<Item30>
|
||||
<Filename Value="bcrtti.pas"/>
|
||||
<UnitName Value="BCRTTI"/>
|
||||
</Item30>
|
||||
<Item31>
|
||||
<Filename Value="bcsamples.pas"/>
|
||||
<UnitName Value="BCSamples"/>
|
||||
</Item31>
|
||||
<Item32>
|
||||
<Filename Value="bcstylesform.pas"/>
|
||||
<UnitName Value="BCStylesForm"/>
|
||||
</Item32>
|
||||
<Item33>
|
||||
<Filename Value="bcsvgbutton.pas"/>
|
||||
<HasRegisterProc Value="True"/>
|
||||
<UnitName Value="BCSVGButton"/>
|
||||
</Item33>
|
||||
<Item34>
|
||||
<Filename Value="bcsvgviewer.pas"/>
|
||||
<HasRegisterProc Value="True"/>
|
||||
<UnitName Value="BCSVGViewer"/>
|
||||
</Item34>
|
||||
<Item35>
|
||||
<Filename Value="bcthememanager.pas"/>
|
||||
<AddToUsesPkgSection Value="False"/>
|
||||
<UnitName Value="BCThemeManager"/>
|
||||
</Item35>
|
||||
<Item36>
|
||||
<Filename Value="bctoolbar.pas"/>
|
||||
<HasRegisterProc Value="True"/>
|
||||
<UnitName Value="BCToolBar"/>
|
||||
</Item36>
|
||||
<Item37>
|
||||
<Filename Value="bctools.pas"/>
|
||||
<AddToUsesPkgSection Value="False"/>
|
||||
<UnitName Value="BCTools"/>
|
||||
</Item37>
|
||||
<Item38>
|
||||
<Filename Value="bctrackbarupdown.pas"/>
|
||||
<HasRegisterProc Value="True"/>
|
||||
<UnitName Value="BCTrackbarUpdown"/>
|
||||
</Item38>
|
||||
<Item39>
|
||||
<Filename Value="bctypes.pas"/>
|
||||
<AddToUsesPkgSection Value="False"/>
|
||||
<UnitName Value="BCTypes"/>
|
||||
</Item39>
|
||||
<Item40>
|
||||
<Filename Value="bgracolortheme.pas"/>
|
||||
<HasRegisterProc Value="True"/>
|
||||
<UnitName Value="BGRAColorTheme"/>
|
||||
</Item40>
|
||||
<Item41>
|
||||
<Filename Value="bgracontrolsinfo.pas"/>
|
||||
<UnitName Value="bgracontrolsinfo"/>
|
||||
</Item41>
|
||||
<Item42>
|
||||
<Filename Value="bgracustomdrawn.pas"/>
|
||||
<HasRegisterProc Value="True"/>
|
||||
<UnitName Value="BGRACustomDrawn"/>
|
||||
</Item42>
|
||||
<Item43>
|
||||
<Filename Value="bgradrawerflashprogressbar.pas"/>
|
||||
<UnitName Value="BGRADrawerFlashProgressBar"/>
|
||||
</Item43>
|
||||
<Item44>
|
||||
<Filename Value="bgraflashprogressbar.pas"/>
|
||||
<HasRegisterProc Value="True"/>
|
||||
<UnitName Value="BGRAFlashProgressBar"/>
|
||||
</Item44>
|
||||
<Item45>
|
||||
<Filename Value="bgragraphiccontrol.pas"/>
|
||||
<HasRegisterProc Value="True"/>
|
||||
<UnitName Value="BGRAGraphicControl"/>
|
||||
</Item45>
|
||||
<Item46>
|
||||
<Filename Value="bgraimagelist.pas"/>
|
||||
<HasRegisterProc Value="True"/>
|
||||
<UnitName Value="BGRAImageList"/>
|
||||
</Item46>
|
||||
<Item47>
|
||||
<Filename Value="bgraimagemanipulation.pas"/>
|
||||
<HasRegisterProc Value="True"/>
|
||||
<UnitName Value="BGRAImageManipulation"/>
|
||||
</Item47>
|
||||
<Item48>
|
||||
<Filename Value="bgraimagetheme.pas"/>
|
||||
<HasRegisterProc Value="True"/>
|
||||
<UnitName Value="BGRAImageTheme"/>
|
||||
</Item48>
|
||||
<Item49>
|
||||
<Filename Value="bgraknob.pas"/>
|
||||
<HasRegisterProc Value="True"/>
|
||||
<UnitName Value="BGRAKnob"/>
|
||||
</Item49>
|
||||
<Item50>
|
||||
<Filename Value="bgraresizespeedbutton.pas"/>
|
||||
<HasRegisterProc Value="True"/>
|
||||
<UnitName Value="BGRAResizeSpeedButton"/>
|
||||
</Item50>
|
||||
<Item51>
|
||||
<Filename Value="bgrashape.pas"/>
|
||||
<HasRegisterProc Value="True"/>
|
||||
<UnitName Value="BGRAShape"/>
|
||||
</Item51>
|
||||
<Item52>
|
||||
<Filename Value="bgraspeedbutton.pas"/>
|
||||
<HasRegisterProc Value="True"/>
|
||||
<UnitName Value="BGRASpeedButton"/>
|
||||
</Item52>
|
||||
<Item53>
|
||||
<Filename Value="bgraspriteanimation.pas"/>
|
||||
<HasRegisterProc Value="True"/>
|
||||
<UnitName Value="BGRASpriteAnimation"/>
|
||||
</Item53>
|
||||
<Item54>
|
||||
<Filename Value="bgrasvgimagelist.pas"/>
|
||||
<HasRegisterProc Value="True"/>
|
||||
<UnitName Value="BGRASVGImageList"/>
|
||||
</Item54>
|
||||
<Item55>
|
||||
<Filename Value="bgrasvgtheme.pas"/>
|
||||
<HasRegisterProc Value="True"/>
|
||||
<UnitName Value="BGRASVGTheme"/>
|
||||
</Item55>
|
||||
<Item56>
|
||||
<Filename Value="bgratheme.pas"/>
|
||||
<HasRegisterProc Value="True"/>
|
||||
<UnitName Value="BGRATheme"/>
|
||||
</Item56>
|
||||
<Item57>
|
||||
<Filename Value="bgrathemebutton.pas"/>
|
||||
<HasRegisterProc Value="True"/>
|
||||
<UnitName Value="BGRAThemeButton"/>
|
||||
</Item57>
|
||||
<Item58>
|
||||
<Filename Value="bgrathemecheckbox.pas"/>
|
||||
<HasRegisterProc Value="True"/>
|
||||
<UnitName Value="BGRAThemeCheckBox"/>
|
||||
</Item58>
|
||||
<Item59>
|
||||
<Filename Value="bgrathemeradiobutton.pas"/>
|
||||
<HasRegisterProc Value="True"/>
|
||||
<AddToUsesPkgSection Value="False"/>
|
||||
<UnitName Value="BGRAThemeRadioButton"/>
|
||||
</Item59>
|
||||
<Item60>
|
||||
<Filename Value="bgravirtualscreen.pas"/>
|
||||
<HasRegisterProc Value="True"/>
|
||||
<UnitName Value="BGRAVirtualScreen"/>
|
||||
</Item60>
|
||||
<Item61>
|
||||
<Filename Value="colorspeedbutton.pas"/>
|
||||
<HasRegisterProc Value="True"/>
|
||||
<UnitName Value="ColorSpeedButton"/>
|
||||
</Item61>
|
||||
<Item62>
|
||||
<Filename Value="dtanalogclock.pas"/>
|
||||
<HasRegisterProc Value="True"/>
|
||||
<UnitName Value="DTAnalogClock"/>
|
||||
</Item62>
|
||||
<Item63>
|
||||
<Filename Value="dtanalogcommon.pas"/>
|
||||
<UnitName Value="DTAnalogCommon"/>
|
||||
</Item63>
|
||||
<Item64>
|
||||
<Filename Value="dtanaloggauge.pas"/>
|
||||
<HasRegisterProc Value="True"/>
|
||||
<AddToUsesPkgSection Value="False"/>
|
||||
<UnitName Value="DTAnalogGauge"/>
|
||||
</Item64>
|
||||
<Item65>
|
||||
<Filename Value="dtthemedclock.pas"/>
|
||||
<HasRegisterProc Value="True"/>
|
||||
<UnitName Value="dtthemedclock"/>
|
||||
</Item65>
|
||||
<Item66>
|
||||
<Filename Value="dtthemedgauge.pas"/>
|
||||
<HasRegisterProc Value="True"/>
|
||||
<UnitName Value="dtthemedgauge"/>
|
||||
</Item66>
|
||||
<Item67>
|
||||
<Filename Value="materialcolors.pas"/>
|
||||
<UnitName Value="MaterialColors"/>
|
||||
</Item67>
|
||||
<Item68>
|
||||
<Filename Value="bgrasvgimagelistform/bgrasvgimagelistform.pas"/>
|
||||
<UnitName Value="bgrasvgimagelistform"/>
|
||||
</Item68>
|
||||
<Item69>
|
||||
<Filename Value="BCExpandPanels.pas"/>
|
||||
<HasRegisterProc Value="True"/>
|
||||
<UnitName Value="BCExpandPanels"/>
|
||||
</Item69>
|
||||
</Files>
|
||||
<CompatibilityMode Value="True"/>
|
||||
<LazDoc Paths="fpdoc"/>
|
||||
<RequiredPkgs Count="2">
|
||||
<Item1>
|
||||
<PackageName Value="BGRABitmapPack"/>
|
||||
<MinVersion Major="11" Minor="5" Release="5" Valid="True"/>
|
||||
</Item1>
|
||||
<Item2>
|
||||
<PackageName Value="IDEIntf"/>
|
||||
</Item2>
|
||||
</RequiredPkgs>
|
||||
<UsageOptions>
|
||||
<UnitPath Value="$(PkgOutDir)"/>
|
||||
</UsageOptions>
|
||||
<PublishOptions>
|
||||
<Version Value="2"/>
|
||||
</PublishOptions>
|
||||
<CustomOptions Items="ExternHelp" Version="2">
|
||||
<_ExternHelp Items="Count"/>
|
||||
</CustomOptions>
|
||||
</Package>
|
||||
</CONFIG>
|
||||
86
bgracontrols/bgracontrols.pas
Normal file
86
bgracontrols/bgracontrols.pas
Normal file
@@ -0,0 +1,86 @@
|
||||
{ This file was automatically created by Lazarus. Do not edit!
|
||||
This source is only used to compile and install the package.
|
||||
}
|
||||
|
||||
unit bgracontrols;
|
||||
|
||||
{$warn 5023 off : no warning about unused units}
|
||||
interface
|
||||
|
||||
uses
|
||||
atshapelinebgra, BCButton, BCButtonFocus, BCCheckComboBox, BCComboBox,
|
||||
BCEffect, bcfilters, BCFluentProgressRing, BCGameGrid, BCGradientButton,
|
||||
BCImageButton, BCLabel, BCListBox, BCListBoxEx, BCMaterialDesignButton,
|
||||
BCMaterialEdit, BCMaterialFloatSpinEdit, BCMaterialProgressBarMarquee,
|
||||
BCMaterialSpinEdit, BCMDButton, BCMDButtonFocus, BCPanel,
|
||||
BCRadialProgressBar, BCRoundedImage, BCRTTI, BCSamples, BCStylesForm,
|
||||
BCSVGButton, BCSVGViewer, BCToolBar, BCTrackbarUpdown, BGRAColorTheme,
|
||||
bgracontrolsinfo, BGRACustomDrawn, BGRADrawerFlashProgressBar,
|
||||
BGRAFlashProgressBar, BGRAGraphicControl, BGRAImageList,
|
||||
BGRAImageManipulation, BGRAImageTheme, BGRAKnob, BGRAResizeSpeedButton,
|
||||
BGRAShape, BGRASpeedButton, BGRASpriteAnimation, BGRASVGImageList,
|
||||
BGRASVGTheme, BGRATheme, BGRAThemeButton, BGRAThemeCheckBox,
|
||||
BGRAThemeRadioButton, BGRAVirtualScreen, ColorSpeedButton, DTAnalogClock,
|
||||
DTAnalogCommon, DTAnalogGauge, dtthemedclock, dtthemedgauge, MaterialColors,
|
||||
bgrasvgimagelistform, BCExpandPanels, LazarusPackageIntf;
|
||||
|
||||
implementation
|
||||
|
||||
procedure Register;
|
||||
begin
|
||||
RegisterUnit('atshapelinebgra', @atshapelinebgra.Register);
|
||||
RegisterUnit('BCButton', @BCButton.Register);
|
||||
RegisterUnit('BCButtonFocus', @BCButtonFocus.Register);
|
||||
RegisterUnit('BCCheckComboBox', @BCCheckComboBox.Register);
|
||||
RegisterUnit('BCComboBox', @BCComboBox.Register);
|
||||
RegisterUnit('BCFluentProgressRing', @BCFluentProgressRing.Register);
|
||||
RegisterUnit('BCGameGrid', @BCGameGrid.Register);
|
||||
RegisterUnit('BCGradientButton', @BCGradientButton.Register);
|
||||
RegisterUnit('BCImageButton', @BCImageButton.Register);
|
||||
RegisterUnit('BCLabel', @BCLabel.Register);
|
||||
RegisterUnit('BCListBox', @BCListBox.Register);
|
||||
RegisterUnit('BCMaterialDesignButton', @BCMaterialDesignButton.Register);
|
||||
RegisterUnit('BCMaterialEdit', @BCMaterialEdit.Register);
|
||||
RegisterUnit('BCMaterialFloatSpinEdit', @BCMaterialFloatSpinEdit.Register);
|
||||
RegisterUnit('BCMaterialProgressBarMarquee',
|
||||
@BCMaterialProgressBarMarquee.Register);
|
||||
RegisterUnit('BCMaterialSpinEdit', @BCMaterialSpinEdit.Register);
|
||||
RegisterUnit('BCMDButton', @BCMDButton.Register);
|
||||
RegisterUnit('BCMDButtonFocus', @BCMDButtonFocus.Register);
|
||||
RegisterUnit('BCPanel', @BCPanel.Register);
|
||||
RegisterUnit('BCRadialProgressBar', @BCRadialProgressBar.Register);
|
||||
RegisterUnit('BCRoundedImage', @BCRoundedImage.Register);
|
||||
RegisterUnit('BCSVGButton', @BCSVGButton.Register);
|
||||
RegisterUnit('BCSVGViewer', @BCSVGViewer.Register);
|
||||
RegisterUnit('BCToolBar', @BCToolBar.Register);
|
||||
RegisterUnit('BCTrackbarUpdown', @BCTrackbarUpdown.Register);
|
||||
RegisterUnit('BGRAColorTheme', @BGRAColorTheme.Register);
|
||||
RegisterUnit('BGRACustomDrawn', @BGRACustomDrawn.Register);
|
||||
RegisterUnit('BGRAFlashProgressBar', @BGRAFlashProgressBar.Register);
|
||||
RegisterUnit('BGRAGraphicControl', @BGRAGraphicControl.Register);
|
||||
RegisterUnit('BGRAImageList', @BGRAImageList.Register);
|
||||
RegisterUnit('BGRAImageManipulation', @BGRAImageManipulation.Register);
|
||||
RegisterUnit('BGRAImageTheme', @BGRAImageTheme.Register);
|
||||
RegisterUnit('BGRAKnob', @BGRAKnob.Register);
|
||||
RegisterUnit('BGRAResizeSpeedButton', @BGRAResizeSpeedButton.Register);
|
||||
RegisterUnit('BGRAShape', @BGRAShape.Register);
|
||||
RegisterUnit('BGRASpeedButton', @BGRASpeedButton.Register);
|
||||
RegisterUnit('BGRASpriteAnimation', @BGRASpriteAnimation.Register);
|
||||
RegisterUnit('BGRASVGImageList', @BGRASVGImageList.Register);
|
||||
RegisterUnit('BGRASVGTheme', @BGRASVGTheme.Register);
|
||||
RegisterUnit('BGRATheme', @BGRATheme.Register);
|
||||
RegisterUnit('BGRAThemeButton', @BGRAThemeButton.Register);
|
||||
RegisterUnit('BGRAThemeCheckBox', @BGRAThemeCheckBox.Register);
|
||||
RegisterUnit('BGRAThemeRadioButton', @BGRAThemeRadioButton.Register);
|
||||
RegisterUnit('BGRAVirtualScreen', @BGRAVirtualScreen.Register);
|
||||
RegisterUnit('ColorSpeedButton', @ColorSpeedButton.Register);
|
||||
RegisterUnit('DTAnalogClock', @DTAnalogClock.Register);
|
||||
RegisterUnit('DTAnalogGauge', @DTAnalogGauge.Register);
|
||||
RegisterUnit('dtthemedclock', @dtthemedclock.Register);
|
||||
RegisterUnit('dtthemedgauge', @dtthemedgauge.Register);
|
||||
RegisterUnit('BCExpandPanels', @BCExpandPanels.Register);
|
||||
end;
|
||||
|
||||
initialization
|
||||
RegisterPackage('bgracontrols', @Register);
|
||||
end.
|
||||
37
bgracontrols/bgracontrolsinfo.pas
Normal file
37
bgracontrols/bgracontrolsinfo.pas
Normal file
@@ -0,0 +1,37 @@
|
||||
// SPDX-License-Identifier: LGPL-3.0-linking-exception
|
||||
unit bgracontrolsinfo;
|
||||
|
||||
{$mode objfpc}{$H+}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils;
|
||||
|
||||
const
|
||||
BGRAControlsVersion = 9000000;
|
||||
|
||||
function BGRAControlsVersionStr: string;
|
||||
|
||||
implementation
|
||||
|
||||
function BGRAControlsVersionStr: string;
|
||||
var numbers: TStringList;
|
||||
i,remaining: cardinal;
|
||||
begin
|
||||
numbers := TStringList.Create;
|
||||
remaining := BGRAControlsVersion;
|
||||
for i := 1 to 4 do
|
||||
begin
|
||||
numbers.Insert(0, IntToStr(remaining mod 100));
|
||||
remaining := remaining div 100;
|
||||
end;
|
||||
while (numbers.Count > 1) and (numbers[numbers.Count-1]='0') do
|
||||
numbers.Delete(numbers.Count-1);
|
||||
numbers.Delimiter:= '.';
|
||||
result := numbers.DelimitedText;
|
||||
numbers.Free;
|
||||
end;
|
||||
|
||||
end.
|
||||
|
||||
1025
bgracontrols/bgracustomdrawn.pas
Normal file
1025
bgracontrols/bgracustomdrawn.pas
Normal file
File diff suppressed because it is too large
Load Diff
226
bgracontrols/bgradrawerflashprogressbar.pas
Normal file
226
bgracontrols/bgradrawerflashprogressbar.pas
Normal file
@@ -0,0 +1,226 @@
|
||||
unit BGRADrawerFlashProgressBar;
|
||||
|
||||
{$mode objfpc}{$H+}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, {$IFDEF BGRABITMAP_USE_MSEGUI} mclasses, {$ENDIF} SysUtils, Types, BGRABitmap, BGRABitmapTypes, BGRAGraphics, BGRAGradients,
|
||||
Math;
|
||||
|
||||
type
|
||||
|
||||
TBGRAProgressBarRedrawEvent = procedure(Sender: TObject; Bitmap: TBGRABitmap; xpos: integer) of object;
|
||||
|
||||
{ TBGRADrawerFlashProgressBar }
|
||||
|
||||
TBGRADrawerFlashProgressBar = class(TPersistent)
|
||||
private
|
||||
FBackgroundColor: TColor;
|
||||
FBackgroundRandomize: boolean;
|
||||
FBackgroundRandomizeMaxIntensity: word;
|
||||
FBackgroundRandomizeMinIntensity: word;
|
||||
FBarColor: TColor;
|
||||
FMaxValue: integer;
|
||||
FMinValue: integer;
|
||||
FOnChange: TNotifyEvent;
|
||||
FRandSeed: integer;
|
||||
FValue: integer;
|
||||
xpos: integer;
|
||||
procedure SetBackgroundRandomize(AValue: boolean);
|
||||
procedure SetBackgroundRandomizeMaxIntensity(AValue: word);
|
||||
procedure SetBackgroundRandomizeMinIntensity(AValue: word);
|
||||
procedure SetBarColor(AValue: TColor);
|
||||
procedure SetBackgroundColor(AValue: TColor);
|
||||
procedure SetMaxValue(AValue: integer);
|
||||
procedure SetMinValue(AValue: integer);
|
||||
procedure SetRandSeed(AValue: integer);
|
||||
procedure SetValue(AValue: integer);
|
||||
public
|
||||
procedure Draw(ABitmap: TBGRABitmap);
|
||||
public
|
||||
property OnChange: TNotifyEvent read FOnChange write FOnChange;
|
||||
property RandSeed: integer read FRandSeed write SetRandSeed;
|
||||
property BarColor: TColor read FBarColor write SetBarColor;
|
||||
property BackgroundColor: TColor read FBackgroundColor write SetBackgroundColor;
|
||||
property BackgroundRandomizeMinIntensity: word
|
||||
read FBackgroundRandomizeMinIntensity write SetBackgroundRandomizeMinIntensity;
|
||||
property BackgroundRandomizeMaxIntensity: word
|
||||
read FBackgroundRandomizeMaxIntensity write SetBackgroundRandomizeMaxIntensity;
|
||||
property BackgroundRandomize: boolean read FBackgroundRandomize
|
||||
write SetBackgroundRandomize;
|
||||
property XPosition: integer read xpos;
|
||||
public
|
||||
property MinValue: integer read FMinValue write SetMinValue;
|
||||
property MaxValue: integer read FMaxValue write SetMaxValue;
|
||||
property Value: integer read FValue write SetValue;
|
||||
end;
|
||||
|
||||
implementation
|
||||
|
||||
{ TBGRADrawerFlashProgressBar }
|
||||
|
||||
procedure TBGRADrawerFlashProgressBar.SetBarColor(AValue: TColor);
|
||||
begin
|
||||
if FBarColor = AValue then
|
||||
Exit;
|
||||
FBarColor := AValue;
|
||||
if Assigned(FOnChange) then
|
||||
FOnChange(Self);
|
||||
if Assigned(FOnChange) then
|
||||
FOnChange(Self);
|
||||
end;
|
||||
|
||||
procedure TBGRADrawerFlashProgressBar.SetBackgroundRandomize(AValue: boolean);
|
||||
begin
|
||||
if FBackgroundRandomize = AValue then
|
||||
Exit;
|
||||
FBackgroundRandomize := AValue;
|
||||
if Assigned(FOnChange) then
|
||||
FOnChange(Self);
|
||||
end;
|
||||
|
||||
procedure TBGRADrawerFlashProgressBar.SetBackgroundRandomizeMaxIntensity(AValue: word);
|
||||
begin
|
||||
if FBackgroundRandomizeMaxIntensity = AValue then
|
||||
Exit;
|
||||
FBackgroundRandomizeMaxIntensity := AValue;
|
||||
if Assigned(FOnChange) then
|
||||
FOnChange(Self);
|
||||
end;
|
||||
|
||||
procedure TBGRADrawerFlashProgressBar.SetBackgroundRandomizeMinIntensity(AValue: word);
|
||||
begin
|
||||
if FBackgroundRandomizeMinIntensity = AValue then
|
||||
Exit;
|
||||
FBackgroundRandomizeMinIntensity := AValue;
|
||||
if Assigned(FOnChange) then
|
||||
FOnChange(Self);
|
||||
end;
|
||||
|
||||
procedure TBGRADrawerFlashProgressBar.SetBackgroundColor(AValue: TColor);
|
||||
begin
|
||||
if FBackgroundColor = AValue then
|
||||
Exit;
|
||||
FBackgroundColor := AValue;
|
||||
if Assigned(FOnChange) then
|
||||
FOnChange(Self);
|
||||
end;
|
||||
|
||||
procedure TBGRADrawerFlashProgressBar.SetMaxValue(AValue: integer);
|
||||
begin
|
||||
if FMaxValue = AValue then
|
||||
exit;
|
||||
FMaxValue := AValue;
|
||||
if FValue > FMaxValue then
|
||||
FValue := FMaxValue;
|
||||
if FMinValue > FMaxValue then
|
||||
FMinValue := FMaxValue;
|
||||
if Assigned(FOnChange) then
|
||||
FOnChange(Self);
|
||||
end;
|
||||
|
||||
procedure TBGRADrawerFlashProgressBar.SetMinValue(AValue: integer);
|
||||
begin
|
||||
if FMinValue = AValue then
|
||||
exit;
|
||||
FMinValue := AValue;
|
||||
if FValue < FMinValue then
|
||||
FValue := FMinValue;
|
||||
if FMaxValue < FMinValue then
|
||||
FMaxValue := FMinValue;
|
||||
if Assigned(FOnChange) then
|
||||
FOnChange(Self);
|
||||
end;
|
||||
|
||||
procedure TBGRADrawerFlashProgressBar.SetRandSeed(AValue: integer);
|
||||
begin
|
||||
if FRandSeed = AValue then
|
||||
Exit;
|
||||
FRandSeed := AValue;
|
||||
end;
|
||||
|
||||
procedure TBGRADrawerFlashProgressBar.SetValue(AValue: integer);
|
||||
begin
|
||||
if FValue = AValue then
|
||||
exit;
|
||||
FValue := AValue;
|
||||
if FValue < FMinValue then
|
||||
FValue := FMinValue;
|
||||
if FValue > FMaxValue then
|
||||
FValue := FMaxValue;
|
||||
if Assigned(FOnChange) then
|
||||
FOnChange(Self);
|
||||
end;
|
||||
|
||||
procedure TBGRADrawerFlashProgressBar.Draw(ABitmap: TBGRABitmap);
|
||||
var
|
||||
content: TRect;
|
||||
y, tx, ty: integer;
|
||||
bgColor: TBGRAPixel;
|
||||
|
||||
function ApplyLightness(c: TBGRAPixel; lightness: word): TBGRAPixel;
|
||||
begin
|
||||
Result := GammaCompression(SetLightness(GammaExpansion(c), lightness));
|
||||
end;
|
||||
|
||||
procedure DrawBar(bounds: TRect);
|
||||
var
|
||||
lCol: TBGRAPixel;
|
||||
begin
|
||||
lCol := BarColor;
|
||||
|
||||
DoubleGradientAlphaFill(ABitmap, bounds,
|
||||
ApplyLightness(lCol, 37000), ApplyLightness(lCol, 29000),
|
||||
ApplyLightness(lCol, 26000), ApplyLightness(lCol, 18000),
|
||||
gdVertical, gdVertical, gdVertical, 0.53);
|
||||
|
||||
InflateRect(bounds, -1, -1);
|
||||
|
||||
DoubleGradientAlphaFill(ABitmap, bounds,
|
||||
ApplyLightness(lCol, 28000), ApplyLightness(lCol, 22000),
|
||||
ApplyLightness(lCol, 19000), ApplyLightness(lCol, 11000),
|
||||
gdVertical, gdVertical, gdVertical, 0.53);
|
||||
end;
|
||||
|
||||
begin
|
||||
ABitmap.FillTransparent;
|
||||
tx := ABitmap.Width;
|
||||
ty := ABitmap.Height;
|
||||
|
||||
ABitmap.Rectangle(0, 0, tx, ty, BGRA(255, 255, 255, 6), BackgroundColor, dmSet);
|
||||
if (tx > 2) and (ty > 2) then
|
||||
ABitmap.Rectangle(1, 1, tx - 1, ty - 1, BGRA(29, 29, 29), dmSet);
|
||||
|
||||
if (tx > 4) and (ty > 4) then
|
||||
begin
|
||||
content := Rect(2, 2, tx - 2, ty - 2);
|
||||
randseed := FRandSeed;
|
||||
if BackgroundRandomize then
|
||||
for y := content.Top to content.Bottom - 1 do
|
||||
begin
|
||||
bgColor := BackgroundColor;
|
||||
bgColor.Intensity := RandomRange(BackgroundRandomizeMinIntensity, BackgroundRandomizeMaxIntensity);
|
||||
ABitmap.HorizLine(content.Left, y, content.Right - 1, bgColor, dmSet);
|
||||
end;
|
||||
if tx >= 6 then
|
||||
ABitmap.DrawVertLine(content.Right - 1, content.Top, content.Bottom - 1,
|
||||
BGRA(0, 0, 0, 32));
|
||||
if FMaxValue > FMinValue then
|
||||
begin
|
||||
xpos := round((FValue - FMinValue) / (FMaxValue - FMinValue) *
|
||||
(content.right - content.left)) + content.left;
|
||||
if xpos > content.left then
|
||||
begin
|
||||
DrawBar(rect(content.left, content.top, xpos, content.bottom));
|
||||
if xpos < content.right then
|
||||
begin
|
||||
ABitmap.SetPixel(xpos, content.top, BGRA(62, 62, 62));
|
||||
ABitmap.SetVertLine(xpos, content.top + 1, content.bottom - 1, BGRA(40, 40, 40));
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
end.
|
||||
286
bgracontrols/bgraflashprogressbar.pas
Normal file
286
bgracontrols/bgraflashprogressbar.pas
Normal file
@@ -0,0 +1,286 @@
|
||||
// SPDX-License-Identifier: LGPL-3.0-linking-exception
|
||||
{
|
||||
Created by BGRA Controls Team
|
||||
Dibo, Circular, lainz (007) and contributors.
|
||||
For detailed information see readme.txt
|
||||
|
||||
Site: https://sourceforge.net/p/bgra-controls/
|
||||
Wiki: http://wiki.lazarus.freepascal.org/BGRAControls
|
||||
Forum: http://forum.lazarus.freepascal.org/index.php/board,46.0.html
|
||||
}
|
||||
{******************************* CONTRIBUTOR(S) ******************************
|
||||
- Edivando S. Santos Brasil | mailedivando@gmail.com
|
||||
(Compatibility with delphi VCL 11/2018)
|
||||
|
||||
***************************** END CONTRIBUTOR(S) *****************************}
|
||||
unit BGRAFlashProgressBar;
|
||||
|
||||
{$I bgracontrols.inc}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils, {$IFDEF FPC}LResources, LMessages,{$ENDIF} Forms, Controls, Graphics,
|
||||
{$IFNDEF FPC}Messages, Windows, BGRAGraphics, GraphType, FPImage, {$ENDIF}
|
||||
BCBaseCtrls, Dialogs, BGRABitmap, BGRADrawerFlashProgressBar;
|
||||
|
||||
type
|
||||
{ TBGRAFlashProgressBar }
|
||||
|
||||
TBGRAFlashProgressBar = class(TBGRAGraphicCtrl)
|
||||
private
|
||||
FBGRA: TBGRABitmap;
|
||||
FDrawer: TBGRADrawerFlashProgressBar;
|
||||
FOnRedraw: TBGRAProgressBarRedrawEvent;
|
||||
function GetBackgroundColor: TColor;
|
||||
function GetBackgroundRandomize: boolean;
|
||||
function GetBackgroundRandomizeMaxIntensity: word;
|
||||
function GetBackgroundRandomizeMinIntensity: word;
|
||||
function GetBarColor: TColor;
|
||||
function GetMaxValue: integer;
|
||||
function GetMinValue: integer;
|
||||
function GetValue: integer;
|
||||
procedure OnChangeDrawer(Sender: TObject);
|
||||
procedure SetBackgroundColor(AValue: TColor);
|
||||
procedure SetBackgroundRandomize(AValue: boolean);
|
||||
procedure SetBackgroundRandomizeMaxIntensity(AValue: word);
|
||||
procedure SetBackgroundRandomizeMinIntensity(AValue: word);
|
||||
procedure SetBarColor(AValue: TColor);
|
||||
procedure SetMaxValue(const AValue: integer);
|
||||
procedure SetMinValue(const AValue: integer);
|
||||
procedure SetValue(const AValue: integer);
|
||||
protected
|
||||
procedure CalculatePreferredSize(var PreferredWidth, PreferredHeight: integer;
|
||||
WithThemeSpace: boolean); override;
|
||||
procedure WMEraseBkgnd(var Message: {$IFDEF FPC}TLMEraseBkgnd{$ELSE}TWMEraseBkgnd{$ENDIF}); message {$IFDEF FPC}LM_ERASEBKGND{$ELSE}WM_ERASEBKGND{$ENDIF};
|
||||
procedure Paint; override;
|
||||
public
|
||||
constructor Create(AOwner: TComponent); override;
|
||||
destructor Destroy; override;
|
||||
public
|
||||
{ Streaming }
|
||||
{$IFDEF FPC}
|
||||
procedure SaveToFile(AFileName: string);
|
||||
procedure LoadFromFile(AFileName: string);
|
||||
procedure OnFindClass({%H-}Reader: TReader; const AClassName: string;
|
||||
var ComponentClass: TComponentClass);
|
||||
{$ENDIF}
|
||||
published
|
||||
property Align;
|
||||
property Anchors;
|
||||
property OnClick;
|
||||
property OnMouseDown;
|
||||
property OnMouseEnter;
|
||||
property OnMouseLeave;
|
||||
property OnMouseMove;
|
||||
property OnMouseUp;
|
||||
property OnMouseWheel;
|
||||
property OnMouseWheelUp;
|
||||
property OnMouseWheelDown;
|
||||
property MinValue: integer Read GetMinValue Write SetMinValue;
|
||||
property MaxValue: integer Read GetMaxValue Write SetMaxValue;
|
||||
property Value: integer Read GetValue Write SetValue;
|
||||
property Color; deprecated 'User BarColor instead';
|
||||
property BarColor: TColor read GetBarColor write SetBarColor;
|
||||
property BackgroundColor: TColor read GetBackgroundColor write SetBackgroundColor;
|
||||
property BackgroundRandomizeMinIntensity: word read GetBackgroundRandomizeMinIntensity write SetBackgroundRandomizeMinIntensity;
|
||||
property BackgroundRandomizeMaxIntensity: word read GetBackgroundRandomizeMaxIntensity write SetBackgroundRandomizeMaxIntensity;
|
||||
property BackgroundRandomize: boolean read GetBackgroundRandomize write SetBackgroundRandomize;
|
||||
property OnRedraw: TBGRAProgressBarRedrawEvent read FOnredraw write FOnRedraw;
|
||||
end;
|
||||
|
||||
{$IFDEF FPC}procedure Register;{$ENDIF}
|
||||
|
||||
implementation
|
||||
|
||||
uses BGRABitmapTypes;
|
||||
|
||||
{$IFDEF FPC}
|
||||
procedure Register;
|
||||
begin
|
||||
RegisterComponents('BGRA Controls', [TBGRAFlashProgressBar]);
|
||||
end;
|
||||
{$ENDIF}
|
||||
|
||||
procedure TBGRAFlashProgressBar.SetMinValue(const AValue: integer);
|
||||
begin
|
||||
FDrawer.MinValue := AValue;
|
||||
end;
|
||||
|
||||
procedure TBGRAFlashProgressBar.SetValue(const AValue: integer);
|
||||
begin
|
||||
FDrawer.Value := AValue;
|
||||
end;
|
||||
|
||||
{$hints off}
|
||||
procedure TBGRAFlashProgressBar.CalculatePreferredSize(
|
||||
var PreferredWidth, PreferredHeight: integer; WithThemeSpace: boolean);
|
||||
begin
|
||||
PreferredWidth := 379;
|
||||
PreferredHeight := 33;
|
||||
end;
|
||||
|
||||
{$hints on}
|
||||
|
||||
procedure TBGRAFlashProgressBar.Paint;
|
||||
begin
|
||||
if (ClientWidth <> FBGRA.Width) or (ClientHeight <> FBGRA.Height) then
|
||||
FBGRA.SetSize(ClientWidth, ClientHeight);
|
||||
FDrawer.Draw(FBGRA);
|
||||
if Assigned(OnRedraw) then
|
||||
OnRedraw(Self, FBGRA, {%H-}FDrawer.XPosition);
|
||||
FBGRA.Draw(Canvas, 0, 0, False);
|
||||
end;
|
||||
|
||||
{$hints off}
|
||||
procedure TBGRAFlashProgressBar.WMEraseBkgnd(var Message: {$IFDEF FPC}TLMEraseBkgnd{$ELSE}TWMEraseBkgnd{$ENDIF});
|
||||
begin
|
||||
//do nothing
|
||||
end;
|
||||
{$hints on}
|
||||
|
||||
constructor TBGRAFlashProgressBar.Create(AOwner: TComponent);
|
||||
begin
|
||||
inherited Create(AOwner);
|
||||
|
||||
with GetControlClassDefaultSize do
|
||||
SetInitialBounds(0, 0, CX, 33);
|
||||
|
||||
// Bitmap and Drawer
|
||||
FBGRA := TBGRABitmap.Create(Width, Height);
|
||||
FDrawer := TBGRADrawerFlashProgressBar.Create;
|
||||
FDrawer.OnChange := OnChangeDrawer;
|
||||
// Functionality
|
||||
MinValue := 0;
|
||||
MaxValue := 100;
|
||||
Value := 30;
|
||||
// Functionality and Style
|
||||
Randomize;
|
||||
FDrawer.RandSeed := RandSeed;
|
||||
// Style
|
||||
BarColor := BGRA(102, 163, 226);
|
||||
BackgroundColor := BGRA(47,47,47);
|
||||
BackgroundRandomize := True;
|
||||
BackgroundRandomizeMinIntensity := 4000;
|
||||
BackgroundRandomizeMaxIntensity := 5000;
|
||||
end;
|
||||
|
||||
destructor TBGRAFlashProgressBar.Destroy;
|
||||
begin
|
||||
FreeAndNil(FBGRA);
|
||||
FDrawer.Free;
|
||||
inherited Destroy;
|
||||
end;
|
||||
{$IFDEF FPC}
|
||||
procedure TBGRAFlashProgressBar.SaveToFile(AFileName: string);
|
||||
var
|
||||
AStream: TMemoryStream;
|
||||
begin
|
||||
AStream := TMemoryStream.Create;
|
||||
try
|
||||
WriteComponentAsTextToStream(AStream, Self);
|
||||
AStream.SaveToFile(AFileName);
|
||||
finally
|
||||
AStream.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TBGRAFlashProgressBar.LoadFromFile(AFileName: string);
|
||||
var
|
||||
AStream: TMemoryStream;
|
||||
begin
|
||||
AStream := TMemoryStream.Create;
|
||||
try
|
||||
AStream.LoadFromFile(AFileName);
|
||||
ReadComponentFromTextStream(AStream, TComponent(Self), OnFindClass);
|
||||
finally
|
||||
AStream.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TBGRAFlashProgressBar.OnFindClass(Reader: TReader;
|
||||
const AClassName: string; var ComponentClass: TComponentClass);
|
||||
begin
|
||||
if CompareText(AClassName, 'TBGRAFlashProgressBar') = 0 then
|
||||
ComponentClass := TBGRAFlashProgressBar;
|
||||
end;
|
||||
{$ENDIF}
|
||||
|
||||
procedure TBGRAFlashProgressBar.SetMaxValue(const AValue: integer);
|
||||
begin
|
||||
FDrawer.MaxValue := AValue;
|
||||
end;
|
||||
|
||||
procedure TBGRAFlashProgressBar.OnChangeDrawer(Sender: TObject);
|
||||
begin
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
function TBGRAFlashProgressBar.GetBackgroundColor: TColor;
|
||||
begin
|
||||
Result := FDrawer.BackgroundColor;
|
||||
end;
|
||||
|
||||
function TBGRAFlashProgressBar.GetBackgroundRandomize: boolean;
|
||||
begin
|
||||
Result := FDrawer.BackgroundRandomize;
|
||||
end;
|
||||
|
||||
function TBGRAFlashProgressBar.GetBackgroundRandomizeMaxIntensity: word;
|
||||
begin
|
||||
Result := FDrawer.BackgroundRandomizeMaxIntensity;
|
||||
end;
|
||||
|
||||
function TBGRAFlashProgressBar.GetBackgroundRandomizeMinIntensity: word;
|
||||
begin
|
||||
Result := FDrawer.BackgroundRandomizeMinIntensity;
|
||||
end;
|
||||
|
||||
function TBGRAFlashProgressBar.GetBarColor: TColor;
|
||||
begin
|
||||
Result := FDrawer.BarColor;
|
||||
end;
|
||||
|
||||
function TBGRAFlashProgressBar.GetMaxValue: integer;
|
||||
begin
|
||||
Result := FDrawer.MaxValue;
|
||||
end;
|
||||
|
||||
function TBGRAFlashProgressBar.GetMinValue: integer;
|
||||
begin
|
||||
Result := FDrawer.MinValue;
|
||||
end;
|
||||
|
||||
function TBGRAFlashProgressBar.GetValue: integer;
|
||||
begin
|
||||
Result := FDrawer.Value;
|
||||
end;
|
||||
|
||||
procedure TBGRAFlashProgressBar.SetBackgroundColor(AValue: TColor);
|
||||
begin
|
||||
FDrawer.BackgroundColor := AValue;
|
||||
end;
|
||||
|
||||
procedure TBGRAFlashProgressBar.SetBackgroundRandomize(AValue: boolean);
|
||||
begin
|
||||
FDrawer.BackgroundRandomize := AValue;
|
||||
end;
|
||||
|
||||
procedure TBGRAFlashProgressBar.SetBackgroundRandomizeMaxIntensity(AValue: word
|
||||
);
|
||||
begin
|
||||
FDrawer.BackgroundRandomizeMaxIntensity := AValue;
|
||||
end;
|
||||
|
||||
procedure TBGRAFlashProgressBar.SetBackgroundRandomizeMinIntensity(AValue: word
|
||||
);
|
||||
begin
|
||||
FDrawer.BackgroundRandomizeMinIntensity := AValue;
|
||||
end;
|
||||
|
||||
procedure TBGRAFlashProgressBar.SetBarColor(AValue: TColor);
|
||||
begin
|
||||
FDrawer.BarColor := AValue;
|
||||
end;
|
||||
|
||||
end.
|
||||
341
bgracontrols/bgragraphiccontrol.pas
Normal file
341
bgracontrols/bgragraphiccontrol.pas
Normal file
@@ -0,0 +1,341 @@
|
||||
// SPDX-License-Identifier: LGPL-3.0-linking-exception
|
||||
{
|
||||
Created by BGRA Controls Team
|
||||
Dibo, Circular, lainz (007) and contributors.
|
||||
For detailed information see readme.txt
|
||||
|
||||
Site: https://sourceforge.net/p/bgra-controls/
|
||||
Wiki: http://wiki.lazarus.freepascal.org/BGRAControls
|
||||
Forum: http://forum.lazarus.freepascal.org/index.php/board,46.0.html
|
||||
}
|
||||
{******************************* CONTRIBUTOR(S) ******************************
|
||||
- Edivando S. Santos Brasil | mailedivando@gmail.com
|
||||
(Compatibility with delphi VCL 11/2018)
|
||||
|
||||
***************************** END CONTRIBUTOR(S) *****************************}
|
||||
unit BGRAGraphicControl;
|
||||
|
||||
{$I bgracontrols.inc}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils, {$IFDEF FPC}LResources,{$ENDIF} Forms, Controls, Graphics, Dialogs, Types,
|
||||
{$IFNDEF FPC}BGRAGraphics, GraphType, FPImage, {$ENDIF}
|
||||
BCBaseCtrls, ExtCtrls, BGRABitmap, BCTypes;
|
||||
|
||||
type
|
||||
|
||||
{ TCustomBGRAGraphicControl }
|
||||
|
||||
TCustomBGRAGraphicControl = class(TBGRAGraphicCtrl)
|
||||
private
|
||||
{ Private declarations }
|
||||
FOnRedraw: TBGRARedrawEvent;
|
||||
FBevelInner, FBevelOuter: TPanelBevel;
|
||||
FBevelWidth: TBevelWidth;
|
||||
FBorderWidth: TBorderWidth;
|
||||
FAlignment: TAlignment;
|
||||
FColorOpacity: byte;
|
||||
function GetBitmapHeight: integer;
|
||||
function GetBitmapScale: double;
|
||||
function GetBitmapWidth: integer;
|
||||
procedure SetAlignment(const Value: TAlignment);
|
||||
procedure SetBevelInner(const AValue: TPanelBevel);
|
||||
procedure SetBevelOuter(const AValue: TPanelBevel);
|
||||
procedure SetBevelWidth(const AValue: TBevelWidth);
|
||||
procedure SetBitmapAutoScale(AValue: boolean);
|
||||
procedure SetBorderWidth(const AValue: TBorderWidth);
|
||||
procedure SetColorOpacity(const AValue: byte);
|
||||
protected
|
||||
{ Protected declarations }
|
||||
FBGRA: TBGRABitmap;
|
||||
FBitmapAutoScale: boolean;
|
||||
procedure Paint; override;
|
||||
procedure Resize; override;
|
||||
procedure BGRASetSize(AWidth, AHeight: integer); virtual;
|
||||
procedure RedrawBitmapContent; virtual;
|
||||
procedure SetColor(Value: TColor); override;
|
||||
procedure SetEnabled(Value: boolean); override;
|
||||
procedure TextChanged; override;
|
||||
property BitmapAutoScale: boolean read FBitmapAutoScale write SetBitmapAutoScale default true;
|
||||
property BitmapScale: double read GetBitmapScale;
|
||||
property BitmapWidth: integer read GetBitmapWidth;
|
||||
property BitmapHeight: integer read GetBitmapHeight;
|
||||
public
|
||||
{ Public declarations }
|
||||
constructor Create(TheOwner: TComponent); override;
|
||||
procedure RedrawBitmap;
|
||||
procedure DiscardBitmap;
|
||||
destructor Destroy; override;
|
||||
property OnRedraw: TBGRARedrawEvent Read FOnRedraw Write FOnRedraw;
|
||||
property Bitmap: TBGRABitmap Read FBGRA;
|
||||
property BorderWidth: TBorderWidth Read FBorderWidth Write SetBorderWidth default 0;
|
||||
property BevelInner: TPanelBevel Read FBevelInner Write SetBevelInner default bvNone;
|
||||
property BevelOuter: TPanelBevel
|
||||
Read FBevelOuter Write SetBevelOuter default bvRaised;
|
||||
property BevelWidth: TBevelWidth Read FBevelWidth Write SetBevelWidth default 1;
|
||||
property ColorOpacity: byte Read FColorOpacity Write SetColorOpacity;
|
||||
property Alignment: TAlignment Read FAlignment Write SetAlignment;
|
||||
end;
|
||||
|
||||
TBGRAGraphicControl = class(TCustomBGRAGraphicControl)
|
||||
published
|
||||
{ Published declarations }
|
||||
property Align;
|
||||
property Anchors;
|
||||
property OnRedraw;
|
||||
property Bitmap;
|
||||
property BitmapAutoscale;
|
||||
property BitmapScale;
|
||||
property BorderWidth;
|
||||
property BevelInner;
|
||||
property BevelOuter;
|
||||
property BevelWidth;
|
||||
property Color;
|
||||
property ColorOpacity;
|
||||
property Alignment;
|
||||
property OnClick;
|
||||
property OnDblClick;
|
||||
property OnMouseDown;
|
||||
property OnMouseEnter;
|
||||
property OnMouseLeave;
|
||||
property OnMouseMove;
|
||||
property OnMouseUp;
|
||||
{$IFDEF FPC}
|
||||
property OnPaint;
|
||||
{$ENDIF}
|
||||
property Caption;
|
||||
end;
|
||||
|
||||
{$IFDEF FPC}procedure Register;{$ENDIF}
|
||||
|
||||
implementation
|
||||
|
||||
uses BGRABitmapTypes, LazVersion;
|
||||
|
||||
{$IFDEF FPC}
|
||||
procedure Register;
|
||||
begin
|
||||
RegisterComponents('BGRA Controls', [TBGRAGraphicControl]);
|
||||
end;
|
||||
{$ENDIF}
|
||||
|
||||
procedure TCustomBGRAGraphicControl.SetAlignment(const Value: TAlignment);
|
||||
begin
|
||||
if FAlignment = Value then
|
||||
exit;
|
||||
FAlignment := Value;
|
||||
DiscardBitmap;
|
||||
end;
|
||||
|
||||
function TCustomBGRAGraphicControl.GetBitmapHeight: integer;
|
||||
begin
|
||||
result := round(ClientHeight * BitmapScale);
|
||||
end;
|
||||
|
||||
function TCustomBGRAGraphicControl.GetBitmapScale: double;
|
||||
begin
|
||||
{$if laz_fullversion >= 2000000}
|
||||
if not FBitmapAutoScale then
|
||||
result := GetCanvasScaleFactor
|
||||
else
|
||||
result := 1;
|
||||
{$else}
|
||||
result := 1;
|
||||
{$endif}
|
||||
end;
|
||||
|
||||
function TCustomBGRAGraphicControl.GetBitmapWidth: integer;
|
||||
begin
|
||||
result := round(ClientWidth * BitmapScale);
|
||||
end;
|
||||
|
||||
procedure TCustomBGRAGraphicControl.SetBevelInner(const AValue: TPanelBevel);
|
||||
begin
|
||||
if FBevelInner = AValue then
|
||||
exit;
|
||||
FBevelInner := AValue;
|
||||
DiscardBitmap;
|
||||
end;
|
||||
|
||||
procedure TCustomBGRAGraphicControl.SetBevelOuter(const AValue: TPanelBevel);
|
||||
begin
|
||||
if FBevelOuter = AValue then
|
||||
exit;
|
||||
FBevelOuter := AValue;
|
||||
DiscardBitmap;
|
||||
end;
|
||||
|
||||
procedure TCustomBGRAGraphicControl.SetBevelWidth(const AValue: TBevelWidth);
|
||||
begin
|
||||
if FBevelWidth = AValue then
|
||||
exit;
|
||||
FBevelWidth := AValue;
|
||||
DiscardBitmap;
|
||||
end;
|
||||
|
||||
procedure TCustomBGRAGraphicControl.SetBitmapAutoScale(AValue: boolean);
|
||||
begin
|
||||
if FBitmapAutoScale=AValue then Exit;
|
||||
FBitmapAutoScale:=AValue;
|
||||
DiscardBitmap;
|
||||
end;
|
||||
|
||||
procedure TCustomBGRAGraphicControl.SetBorderWidth(const AValue: TBorderWidth);
|
||||
begin
|
||||
if FBorderWidth = AValue then
|
||||
exit;
|
||||
FBorderWidth := AValue;
|
||||
DiscardBitmap;
|
||||
end;
|
||||
|
||||
procedure TCustomBGRAGraphicControl.SetColorOpacity(const AValue: byte);
|
||||
begin
|
||||
if FColorOpacity = AValue then
|
||||
exit;
|
||||
FColorOpacity := AValue;
|
||||
DiscardBitmap;
|
||||
end;
|
||||
|
||||
procedure TCustomBGRAGraphicControl.Paint;
|
||||
begin
|
||||
BGRASetSize(BitmapWidth, BitmapHeight);
|
||||
inherited Paint;
|
||||
FBGRA.Draw(Canvas, rect(0, 0, ClientWidth, ClientHeight), False);
|
||||
end;
|
||||
|
||||
procedure TCustomBGRAGraphicControl.Resize;
|
||||
begin
|
||||
inherited Resize;
|
||||
DiscardBitmap;
|
||||
end;
|
||||
|
||||
procedure TCustomBGRAGraphicControl.BGRASetSize(AWidth, AHeight: integer);
|
||||
begin
|
||||
if (FBGRA <> nil) and (AWidth <> FBGRA.Width) and (AHeight <> FBGRA.Height) then
|
||||
begin
|
||||
FBGRA.SetSize(AWidth, AHeight);
|
||||
RedrawBitmapContent;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TCustomBGRAGraphicControl.RedrawBitmapContent;
|
||||
var
|
||||
ARect: TRect;
|
||||
TS: TTextStyle;
|
||||
scale: Double;
|
||||
begin
|
||||
if (FBGRA <> nil) and (FBGRA.NbPixels <> 0) then
|
||||
begin
|
||||
FBGRA.Fill(ColorToBGRA(ColorToRGB(Color), FColorOpacity));
|
||||
|
||||
scale := BitmapScale;
|
||||
ARect := GetClientRect;
|
||||
ARect.Left := round(ARect.Left*scale);
|
||||
ARect.Top := round(ARect.Top*scale);
|
||||
ARect.Right := round(ARect.Right*scale);
|
||||
ARect.Bottom := round(ARect.Bottom*scale);
|
||||
|
||||
// if BevelOuter is set then draw a frame with BevelWidth
|
||||
if (BevelOuter <> bvNone) and (BevelWidth > 0) then
|
||||
FBGRA.CanvasBGRA.Frame3d(ARect, round(BevelWidth*scale), BevelOuter,
|
||||
BGRA(255, 255, 255, 200), BGRA(0, 0, 0, 160)); // Note: Frame3D inflates ARect
|
||||
|
||||
InflateRect(ARect, -round(BorderWidth*scale), -round(BorderWidth*scale));
|
||||
|
||||
// if BevelInner is set then skip the BorderWidth and draw a frame with BevelWidth
|
||||
if (BevelInner <> bvNone) and (BevelWidth > 0) then
|
||||
FBGRA.CanvasBGRA.Frame3d(ARect, round(BevelWidth*scale), BevelInner,
|
||||
BGRA(255, 255, 255, 160), BGRA(0, 0, 0, 160)); // Note: Frame3D inflates ARect
|
||||
|
||||
if Caption <> '' then
|
||||
begin
|
||||
FBGRA.CanvasBGRA.Font.Assign(Canvas.Font);
|
||||
FBGRA.CanvasBGRA.Font.Height:= round(FBGRA.CanvasBGRA.Font.Height*scale);
|
||||
{$IFDEF FPC}//#
|
||||
TS := Canvas.TextStyle;
|
||||
{$ENDIF}
|
||||
TS.Alignment := Alignment;
|
||||
TS.Layout := tlCenter;
|
||||
TS.Opaque := False;
|
||||
TS.Clipping := False;
|
||||
{$IFDEF FPC}//#
|
||||
TS.SystemFont := Canvas.Font.IsDefault;
|
||||
{$ENDIF}
|
||||
|
||||
FBGRA.CanvasBGRA.Font.Color := Color xor $FFFFFF;
|
||||
FBGRA.CanvasBGRA.Font.Opacity := 255;
|
||||
|
||||
if not Enabled then
|
||||
FBGRA.CanvasBGRA.Font.Style := [fsStrikeOut]
|
||||
else
|
||||
FBGRA.CanvasBGRA.Font.Style := [];
|
||||
|
||||
FBGRA.CanvasBGRA.TextRect(ARect, ARect.Left, ARect.Top, Caption, TS);
|
||||
end;
|
||||
|
||||
if Assigned(FOnRedraw) then
|
||||
FOnRedraw(self, FBGRA);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TCustomBGRAGraphicControl.SetColor(Value: TColor);
|
||||
begin
|
||||
if Value <> Color then
|
||||
DiscardBitmap;
|
||||
|
||||
inherited SetColor(Value);
|
||||
end;
|
||||
|
||||
procedure TCustomBGRAGraphicControl.SetEnabled(Value: boolean);
|
||||
begin
|
||||
if Value <> Enabled then
|
||||
DiscardBitmap;
|
||||
inherited SetEnabled(Value);
|
||||
end;
|
||||
|
||||
procedure TCustomBGRAGraphicControl.TextChanged;
|
||||
begin
|
||||
DiscardBitmap;
|
||||
end;
|
||||
|
||||
constructor TCustomBGRAGraphicControl.Create(TheOwner: TComponent);
|
||||
begin
|
||||
inherited Create(TheOwner);
|
||||
|
||||
with GetControlClassDefaultSize do
|
||||
SetInitialBounds(0, 0, CX, CY);
|
||||
|
||||
FBGRA := TBGRABitmap.Create;
|
||||
FBitmapAutoScale:= true;
|
||||
FBevelWidth := 1;
|
||||
FAlignment := taCenter;
|
||||
Color := clWhite;
|
||||
FColorOpacity := 128;
|
||||
FBevelOuter := bvRaised;
|
||||
FBevelInner := bvNone;
|
||||
end;
|
||||
|
||||
procedure TCustomBGRAGraphicControl.RedrawBitmap;
|
||||
begin
|
||||
RedrawBitmapContent;
|
||||
Repaint;
|
||||
end;
|
||||
|
||||
procedure TCustomBGRAGraphicControl.DiscardBitmap;
|
||||
begin
|
||||
if (FBGRA <> nil) and (FBGRA.NbPixels <> 0) then
|
||||
begin
|
||||
FBGRA.SetSize(0, 0);
|
||||
Invalidate;
|
||||
end;
|
||||
end;
|
||||
|
||||
destructor TCustomBGRAGraphicControl.Destroy;
|
||||
begin
|
||||
FBGRA.Free;
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
end.
|
||||
125
bgracontrols/bgraimagelist.pas
Normal file
125
bgracontrols/bgraimagelist.pas
Normal file
@@ -0,0 +1,125 @@
|
||||
// SPDX-License-Identifier: LGPL-3.0-linking-exception
|
||||
{ This component partialy solve problem with no alpha in lazarus GTK.
|
||||
It is using BGRABitmap library for drawing icons.
|
||||
|
||||
originally written in 2011 by Krzysztof Dibowski dibowski at interia.pl
|
||||
}
|
||||
{******************************* CONTRIBUTOR(S) ******************************
|
||||
- Edivando S. Santos Brasil | mailedivando@gmail.com
|
||||
(Compatibility with delphi VCL 11/2018)
|
||||
|
||||
***************************** END CONTRIBUTOR(S) *****************************}
|
||||
unit BGRAImageList;
|
||||
|
||||
{$I bgracontrols.inc}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils, {$IFDEF FPC}LResources,{$ENDIF} Forms, Controls, Graphics, Dialogs,
|
||||
GraphType, BGRABitmap, BGRABitmapTypes, {%H-}ImgList;
|
||||
|
||||
{$IFDEF LCLgtk}
|
||||
{ $DEFINE BGRA_DRAW}
|
||||
{$ELSE}
|
||||
{$IFDEF LCLgtk2}
|
||||
{ $DEFINE BGRA_DRAW}
|
||||
{$ENDIF}
|
||||
{$ENDIF}
|
||||
|
||||
type
|
||||
|
||||
{ TBGRAImageList }
|
||||
|
||||
TBGRAImageList = class(TImageList)
|
||||
private
|
||||
{ Private declarations }
|
||||
{$IFDEF BGRA_DRAW}
|
||||
FBGRA: TBGRABitmap;
|
||||
FBmp: TBitmap;
|
||||
{$ENDIF}
|
||||
protected
|
||||
{ Protected declarations }
|
||||
public
|
||||
{ Public declarations }
|
||||
{$IFDEF BGRA_DRAW}
|
||||
constructor Create(AOwner: TComponent); override;
|
||||
destructor Destroy; override;
|
||||
|
||||
procedure Draw(ACanvas: TCanvas; AX, AY, AIndex: integer;
|
||||
ADrawingStyle: TDrawingStyle; AImageType: TImageType;
|
||||
ADrawEffect: TGraphicsDrawEffect); override;
|
||||
{$ENDIF}
|
||||
published
|
||||
{ Published declarations }
|
||||
end;
|
||||
|
||||
{$IFDEF FPC}procedure Register;{$ENDIF}
|
||||
|
||||
implementation
|
||||
|
||||
{$IFDEF FPC}
|
||||
procedure Register;
|
||||
begin
|
||||
RegisterComponents('BGRA Controls', [TBGRAImageList]);
|
||||
end;
|
||||
{$ENDIF}
|
||||
|
||||
{$IFDEF BGRA_DRAW}
|
||||
{ TBGRAImageList }
|
||||
constructor TBGRAImageList.Create(AOwner: TComponent);
|
||||
begin
|
||||
inherited Create(AOwner);
|
||||
FBGRA := TBGRABitmap.Create;
|
||||
FBmp := TBitmap.Create;
|
||||
end;
|
||||
|
||||
destructor TBGRAImageList.Destroy;
|
||||
begin
|
||||
FBGRA.Free;
|
||||
FBmp.Free;
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
{ Problem with no alpha is only on GTK so on Windows we use default drawing }
|
||||
procedure TBGRAImageList.Draw(ACanvas: TCanvas; AX, AY, AIndex: integer;
|
||||
ADrawingStyle: TDrawingStyle; AImageType: TImageType;
|
||||
ADrawEffect: TGraphicsDrawEffect);
|
||||
begin
|
||||
//inherited; - We use TBGRABitmap drawing only
|
||||
|
||||
// This is required part from TImageList.Draw
|
||||
if (AIndex < 0) or (AIndex >= Count) then
|
||||
Exit;
|
||||
ReferenceNeeded;
|
||||
|
||||
{*** BGRA Drawing *** }
|
||||
case ADrawEffect of
|
||||
gdeDisabled:
|
||||
begin
|
||||
{$IFDEF FPC}
|
||||
GetBitmap(AIndex, FBmp, gdeNormal);
|
||||
{$ELSE}
|
||||
GetBitmapRaw(AIndex, FBmp, gdeNormal);
|
||||
{$ENDIF}
|
||||
FBGRA.Assign(FBmp);
|
||||
BGRAReplace(FBGRA, FBGRA.FilterGrayscale);
|
||||
end;
|
||||
else
|
||||
begin
|
||||
{$IFDEF FPC}
|
||||
GetBitmap(AIndex, FBmp, ADrawEffect);
|
||||
{$ELSE}
|
||||
GetBitmapRaw(AIndex, FBmp, ADrawEffect);
|
||||
{$ENDIF}
|
||||
FBGRA.Assign(FBmp);
|
||||
end;
|
||||
end;
|
||||
if ADrawingStyle in [dsFocus, dsSelected] then
|
||||
FBGRA.ApplyGlobalOpacity(128);
|
||||
FBGRA.Draw(ACanvas, AX, AY, False);
|
||||
end;
|
||||
|
||||
{$ENDIF}
|
||||
|
||||
end.
|
||||
4072
bgracontrols/bgraimagemanipulation.pas
Normal file
4072
bgracontrols/bgraimagemanipulation.pas
Normal file
File diff suppressed because it is too large
Load Diff
106
bgracontrols/bgraimagetheme.pas
Normal file
106
bgracontrols/bgraimagetheme.pas
Normal file
@@ -0,0 +1,106 @@
|
||||
// SPDX-License-Identifier: LGPL-3.0-linking-exception
|
||||
unit BGRAImageTheme;
|
||||
|
||||
{$mode objfpc}{$H+}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, BGRATheme,
|
||||
BGRASliceScaling, BGRABitmap, BGRABitmapTypes, BGRASVGImageList;
|
||||
|
||||
type
|
||||
|
||||
{ TBGRAImageTheme }
|
||||
|
||||
TBGRAImageTheme = class(TBGRATheme)
|
||||
private
|
||||
FBackgroundColor: TColor;
|
||||
FSliceScalingButton: TBGRAMultiSliceScaling;
|
||||
procedure SetFBackgroundColor(AValue: TColor);
|
||||
protected
|
||||
|
||||
public
|
||||
constructor Create(AOwner: TComponent); override;
|
||||
destructor Destroy; override;
|
||||
procedure LoadResources(AFileName: string);
|
||||
procedure DrawButton(Caption: string; State: TBGRAThemeButtonState;
|
||||
Focused: boolean; ARect: TRect; ASurface: TBGRAThemeSurface; AImageIndex: Integer = -1; AImageList: TBGRASVGImageList = nil); override;
|
||||
published
|
||||
property BackgroundColor: TColor read FBackgroundColor
|
||||
write SetFBackgroundColor default clForm;
|
||||
end;
|
||||
|
||||
procedure Register;
|
||||
|
||||
implementation
|
||||
|
||||
procedure Register;
|
||||
begin
|
||||
RegisterComponents('BGRA Themes', [TBGRAImageTheme]);
|
||||
end;
|
||||
|
||||
{ TBGRAImageTheme }
|
||||
|
||||
procedure TBGRAImageTheme.SetFBackgroundColor(AValue: TColor);
|
||||
begin
|
||||
if FBackgroundColor = AValue then
|
||||
Exit;
|
||||
FBackgroundColor := AValue;
|
||||
end;
|
||||
|
||||
constructor TBGRAImageTheme.Create(AOwner: TComponent);
|
||||
begin
|
||||
inherited Create(AOwner);
|
||||
BackgroundColor := clForm;
|
||||
end;
|
||||
|
||||
destructor TBGRAImageTheme.Destroy;
|
||||
begin
|
||||
FSliceScalingButton.Free;
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
procedure TBGRAImageTheme.LoadResources(AFileName: string);
|
||||
begin
|
||||
FreeAndNil(FSliceScalingButton);
|
||||
FSliceScalingButton := TBGRAMultiSliceScaling.Create(AFileName, 'Button');
|
||||
end;
|
||||
|
||||
procedure TBGRAImageTheme.DrawButton(Caption: string;
|
||||
State: TBGRAThemeButtonState; Focused: boolean; ARect: TRect;
|
||||
ASurface: TBGRAThemeSurface; AImageIndex: Integer;
|
||||
AImageList: TBGRASVGImageList);
|
||||
var
|
||||
Style: TTextStyle;
|
||||
ImageIndex: integer;
|
||||
begin
|
||||
With ASurface do
|
||||
begin
|
||||
case State of
|
||||
btbsHover: ImageIndex := 1;
|
||||
btbsActive: ImageIndex := 2;
|
||||
btbsDisabled: ImageIndex := 3;
|
||||
else {btbsNormal}
|
||||
ImageIndex := 0;
|
||||
end;
|
||||
|
||||
Bitmap.Fill(BackgroundColor);
|
||||
|
||||
if Assigned(FSliceScalingButton) then
|
||||
FSliceScalingButton.Draw(ImageIndex, Bitmap, 0, 0, Bitmap.Width, Bitmap.Height);
|
||||
|
||||
DrawBitmap;
|
||||
|
||||
if Caption <> '' then
|
||||
begin
|
||||
fillchar(Style, sizeof(Style), 0);
|
||||
Style.Alignment := taCenter;
|
||||
Style.Layout := tlCenter;
|
||||
Style.Wordbreak := True;
|
||||
DestCanvas.TextRect(ARect, 0, 0, Caption, Style);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
end.
|
||||
537
bgracontrols/bgraknob.pas
Normal file
537
bgracontrols/bgraknob.pas
Normal file
@@ -0,0 +1,537 @@
|
||||
// SPDX-License-Identifier: LGPL-3.0-linking-exception
|
||||
{
|
||||
Iintially written by Circular.
|
||||
}
|
||||
{******************************* CONTRIBUTOR(S) ******************************
|
||||
- Edivando S. Santos Brasil | mailedivando@gmail.com
|
||||
(Compatibility with delphi VCL 11/2018)
|
||||
|
||||
***************************** END CONTRIBUTOR(S) *****************************}
|
||||
|
||||
unit BGRAKnob;
|
||||
|
||||
{$I bgracontrols.inc}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils, {$IFDEF FPC}LResources,{$ENDIF} Forms, Controls, Graphics, Dialogs,
|
||||
{$IFNDEF FPC}BGRAGraphics, GraphType, FPImage, {$ENDIF}
|
||||
BCBaseCtrls, BGRAGradients, BGRABitmap, BGRABitmapTypes;
|
||||
|
||||
type
|
||||
TBGRAKnobPositionType = (kptLineSquareCap, kptLineRoundCap, kptFilledCircle,
|
||||
kptHollowCircle);
|
||||
TBGRAKnobValueChangedEvent = procedure(Sender: TObject; Value: single) of object;
|
||||
|
||||
{ TBGRAKnob }
|
||||
|
||||
TBGRAKnob = class(TBGRAGraphicCtrl)
|
||||
private
|
||||
{ Private declarations }
|
||||
FPhong: TPhongShading;
|
||||
FCurveExponent: single;
|
||||
FKnobBmp: TBGRABitmap;
|
||||
FKnobColor: TColor;
|
||||
FAngularPos: single;
|
||||
FPositionColor: TColor;
|
||||
FPositionMargin: single;
|
||||
FPositionOpacity: byte;
|
||||
FPositionType: TBGRAKnobPositionType;
|
||||
FPositionWidth: single;
|
||||
FSettingAngularPos: boolean;
|
||||
FUsePhongLighting: boolean;
|
||||
FMinValue, FMaxValue: single;
|
||||
FOnKnobValueChange: TBGRAKnobValueChangedEvent;
|
||||
FStartFromBottom: boolean;
|
||||
procedure CreateKnobBmp;
|
||||
function GetLightIntensity: integer;
|
||||
function GetValue: single;
|
||||
procedure SetCurveExponent(const AValue: single);
|
||||
procedure SetLightIntensity(const AValue: integer);
|
||||
procedure SetStartFromBottom(const AValue: boolean);
|
||||
procedure SetValue(AValue: single);
|
||||
procedure SetMaxValue(AValue: single);
|
||||
procedure SetMinValue(AValue: single);
|
||||
procedure SetPositionColor(const AValue: TColor);
|
||||
procedure SetPositionMargin(AValue: single);
|
||||
procedure SetPositionOpacity(const AValue: byte);
|
||||
procedure SetPositionType(const AValue: TBGRAKnobPositionType);
|
||||
procedure SetPositionWidth(const AValue: single);
|
||||
procedure SetUsePhongLighting(const AValue: boolean);
|
||||
procedure UpdateAngularPos(X, Y: integer);
|
||||
procedure SetKnobColor(const AValue: TColor);
|
||||
protected
|
||||
{ Protected declarations }
|
||||
procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
|
||||
X, Y: integer); override;
|
||||
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: integer); override;
|
||||
procedure MouseMove(Shift: TShiftState; X, Y: integer); override;
|
||||
procedure Paint; override;
|
||||
procedure Resize; override;
|
||||
function ValueCorrection(var AValue: single): boolean; overload; virtual;
|
||||
function ValueCorrection: boolean; overload; virtual;
|
||||
public
|
||||
{ Public declarations }
|
||||
constructor Create(AOwner: TComponent); override;
|
||||
destructor Destroy; override;
|
||||
public
|
||||
{ Streaming }
|
||||
{$IFDEF FPC}
|
||||
procedure SaveToFile(AFileName: string);
|
||||
procedure LoadFromFile(AFileName: string);
|
||||
{$ENDIF}
|
||||
procedure OnFindClass({%H-}Reader: TReader; const AClassName: string;
|
||||
var ComponentClass: TComponentClass);
|
||||
published
|
||||
{ Published declarations }
|
||||
property Anchors;
|
||||
property CurveExponent: single read FCurveExponent write SetCurveExponent;
|
||||
property KnobColor: TColor read FKnobColor write SetKnobColor;
|
||||
property LightIntensity: integer read GetLightIntensity write SetLightIntensity;
|
||||
property PositionColor: TColor read FPositionColor write SetPositionColor;
|
||||
property PositionWidth: single read FPositionWidth write SetPositionWidth;
|
||||
property PositionOpacity: byte read FPositionOpacity write SetPositionOpacity;
|
||||
property PositionMargin: single read FPositionMargin write SetPositionMargin;
|
||||
property PositionType: TBGRAKnobPositionType
|
||||
read FPositionType write SetPositionType;
|
||||
property UsePhongLighting: boolean read FUsePhongLighting write SetUsePhongLighting;
|
||||
property MinValue: single read FMinValue write SetMinValue;
|
||||
property MaxValue: single read FMaxValue write SetMaxValue;
|
||||
property Value: single read GetValue write SetValue;
|
||||
property OnValueChanged: TBGRAKnobValueChangedEvent
|
||||
read FOnKnobValueChange write FOnKnobValueChange;
|
||||
property StartFromBottom: boolean read FStartFromBottom write SetStartFromBottom;
|
||||
end;
|
||||
|
||||
{$IFDEF FPC}procedure Register;{$ENDIF}
|
||||
|
||||
implementation
|
||||
|
||||
uses Math;
|
||||
|
||||
{$IFDEF FPC}
|
||||
procedure Register;
|
||||
begin
|
||||
RegisterComponents('BGRA Controls', [TBGRAKnob]);
|
||||
end;
|
||||
{$ENDIF}
|
||||
|
||||
{ TBGRAKnob }
|
||||
|
||||
procedure TBGRAKnob.CreateKnobBmp;
|
||||
var
|
||||
tx, ty: integer;
|
||||
h: single;
|
||||
d2: single;
|
||||
v: TPointF;
|
||||
p: PBGRAPixel;
|
||||
center: TPointF;
|
||||
yb: integer;
|
||||
xb: integer;
|
||||
mask: TBGRABitmap;
|
||||
Map: TBGRABitmap;
|
||||
BGRAKnobColor: TBGRAPixel;
|
||||
begin
|
||||
tx := ClientWidth;
|
||||
ty := ClientHeight;
|
||||
if (tx = 0) or (ty = 0) then
|
||||
exit;
|
||||
|
||||
FreeAndNil(FKnobBmp);
|
||||
|
||||
FKnobBmp := TBGRABitmap.Create(tx, ty);
|
||||
center := PointF((tx - 1) / 2, (ty - 1) / 2);
|
||||
BGRAKnobColor := KnobColor;
|
||||
|
||||
if UsePhongLighting then
|
||||
begin
|
||||
//compute knob height map
|
||||
Map := TBGRABitmap.Create(tx, ty);
|
||||
for yb := 0 to ty - 1 do
|
||||
begin
|
||||
p := map.ScanLine[yb];
|
||||
for xb := 0 to tx - 1 do
|
||||
begin
|
||||
//compute vector between center and current pixel
|
||||
v := PointF(xb, yb) - center;
|
||||
//scale down to unit circle (with 1 pixel margin for soft border)
|
||||
v.x := v.x /(tx / 2 + 1);
|
||||
v.y := v.y / (ty / 2 + 1);
|
||||
//compute squared distance with scalar product
|
||||
d2 := v {$if FPC_FULLVERSION < 30203}*{$ELSE}**{$ENDIF} v;
|
||||
//interpolate as quadratic curve and apply power function
|
||||
if d2 > 1 then
|
||||
h := 0
|
||||
else
|
||||
h := power(1 - d2, FCurveExponent);
|
||||
p^ := MapHeightToBGRA(h, 255);
|
||||
Inc(p);
|
||||
end;
|
||||
end;
|
||||
//antialiased border
|
||||
mask := TBGRABitmap.Create(tx, ty, BGRABlack);
|
||||
Mask.FillEllipseAntialias(center.x, center.y, tx / 2, ty / 2, BGRAWhite);
|
||||
map.ApplyMask(mask);
|
||||
Mask.Free;
|
||||
|
||||
FPhong.Draw(FKnobBmp, Map, 30, 0, 0, BGRAKnobColor);
|
||||
Map.Free;
|
||||
end
|
||||
else
|
||||
begin
|
||||
FKnobBmp.FillEllipseAntialias(center.x, center.y, tx / 2, ty / 2, BGRAKnobColor);
|
||||
end;
|
||||
|
||||
end;
|
||||
|
||||
function TBGRAKnob.GetLightIntensity: integer;
|
||||
begin
|
||||
Result := round(FPhong.LightSourceIntensity);
|
||||
end;
|
||||
|
||||
function TBGRAKnob.GetValue: single;
|
||||
begin
|
||||
Result := FAngularPos * 180 / Pi;
|
||||
if Result < 0 then
|
||||
Result := Result +360;
|
||||
Result := 270 - Result;
|
||||
if Result < 0 then
|
||||
Result := Result +360;
|
||||
end;
|
||||
|
||||
procedure TBGRAKnob.SetCurveExponent(const AValue: single);
|
||||
begin
|
||||
if FCurveExponent = AValue then
|
||||
exit;
|
||||
FCurveExponent := AValue;
|
||||
FreeAndNil(FKnobBmp);
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBGRAKnob.SetKnobColor(const AValue: TColor);
|
||||
begin
|
||||
if FKnobColor = AValue then
|
||||
exit;
|
||||
FKnobColor := AValue;
|
||||
FreeAndNil(FKnobBmp);
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBGRAKnob.SetLightIntensity(const AValue: integer);
|
||||
begin
|
||||
if AValue <> FPhong.LightSourceIntensity then
|
||||
begin
|
||||
FPhong.LightSourceIntensity := AValue;
|
||||
FreeAndNil(FKnobBmp);
|
||||
Invalidate;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TBGRAKnob.SetStartFromBottom(const AValue: boolean);
|
||||
begin
|
||||
if FStartFromBottom = AValue then
|
||||
exit;
|
||||
FStartFromBottom := AValue;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBGRAKnob.SetValue(AValue: single);
|
||||
var
|
||||
NewAngularPos: single;
|
||||
begin
|
||||
ValueCorrection(AValue);
|
||||
NewAngularPos := 3 * Pi / 2 - AValue * Pi / 180;
|
||||
if NewAngularPos > Pi then
|
||||
NewAngularPos := NewAngularPos -(2 * Pi);
|
||||
if NewAngularPos < -Pi then
|
||||
NewAngularPos := NewAngularPos +(2 * Pi);
|
||||
if NewAngularPos <> FAngularPos then
|
||||
begin
|
||||
FAngularPos := NewAngularPos;
|
||||
Invalidate;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TBGRAKnob.SetMaxValue(AValue: single);
|
||||
begin
|
||||
if AValue < 0 then
|
||||
AValue := 0;
|
||||
if AValue > 360 then
|
||||
AValue := 360;
|
||||
if FMaxValue = AValue then
|
||||
exit;
|
||||
FMaxValue := AValue;
|
||||
if FMinValue > FMaxValue then
|
||||
FMinValue := FMaxValue;
|
||||
if ValueCorrection then
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBGRAKnob.SetMinValue(AValue: single);
|
||||
begin
|
||||
if AValue < 0 then
|
||||
AValue := 0;
|
||||
if AValue > 360 then
|
||||
AValue := 360;
|
||||
if FMinValue = AValue then
|
||||
exit;
|
||||
FMinValue := AValue;
|
||||
if FMaxValue < FMinValue then
|
||||
FMaxValue := FMinValue;
|
||||
if ValueCorrection then
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBGRAKnob.SetPositionColor(const AValue: TColor);
|
||||
begin
|
||||
if FPositionColor = AValue then
|
||||
exit;
|
||||
FPositionColor := AValue;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBGRAKnob.SetPositionMargin(AValue: single);
|
||||
begin
|
||||
if FPositionMargin = AValue then
|
||||
exit;
|
||||
FPositionMargin := AValue;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBGRAKnob.SetPositionOpacity(const AValue: byte);
|
||||
begin
|
||||
if FPositionOpacity = AValue then
|
||||
exit;
|
||||
FPositionOpacity := AValue;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBGRAKnob.SetPositionType(const AValue: TBGRAKnobPositionType);
|
||||
begin
|
||||
if FPositionType = AValue then
|
||||
exit;
|
||||
FPositionType := AValue;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBGRAKnob.SetPositionWidth(const AValue: single);
|
||||
begin
|
||||
if FPositionWidth = AValue then
|
||||
exit;
|
||||
FPositionWidth := AValue;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBGRAKnob.SetUsePhongLighting(const AValue: boolean);
|
||||
begin
|
||||
if FUsePhongLighting = AValue then
|
||||
exit;
|
||||
FUsePhongLighting := AValue;
|
||||
FreeAndNil(FKnobBmp);
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBGRAKnob.UpdateAngularPos(X, Y: integer);
|
||||
var
|
||||
FPreviousPos, Sign: single;
|
||||
begin
|
||||
FPreviousPos := FAngularPos;
|
||||
if FStartFromBottom then
|
||||
Sign := 1
|
||||
else
|
||||
Sign := -1;
|
||||
FAngularPos := ArcTan2((-Sign) * (Y - ClientHeight / 2) / ClientHeight,
|
||||
Sign * (X - ClientWidth / 2) / ClientWidth);
|
||||
ValueCorrection;
|
||||
Invalidate;
|
||||
if (FPreviousPos <> FAngularPos) and Assigned(FOnKnobValueChange) then
|
||||
FOnKnobValueChange(Self, Value);
|
||||
end;
|
||||
|
||||
procedure TBGRAKnob.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: integer);
|
||||
begin
|
||||
inherited MouseDown(Button, Shift, X, Y);
|
||||
if Button = mbLeft then
|
||||
begin
|
||||
FSettingAngularPos := True;
|
||||
UpdateAngularPos(X, Y);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TBGRAKnob.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: integer);
|
||||
begin
|
||||
inherited MouseUp(Button, Shift, X, Y);
|
||||
if Button = mbLeft then
|
||||
FSettingAngularPos := False;
|
||||
end;
|
||||
|
||||
procedure TBGRAKnob.MouseMove(Shift: TShiftState; X, Y: integer);
|
||||
begin
|
||||
inherited MouseMove(Shift, X, Y);
|
||||
if FSettingAngularPos then
|
||||
UpdateAngularPos(X, Y);
|
||||
end;
|
||||
|
||||
procedure TBGRAKnob.Paint;
|
||||
var
|
||||
Bmp: TBGRABitmap;
|
||||
Center, Pos: TPointF;
|
||||
PosColor: TBGRAPixel;
|
||||
PosLen: single;
|
||||
begin
|
||||
if (ClientWidth = 0) or (ClientHeight = 0) then
|
||||
exit;
|
||||
if FKnobBmp = nil then
|
||||
begin
|
||||
CreateKnobBmp;
|
||||
if FKnobBmp = nil then
|
||||
Exit;
|
||||
end;
|
||||
Bmp := TBGRABitmap.Create(ClientWidth, ClientHeight);
|
||||
Bmp.BlendImage(0, 0, FKnobBmp, boLinearBlend);
|
||||
|
||||
//draw current position
|
||||
PosColor := ColorToBGRA(ColorToRGB(FPositionColor), FPositionOpacity);
|
||||
Center := PointF(ClientWidth / 2, ClientHeight / 2);
|
||||
Pos.X := Cos(FAngularPos) * (ClientWidth / 2);
|
||||
Pos.Y := -Sin(FAngularPos) * (ClientHeight / 2);
|
||||
if not FStartFromBottom then
|
||||
Pos := -Pos;
|
||||
PosLen := VectLen(Pos);
|
||||
|
||||
Pos := Pos * ((PosLen - PositionMargin - FPositionWidth) / PosLen);
|
||||
Pos := Center + Pos;
|
||||
|
||||
case PositionType of
|
||||
kptLineSquareCap:
|
||||
begin
|
||||
Bmp.LineCap := pecSquare;
|
||||
Bmp.DrawLineAntialias(Center.X, Center.Y, Pos.X, Pos.Y, PosColor, FPositionWidth);
|
||||
end;
|
||||
kptLineRoundCap:
|
||||
begin
|
||||
Bmp.LineCap := pecRound;
|
||||
Bmp.DrawLineAntialias(Center.X, Center.Y, Pos.X, Pos.Y, PosColor, FPositionWidth);
|
||||
end;
|
||||
kptFilledCircle:
|
||||
begin
|
||||
Bmp.FillEllipseAntialias(Pos.X, Pos.Y, FPositionWidth, FPositionWidth, PosColor);
|
||||
end;
|
||||
kptHollowCircle:
|
||||
begin
|
||||
Bmp.EllipseAntialias(Pos.X, Pos.Y, FPositionWidth * 2 / 3,
|
||||
FPositionWidth * 2 / 3, PosColor, FPositionWidth / 3);
|
||||
end;
|
||||
end;
|
||||
|
||||
Bmp.Draw(Canvas, 0, 0, False);
|
||||
Bmp.Free;
|
||||
end;
|
||||
|
||||
procedure TBGRAKnob.Resize;
|
||||
begin
|
||||
inherited Resize;
|
||||
if (FKnobBmp <> nil) and ((ClientWidth <> FKnobBmp.Width) or
|
||||
(ClientHeight <> FKnobBmp.Height)) then
|
||||
FreeAndNil(FKnobBmp);
|
||||
end;
|
||||
|
||||
function TBGRAKnob.ValueCorrection(var AValue: single): boolean;
|
||||
begin
|
||||
if AValue < MinValue then
|
||||
begin
|
||||
AValue := MinValue;
|
||||
Result := True;
|
||||
end
|
||||
else
|
||||
if AValue > MaxValue then
|
||||
begin
|
||||
AValue := MaxValue;
|
||||
Result := True;
|
||||
end
|
||||
else
|
||||
Result := False;
|
||||
end;
|
||||
|
||||
function TBGRAKnob.ValueCorrection: boolean;
|
||||
var
|
||||
LValue: single;
|
||||
begin
|
||||
LValue := Value;
|
||||
Result := ValueCorrection(LValue);
|
||||
if Result then
|
||||
Value := LValue;
|
||||
end;
|
||||
|
||||
constructor TBGRAKnob.Create(AOwner: TComponent);
|
||||
begin
|
||||
inherited Create(AOwner);
|
||||
|
||||
with GetControlClassDefaultSize do
|
||||
SetInitialBounds(0, 0, CX, CY);
|
||||
|
||||
FPhong := TPhongShading.Create;
|
||||
FPhong.LightPositionZ := 100;
|
||||
FPhong.LightSourceIntensity := 300;
|
||||
FPhong.NegativeDiffusionFactor := 0.8;
|
||||
FPhong.AmbientFactor := 0.5;
|
||||
FPhong.DiffusionFactor := 0.6;
|
||||
FKnobBmp := nil;
|
||||
FCurveExponent := 0.2;
|
||||
FKnobColor := clBtnFace;
|
||||
FPositionColor := clBtnText;
|
||||
FPositionOpacity := 192;
|
||||
FPositionWidth := 4;
|
||||
FPositionMargin := 4;
|
||||
FPositionType := kptLineSquareCap;
|
||||
FUsePhongLighting := True;
|
||||
FOnKnobValueChange := nil;
|
||||
FStartFromBottom := True;
|
||||
FMinValue := 30;
|
||||
FMaxValue := 330;
|
||||
end;
|
||||
|
||||
destructor TBGRAKnob.Destroy;
|
||||
begin
|
||||
FPhong.Free;
|
||||
FKnobBmp.Free;
|
||||
inherited Destroy;
|
||||
end;
|
||||
{$IFDEF FPC}
|
||||
procedure TBGRAKnob.SaveToFile(AFileName: string);
|
||||
var
|
||||
AStream: TMemoryStream;
|
||||
begin
|
||||
AStream := TMemoryStream.Create;
|
||||
try
|
||||
WriteComponentAsTextToStream(AStream, Self);
|
||||
AStream.SaveToFile(AFileName);
|
||||
finally
|
||||
AStream.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TBGRAKnob.LoadFromFile(AFileName: string);
|
||||
var
|
||||
AStream: TMemoryStream;
|
||||
begin
|
||||
AStream := TMemoryStream.Create;
|
||||
try
|
||||
AStream.LoadFromFile(AFileName);
|
||||
ReadComponentFromTextStream(AStream, TComponent(Self), OnFindClass);
|
||||
finally
|
||||
AStream.Free;
|
||||
end;
|
||||
end;
|
||||
{$ENDIF}
|
||||
|
||||
procedure TBGRAKnob.OnFindClass(Reader: TReader; const AClassName: string;
|
||||
var ComponentClass: TComponentClass);
|
||||
begin
|
||||
if CompareText(AClassName, 'TBGRAKnob') = 0 then
|
||||
ComponentClass := TBGRAKnob;
|
||||
end;
|
||||
|
||||
end.
|
||||
|
||||
433
bgracontrols/bgrapascalscript.pas
Normal file
433
bgracontrols/bgrapascalscript.pas
Normal file
@@ -0,0 +1,433 @@
|
||||
// SPDX-License-Identifier: LGPL-3.0-linking-exception
|
||||
{
|
||||
Created by BGRA Controls Team
|
||||
Dibo, Circular, lainz (007) and contributors.
|
||||
For detailed information see readme.txt
|
||||
|
||||
Site: https://sourceforge.net/p/bgra-controls/
|
||||
Wiki: http://wiki.lazarus.freepascal.org/BGRAControls
|
||||
Forum: http://forum.lazarus.freepascal.org/index.php/board,46.0.html
|
||||
}
|
||||
{******************************* CONTRIBUTOR(S) ******************************
|
||||
- Edivando S. Santos Brasil | mailedivando@gmail.com
|
||||
(Compatibility with delphi VCL 11/2018)
|
||||
|
||||
***************************** END CONTRIBUTOR(S) *****************************}
|
||||
unit BGRAPascalScript;
|
||||
// Note: overloaded procedures not supported, use unique identifiers
|
||||
{$I bgracontrols.inc}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils, BGRABitmap, BGRABitmapTypes;
|
||||
|
||||
type
|
||||
TBGRAColor = longword;
|
||||
|
||||
var
|
||||
BitmapArray: array of TBGRABitmap;
|
||||
|
||||
{Internal use only}
|
||||
procedure bgra_Initialization;
|
||||
procedure bgra_Finalization;
|
||||
|
||||
procedure bgra_AddBitmap(id: integer);
|
||||
function bgra_GetHighestID: integer;
|
||||
|
||||
function BGRAColorToBGRAPixel(AColor: TBGRAColor): TBGRAPixel;
|
||||
|
||||
function rgb(red, green, blue: byte): TBGRAColor;
|
||||
function rgba(red, green, blue, alpha: byte): TBGRAColor;
|
||||
function getBlue(AColor: TBGRAColor): byte;
|
||||
function getGreen(AColor: TBGRAColor): byte;
|
||||
function getRed(AColor: TBGRAColor): byte;
|
||||
function getAlpha(AColor: TBGRAColor): byte;
|
||||
function setBlue(AColor: TBGRAColor; AValue: byte): TBGRAColor;
|
||||
function setGreen(AColor: TBGRAColor; AValue: byte): TBGRAColor;
|
||||
function setRed(AColor: TBGRAColor; AValue: byte): TBGRAColor;
|
||||
function setAlpha(AColor: TBGRAColor; AValue: byte): TBGRAColor;
|
||||
|
||||
{Constructors}
|
||||
procedure bgra_Create(id: integer);
|
||||
procedure bgra_CreateWithSize(id: integer; AWidth, AHeight: integer);
|
||||
procedure bgra_CreateFromFile(id: integer; AFilename: string);
|
||||
procedure bgra_Destroy(id: integer);
|
||||
procedure bgra_DestroyAll;
|
||||
|
||||
procedure bgra_Fill(id: integer; AColor: TBGRAColor);
|
||||
procedure bgra_SetPixel(id: integer; x, y: integer; AColor: TBGRAColor);
|
||||
function bgra_GetPixel(id: integer; x, y: integer): TBGRAColor;
|
||||
|
||||
{Loading functions}
|
||||
procedure bgra_SaveToFile(id: integer; const filename: string);
|
||||
|
||||
{Filters - direct apply}
|
||||
procedure bgra_FilterSmartZoom3(id: integer; Option: TMedianOption);
|
||||
procedure bgra_FilterMedian(id: integer; Option: TMedianOption);
|
||||
procedure bgra_FilterSmooth(id: integer);
|
||||
procedure bgra_FilterSharpen(id: integer; Amount: single);
|
||||
procedure bgra_FilterSharpenRect(id: integer; ABounds: TRect; Amount: single);
|
||||
procedure bgra_FilterContour(id: integer);
|
||||
procedure bgra_FilterPixelate(id: integer; pixelSize: integer;
|
||||
useResample: boolean; filter: TResampleFilter);
|
||||
procedure bgra_FilterBlurRadial(id: integer; radius: integer; blurType: TRadialBlurType);
|
||||
procedure bgra_FilterBlurRadialRect(id: integer; ABounds: TRect;
|
||||
radius: integer; blurType: TRadialBlurType);
|
||||
procedure bgra_FilterBlurMotion(id: integer; distance: integer;
|
||||
angle: single; oriented: boolean);
|
||||
procedure bgra_FilterBlurMotionRect(id: integer; ABounds: TRect;
|
||||
distance: integer; angle: single; oriented: boolean);
|
||||
procedure bgra_FilterCustomBlur(id: integer; mask: integer);
|
||||
procedure bgra_FilterCustomBlurRect(id: integer; ABounds: TRect; mask: integer);
|
||||
procedure bgra_FilterEmboss(id: integer; angle: single);
|
||||
procedure bgra_FilterEmbossRect(id: integer; angle: single; ABounds: TRect);
|
||||
procedure bgra_FilterEmbossHighlight(id: integer; FillSelection: boolean);
|
||||
procedure bgra_FilterEmbossHighlightBorder(id: integer; FillSelection: boolean;
|
||||
BorderColor: TBGRAColor);
|
||||
procedure bgra_FilterEmbossHighlightBorderAndOffset(id: integer;
|
||||
FillSelection: boolean; BorderColor: TBGRAColor; Offset: TPoint);
|
||||
procedure bgra_FilterGrayscale(id: integer);
|
||||
procedure bgra_FilterGrayscaleRect(id: integer; ABounds: TRect);
|
||||
procedure bgra_FilterNormalize(id: integer; eachChannel: boolean);
|
||||
procedure bgra_FilterNormalizeRect(id: integer; ABounds: TRect; eachChannel: boolean);
|
||||
procedure bgra_FilterRotate(id: integer; origin: TPointF; angle: single;
|
||||
correctBlur: boolean);
|
||||
procedure bgra_FilterSphere(id: integer);
|
||||
procedure bgra_FilterTwirl(id: integer; ACenter: TPoint; ARadius: single;
|
||||
ATurn: single; AExponent: single);
|
||||
procedure bgra_FilterTwirlRect(id: integer; ABounds: TRect; ACenter: TPoint;
|
||||
ARadius: single; ATurn: single; AExponent: single);
|
||||
procedure bgra_FilterCylinder(id: integer);
|
||||
procedure bgra_FilterPlane(id: integer);
|
||||
|
||||
implementation
|
||||
|
||||
procedure bgra_Initialization;
|
||||
begin
|
||||
|
||||
end;
|
||||
|
||||
procedure bgra_Finalization;
|
||||
var
|
||||
i: integer;
|
||||
begin
|
||||
for i := 0 to High(BitmapArray) do
|
||||
FreeAndNil(BitmapArray[i]);
|
||||
BitmapArray := nil;
|
||||
end;
|
||||
|
||||
procedure bgra_AddBitmap(id: integer);
|
||||
begin
|
||||
if id + 1 > length(BitmapArray) then
|
||||
SetLength(BitmapArray, id + 1);
|
||||
FreeAndNil(BitmapArray[id]);
|
||||
end;
|
||||
|
||||
function bgra_GetHighestID: integer;
|
||||
begin
|
||||
Result := High(BitmapArray);
|
||||
end;
|
||||
|
||||
function BGRAColorToBGRAPixel(AColor: TBGRAColor): TBGRAPixel;
|
||||
begin
|
||||
Result := TBGRAPixel(
|
||||
{$IFDEF ENDIAN_BIG}
|
||||
SwapEndian
|
||||
{$ENDIF}
|
||||
(AColor));
|
||||
end;
|
||||
|
||||
function rgb(red, green, blue: byte): TBGRAColor;
|
||||
begin
|
||||
Result := blue + (green shl 8) + (red shl 16) + $ff000000;
|
||||
end;
|
||||
|
||||
function rgba(red, green, blue, alpha: byte): TBGRAColor;
|
||||
begin
|
||||
Result := blue + (green shl 8) + (red shl 16) + (alpha shl 24);
|
||||
end;
|
||||
|
||||
function getBlue(AColor: TBGRAColor): byte;
|
||||
begin
|
||||
Result := AColor and $ff;
|
||||
end;
|
||||
|
||||
function getGreen(AColor: TBGRAColor): byte;
|
||||
begin
|
||||
Result := (AColor shr 8) and $ff;
|
||||
end;
|
||||
|
||||
function getRed(AColor: TBGRAColor): byte;
|
||||
begin
|
||||
Result := (AColor shr 16) and $ff;
|
||||
end;
|
||||
|
||||
function getAlpha(AColor: TBGRAColor): byte;
|
||||
begin
|
||||
Result := AColor shr 24;
|
||||
end;
|
||||
|
||||
function setBlue(AColor: TBGRAColor; AValue: byte): TBGRAColor;
|
||||
begin
|
||||
Result := (AColor and $ffffff00) or AValue;
|
||||
end;
|
||||
|
||||
function setGreen(AColor: TBGRAColor; AValue: byte): TBGRAColor;
|
||||
begin
|
||||
Result := (AColor and $ffff00ff) or (AValue shl 8);
|
||||
end;
|
||||
|
||||
function setRed(AColor: TBGRAColor; AValue: byte): TBGRAColor;
|
||||
begin
|
||||
Result := (AColor and $ff00ffff) or (AValue shl 16);
|
||||
end;
|
||||
|
||||
function setAlpha(AColor: TBGRAColor; AValue: byte): TBGRAColor;
|
||||
begin
|
||||
Result := (AColor and $00ffffff) or (AValue shl 24);
|
||||
end;
|
||||
|
||||
procedure bgra_Create(id: integer);
|
||||
begin
|
||||
bgra_AddBitmap(id);
|
||||
BitmapArray[id] := TBGRABitmap.Create;
|
||||
end;
|
||||
|
||||
procedure bgra_CreateWithSize(id: integer; AWidth, AHeight: integer);
|
||||
begin
|
||||
bgra_AddBitmap(id);
|
||||
BitmapArray[id] := TBGRABitmap.Create(AWidth, AHeight);
|
||||
end;
|
||||
|
||||
procedure bgra_CreateFromFile(id: integer; AFilename: string);
|
||||
begin
|
||||
bgra_AddBitmap(id);
|
||||
BitmapArray[id] := TBGRABitmap.Create(AFilename);
|
||||
end;
|
||||
|
||||
procedure bgra_Destroy(id: integer);
|
||||
begin
|
||||
FreeAndNil(BitmapArray[id]);
|
||||
end;
|
||||
|
||||
procedure bgra_DestroyAll;
|
||||
var
|
||||
id: integer;
|
||||
begin
|
||||
for id := 0 to bgra_GetHighestID do
|
||||
bgra_Destroy(id);
|
||||
SetLength(BitmapArray, 0);
|
||||
end;
|
||||
|
||||
procedure bgra_Fill(id: integer; AColor: TBGRAColor);
|
||||
begin
|
||||
if Assigned(BitmapArray[id]) then
|
||||
BitmapArray[id].Fill(TBGRAPixel(
|
||||
{$IFDEF ENDIAN_BIG}
|
||||
SwapEndian
|
||||
{$ENDIF}
|
||||
(AColor)));
|
||||
end;
|
||||
|
||||
procedure bgra_SetPixel(id: integer; x, y: integer; AColor: TBGRAColor);
|
||||
begin
|
||||
if Assigned(BitmapArray[id]) then
|
||||
BitmapArray[id].SetPixel(x, y, TBGRAPixel(
|
||||
{$IFDEF ENDIAN_BIG}
|
||||
SwapEndian
|
||||
{$ENDIF}
|
||||
(AColor)));
|
||||
end;
|
||||
|
||||
function bgra_GetPixel(id: integer; x, y: integer): TBGRAColor;
|
||||
begin
|
||||
if Assigned(BitmapArray[id]) then
|
||||
Result :=
|
||||
{$IFDEF ENDIAN_BIG}
|
||||
SwapEndian
|
||||
{$ENDIF}
|
||||
(TBGRAColor(BitmapArray[id].GetPixel(x, y)))
|
||||
else
|
||||
Result := 0;
|
||||
end;
|
||||
|
||||
procedure bgra_SaveToFile(id: integer; const filename: string);
|
||||
begin
|
||||
BitmapArray[id].SaveToFile(filename);
|
||||
end;
|
||||
|
||||
procedure bgra_FilterSmartZoom3(id: integer; Option: TMedianOption);
|
||||
begin
|
||||
BGRAReplace(BitmapArray[id], BitmapArray[id].FilterSmartZoom3(Option) as TBGRABitmap);
|
||||
end;
|
||||
|
||||
procedure bgra_FilterMedian(id: integer; Option: TMedianOption);
|
||||
begin
|
||||
BGRAReplace(BitmapArray[id], BitmapArray[id].FilterMedian(Option) as TBGRABitmap);
|
||||
end;
|
||||
|
||||
procedure bgra_FilterSmooth(id: integer);
|
||||
begin
|
||||
BGRAReplace(BitmapArray[id], BitmapArray[id].FilterSmooth as TBGRABitmap);
|
||||
end;
|
||||
|
||||
procedure bgra_FilterSharpen(id: integer; Amount: single);
|
||||
begin
|
||||
BGRAReplace(BitmapArray[id], BitmapArray[id].FilterSharpen(Amount) as TBGRABitmap);
|
||||
end;
|
||||
|
||||
procedure bgra_FilterSharpenRect(id: integer; ABounds: TRect; Amount: single);
|
||||
begin
|
||||
BGRAReplace(BitmapArray[id], BitmapArray[id].FilterSharpen(ABounds, Amount) as
|
||||
TBGRABitmap);
|
||||
end;
|
||||
|
||||
procedure bgra_FilterContour(id: integer);
|
||||
begin
|
||||
BGRAReplace(BitmapArray[id], BitmapArray[id].FilterContour as TBGRABitmap);
|
||||
end;
|
||||
|
||||
procedure bgra_FilterPixelate(id: integer; pixelSize: integer;
|
||||
useResample: boolean; filter: TResampleFilter);
|
||||
begin
|
||||
BGRAReplace(BitmapArray[id], BitmapArray[id].FilterPixelate(pixelSize,
|
||||
useResample, filter) as TBGRABitmap);
|
||||
end;
|
||||
|
||||
procedure bgra_FilterBlurRadial(id: integer; radius: integer;
|
||||
blurType: TRadialBlurType);
|
||||
begin
|
||||
BGRAReplace(BitmapArray[id], BitmapArray[id].FilterBlurRadial(radius, blurType) as
|
||||
TBGRABitmap);
|
||||
end;
|
||||
|
||||
procedure bgra_FilterBlurRadialRect(id: integer; ABounds: TRect;
|
||||
radius: integer; blurType: TRadialBlurType);
|
||||
begin
|
||||
BGRAReplace(BitmapArray[id], BitmapArray[id].FilterBlurRadial(ABounds,
|
||||
radius, blurType) as TBGRABitmap);
|
||||
end;
|
||||
|
||||
procedure bgra_FilterBlurMotion(id: integer; distance: integer;
|
||||
angle: single; oriented: boolean);
|
||||
begin
|
||||
BGRAReplace(BitmapArray[id], BitmapArray[id].FilterBlurMotion(distance,
|
||||
angle, oriented) as TBGRABitmap);
|
||||
end;
|
||||
|
||||
procedure bgra_FilterBlurMotionRect(id: integer; ABounds: TRect;
|
||||
distance: integer; angle: single; oriented: boolean);
|
||||
begin
|
||||
BGRAReplace(BitmapArray[id], BitmapArray[id].FilterBlurMotion(ABounds,
|
||||
distance, angle, oriented) as TBGRABitmap);
|
||||
end;
|
||||
|
||||
procedure bgra_FilterCustomBlur(id: integer; mask: integer);
|
||||
begin
|
||||
BGRAReplace(BitmapArray[id], BitmapArray[id].FilterCustomBlur(BitmapArray[mask]) as
|
||||
TBGRABitmap);
|
||||
end;
|
||||
|
||||
procedure bgra_FilterCustomBlurRect(id: integer; ABounds: TRect; mask: integer);
|
||||
begin
|
||||
BGRAReplace(BitmapArray[id], BitmapArray[id].FilterCustomBlur(ABounds,
|
||||
BitmapArray[mask]) as TBGRABitmap);
|
||||
end;
|
||||
|
||||
procedure bgra_FilterEmboss(id: integer; angle: single);
|
||||
begin
|
||||
BGRAReplace(BitmapArray[id], BitmapArray[id].FilterEmboss(angle) as TBGRABitmap);
|
||||
end;
|
||||
|
||||
procedure bgra_FilterEmbossRect(id: integer; angle: single; ABounds: TRect);
|
||||
begin
|
||||
BGRAReplace(BitmapArray[id], BitmapArray[id].FilterEmboss(angle, ABounds) as
|
||||
TBGRABitmap);
|
||||
end;
|
||||
|
||||
procedure bgra_FilterEmbossHighlight(id: integer; FillSelection: boolean);
|
||||
begin
|
||||
BGRAReplace(BitmapArray[id], BitmapArray[id].FilterEmbossHighlight(FillSelection) as
|
||||
TBGRABitmap);
|
||||
end;
|
||||
|
||||
procedure bgra_FilterEmbossHighlightBorder(id: integer; FillSelection: boolean;
|
||||
BorderColor: TBGRAColor);
|
||||
begin
|
||||
BGRAReplace(BitmapArray[id], BitmapArray[id].FilterEmbossHighlight(
|
||||
FillSelection, BGRAColorToBGRAPixel(BorderColor)) as TBGRABitmap);
|
||||
end;
|
||||
|
||||
procedure bgra_FilterEmbossHighlightBorderAndOffset(id: integer;
|
||||
FillSelection: boolean; BorderColor: TBGRAColor; Offset: TPoint);
|
||||
begin
|
||||
BGRAReplace(BitmapArray[id], BitmapArray[id].FilterEmbossHighlight(
|
||||
FillSelection, BGRAColorToBGRAPixel(BorderColor), Offset) as TBGRABitmap);
|
||||
end;
|
||||
|
||||
procedure bgra_FilterGrayscale(id: integer);
|
||||
begin
|
||||
BGRAReplace(BitmapArray[id], BitmapArray[id].FilterGrayscale as TBGRABitmap);
|
||||
end;
|
||||
|
||||
procedure bgra_FilterGrayscaleRect(id: integer; ABounds: TRect);
|
||||
begin
|
||||
BGRAReplace(BitmapArray[id], BitmapArray[id].FilterGrayscale(ABounds) as TBGRABitmap);
|
||||
end;
|
||||
|
||||
procedure bgra_FilterNormalize(id: integer; eachChannel: boolean);
|
||||
begin
|
||||
BGRAReplace(BitmapArray[id], BitmapArray[id].FilterNormalize(eachChannel) as
|
||||
TBGRABitmap);
|
||||
end;
|
||||
|
||||
procedure bgra_FilterNormalizeRect(id: integer; ABounds: TRect; eachChannel: boolean);
|
||||
begin
|
||||
BGRAReplace(BitmapArray[id], BitmapArray[id].FilterNormalize(ABounds, eachChannel) as
|
||||
TBGRABitmap);
|
||||
end;
|
||||
|
||||
procedure bgra_FilterRotate(id: integer; origin: TPointF; angle: single;
|
||||
correctBlur: boolean);
|
||||
begin
|
||||
BGRAReplace(BitmapArray[id], BitmapArray[id].FilterRotate(origin,
|
||||
angle, correctBlur) as TBGRABitmap);
|
||||
end;
|
||||
|
||||
procedure bgra_FilterSphere(id: integer);
|
||||
begin
|
||||
BGRAReplace(BitmapArray[id], BitmapArray[id].FilterSphere as TBGRABitmap);
|
||||
end;
|
||||
|
||||
procedure bgra_FilterTwirl(id: integer; ACenter: TPoint; ARadius: single;
|
||||
ATurn: single; AExponent: single);
|
||||
begin
|
||||
BGRAReplace(BitmapArray[id], BitmapArray[id].FilterTwirl(ACenter,
|
||||
ARadius, ATurn, AExponent) as TBGRABitmap);
|
||||
end;
|
||||
|
||||
procedure bgra_FilterTwirlRect(id: integer; ABounds: TRect; ACenter: TPoint;
|
||||
ARadius: single; ATurn: single; AExponent: single);
|
||||
begin
|
||||
BGRAReplace(BitmapArray[id], BitmapArray[id].FilterTwirl(ABounds,
|
||||
ACenter, ARadius, ATurn, AExponent) as TBGRABitmap);
|
||||
end;
|
||||
|
||||
procedure bgra_FilterCylinder(id: integer);
|
||||
begin
|
||||
BGRAReplace(BitmapArray[id], BitmapArray[id].FilterCylinder as TBGRABitmap);
|
||||
end;
|
||||
|
||||
procedure bgra_FilterPlane(id: integer);
|
||||
begin
|
||||
BGRAReplace(BitmapArray[id], BitmapArray[id].FilterPlane as TBGRABitmap);
|
||||
end;
|
||||
|
||||
initialization
|
||||
bgra_Initialization;
|
||||
|
||||
finalization
|
||||
bgra_Finalization;
|
||||
|
||||
end.
|
||||
50
bgracontrols/bgrapascalscriptcomponent.lpk
Normal file
50
bgracontrols/bgrapascalscriptcomponent.lpk
Normal file
@@ -0,0 +1,50 @@
|
||||
<?xml version="1.0" encoding="UTF-8"?>
|
||||
<CONFIG>
|
||||
<Package Version="4">
|
||||
<PathDelim Value="\"/>
|
||||
<Name Value="bgrapascalscriptcomponent"/>
|
||||
<Type Value="RunAndDesignTime"/>
|
||||
<CompilerOptions>
|
||||
<Version Value="11"/>
|
||||
<PathDelim Value="\"/>
|
||||
<SearchPaths>
|
||||
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
|
||||
</SearchPaths>
|
||||
</CompilerOptions>
|
||||
<Version Major="9"/>
|
||||
<Files Count="3">
|
||||
<Item1>
|
||||
<Filename Value="bgrapascalscript.pas"/>
|
||||
<AddToUsesPkgSection Value="False"/>
|
||||
<UnitName Value="BGRAPascalScript"/>
|
||||
</Item1>
|
||||
<Item2>
|
||||
<Filename Value="upsi_bgrapascalscript.pas"/>
|
||||
<HasRegisterProc Value="True"/>
|
||||
<UnitName Value="uPSI_BGRAPascalScript"/>
|
||||
</Item2>
|
||||
<Item3>
|
||||
<Filename Value="bgrascript.pas"/>
|
||||
<AddToUsesPkgSection Value="False"/>
|
||||
<UnitName Value="BGRAScript"/>
|
||||
</Item3>
|
||||
</Files>
|
||||
<RequiredPkgs Count="3">
|
||||
<Item1>
|
||||
<PackageName Value="BGRABitmapPack"/>
|
||||
</Item1>
|
||||
<Item2>
|
||||
<PackageName Value="pascalscript"/>
|
||||
</Item2>
|
||||
<Item3>
|
||||
<PackageName Value="FCL"/>
|
||||
</Item3>
|
||||
</RequiredPkgs>
|
||||
<UsageOptions>
|
||||
<UnitPath Value="$(PkgOutDir)"/>
|
||||
</UsageOptions>
|
||||
<PublishOptions>
|
||||
<Version Value="2"/>
|
||||
</PublishOptions>
|
||||
</Package>
|
||||
</CONFIG>
|
||||
22
bgracontrols/bgrapascalscriptcomponent.pas
Normal file
22
bgracontrols/bgrapascalscriptcomponent.pas
Normal file
@@ -0,0 +1,22 @@
|
||||
{ This file was automatically created by Lazarus. Do not edit!
|
||||
This source is only used to compile and install the package.
|
||||
}
|
||||
|
||||
unit bgrapascalscriptcomponent;
|
||||
|
||||
{$warn 5023 off : no warning about unused units}
|
||||
interface
|
||||
|
||||
uses
|
||||
uPSI_BGRAPascalScript, LazarusPackageIntf;
|
||||
|
||||
implementation
|
||||
|
||||
procedure Register;
|
||||
begin
|
||||
RegisterUnit('uPSI_BGRAPascalScript', @uPSI_BGRAPascalScript.Register);
|
||||
end;
|
||||
|
||||
initialization
|
||||
RegisterPackage('bgrapascalscriptcomponent', @Register);
|
||||
end.
|
||||
88
bgracontrols/bgraresizespeedbutton.pas
Normal file
88
bgracontrols/bgraresizespeedbutton.pas
Normal file
@@ -0,0 +1,88 @@
|
||||
// SPDX-License-Identifier: LGPL-3.0-linking-exception
|
||||
{
|
||||
Created by Fox. Part of BGRA Controls.
|
||||
For detailed information see readme.txt
|
||||
|
||||
Site: https://sourceforge.net/p/bgra-controls/
|
||||
Wiki: http://wiki.lazarus.freepascal.org/BGRAControls
|
||||
Forum: http://forum.lazarus.freepascal.org/index.php/board,46.0.html
|
||||
}
|
||||
{******************************* CONTRIBUTOR(S) ******************************
|
||||
- Edivando S. Santos Brasil | mailedivando@gmail.com
|
||||
(Compatibility with delphi VCL 11/2018)
|
||||
|
||||
***************************** END CONTRIBUTOR(S) *****************************}
|
||||
unit BGRAResizeSpeedButton;
|
||||
|
||||
{$I bgracontrols.inc}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils, Buttons, {$IFDEF FPC}LResources,{$ENDIF} Forms,
|
||||
Controls, Graphics, Dialogs,
|
||||
{$IFNDEF FPC}Types, BGRAGraphics, GraphType, FPImage, {$ENDIF}
|
||||
BGRASpeedButton, BGRABitmap;
|
||||
|
||||
type
|
||||
TBGRAResizeSpeedButton = class(TBGRASpeedButton)
|
||||
private
|
||||
{ Private declarations }
|
||||
FBGRA: TBGRABitmap;
|
||||
protected
|
||||
{ Protected declarations }
|
||||
function DrawGlyph(ACanvas: TCanvas; const AClient: TRect;
|
||||
const {%H-}AOffset: TPoint; AState: TButtonState; {%H-}ATransparent: boolean;
|
||||
{%H-}BiDiFlags: longint): TRect; {$IFDEF FPC}override;{$ENDIF}
|
||||
public
|
||||
{ Public declarations }
|
||||
constructor Create(AOwner: TComponent); override;
|
||||
destructor Destroy; override;
|
||||
published
|
||||
{ Published declarations }
|
||||
end;
|
||||
|
||||
{$IFDEF FPC}procedure Register;{$ENDIF}
|
||||
|
||||
implementation
|
||||
|
||||
function TBGRAResizeSpeedButton.DrawGlyph(ACanvas: TCanvas;
|
||||
const AClient: TRect; const AOffset: TPoint; AState: TButtonState;
|
||||
ATransparent: boolean; BiDiFlags: longint): TRect;
|
||||
|
||||
begin
|
||||
Result := Rect(0, 0, 0, 0);
|
||||
if Glyph = nil then
|
||||
Exit;
|
||||
Result := AClient;
|
||||
if Assigned(Glyph) and not Glyph.Empty then
|
||||
begin
|
||||
FBGRA.Assign(Glyph);
|
||||
BGRAReplace(FBGRA, FBGRA.Resample(Self.Width - 6, Self.Height - 6));
|
||||
if (AState = bsDown) or (Down = True) then
|
||||
FBGRA.Draw(ACanvas, 4, 4, False)
|
||||
else
|
||||
FBGRA.Draw(ACanvas, 3, 3, False);
|
||||
end;
|
||||
end;
|
||||
|
||||
constructor TBGRAResizeSpeedButton.Create(AOwner: TComponent);
|
||||
begin
|
||||
inherited Create(AOwner);
|
||||
FBGRA := TBGRABitmap.Create;
|
||||
end;
|
||||
|
||||
destructor TBGRAResizeSpeedButton.Destroy;
|
||||
begin
|
||||
FBGRA.Free;
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
{$IFDEF FPC}
|
||||
procedure Register;
|
||||
begin
|
||||
RegisterComponents('BGRA Button Controls', [TBGRAResizeSpeedButton]);
|
||||
end;
|
||||
{$ENDIF}
|
||||
|
||||
end.
|
||||
687
bgracontrols/bgrascript.pas
Normal file
687
bgracontrols/bgrascript.pas
Normal file
@@ -0,0 +1,687 @@
|
||||
// SPDX-License-Identifier: LGPL-3.0-linking-exception
|
||||
{
|
||||
Created by BGRA Controls Team
|
||||
Dibo, Circular, lainz (007) and contributors.
|
||||
For detailed information see readme.txt
|
||||
|
||||
Site: https://sourceforge.net/p/bgra-controls/
|
||||
Wiki: http://wiki.lazarus.freepascal.org/BGRAControls
|
||||
Forum: http://forum.lazarus.freepascal.org/index.php/board,46.0.html
|
||||
}
|
||||
|
||||
unit BGRAScript;
|
||||
|
||||
{$I bgracontrols.inc}
|
||||
{ $define debug}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils, BGRABitmap, BGRABitmapTypes, Dialogs;
|
||||
|
||||
{Template}
|
||||
procedure SynCompletionList(itemlist: TStrings);
|
||||
{Scripting}
|
||||
function ScriptCommand(command: string; var bitmap: TBGRABitmap;
|
||||
var variables: TStringList; var line: integer): boolean;
|
||||
function ScriptCommandList(commandlist: TStrings; var bitmap: TBGRABitmap): boolean;
|
||||
|
||||
{Tools}
|
||||
function StrToDrawMode(mode: string): TDrawMode;
|
||||
|
||||
implementation
|
||||
|
||||
procedure SynCompletionList(itemlist: TStrings);
|
||||
begin
|
||||
with itemlist do
|
||||
begin
|
||||
{Assign key values}
|
||||
Add('let key "value"');
|
||||
{Goto line}
|
||||
Add('goto 10');
|
||||
{Messages}
|
||||
Add('print "Message"');
|
||||
Add('input "Title","Message","Default value",result');
|
||||
{Read Values}
|
||||
Add('GetWidth width');
|
||||
Add('GetHeight height');
|
||||
{TFPCustomImage override}
|
||||
Add('SetSize 320,240');
|
||||
{Loading functions}
|
||||
Add('SaveToFile "file.png"');
|
||||
{Loading functions}
|
||||
Add('SetHorizLine 0,0,100,"rgba(0,0,0,1)"');
|
||||
Add('XorHorizLine 0,0,100,"rgba(0,0,0,1)"');
|
||||
Add('DrawHorizLine 0,0,100,"rgba(0,0,0,1)"');
|
||||
Add('FastBlendHorizLine 0,0,100,"rgba(0,0,0,1)"');
|
||||
Add('AlphaHorizLine 0,0,100,"rgba(0,0,0,1)"');
|
||||
Add('SetVertLine 0,0,100,"rgba(0,0,0,1)"');
|
||||
Add('XorVertLine 0,0,100,"rgba(0,0,0,1)"');
|
||||
Add('DrawVertLine 0,0,100,"rgba(0,0,0,1)"');
|
||||
Add('FastBlendVertLine 0,0,100,"rgba(0,0,0,1)"');
|
||||
Add('AlphaVertLine 0,0,100,"rgba(0,0,0,1)"');
|
||||
Add('DrawHorizLinediff 0,0,100,"rgba(0,0,0,1)","rgba(255,255,255,1)",128');
|
||||
//--
|
||||
Add('FillTransparent');
|
||||
Add('Rectangle 0,0,100,100,"rgba(0,0,0,1)","rgba(255,255,255,1)","dmDrawWithTransparency"');
|
||||
Add('RectangleAntiAlias "0,5","0,5","99,5","99,5","rgba(0,0,0,1)","1,5","rgba(255,255,255,1)"');
|
||||
{BGRA bitmap functions}
|
||||
Add('RotateCW');
|
||||
Add('RotateCCW');
|
||||
Add('Negative');
|
||||
Add('NegativeRect 0,0,100,100');
|
||||
Add('LinearNegative');
|
||||
Add('LinearNegativeRect 0,0,100,100');
|
||||
Add('InplaceGrayscale');
|
||||
Add('InplaceGrayscaleRect 0,0,100,100');
|
||||
Add('SwapRedBlue');
|
||||
Add('GrayscaleToAlpha');
|
||||
Add('AlphaToGrayscale');
|
||||
Add('ApplyGlobalOpacity 128');
|
||||
Add('ConvertToLinearRGB');
|
||||
Add('ConvertFromLinearRGB');
|
||||
Add('DrawCheckers 0,0,100,100,"rgba(100,100,100,255)","rgba(0,0,0,0)"');
|
||||
{Custom functions}
|
||||
Add('VerticalFlip 0,0,100,100');
|
||||
Add('HorizontalFlip 0,0,100,100');
|
||||
Add('BlendBitmap 0,0,"file.png","boTransparent"');
|
||||
Add('BlendBitmapOver 0,0,"file.png","boTransparent",255,"False"');
|
||||
Add('ApplyBitmapMask "file.png",0,0,100,100,0,0');
|
||||
{Filters}
|
||||
Add('FilterFastBlur 5,"False"');
|
||||
Add('FilterSmooth "False"');
|
||||
Add('FilterSharpen 5,"False"');
|
||||
Add('FilterContour');
|
||||
Add('FilterEmboss "1,5"');
|
||||
Add('FilterNormalize "True"');
|
||||
Add('FilterSphere "True"');
|
||||
Add('FilterCylinder "True"');
|
||||
Add('FilterPlane "True"');
|
||||
end;
|
||||
end;
|
||||
|
||||
function ScriptCommand(command: string; var bitmap: TBGRABitmap;
|
||||
var variables: TStringList; var line: integer): boolean;
|
||||
|
||||
function ParamCheck(passed, mustbe: integer): boolean;
|
||||
begin
|
||||
Result := True;
|
||||
if passed <> mustbe then
|
||||
Result := False;
|
||||
|
||||
{$IFDEF INDEBUG}
|
||||
if not Result then
|
||||
begin
|
||||
writeln('>> Wrong number of parameters: ' + IntToStr(passed));
|
||||
writeln('>> Must be: ' + IntToStr(mustbe));
|
||||
end;
|
||||
{$endif}
|
||||
end;
|
||||
|
||||
function ParamCheckAtLeast(passed, mustbe: integer): boolean;
|
||||
begin
|
||||
Result := True;
|
||||
if passed < mustbe then
|
||||
Result := False;
|
||||
|
||||
{$IFDEF INDEBUG}
|
||||
if not Result then
|
||||
begin
|
||||
writeln('>> Wrong number of parameters: ' + IntToStr(passed));
|
||||
writeln('>> At least must be: ' + IntToStr(mustbe));
|
||||
end;
|
||||
{$endif}
|
||||
end;
|
||||
|
||||
var
|
||||
list: TStringList;
|
||||
passed: integer;
|
||||
tmpbmp1: TBGRABitmap;
|
||||
i: integer;
|
||||
a: string;
|
||||
begin
|
||||
{ $ifdef debug}
|
||||
//writeln('---Script-Command---');
|
||||
{ $endif}
|
||||
|
||||
Result := True;
|
||||
list := TStringList.Create;
|
||||
list.CommaText := command;
|
||||
passed := list.Count;
|
||||
|
||||
{Replace values in variable names}
|
||||
for i := 0 to list.Count - 1 do
|
||||
if variables.Values[list[i]] <> '' then
|
||||
list[i] := variables.Values[list[i]];
|
||||
|
||||
case LowerCase(list[0]) of
|
||||
{Assign key values}
|
||||
'let':
|
||||
begin
|
||||
Result := ParamCheck(passed, 3);
|
||||
if Result then
|
||||
variables.Add(list[1] + '=' + list[2]);
|
||||
end;
|
||||
|
||||
{Messages}
|
||||
'input':
|
||||
begin
|
||||
Result := ParamCheck(passed, 5);
|
||||
if Result then
|
||||
begin
|
||||
a := InputBox(list[1],list[2],list[3]);
|
||||
variables.Add(list[4] + '=' + a);
|
||||
end;
|
||||
end;
|
||||
|
||||
'print':
|
||||
begin
|
||||
Result := ParamCheckAtLeast(passed, 2);
|
||||
if Result then
|
||||
begin
|
||||
a := '';
|
||||
for i:=1 to passed -1 do
|
||||
a := a + list[i];
|
||||
ShowMessage(a);
|
||||
end;
|
||||
end;
|
||||
|
||||
{GoTo}
|
||||
'goto':
|
||||
begin
|
||||
Result := ParamCheck(passed,2);
|
||||
if Result then
|
||||
begin
|
||||
line := StrToInt(list[1]) - 2;
|
||||
if line < 0 then
|
||||
line := -1;
|
||||
end;
|
||||
end;
|
||||
|
||||
{Read values}
|
||||
'getwidth':
|
||||
begin
|
||||
Result := ParamCheck(passed, 2);
|
||||
if Result then
|
||||
variables.Add(list[1] + '=' + IntToStr(bitmap.Width));
|
||||
end;
|
||||
|
||||
'getheight':
|
||||
begin
|
||||
Result := ParamCheck(passed, 2);
|
||||
if Result then
|
||||
variables.Add(list[1] + '=' + IntToStr(bitmap.Height));
|
||||
end;
|
||||
|
||||
{TFPCustomImage override}
|
||||
'setsize':
|
||||
begin
|
||||
Result := ParamCheck(passed, 3);
|
||||
if Result then
|
||||
bitmap.SetSize(StrToInt(list[1]), StrToInt(list[2]));
|
||||
end;
|
||||
|
||||
{Loading functions}
|
||||
'savetofile':
|
||||
begin
|
||||
Result := ParamCheck(passed, 2);
|
||||
if Result then
|
||||
bitmap.SaveToFile(list[1]);
|
||||
end;
|
||||
|
||||
{Pixel functions}
|
||||
|
||||
{Loading functions}
|
||||
{* Horiz *}
|
||||
'sethorizline':
|
||||
begin
|
||||
Result := ParamCheck(passed, 5);
|
||||
if Result then
|
||||
bitmap.SetHorizLine(StrToInt(list[1]), StrToInt(list[2]),
|
||||
StrToInt(list[3]), StrToBGRA(list[4]));
|
||||
end;
|
||||
'xorhorizline':
|
||||
begin
|
||||
Result := ParamCheck(passed, 5);
|
||||
if Result then
|
||||
bitmap.XorHorizLine(StrToInt(list[1]), StrToInt(list[2]),
|
||||
StrToInt(list[3]), StrToBGRA(list[4]));
|
||||
end;
|
||||
'drawhorizline':
|
||||
begin
|
||||
Result := ParamCheck(passed, 5);
|
||||
if Result then
|
||||
bitmap.DrawHorizLine(StrToInt(list[1]), StrToInt(list[2]),
|
||||
StrToInt(list[3]), StrToBGRA(list[4]));
|
||||
end;
|
||||
'fastblendhorizline':
|
||||
begin
|
||||
Result := ParamCheck(passed, 5);
|
||||
if Result then
|
||||
bitmap.FastBlendHorizLine(StrToInt(list[1]), StrToInt(list[2]),
|
||||
StrToInt(list[3]), StrToBGRA(list[4]));
|
||||
end;
|
||||
'alphahorizline':
|
||||
begin
|
||||
Result := ParamCheck(passed, 5);
|
||||
if Result then
|
||||
bitmap.AlphaHorizLine(StrToInt(list[1]), StrToInt(list[2]),
|
||||
StrToInt(list[3]), StrToInt(list[4]));
|
||||
end;
|
||||
{* Vert *}
|
||||
'setvertline':
|
||||
begin
|
||||
Result := ParamCheck(passed, 5);
|
||||
if Result then
|
||||
bitmap.SetVertLine(StrToInt(list[1]), StrToInt(list[2]),
|
||||
StrToInt(list[3]), StrToBGRA(list[4]));
|
||||
end;
|
||||
'xorvertline':
|
||||
begin
|
||||
Result := ParamCheck(passed, 5);
|
||||
if Result then
|
||||
bitmap.XorVertLine(StrToInt(list[1]), StrToInt(list[2]),
|
||||
StrToInt(list[3]), StrToBGRA(list[4]));
|
||||
end;
|
||||
'drawvertline':
|
||||
begin
|
||||
Result := ParamCheck(passed, 5);
|
||||
if Result then
|
||||
bitmap.DrawVertLine(StrToInt(list[1]), StrToInt(list[2]),
|
||||
StrToInt(list[3]), StrToBGRA(list[4]));
|
||||
end;
|
||||
'fastblendvertline':
|
||||
begin
|
||||
Result := ParamCheck(passed, 5);
|
||||
if Result then
|
||||
bitmap.FastBlendVertLine(StrToInt(list[1]), StrToInt(list[2]),
|
||||
StrToInt(list[3]), StrToBGRA(list[4]));
|
||||
end;
|
||||
'alphavertline':
|
||||
begin
|
||||
Result := ParamCheck(passed, 5);
|
||||
if Result then
|
||||
bitmap.AlphaVertLine(StrToInt(list[1]), StrToInt(list[2]),
|
||||
StrToInt(list[3]), StrToInt(list[4]));
|
||||
end;
|
||||
{* Misc *}
|
||||
'drawhorizlinediff':
|
||||
begin
|
||||
Result := ParamCheck(passed, 7);
|
||||
if Result then
|
||||
bitmap.DrawHorizLineDiff(StrToInt(list[1]), StrToInt(list[2]),
|
||||
StrToInt(list[3]), StrToBGRA(list[4]), StrToBGRA(list[5]), StrToInt(list[6]));
|
||||
end;
|
||||
|
||||
//---
|
||||
'filltransparent':
|
||||
begin
|
||||
Result := ParamCheck(passed, 1);
|
||||
if Result then
|
||||
bitmap.FillTransparent;
|
||||
end;
|
||||
|
||||
'rectangle':
|
||||
begin
|
||||
Result := ParamCheck(passed, 8);
|
||||
if Result then
|
||||
bitmap.Rectangle(StrToInt(list[1]), StrToInt(list[2]), StrToInt(
|
||||
list[3]), StrToInt(list[4]), StrToBGRA(list[5]), StrToBGRA(list[6]),
|
||||
StrToDrawMode(list[7]));
|
||||
end;
|
||||
|
||||
'rectangleantialias':
|
||||
begin
|
||||
Result := ParamCheck(passed, 8);
|
||||
if Result then
|
||||
bitmap.RectangleAntialias(StrToFloat(list[1]), StrToFloat(list[2]),
|
||||
StrToFloat(list[3]), StrToFloat(list[4]), StrToBGRA(list[5]),
|
||||
StrToFloat(list[6]), StrToBGRA(list[7]));
|
||||
end;
|
||||
|
||||
{BGRA bitmap functions}
|
||||
'verticalflip':
|
||||
begin
|
||||
Result := ParamCheck(passed, 5);
|
||||
if Result then
|
||||
bitmap.VerticalFlip(Rect(StrToInt(list[1]), StrToInt(list[2]),
|
||||
StrToInt(list[3]), StrToInt(list[4])));
|
||||
end;
|
||||
'horizontalflip':
|
||||
begin
|
||||
Result := ParamCheck(passed, 5);
|
||||
if Result then
|
||||
bitmap.HorizontalFlip(Rect(StrToInt(list[1]), StrToInt(list[2]),
|
||||
StrToInt(list[3]), StrToInt(list[4])));
|
||||
end;
|
||||
'rotatecw':
|
||||
begin
|
||||
Result := ParamCheck(passed, 1);
|
||||
if Result then
|
||||
try
|
||||
tmpbmp1 := bitmap.RotateCW as TBGRABitmap;
|
||||
bitmap.FillTransparent;
|
||||
bitmap.BlendImage(0, 0, tmpbmp1, boLinearBlend);
|
||||
finally
|
||||
tmpbmp1.Free;
|
||||
end;
|
||||
end;
|
||||
'rotateccw':
|
||||
begin
|
||||
Result := ParamCheck(passed, 1);
|
||||
if Result then
|
||||
try
|
||||
tmpbmp1 := bitmap.RotateCCW as TBGRABitmap;
|
||||
bitmap.FillTransparent;
|
||||
bitmap.BlendImage(0, 0, tmpbmp1, boLinearBlend);
|
||||
finally
|
||||
tmpbmp1.Free;
|
||||
end;
|
||||
end;
|
||||
'negative':
|
||||
begin
|
||||
Result := ParamCheck(passed, 1);
|
||||
if Result then
|
||||
bitmap.Negative;
|
||||
end;
|
||||
'negativerect':
|
||||
begin
|
||||
Result := ParamCheck(passed, 5);
|
||||
if Result then
|
||||
bitmap.NegativeRect(Rect(StrToInt(list[1]), StrToInt(list[2]),
|
||||
StrToInt(list[3]), StrToInt(list[4])));
|
||||
end;
|
||||
'linearnegative':
|
||||
begin
|
||||
Result := ParamCheck(passed, 1);
|
||||
if Result then
|
||||
bitmap.LinearNegative;
|
||||
end;
|
||||
'linearnegativerect':
|
||||
begin
|
||||
Result := ParamCheck(passed, 5);
|
||||
if Result then
|
||||
bitmap.LinearNegativeRect(Rect(StrToInt(list[1]), StrToInt(list[2]),
|
||||
StrToInt(list[3]), StrToInt(list[4])));
|
||||
end;
|
||||
'inplacegrayscale':
|
||||
begin
|
||||
Result := ParamCheck(passed, 1);
|
||||
if Result then
|
||||
bitmap.InplaceGrayscale;
|
||||
end;
|
||||
'inplacegrayscalerect':
|
||||
begin
|
||||
Result := ParamCheck(passed, 5);
|
||||
if Result then
|
||||
bitmap.InplaceGrayscale(Rect(StrToInt(list[1]), StrToInt(list[2]),
|
||||
StrToInt(list[3]), StrToInt(list[4])));
|
||||
end;
|
||||
'swapredblue':
|
||||
begin
|
||||
Result := ParamCheck(passed, 1);
|
||||
if Result then
|
||||
bitmap.SwapRedBlue;
|
||||
end;
|
||||
'grayscaletoalpha':
|
||||
begin
|
||||
Result := ParamCheck(passed, 1);
|
||||
if Result then
|
||||
bitmap.GrayscaleToAlpha;
|
||||
end;
|
||||
'alphatograyscale':
|
||||
begin
|
||||
Result := ParamCheck(passed, 1);
|
||||
if Result then
|
||||
bitmap.AlphaToGrayscale;
|
||||
end;
|
||||
'applyglobalopacity':
|
||||
begin
|
||||
Result := ParamCheck(passed, 2);
|
||||
if Result then
|
||||
bitmap.ApplyGlobalOpacity(StrToInt(list[1]));
|
||||
end;
|
||||
'converttolinearrgb':
|
||||
begin
|
||||
Result := ParamCheck(passed, 1);
|
||||
if Result then
|
||||
bitmap.ConvertToLinearRGB;
|
||||
end;
|
||||
'convertfromlinearrgb':
|
||||
begin
|
||||
Result := ParamCheck(passed, 1);
|
||||
if Result then
|
||||
bitmap.ConvertFromLinearRGB;
|
||||
end;
|
||||
'drawcheckers':
|
||||
begin
|
||||
Result := ParamCheck(passed, 7);
|
||||
if Result then
|
||||
bitmap.DrawCheckers(Rect(StrToInt(list[1]), StrToInt(list[2]),
|
||||
StrToInt(list[3]), StrToInt(list[4])), StrToBGRA(list[5]), StrToBGRA(list[6]));
|
||||
end;
|
||||
|
||||
{Filters}
|
||||
|
||||
{Custom Functions}
|
||||
'blendbitmap':
|
||||
begin
|
||||
Result := ParamCheck(passed, 5);
|
||||
if Result then
|
||||
try
|
||||
tmpbmp1 := TBGRABitmap.Create(list[3]);
|
||||
bitmap.BlendImage(StrToInt(list[1]), StrToInt(list[2]), tmpbmp1,
|
||||
StrToBlendOperation(list[4]));
|
||||
finally
|
||||
tmpbmp1.Free;
|
||||
end;
|
||||
end;
|
||||
'blendbitmapover':
|
||||
begin
|
||||
Result := ParamCheck(passed, 7);
|
||||
if Result then
|
||||
try
|
||||
tmpbmp1 := TBGRABitmap.Create(list[3]);
|
||||
bitmap.BlendImageOver(StrToInt(list[1]), StrToInt(list[2]),
|
||||
tmpbmp1, StrToBlendOperation(list[4]), StrToInt(list[5]),
|
||||
StrToBool(list[6]));
|
||||
finally
|
||||
tmpbmp1.Free;
|
||||
end;
|
||||
end;
|
||||
'applybitmapmask':
|
||||
begin
|
||||
Result := ParamCheck(passed, 8);
|
||||
if Result then
|
||||
try
|
||||
tmpbmp1 := TBGRABitmap.Create(list[1]);
|
||||
bitmap.ApplyMask(tmpbmp1, Rect(StrToInt(list[2]), StrToInt(
|
||||
list[3]), StrToInt(list[4]), StrToInt(list[5])), Point(
|
||||
StrToInt(list[6]), StrToInt(list[7])));
|
||||
finally
|
||||
tmpbmp1.Free;
|
||||
end;
|
||||
end;
|
||||
'filterfastblur':
|
||||
begin
|
||||
Result := ParamCheck(passed, 3);
|
||||
if Result then
|
||||
begin
|
||||
tmpbmp1 := bitmap.FilterBlurRadial(StrToInt(list[1]), rbFast) as TBGRABitmap;
|
||||
if StrToBool(list[2]) then
|
||||
bitmap.FillTransparent;
|
||||
bitmap.BlendImage(0, 0, tmpbmp1, boLinearBlend);
|
||||
tmpbmp1.Free;
|
||||
end;
|
||||
end;
|
||||
'filtersmooth':
|
||||
begin
|
||||
Result := ParamCheck(passed, 2);
|
||||
if Result then
|
||||
begin
|
||||
tmpbmp1 := bitmap.FilterSmooth as TBGRABitmap;
|
||||
if StrToBool(list[1]) then
|
||||
bitmap.FillTransparent;
|
||||
bitmap.BlendImage(0, 0, tmpbmp1, boLinearBlend);
|
||||
tmpbmp1.Free;
|
||||
end;
|
||||
end;
|
||||
'filtersharpen':
|
||||
begin
|
||||
Result := ParamCheck(passed, 3);
|
||||
if Result then
|
||||
begin
|
||||
tmpbmp1 := bitmap.FilterSharpen(StrToInt(list[1])) as TBGRABitmap;
|
||||
if StrToBool(list[2]) then
|
||||
bitmap.FillTransparent;
|
||||
bitmap.BlendImage(0, 0, tmpbmp1, boLinearBlend);
|
||||
tmpbmp1.Free;
|
||||
end;
|
||||
end;
|
||||
'filtercontour':
|
||||
begin
|
||||
Result := ParamCheck(passed, 1);
|
||||
if Result then
|
||||
begin
|
||||
tmpbmp1 := bitmap.FilterContour as TBGRABitmap;
|
||||
bitmap.BlendImage(0, 0, tmpbmp1, boLinearBlend);
|
||||
tmpbmp1.Free;
|
||||
end;
|
||||
end;
|
||||
'filteremboss':
|
||||
begin
|
||||
Result := ParamCheck(passed, 2);
|
||||
if Result then
|
||||
begin
|
||||
tmpbmp1 := bitmap.FilterEmboss(StrToFloat(list[1])) as TBGRABitmap;
|
||||
bitmap.BlendImage(0, 0, tmpbmp1, boLinearBlend);
|
||||
tmpbmp1.Free;
|
||||
end;
|
||||
end;
|
||||
'filternormalize':
|
||||
begin
|
||||
Result := ParamCheck(passed, 2);
|
||||
if Result then
|
||||
begin
|
||||
tmpbmp1 := bitmap.FilterNormalize(StrToBool(list[1])) as TBGRABitmap;
|
||||
bitmap.FillTransparent;
|
||||
bitmap.BlendImage(0, 0, tmpbmp1, boLinearBlend);
|
||||
tmpbmp1.Free;
|
||||
end;
|
||||
end;
|
||||
'filtersphere':
|
||||
begin
|
||||
Result := ParamCheck(passed, 2);
|
||||
if Result then
|
||||
begin
|
||||
tmpbmp1 := bitmap.FilterSphere as TBGRABitmap;
|
||||
if StrToBool(list[1]) then
|
||||
bitmap.FillTransparent;
|
||||
bitmap.BlendImage(0, 0, tmpbmp1, boLinearBlend);
|
||||
tmpbmp1.Free;
|
||||
end;
|
||||
end;
|
||||
'filtercylinder':
|
||||
begin
|
||||
Result := ParamCheck(passed, 2);
|
||||
if Result then
|
||||
begin
|
||||
tmpbmp1 := bitmap.FilterCylinder as TBGRABitmap;
|
||||
if StrToBool(list[1]) then
|
||||
bitmap.FillTransparent;
|
||||
bitmap.BlendImage(0, 0, tmpbmp1, boLinearBlend);
|
||||
tmpbmp1.Free;
|
||||
end;
|
||||
end;
|
||||
'filterplane':
|
||||
begin
|
||||
Result := ParamCheck(passed, 2);
|
||||
if Result then
|
||||
begin
|
||||
tmpbmp1 := bitmap.FilterPlane as TBGRABitmap;
|
||||
if StrToBool(list[1]) then
|
||||
bitmap.FillTransparent;
|
||||
bitmap.BlendImage(0, 0, tmpbmp1, boLinearBlend);
|
||||
tmpbmp1.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
'//':
|
||||
begin
|
||||
// comment
|
||||
end;
|
||||
|
||||
'{':
|
||||
begin
|
||||
{ comment }
|
||||
end;
|
||||
|
||||
else
|
||||
begin
|
||||
{$IFDEF INDEBUG}
|
||||
writeln('>> Command "' + list[0] + '" not found.');
|
||||
{$endif}
|
||||
Result := False;
|
||||
end;
|
||||
end;
|
||||
|
||||
{$IFDEF INDEBUG}
|
||||
if not Result then
|
||||
writeln('>> ERROR');
|
||||
for i := 0 to list.Count - 1 do
|
||||
writeln(' ' + list[i]);
|
||||
writeln('____________________');
|
||||
{$endif}
|
||||
|
||||
list.Free;
|
||||
end;
|
||||
|
||||
function ScriptCommandList(commandlist: TStrings; var bitmap: TBGRABitmap): boolean;
|
||||
var
|
||||
line: integer;
|
||||
variables: TStringList;
|
||||
begin
|
||||
{$IFDEF INDEBUG}
|
||||
//writeln('----SCRIPT--LIST----');
|
||||
writeln(' Executing ' + IntToStr(commandlist.Count) + ' lines...');
|
||||
writeln('____________________');
|
||||
{$endif}
|
||||
|
||||
variables := TStringList.Create;
|
||||
|
||||
{Result := True;
|
||||
for i := 0 to commandlist.Count - 1 do
|
||||
if commandlist[i] <> '' then
|
||||
ScriptCommand(commandlist[i], bitmap, variables);
|
||||
}
|
||||
Result := True;
|
||||
line := 0;
|
||||
repeat
|
||||
if commandlist[line] <> '' then
|
||||
ScriptCommand(commandlist[line], bitmap, variables, line);
|
||||
Inc(line);
|
||||
until line > commandList.Count;
|
||||
|
||||
variables.Free;
|
||||
|
||||
{$IFDEF INDEBUG}
|
||||
//writeln('----SCRIPT--LIST----');
|
||||
writeln(' END');
|
||||
writeln('____________________');
|
||||
{$endif}
|
||||
end;
|
||||
|
||||
function StrToDrawMode(mode: string): TDrawMode;
|
||||
begin
|
||||
case LowerCase(mode) of
|
||||
'dmset': Result := dmSet;
|
||||
'dmsetexcepttransparent': Result := dmSetExceptTransparent;
|
||||
'dmlinearblend': Result := dmLinearBlend;
|
||||
'dmdrawwithtransparency': Result := dmDrawWithTransparency;
|
||||
'dmxor': Result := dmXor;
|
||||
else
|
||||
Result := dmDrawWithTransparency;
|
||||
end;
|
||||
end;
|
||||
|
||||
end.
|
||||
452
bgracontrols/bgrashape.pas
Normal file
452
bgracontrols/bgrashape.pas
Normal file
@@ -0,0 +1,452 @@
|
||||
// SPDX-License-Identifier: LGPL-3.0-linking-exception
|
||||
{
|
||||
Created by BGRA Controls Team
|
||||
Dibo, Circular, lainz (007) and contributors.
|
||||
For detailed information see readme.txt
|
||||
|
||||
Site: https://sourceforge.net/p/bgra-controls/
|
||||
Wiki: http://wiki.lazarus.freepascal.org/BGRAControls
|
||||
Forum: http://forum.lazarus.freepascal.org/index.php/board,46.0.html
|
||||
}
|
||||
|
||||
{******************************* CONTRIBUTOR(S) ******************************
|
||||
- Edivando S. Santos Brasil | mailedivando@gmail.com
|
||||
(Compatibility with delphi VCL 11/2018)
|
||||
|
||||
***************************** END CONTRIBUTOR(S) *****************************}
|
||||
unit BGRAShape;
|
||||
|
||||
{$I bgracontrols.inc}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils, {$IFDEF FPC}LResources,{$ENDIF} Forms, Controls, Graphics, Dialogs,
|
||||
{$IFNDEF FPC}Types, BGRAGraphics, GraphType, FPImage, {$ENDIF}
|
||||
BCBaseCtrls, BGRABitmap, BGRABitmapTypes, BCTypes;
|
||||
|
||||
type
|
||||
TBGRAShapeType = (stRegularPolygon, stEllipse);
|
||||
|
||||
{ TBGRAShape }
|
||||
|
||||
TBGRAShape = class(TBGRAGraphicCtrl)
|
||||
private
|
||||
{ Private declarations }
|
||||
FBorderColor: TColor;
|
||||
FBorderOpacity: byte;
|
||||
FBorderStyle: TPenStyle;
|
||||
FBorderWidth: integer;
|
||||
FBorderGradient: TBCGradient;
|
||||
FUseBorderGradient: boolean;
|
||||
FFillColor: TColor;
|
||||
FFillOpacity: byte;
|
||||
FFillGradient: TBCGradient;
|
||||
FUseFillGradient: boolean;
|
||||
FRoundRadius: integer;
|
||||
FBGRA: TBGRABitmap;
|
||||
FSideCount: integer;
|
||||
FRatioXY: single;
|
||||
FUseRatioXY: boolean;
|
||||
FAngle: single;
|
||||
FShapeType: TBGRAShapeType;
|
||||
procedure SetAngle(const AValue: single);
|
||||
procedure SetBorderColor(const AValue: TColor);
|
||||
procedure SetBorderGradient(const AValue: TBCGradient);
|
||||
procedure SetBorderOpacity(const AValue: byte);
|
||||
procedure SetBorderStyle(const AValue: TPenStyle);
|
||||
procedure SetBorderWidth(AValue: integer);
|
||||
procedure SetFillColor(const AValue: TColor);
|
||||
procedure SetFillGradient(const AValue: TBCGradient);
|
||||
procedure SetFillOpacity(const AValue: byte);
|
||||
procedure SetRatioXY(const AValue: single);
|
||||
procedure SetRoundRadius(AValue: integer);
|
||||
procedure SetShapeType(const AValue: TBGRAShapeType);
|
||||
procedure SetSideCount(AValue: integer);
|
||||
procedure SetUseBorderGradient(const AValue: boolean);
|
||||
procedure SetUseFillGradient(const AValue: boolean);
|
||||
procedure SetUseRatioXY(const AValue: boolean);
|
||||
protected
|
||||
{ Protected declarations }
|
||||
procedure Paint; override;
|
||||
public
|
||||
{ Public declarations }
|
||||
constructor Create(AOwner: TComponent); override;
|
||||
destructor Destroy; override;
|
||||
public
|
||||
{ Streaming }
|
||||
{$IFDEF FPC}
|
||||
procedure SaveToFile(AFileName: string);
|
||||
procedure LoadFromFile(AFileName: string);
|
||||
{$ENDIF}
|
||||
procedure OnFindClass({%H-}Reader: TReader; const AClassName: string;
|
||||
var ComponentClass: TComponentClass);
|
||||
published
|
||||
{ Published declarations }
|
||||
property AutoSize;
|
||||
property Align;
|
||||
property Anchors;
|
||||
property Angle: single Read FAngle Write SetAngle {$IFDEF FPC}default 0{$ENDIF};
|
||||
property BorderWidth: integer Read FBorderWidth Write SetBorderWidth default 1;
|
||||
property BorderOpacity: byte Read FBorderOpacity Write SetBorderOpacity default 255;
|
||||
property BorderColor: TColor Read FBorderColor Write SetBorderColor;
|
||||
property BorderGradient: TBCGradient Read FBorderGradient Write SetBorderGradient;
|
||||
property BorderStyle: TPenStyle
|
||||
Read FBorderStyle Write SetBorderStyle default psSolid;
|
||||
property FillColor: TColor Read FFillColor Write SetFillColor;
|
||||
property FillOpacity: byte Read FFillOpacity Write SetFillOpacity;
|
||||
property FillGradient: TBCGradient Read FFillGradient Write SetFillGradient;
|
||||
property SideCount: integer Read FSideCount Write SetSideCount default 4;
|
||||
property RatioXY: single Read FRatioXY Write SetRatioXY {$IFDEF FPC}default 1{$ENDIF};
|
||||
property UseRatioXY: boolean Read FUseRatioXY Write SetUseRatioXY default False;
|
||||
property UseFillGradient: boolean Read FUseFillGradient
|
||||
Write SetUseFillGradient default False;
|
||||
property UseBorderGradient: boolean Read FUseBorderGradient
|
||||
Write SetUseBorderGradient default False;
|
||||
property ShapeType: TBGRAShapeType
|
||||
Read FShapeType Write SetShapeType default stRegularPolygon;
|
||||
property BorderSpacing;
|
||||
property Caption;
|
||||
property PopupMenu;
|
||||
property RoundRadius: integer Read FRoundRadius Write SetRoundRadius default 0;
|
||||
property Visible;
|
||||
|
||||
property OnClick;
|
||||
property OnDblClick;
|
||||
property OnMouseDown;
|
||||
property OnMouseEnter;
|
||||
property OnMouseLeave;
|
||||
property OnMouseMove;
|
||||
property OnMouseUp;
|
||||
end;
|
||||
|
||||
{$IFDEF FPC}procedure Register;{$ENDIF}
|
||||
|
||||
implementation
|
||||
|
||||
uses BCTools;
|
||||
|
||||
{$IFDEF FPC}
|
||||
procedure Register;
|
||||
begin
|
||||
RegisterComponents('BGRA Controls', [TBGRAShape]);
|
||||
end;
|
||||
{$ENDIF}
|
||||
|
||||
{ TBGRAShape }
|
||||
|
||||
procedure TBGRAShape.SetBorderColor(const AValue: TColor);
|
||||
begin
|
||||
if FBorderColor = AValue then
|
||||
exit;
|
||||
FBorderColor := AValue;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBGRAShape.SetBorderGradient(const AValue: TBCGradient);
|
||||
begin
|
||||
if FBorderGradient = AValue then
|
||||
exit;
|
||||
FBorderGradient.Assign(AValue);
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBGRAShape.SetAngle(const AValue: single);
|
||||
begin
|
||||
if FAngle = AValue then
|
||||
exit;
|
||||
FAngle := AValue;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBGRAShape.SetBorderOpacity(const AValue: byte);
|
||||
begin
|
||||
if FBorderOpacity = AValue then
|
||||
exit;
|
||||
FBorderOpacity := AValue;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBGRAShape.SetBorderStyle(const AValue: TPenStyle);
|
||||
begin
|
||||
if FBorderStyle = AValue then
|
||||
exit;
|
||||
FBorderStyle := AValue;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBGRAShape.SetBorderWidth(AValue: integer);
|
||||
begin
|
||||
if AValue < 0 then
|
||||
AValue := 0;
|
||||
if FBorderWidth = AValue then
|
||||
exit;
|
||||
FBorderWidth := AValue;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBGRAShape.SetFillColor(const AValue: TColor);
|
||||
begin
|
||||
if FFillColor = AValue then
|
||||
exit;
|
||||
FFillColor := AValue;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBGRAShape.SetFillGradient(const AValue: TBCGradient);
|
||||
begin
|
||||
if FFillGradient = AValue then
|
||||
exit;
|
||||
FFillGradient.Assign(AValue);
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBGRAShape.SetFillOpacity(const AValue: byte);
|
||||
begin
|
||||
if FFillOpacity = AValue then
|
||||
exit;
|
||||
FFillOpacity := AValue;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBGRAShape.SetRatioXY(const AValue: single);
|
||||
begin
|
||||
if FRatioXY = AValue then
|
||||
exit;
|
||||
FRatioXY := AValue;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBGRAShape.SetRoundRadius(AValue: integer);
|
||||
begin
|
||||
if AValue < 0 then
|
||||
AValue := 0;
|
||||
if FRoundRadius = AValue then
|
||||
exit;
|
||||
FRoundRadius := AValue;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBGRAShape.SetShapeType(const AValue: TBGRAShapeType);
|
||||
begin
|
||||
if FShapeType = AValue then
|
||||
exit;
|
||||
FShapeType := AValue;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBGRAShape.SetSideCount(AValue: integer);
|
||||
begin
|
||||
if AValue < 3 then
|
||||
AValue := 3;
|
||||
if FSideCount = AValue then
|
||||
exit;
|
||||
FSideCount := AValue;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBGRAShape.SetUseBorderGradient(const AValue: boolean);
|
||||
begin
|
||||
if FUseBorderGradient = AValue then
|
||||
exit;
|
||||
FUseBorderGradient := AValue;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBGRAShape.SetUseFillGradient(const AValue: boolean);
|
||||
begin
|
||||
if FUseFillGradient = AValue then
|
||||
exit;
|
||||
FUseFillGradient := AValue;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBGRAShape.SetUseRatioXY(const AValue: boolean);
|
||||
begin
|
||||
if FUseRatioXY = AValue then
|
||||
exit;
|
||||
FUseRatioXY := AValue;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBGRAShape.Paint;
|
||||
var
|
||||
cx, cy, rx, ry, curRatio, a: single;
|
||||
coords: array of TPointF;
|
||||
minCoord, maxCoord: TPointF;
|
||||
i: integer;
|
||||
borderGrad, fillGrad: TBGRACustomScanner;
|
||||
scaling: Double;
|
||||
begin
|
||||
if FBGRA = nil then FBGRA := TBGRABitmap.Create;
|
||||
scaling := GetCanvasScaleFactor;
|
||||
FBGRA.SetSize(round(Width*scaling), round(Height*scaling));
|
||||
|
||||
FBGRA.FillTransparent;
|
||||
FBGRA.PenStyle := FBorderStyle;
|
||||
with FBGRA.Canvas2D do
|
||||
begin
|
||||
lineJoin := 'round';
|
||||
if FUseBorderGradient then
|
||||
begin
|
||||
borderGrad := CreateGradient(FBorderGradient, Classes.rect(0, 0, FBGRA.Width, FBGRA.Height));
|
||||
strokeStyle(borderGrad);
|
||||
end
|
||||
else
|
||||
begin
|
||||
borderGrad := nil;
|
||||
strokeStyle(ColorToBGRA(ColorToRGB(FBorderColor), FBorderOpacity));
|
||||
end;
|
||||
lineStyle(FBGRA.CustomPenStyle);
|
||||
lineWidth := FBorderWidth*scaling;
|
||||
if FUseFillGradient then
|
||||
begin
|
||||
fillGrad := CreateGradient(FFillGradient, Classes.rect(0, 0, FBGRA.Width, FBGRA.Height));
|
||||
fillStyle(fillGrad);
|
||||
end
|
||||
else
|
||||
begin
|
||||
fillGrad := nil;
|
||||
fillStyle(ColorToBGRA(ColorToRGB(FFillColor), FFillOpacity));
|
||||
end;
|
||||
cx := FBGRA.Width / 2;
|
||||
cy := FBGRA.Height / 2;
|
||||
rx := (FBGRA.Width - FBorderWidth*scaling) / 2;
|
||||
ry := (FBGRA.Height - FBorderWidth*scaling) / 2;
|
||||
if FUseRatioXY and (ry <> 0) and (FRatioXY <> 0) then
|
||||
begin
|
||||
curRatio := rx / ry;
|
||||
if FRatioXY > curRatio then
|
||||
ry := ry / (FRatioXY / curRatio)
|
||||
else
|
||||
rx := rx / (curRatio / FRatioXY);
|
||||
end;
|
||||
if FShapeType = stRegularPolygon then
|
||||
begin
|
||||
setlength(coords, FSideCount);
|
||||
for i := 0 to high(coords) do
|
||||
begin
|
||||
a := (i / FSideCount + FAngle / 360) * 2 * Pi;
|
||||
coords[i] := PointF(sin(a), -cos(a));
|
||||
end;
|
||||
minCoord := coords[0];
|
||||
maxCoord := coords[0];
|
||||
for i := 1 to high(coords) do
|
||||
begin
|
||||
if coords[i].x < minCoord.x then
|
||||
minCoord.x := coords[i].x;
|
||||
if coords[i].y < minCoord.y then
|
||||
minCoord.y := coords[i].y;
|
||||
if coords[i].x > maxCoord.x then
|
||||
maxCoord.x := coords[i].x;
|
||||
if coords[i].y > maxCoord.y then
|
||||
maxCoord.y := coords[i].y;
|
||||
end;
|
||||
for i := 0 to high(coords) do
|
||||
begin
|
||||
with (coords[i] - minCoord) do
|
||||
coords[i] := PointF((x / (maxCoord.x - minCoord.x) - 0.5) *
|
||||
2 * rx + cx, (y / (maxCoord.y - minCoord.y) - 0.5) * 2 * ry + cy);
|
||||
end;
|
||||
beginPath;
|
||||
for i := 0 to high(coords) do
|
||||
begin
|
||||
lineTo((coords[i] + coords[(i + 1) mod length(coords)]) * (1 / 2));
|
||||
arcTo(coords[(i + 1) mod length(coords)], coords[(i + 2) mod
|
||||
length(coords)], FRoundRadius);
|
||||
end;
|
||||
closePath;
|
||||
end
|
||||
else
|
||||
begin
|
||||
save;
|
||||
translate(cx, cy);
|
||||
scale(rx, ry);
|
||||
beginPath;
|
||||
arc(0, 0, 1, 0, 2 * Pi);
|
||||
restore;
|
||||
end;
|
||||
|
||||
fill;
|
||||
if FBorderWidth <> 0 then
|
||||
stroke;
|
||||
|
||||
fillStyle(BGRAWhite);
|
||||
strokeStyle(BGRABlack);
|
||||
|
||||
fillGrad.Free;
|
||||
borderGrad.Free;
|
||||
end;
|
||||
FBGRA.Draw(Self.Canvas, rect(0,0,Width,Height), False);
|
||||
end;
|
||||
|
||||
constructor TBGRAShape.Create(AOwner: TComponent);
|
||||
begin
|
||||
inherited Create(AOwner);
|
||||
|
||||
with GetControlClassDefaultSize do
|
||||
SetInitialBounds(0, 0, CX, CY);
|
||||
|
||||
FBGRA := nil;
|
||||
|
||||
FBorderColor := clWindowText;
|
||||
FBorderOpacity := 255;
|
||||
FBorderWidth := 1;
|
||||
FBorderStyle := psSolid;
|
||||
FBorderGradient := TBCGradient.Create(Self);
|
||||
FBorderGradient.Point2XPercent := 100;
|
||||
FBorderGradient.StartColor := clWhite;
|
||||
FBorderGradient.EndColor := clBlack;
|
||||
|
||||
FFillColor := clWindow;
|
||||
FFillOpacity := 255;
|
||||
FFillGradient := TBCGradient.Create(Self);
|
||||
|
||||
FRoundRadius := 0;
|
||||
FSideCount := 4;
|
||||
FRatioXY := 1;
|
||||
FUseRatioXY := False;
|
||||
end;
|
||||
|
||||
destructor TBGRAShape.Destroy;
|
||||
begin
|
||||
FBGRA.Free;
|
||||
FFillGradient.Free;
|
||||
FBorderGradient.Free;
|
||||
inherited Destroy;
|
||||
end;
|
||||
{$IFDEF FPC}
|
||||
procedure TBGRAShape.SaveToFile(AFileName: string);
|
||||
var
|
||||
AStream: TMemoryStream;
|
||||
begin
|
||||
AStream := TMemoryStream.Create;
|
||||
try
|
||||
WriteComponentAsTextToStream(AStream, Self);
|
||||
AStream.SaveToFile(AFileName);
|
||||
finally
|
||||
AStream.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TBGRAShape.LoadFromFile(AFileName: string);
|
||||
var
|
||||
AStream: TMemoryStream;
|
||||
begin
|
||||
AStream := TMemoryStream.Create;
|
||||
try
|
||||
AStream.LoadFromFile(AFileName);
|
||||
ReadComponentFromTextStream(AStream, TComponent(Self), OnFindClass);
|
||||
finally
|
||||
AStream.Free;
|
||||
end;
|
||||
end;
|
||||
{$ENDIF}
|
||||
procedure TBGRAShape.OnFindClass(Reader: TReader; const AClassName: string;
|
||||
var ComponentClass: TComponentClass);
|
||||
begin
|
||||
if CompareText(AClassName, 'TBGRAShape') = 0 then
|
||||
ComponentClass := TBGRAShape;
|
||||
end;
|
||||
|
||||
end.
|
||||
111
bgracontrols/bgraspeedbutton.pas
Normal file
111
bgracontrols/bgraspeedbutton.pas
Normal file
@@ -0,0 +1,111 @@
|
||||
// SPDX-License-Identifier: LGPL-3.0-linking-exception
|
||||
{ This component partialy solve problem with no alpha in lazarus GTK.
|
||||
It is using BGRABitmap library for drawing icons.
|
||||
|
||||
originally written in 2011 by Krzysztof Dibowski dibowski at interia.pl
|
||||
}
|
||||
{******************************* CONTRIBUTOR(S) ******************************
|
||||
- Edivando S. Santos Brasil | mailedivando@gmail.com
|
||||
(Compatibility with delphi VCL 11/2018)
|
||||
|
||||
***************************** END CONTRIBUTOR(S) *****************************}
|
||||
unit BGRASpeedButton;
|
||||
|
||||
{$I bgracontrols.inc}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils, {$IFDEF FPC}LResources,{$ENDIF} Forms, Controls, Graphics, Dialogs, Buttons, BGRABitmap,
|
||||
{$IFNDEF FPC}Types, BGRAGraphics, GraphType, FPImage, {$ENDIF}
|
||||
BGRABitmapTypes;
|
||||
|
||||
{$IFDEF LCLgtk}
|
||||
{$DEFINE BGRA_DRAW}
|
||||
{$ELSE}
|
||||
{$IFDEF LCLgtk2}
|
||||
{$DEFINE BGRA_DRAW}
|
||||
{$ENDIF}
|
||||
{$ENDIF}
|
||||
|
||||
type
|
||||
|
||||
{ TBGRASpeedButton }
|
||||
|
||||
TBGRASpeedButton = class(TSpeedButton)
|
||||
private
|
||||
{ Private declarations }
|
||||
{$IFDEF BGRA_DRAW}
|
||||
FBGRA: TBGRABitmap;
|
||||
{$ENDIF}
|
||||
protected
|
||||
{ Protected declarations }
|
||||
{$IFDEF BGRA_DRAW}
|
||||
function DrawGlyph(ACanvas: TCanvas; const AClient: TRect;
|
||||
const AOffset: TPoint; AState: TButtonState; {%H-}ATransparent: boolean;
|
||||
{%H-}BiDiFlags: longint): TRect; override;
|
||||
{$ENDIF}
|
||||
public
|
||||
{ Public declarations }
|
||||
{$IFDEF BGRA_DRAW}
|
||||
constructor Create(AOwner: TComponent); override;
|
||||
destructor Destroy; override;
|
||||
{$ENDIF}
|
||||
published
|
||||
{ Published declarations }
|
||||
end;
|
||||
|
||||
{$IFDEF FPC}procedure Register;{$ENDIF}
|
||||
|
||||
implementation
|
||||
|
||||
{$IFDEF FPC}
|
||||
procedure Register;
|
||||
begin
|
||||
RegisterComponents('BGRA Button Controls', [TBGRASpeedButton]);
|
||||
end;
|
||||
{$ENDIF}
|
||||
|
||||
{$IFDEF BGRA_DRAW}
|
||||
{ TBGRASpeedButton }
|
||||
|
||||
function TBGRASpeedButton.DrawGlyph(ACanvas: TCanvas; const AClient: TRect;
|
||||
const AOffset: TPoint; AState: TButtonState; ATransparent: boolean;
|
||||
BiDiFlags: longint): TRect;
|
||||
begin
|
||||
{*** We are using BGRABitmap drawing only ***}
|
||||
{Result := inherited DrawGlyph(ACanvas, AClient, AOffset, AState,
|
||||
ATransparent, BiDiFlags); }
|
||||
|
||||
if not Assigned(Glyph) then
|
||||
begin
|
||||
Result := Rect(0,0,0,0);
|
||||
Exit;
|
||||
end;
|
||||
{ It's not good solution assigning glyph on each draw call but FGlyph and SetGlyph is
|
||||
in private section }
|
||||
FBGRA.Assign(Glyph);
|
||||
|
||||
if (AState = bsDown) or (Down = True) then
|
||||
FBGRA.Draw(ACanvas, AOffset.x + 1, AOffset.y + 1, False)
|
||||
else
|
||||
FBGRA.Draw(ACanvas, AOffset.x, AOffset.y, False);
|
||||
|
||||
Result := AClient;
|
||||
end;
|
||||
|
||||
constructor TBGRASpeedButton.Create(AOwner: TComponent);
|
||||
begin
|
||||
inherited Create(AOwner);
|
||||
FBGRA := TBGRABitmap.Create;
|
||||
end;
|
||||
|
||||
destructor TBGRASpeedButton.Destroy;
|
||||
begin
|
||||
FBGRA.Free;
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
{$ENDIF}
|
||||
|
||||
end.
|
||||
836
bgracontrols/bgraspriteanimation.pas
Normal file
836
bgracontrols/bgraspriteanimation.pas
Normal file
@@ -0,0 +1,836 @@
|
||||
// SPDX-License-Identifier: LGPL-3.0-linking-exception
|
||||
{
|
||||
Created by BGRA Controls Team
|
||||
Dibo, Circular, lainz (007) and contributors.
|
||||
For detailed information see readme.txt
|
||||
|
||||
Site: https://sourceforge.net/p/bgra-controls/
|
||||
Wiki: http://wiki.lazarus.freepascal.org/BGRAControls
|
||||
Forum: http://forum.lazarus.freepascal.org/index.php/board,46.0.html
|
||||
}
|
||||
{******************************* CONTRIBUTOR(S) ******************************
|
||||
- Edivando S. Santos Brasil | mailedivando@gmail.com
|
||||
(Compatibility with delphi VCL 11/2018)
|
||||
- FreeMan35
|
||||
|
||||
***************************** END CONTRIBUTOR(S) *****************************}
|
||||
unit BGRASpriteAnimation;
|
||||
|
||||
{$I bgracontrols.inc}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, Controls, Dialogs, ExtCtrls, Forms, {$IFDEF FPC}LCLIntF, LResources,{$ENDIF} Graphics,
|
||||
{$IFNDEF FPC}Types, BGRAGraphics, GraphType, FPImage, {$ENDIF}
|
||||
BCBaseCtrls, BGRABitmap, BGRABitmapTypes, BCTypes, BGRAAnimatedGif;
|
||||
|
||||
type
|
||||
TBGRASpriteAnimation = class;
|
||||
|
||||
{ TSpriteBitmap }
|
||||
|
||||
TSpriteBitmap = class(TBitmap)
|
||||
private
|
||||
FOwner: TBGRASpriteAnimation;
|
||||
protected
|
||||
procedure AssignTo(Dest: TPersistent); override;
|
||||
public
|
||||
constructor Create(AOwner: TBGRASpriteAnimation); overload;
|
||||
procedure Assign(Source: TPersistent); override;
|
||||
end;
|
||||
|
||||
TFlipMode = (flNone, flHorizontal, flVertical, flBoth);
|
||||
TRotationMode = (rtNone, rtClockWise, rtCounterClockWise, rt180);
|
||||
|
||||
{ TBGRASpriteAnimation }
|
||||
|
||||
TBGRASpriteAnimation = class(TBGRAGraphicCtrl)
|
||||
private
|
||||
{ Private declarations }
|
||||
FAnimInvert: boolean;
|
||||
FAnimPosition: cardinal;
|
||||
FAnimRepeat: cardinal;
|
||||
FAnimRepeatLap: cardinal;
|
||||
FAnimSpeed: cardinal;
|
||||
FAnimStatic: boolean;
|
||||
FAnimTimer: TTimer;
|
||||
FCenter: boolean;
|
||||
FOnLapChanged: TNotifyEvent;
|
||||
FOnLapChanging: TNotifyEvent;
|
||||
FOnPositionChanged: TNotifyEvent;
|
||||
FOnPositionChanging: TNotifyEvent;
|
||||
FOnRedrawAfter: TBGRARedrawEvent;
|
||||
FOnRedrawBefore: TBGRARedrawEvent;
|
||||
FProportional: boolean;
|
||||
FSprite: TBitmap;
|
||||
FSpriteCount: cardinal;
|
||||
FSpriteFillOpacity: byte;
|
||||
FSpriteFlipMode: TFlipMode;
|
||||
FSpriteKeyColor: TColor;
|
||||
FSpriteResampleFilter: TResampleFilter;
|
||||
FSpriteResampleMode: TResampleMode;
|
||||
FSpriteRotation: TRotationMode;
|
||||
FStretch: boolean;
|
||||
FTile: boolean;
|
||||
function DoCalculateDestRect(AWidth, AHeight: integer): TRect;
|
||||
function DoCalculatePosition(AValue: integer): integer;
|
||||
function DoCalculateSize(AValue: cardinal): cardinal;
|
||||
procedure DoAnimTimerOnTimer({%H-}Sender: TObject);
|
||||
procedure DoSpriteDraw(ABitmap: TBGRABitmap);
|
||||
procedure DoSpriteFillOpacity(ABitmap: TBGRABitmap);
|
||||
procedure DoSpriteFlip(ABitmap: TBGRABitmap);
|
||||
procedure DoSpriteKeyColor(ABitmap: TBGRABitmap);
|
||||
procedure DoSpriteResampleFilter(ABitmap: TBGRABitmap);
|
||||
procedure SetFAnimInvert(const AValue: boolean);
|
||||
procedure SetFAnimPosition(const AValue: cardinal);
|
||||
procedure SetFAnimRepeat(const AValue: cardinal);
|
||||
procedure SetFAnimRepeatLap(const AValue: cardinal);
|
||||
procedure SetFAnimSpeed(const AValue: cardinal);
|
||||
procedure SetFAnimStatic(const AValue: boolean);
|
||||
procedure SetFCenter(const AValue: boolean);
|
||||
procedure SetFProportional(const AValue: boolean);
|
||||
procedure SetFSprite(const AValue: TBitmap);
|
||||
procedure SetFSpriteCount(const AValue: cardinal);
|
||||
procedure SetFSpriteFillOpacity(const AValue: byte);
|
||||
procedure SetFSpriteFlipMode(const AValue: TFlipMode);
|
||||
procedure SetFSpriteKeyColor(const AValue: TColor);
|
||||
procedure SetFSpriteResampleFilter(const AValue: TResampleFilter);
|
||||
procedure SetFSpriteResampleMode(const AValue: TResampleMode);
|
||||
procedure SetFSpriteRotation(const AValue: TRotationMode);
|
||||
procedure SetFStretch(const AValue: boolean);
|
||||
procedure SetFTile(const AValue: boolean);
|
||||
procedure SpriteChange(Sender: TObject);
|
||||
protected
|
||||
{ Protected declarations }
|
||||
procedure Paint; override;
|
||||
procedure CalculatePreferredSize(var PreferredWidth, PreferredHeight: integer;
|
||||
{%H-}WithThemeSpace: Boolean); override;
|
||||
public
|
||||
{ Public declarations }
|
||||
procedure GifImageToSprite(Gif: TBGRAAnimatedGif);
|
||||
procedure SpriteToGifImage(Gif: TBGRAAnimatedGif);
|
||||
procedure LoadFromResourceName(Instance: THandle; const ResName: string); overload;
|
||||
procedure LoadFromBitmapResource(const Resource: string); overload;
|
||||
{$IF BGRABitmapVersion > 11030100}
|
||||
procedure LoadFromBitmapStream(AStream: TStream);
|
||||
{$ENDIF}
|
||||
procedure LoadFromBGRABitmap(const BGRA: TBGRABitmap);
|
||||
procedure SpriteToAnimatedGif(Filename: string);
|
||||
procedure AnimatedGifToSprite(Filename: string);
|
||||
constructor Create(AOwner: TComponent); override;
|
||||
destructor Destroy; override;
|
||||
published
|
||||
{ Published declarations }
|
||||
property AnimInvert: boolean read FAnimInvert write SetFAnimInvert;
|
||||
property AnimPosition: cardinal read FAnimPosition write SetFAnimPosition;
|
||||
property AnimRepeat: cardinal read FAnimRepeat write SetFAnimRepeat;
|
||||
property AnimRepeatLap: cardinal read FAnimRepeatLap write SetFAnimRepeatLap;
|
||||
property AnimSpeed: cardinal read FAnimSpeed write SetFAnimSpeed;
|
||||
property AnimStatic: boolean read FAnimStatic write SetFAnimStatic;
|
||||
property Center: boolean read FCenter write SetFCenter;
|
||||
property Proportional: boolean read FProportional write SetFProportional;
|
||||
property Sprite: TBitmap read FSprite write SetFSprite;
|
||||
property SpriteCount: cardinal read FSpriteCount write SetFSpriteCount;
|
||||
property SpriteFillOpacity: byte read FSpriteFillOpacity write SetFSpriteFillOpacity;
|
||||
property SpriteFlipMode: TFlipMode read FSpriteFlipMode write SetFSpriteFlipMode;
|
||||
property SpriteKeyColor: TColor read FSpriteKeyColor write SetFSpriteKeyColor;
|
||||
property SpriteResampleFilter: TResampleFilter
|
||||
read FSpriteResampleFilter write SetFSpriteResampleFilter;
|
||||
property SpriteResampleMode: TResampleMode
|
||||
read FSpriteResampleMode write SetFSpriteResampleMode;
|
||||
property SpriteRotation: TRotationMode read FSpriteRotation write SetFSpriteRotation;
|
||||
property Stretch: boolean read FStretch write SetFStretch;
|
||||
property Tile: boolean read FTile write SetFTile;
|
||||
published
|
||||
property Align;
|
||||
property Anchors;
|
||||
property AutoSize;
|
||||
property Caption;
|
||||
property Color;
|
||||
property Enabled;
|
||||
property OnClick;
|
||||
property OnDblClick;
|
||||
property OnLapChanged: TNotifyEvent read FOnLapChanged write FOnLapChanged;
|
||||
property OnLapChanging: TNotifyEvent read FOnLapChanging write FOnLapChanging;
|
||||
property OnMouseDown;
|
||||
property OnMouseEnter;
|
||||
property OnMouseLeave;
|
||||
property OnMouseMove;
|
||||
property OnMouseUp;
|
||||
property OnPositionChanged: TNotifyEvent
|
||||
read FOnPositionChanged write FOnPositionChanged;
|
||||
property OnPositionChanging: TNotifyEvent
|
||||
read FOnPositionChanging write FOnPositionChanging;
|
||||
property OnRedrawAfter: TBGRARedrawEvent read FOnRedrawAfter write FOnRedrawAfter;
|
||||
property OnRedrawBefore: TBGRARedrawEvent read FOnRedrawBefore write FOnRedrawBefore;
|
||||
property PopupMenu;
|
||||
property Visible;
|
||||
end;
|
||||
|
||||
{$IFDEF FPC}procedure Register;{$ENDIF}
|
||||
|
||||
implementation
|
||||
|
||||
{$IFDEF FPC}
|
||||
procedure Register;
|
||||
begin
|
||||
RegisterComponents('BGRA Controls', [TBGRASpriteAnimation]);
|
||||
end;
|
||||
|
||||
{ TSpriteBitmap }
|
||||
|
||||
procedure TSpriteBitmap.AssignTo(Dest: TPersistent);
|
||||
begin
|
||||
if Dest is TBGRAAnimatedGif then
|
||||
FOwner.SpriteToGifImage(TBGRAAnimatedGif(Dest));
|
||||
inherited AssignTo(Dest);
|
||||
end;
|
||||
|
||||
constructor TSpriteBitmap.Create(AOwner: TBGRASpriteAnimation);
|
||||
begin
|
||||
inherited Create;
|
||||
FOwner := AOwner;
|
||||
end;
|
||||
|
||||
procedure TSpriteBitmap.Assign(Source: TPersistent);
|
||||
begin
|
||||
if Source is TBGRAAnimatedGif then
|
||||
FOwner.GifImageToSprite(TBGRAAnimatedGif(Source))
|
||||
else
|
||||
inherited Assign(Source);
|
||||
end;
|
||||
|
||||
{$ENDIF}
|
||||
|
||||
{ TBGRASpriteAnimation }
|
||||
|
||||
{ Animation Variables }
|
||||
|
||||
procedure TBGRASpriteAnimation.SetFAnimInvert(const AValue: boolean);
|
||||
begin
|
||||
if FAnimInvert = AValue then
|
||||
Exit;
|
||||
FAnimInvert := AValue;
|
||||
|
||||
if csDesigning in ComponentState then
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBGRASpriteAnimation.SetFAnimPosition(const AValue: cardinal);
|
||||
begin
|
||||
if FAnimPosition = AValue then
|
||||
Exit;
|
||||
if (AValue < 1) or (AValue > FSpriteCount) then
|
||||
FAnimPosition := 1
|
||||
else
|
||||
FAnimPosition := AValue;
|
||||
|
||||
if Assigned(FOnPositionChanged) then
|
||||
FOnPositionChanged(Self);
|
||||
|
||||
if csDesigning in ComponentState then
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBGRASpriteAnimation.SetFAnimRepeat(const AValue: cardinal);
|
||||
begin
|
||||
if FAnimRepeat = AValue then
|
||||
Exit;
|
||||
FAnimRepeat := AValue;
|
||||
end;
|
||||
|
||||
procedure TBGRASpriteAnimation.SetFAnimRepeatLap(const AValue: cardinal);
|
||||
begin
|
||||
if (FAnimRepeatLap = AValue) then
|
||||
Exit;
|
||||
FAnimRepeatLap := AValue;
|
||||
|
||||
if (AValue = FAnimRepeat) and (AValue <> 0) then
|
||||
begin
|
||||
if csDesigning in ComponentState then
|
||||
Exit;
|
||||
SetFAnimStatic(True);
|
||||
end;
|
||||
|
||||
if Assigned(FOnLapChanged) then
|
||||
FOnLapChanged(Self);
|
||||
end;
|
||||
|
||||
procedure TBGRASpriteAnimation.SetFAnimSpeed(const AValue: cardinal);
|
||||
begin
|
||||
if FAnimSpeed = AValue then
|
||||
Exit;
|
||||
FAnimSpeed := AValue;
|
||||
FAnimTimer.Interval := AValue;
|
||||
end;
|
||||
|
||||
procedure TBGRASpriteAnimation.SetFAnimStatic(const AValue: boolean);
|
||||
begin
|
||||
if FAnimStatic = AValue then
|
||||
Exit;
|
||||
FAnimStatic := AValue;
|
||||
|
||||
if csDesigning in ComponentState then
|
||||
Exit;
|
||||
FAnimTimer.Enabled := not AValue;
|
||||
end;
|
||||
|
||||
{ Sprite Variables }
|
||||
|
||||
procedure TBGRASpriteAnimation.SetFSprite(const AValue: TBitmap);
|
||||
begin
|
||||
if (FSprite = AValue) or (AValue = nil) then
|
||||
Exit;
|
||||
|
||||
FSprite.Assign(AValue);
|
||||
end;
|
||||
|
||||
procedure TBGRASpriteAnimation.SetFSpriteCount(const AValue: cardinal);
|
||||
begin
|
||||
if (FSpriteCount = AValue) or (FSprite = nil) then
|
||||
Exit;
|
||||
|
||||
if (AValue < 1) or (AValue > cardinal(FSprite.Width)) then
|
||||
FSpriteCount := 1
|
||||
else
|
||||
FSpriteCount := AValue;
|
||||
|
||||
if AnimPosition > AValue then
|
||||
SetFAnimPosition(1);
|
||||
|
||||
Invalidate;
|
||||
InvalidatePreferredSize;
|
||||
AdjustSize;
|
||||
end;
|
||||
|
||||
procedure TBGRASpriteAnimation.SetFSpriteFillOpacity(const AValue: byte);
|
||||
begin
|
||||
if FSpriteFillOpacity = AValue then
|
||||
Exit;
|
||||
FSpriteFillOpacity := AValue;
|
||||
|
||||
if csDesigning in ComponentState then
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBGRASpriteAnimation.SetFSpriteFlipMode(const AValue: TFlipMode);
|
||||
begin
|
||||
if FSpriteFlipMode = AValue then
|
||||
Exit;
|
||||
FSpriteFlipMode := AValue;
|
||||
|
||||
if csDesigning in ComponentState then
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBGRASpriteAnimation.SetFSpriteKeyColor(const AValue: TColor);
|
||||
begin
|
||||
if FSpriteKeyColor = AValue then
|
||||
Exit;
|
||||
FSpriteKeyColor := AValue;
|
||||
|
||||
if csDesigning in ComponentState then
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBGRASpriteAnimation.SetFSpriteResampleFilter(const AValue: TResampleFilter);
|
||||
begin
|
||||
if FSpriteResampleFilter = AValue then
|
||||
Exit;
|
||||
FSpriteResampleFilter := AValue;
|
||||
|
||||
if csDesigning in ComponentState then
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBGRASpriteAnimation.SetFSpriteResampleMode(const AValue: TResampleMode);
|
||||
begin
|
||||
if FSpriteResampleMode = AValue then
|
||||
Exit;
|
||||
FSpriteResampleMode := AValue;
|
||||
|
||||
if csDesigning in ComponentState then
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBGRASpriteAnimation.SetFSpriteRotation(const AValue: TRotationMode);
|
||||
begin
|
||||
if FSpriteRotation = AValue then
|
||||
Exit;
|
||||
FSpriteRotation := AValue;
|
||||
|
||||
if csDesigning in ComponentState then
|
||||
Invalidate;
|
||||
InvalidatePreferredSize;
|
||||
AdjustSize;
|
||||
end;
|
||||
|
||||
{ General Variables }
|
||||
|
||||
procedure TBGRASpriteAnimation.SetFCenter(const AValue: boolean);
|
||||
begin
|
||||
if FCenter = AValue then
|
||||
Exit;
|
||||
FCenter := AValue;
|
||||
|
||||
if csDesigning in ComponentState then
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBGRASpriteAnimation.SetFProportional(const AValue: boolean);
|
||||
begin
|
||||
if FProportional = AValue then
|
||||
Exit;
|
||||
FProportional := AValue;
|
||||
|
||||
if csDesigning in ComponentState then
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBGRASpriteAnimation.SetFStretch(const AValue: boolean);
|
||||
begin
|
||||
if FStretch = AValue then
|
||||
Exit;
|
||||
FStretch := AValue;
|
||||
|
||||
if csDesigning in ComponentState then
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBGRASpriteAnimation.SetFTile(const AValue: boolean);
|
||||
begin
|
||||
if FTile = AValue then
|
||||
Exit;
|
||||
FTile := AValue;
|
||||
|
||||
if csDesigning in ComponentState then
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBGRASpriteAnimation.SpriteChange(Sender: TObject);
|
||||
begin
|
||||
Invalidate;
|
||||
InvalidatePreferredSize;
|
||||
AdjustSize;
|
||||
end;
|
||||
|
||||
{ Utils }
|
||||
|
||||
function TBGRASpriteAnimation.DoCalculateDestRect(AWidth, AHeight: integer): TRect;
|
||||
var
|
||||
PicWidth: integer;
|
||||
PicHeight: integer;
|
||||
ImgWidth: integer;
|
||||
ImgHeight: integer;
|
||||
w: integer;
|
||||
h: integer;
|
||||
begin
|
||||
PicWidth := AWidth;
|
||||
PicHeight := AHeight;
|
||||
ImgWidth := ClientWidth;
|
||||
ImgHeight := ClientHeight;
|
||||
if Stretch or (Proportional and ((PicWidth > ImgWidth) or
|
||||
(PicHeight > ImgHeight))) then
|
||||
begin
|
||||
if Proportional and (PicWidth > 0) and (PicHeight > 0) then
|
||||
begin
|
||||
w := ImgWidth;
|
||||
h := (PicHeight * w) div PicWidth;
|
||||
if h > ImgHeight then
|
||||
begin
|
||||
h := ImgHeight;
|
||||
w := (PicWidth * h) div PicHeight;
|
||||
end;
|
||||
PicWidth := w;
|
||||
PicHeight := h;
|
||||
end
|
||||
else
|
||||
begin
|
||||
PicWidth := ImgWidth;
|
||||
PicHeight := ImgHeight;
|
||||
end;
|
||||
end;
|
||||
|
||||
Result := Rect(0, 0, PicWidth, PicHeight);
|
||||
|
||||
if Center then
|
||||
OffsetRect(Result, (ImgWidth - PicWidth) div 2, (ImgHeight - PicHeight) div 2);
|
||||
end;
|
||||
|
||||
function TBGRASpriteAnimation.DoCalculatePosition(AValue: integer): integer;
|
||||
begin
|
||||
if FAnimInvert then
|
||||
Result := -AValue * (FSpriteCount - FAnimPosition)
|
||||
else
|
||||
Result := -AValue * (FAnimPosition - 1);
|
||||
end;
|
||||
|
||||
function TBGRASpriteAnimation.DoCalculateSize(AValue: cardinal): cardinal;
|
||||
begin
|
||||
Result := AValue div FSpriteCount;
|
||||
end;
|
||||
|
||||
procedure TBGRASpriteAnimation.DoSpriteResampleFilter(ABitmap: TBGRABitmap);
|
||||
begin
|
||||
ABitmap.ResampleFilter := FSpriteResampleFilter;
|
||||
end;
|
||||
|
||||
procedure TBGRASpriteAnimation.DoSpriteFillOpacity(ABitmap: TBGRABitmap);
|
||||
begin
|
||||
if FSpriteFillOpacity <> 255 then
|
||||
ABitmap.ApplyGlobalOpacity(FSpriteFillOpacity);
|
||||
end;
|
||||
|
||||
procedure TBGRASpriteAnimation.DoSpriteFlip(ABitmap: TBGRABitmap);
|
||||
begin
|
||||
case FSpriteFlipMode of
|
||||
flNone: Exit;
|
||||
flHorizontal: ABitmap.HorizontalFlip;
|
||||
flVertical: ABitmap.VerticalFlip;
|
||||
flBoth:
|
||||
begin
|
||||
ABitmap.HorizontalFlip;
|
||||
ABitmap.VerticalFlip;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TBGRASpriteAnimation.DoSpriteKeyColor(ABitmap: TBGRABitmap);
|
||||
begin
|
||||
if FSpriteKeyColor <> clNone then
|
||||
ABitmap.ReplaceColor(ColorToBGRA(ColorToRGB(FSpriteKeyColor), 255),
|
||||
BGRAPixelTransparent);
|
||||
end;
|
||||
|
||||
{ Main }
|
||||
|
||||
procedure TBGRASpriteAnimation.Paint;
|
||||
|
||||
procedure DrawFrame;
|
||||
begin
|
||||
with inherited Canvas do
|
||||
begin
|
||||
Pen.Color := clBlack;
|
||||
Pen.Style := graphics.psDash;
|
||||
MoveTo(0, 0);
|
||||
LineTo(Self.Width - 1, 0);
|
||||
LineTo(Self.Width - 1, Self.Height - 1);
|
||||
LineTo(0, Self.Height - 1);
|
||||
LineTo(0, 0);
|
||||
end;
|
||||
end;
|
||||
|
||||
var
|
||||
TempSprite, TempSpriteBGRA: TBGRABitmap;
|
||||
TempSpriteWidth, TempSpriteHeight, TempSpritePosition: integer;
|
||||
begin
|
||||
if (Color <> clNone) and (Color <> clDefault) then
|
||||
begin
|
||||
Canvas.Brush.Color := Color;
|
||||
Canvas.Brush.Style := bsSolid;
|
||||
Canvas.FillRect(ClientRect);
|
||||
end;
|
||||
|
||||
if csDesigning in ComponentState then
|
||||
DrawFrame;
|
||||
|
||||
if FSprite = nil then
|
||||
Exit;
|
||||
|
||||
if (Width > 0) and (Height > 0) then
|
||||
begin
|
||||
TempSpriteWidth := DoCalculateSize(FSprite.Width);
|
||||
TempSpriteHeight := FSprite.Height;
|
||||
TempSpritePosition := DoCalculatePosition(TempSpriteWidth);
|
||||
|
||||
TempSpriteBGRA := TBGRABitmap.Create(FSprite);
|
||||
TempSprite := TBGRABitmap.Create(TempSpriteWidth, TempSpriteHeight);
|
||||
TempSprite.BlendImage(TempSpritePosition, 0, TempSpriteBGRA, boLinearBlend);
|
||||
TempSpriteBGRA.Free;
|
||||
|
||||
if Assigned(FOnRedrawBefore) then
|
||||
FOnRedrawBefore(Self, TempSprite);
|
||||
|
||||
DoSpriteDraw(TempSprite);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TBGRASpriteAnimation.CalculatePreferredSize(var PreferredWidth,
|
||||
PreferredHeight: integer; WithThemeSpace: Boolean);
|
||||
begin
|
||||
if SpriteRotation in [rtClockWise,rtCounterClockWise] then
|
||||
begin
|
||||
PreferredWidth := Sprite.Height;
|
||||
PreferredHeight := Sprite.Width div SpriteCount;
|
||||
end else
|
||||
begin
|
||||
PreferredWidth := Sprite.Width div SpriteCount;
|
||||
PreferredHeight := Sprite.Height;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TBGRASpriteAnimation.GifImageToSprite(Gif: TBGRAAnimatedGif);
|
||||
{$IF BGRABitmapVersion > 11030100}
|
||||
var
|
||||
TempBitmap: TBGRABitmap;
|
||||
n: integer;
|
||||
begin
|
||||
if Gif.Count = 0 then exit;
|
||||
TempBitmap := TBGRABitmap.Create(Gif.Width * Gif.Count, Gif.Height);
|
||||
try
|
||||
for n := 0 to Gif.Count-1 do
|
||||
begin
|
||||
Gif.CurrentImage := n;
|
||||
TempBitmap.PutImage(Gif.Width * n, 0, Gif.MemBitmap, dmSet);
|
||||
end;
|
||||
TempBitmap.AssignToBitmap(FSprite);
|
||||
SpriteCount := Gif.Count;
|
||||
AnimSpeed := Gif.TotalAnimationTimeMs div Gif.Count;
|
||||
finally
|
||||
TempBitmap.Free;
|
||||
end;
|
||||
{$ELSE}
|
||||
var
|
||||
TempBitmap: TBGRABitmap;
|
||||
n: integer;
|
||||
begin
|
||||
if Gif.Count = 0 then exit;
|
||||
|
||||
TempBitmap := TBGRABitmap.Create(Gif.Width * Gif.Count, Gif.Height);
|
||||
for n := 0 to Gif.Count do
|
||||
begin
|
||||
Gif.CurrentImage := n;
|
||||
TempBitmap.BlendImage(Gif.Width * n, 0, Gif.MemBitmap, boLinearBlend);
|
||||
end;
|
||||
|
||||
AnimSpeed := Gif.TotalAnimationTimeMs div Gif.Count;
|
||||
FSpriteCount := Gif.Count;
|
||||
FSprite.Width := Gif.Width * Gif.Count;
|
||||
FSprite.Height := Gif.Height;
|
||||
FSprite.Canvas.Brush.Color := SpriteKeyColor;
|
||||
FSprite.Canvas.FillRect(Rect(0, 0, FSprite.Width, FSprite.Height));
|
||||
FSprite.Canvas.Draw(0, 0, TempBitmap.Bitmap);
|
||||
TempBitmap.Free;
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
procedure TBGRASpriteAnimation.SpriteToGifImage(Gif: TBGRAAnimatedGif);
|
||||
var
|
||||
i: integer;
|
||||
TempSpriteWidth: Integer;
|
||||
TempSpritePosition: Integer;
|
||||
TempSpriteBGRA, TempSprite: TBGRABitmap;
|
||||
begin
|
||||
gif.Clear;
|
||||
if AnimRepeat > high(Word) then
|
||||
gif.LoopCount := 0
|
||||
else
|
||||
gif.LoopCount := AnimRepeat;
|
||||
TempSpriteBGRA := TBGRABitmap.Create(FSprite);
|
||||
TempSpriteWidth := TempSpriteBGRA.Width div FSpriteCount;
|
||||
gif.SetSize(TempSpriteWidth, TempSpriteBGRA.Height);
|
||||
for i:=0 to FSpriteCount-1 do
|
||||
begin
|
||||
TempSpritePosition := -TempSpriteWidth * i;
|
||||
TempSprite := TBGRABitmap.Create(TempSpriteWidth, TempSpriteBGRA.Height);
|
||||
TempSprite.BlendImage(TempSpritePosition, 0, TempSpriteBGRA, boLinearBlend);
|
||||
gif.AddFullFrame(TempSprite, FAnimSpeed);
|
||||
TempSprite.Free;
|
||||
end;
|
||||
TempSpriteBGRA.Free;
|
||||
end;
|
||||
|
||||
procedure TBGRASpriteAnimation.LoadFromResourceName(Instance: THandle;
|
||||
const ResName: string);
|
||||
var
|
||||
TempGif: TBGRAAnimatedGif;
|
||||
begin
|
||||
TempGif := TBGRAAnimatedGif.Create;
|
||||
{$IFDEF FPC}//#
|
||||
TempGif.LoadFromResourceName(Instance, ResName);
|
||||
{$ENDIF}
|
||||
GifImageToSprite(TempGif);
|
||||
|
||||
TempGif.Free;
|
||||
end;
|
||||
|
||||
procedure TBGRASpriteAnimation.LoadFromBitmapResource(const Resource: string);
|
||||
{$IF BGRABitmapVersion > 11030100}
|
||||
var
|
||||
stream: TStream;
|
||||
begin
|
||||
stream := BGRAResource.GetResourceStream(Resource);
|
||||
try
|
||||
LoadFromBitmapStream(stream);
|
||||
finally
|
||||
stream.Free;
|
||||
end;
|
||||
{$ELSE}
|
||||
var
|
||||
tempGif: TBGRAAnimatedGif;
|
||||
begin
|
||||
tempGif := TBGRAAnimatedGif.Create;
|
||||
try
|
||||
tempGif.LoadFromResource(Resource);
|
||||
GifImageToSprite(tempGif);
|
||||
finally
|
||||
tempGif.Free;
|
||||
end;
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
{$IF BGRABitmapVersion > 11030100}
|
||||
procedure TBGRASpriteAnimation.LoadFromBitmapStream(AStream: TStream);
|
||||
var
|
||||
tempGif: TBGRAAnimatedGif;
|
||||
tempBGRA: TBGRABitmap;
|
||||
begin
|
||||
if DetectFileFormat(AStream) = ifGif then
|
||||
begin
|
||||
tempGif := TBGRAAnimatedGif.Create;
|
||||
try
|
||||
tempGif.LoadFromStream(AStream);
|
||||
GifImageToSprite(tempGif);
|
||||
finally
|
||||
tempGif.Free;
|
||||
end;
|
||||
end else
|
||||
begin
|
||||
tempBGRA := TBGRABitmap.Create;
|
||||
try
|
||||
tempBGRA.LoadFromStream(AStream);
|
||||
tempBGRA.AssignToBitmap(FSprite);
|
||||
finally
|
||||
tempBGRA.FRee;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
{$ENDIF}
|
||||
|
||||
procedure TBGRASpriteAnimation.LoadFromBGRABitmap(const BGRA: TBGRABitmap);
|
||||
begin
|
||||
{$IF BGRABitmapVersion > 11030100}
|
||||
BGRA.AssignToBitmap(FSprite);
|
||||
{$ELSE}
|
||||
FSprite.Width := BGRA.Width;
|
||||
FSprite.Height := BGRA.Height;
|
||||
BGRA.Draw(FSprite.Canvas, 0, 0, False);
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
procedure TBGRASpriteAnimation.SpriteToAnimatedGif(Filename: string);
|
||||
var
|
||||
gif : TBGRAAnimatedGif;
|
||||
begin
|
||||
gif := TBGRAAnimatedGif.Create;
|
||||
SpriteToGifImage(Gif);
|
||||
gif.SaveToFile(Filename);
|
||||
gif.Free;
|
||||
end;
|
||||
|
||||
procedure TBGRASpriteAnimation.AnimatedGifToSprite(Filename: string);
|
||||
var
|
||||
TempGif: TBGRAAnimatedGif;
|
||||
begin
|
||||
TempGif := TBGRAAnimatedGif.Create(Filename);
|
||||
try
|
||||
GifImageToSprite(TempGif);
|
||||
finally
|
||||
TempGif.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TBGRASpriteAnimation.DoSpriteDraw(ABitmap: TBGRABitmap);
|
||||
var
|
||||
TempRect: TRect;
|
||||
begin
|
||||
DoSpriteResampleFilter(ABitmap);
|
||||
DoSpriteKeyColor(ABitmap);
|
||||
DoSpriteFillOpacity(ABitmap);
|
||||
DoSpriteFlip(ABitmap);
|
||||
|
||||
case FSpriteRotation of
|
||||
rtClockWise: BGRAReplace(ABitmap, ABitmap.RotateCW);
|
||||
rtCounterClockWise: BGRAReplace(ABitmap, ABitmap.RotateCCW);
|
||||
rt180: ABitmap.RotateUDInplace;
|
||||
end;
|
||||
|
||||
{ TODO -oLainz : If there is no Sprite loaded and you set 'Tile' to true a division by cero error is shown }
|
||||
if Tile then
|
||||
BGRAReplace(ABitmap, ABitmap.GetPart(rect(0, 0, Width, Height)));
|
||||
|
||||
TempRect := DoCalculateDestRect(ABitmap.Width, ABitmap.Height);
|
||||
|
||||
if Assigned(FOnRedrawAfter) then
|
||||
FOnRedrawAfter(Self, ABitmap);
|
||||
|
||||
if Stretch and (FSpriteResampleMode = rmFineResample) then
|
||||
BGRAReplace(ABitmap, ABitmap.Resample(Width, Height, FSpriteResampleMode));
|
||||
|
||||
ABitmap.Draw(Canvas, TempRect, False);
|
||||
ABitmap.Free;
|
||||
end;
|
||||
|
||||
procedure TBGRASpriteAnimation.DoAnimTimerOnTimer(Sender: TObject);
|
||||
begin
|
||||
Invalidate;
|
||||
|
||||
if Assigned(FOnPositionChanging) then
|
||||
FOnPositionChanging(Self);
|
||||
SetFAnimPosition(FAnimPosition + 1);
|
||||
|
||||
if FAnimPosition = FSpriteCount then
|
||||
begin
|
||||
if Assigned(FOnLapChanging) then
|
||||
FOnLapChanging(Self);
|
||||
SetFAnimRepeatLap(FAnimRepeatLap + 1);
|
||||
end;
|
||||
end;
|
||||
|
||||
{ Create / Destroy }
|
||||
|
||||
constructor TBGRASpriteAnimation.Create(AOwner: TComponent);
|
||||
begin
|
||||
inherited Create(AOwner);
|
||||
|
||||
with GetControlClassDefaultSize do
|
||||
SetInitialBounds(0, 0, CX, CY);
|
||||
|
||||
FAnimInvert := False;
|
||||
FAnimPosition := 1;
|
||||
FAnimRepeat := 0;
|
||||
FAnimRepeatLap := 0;
|
||||
FAnimSpeed := 1000;
|
||||
FAnimStatic := False;
|
||||
FAnimTimer := TTimer.Create(Self);
|
||||
FAnimTimer.Interval := FAnimSpeed;
|
||||
FAnimTimer.OnTimer := DoAnimTimerOnTimer;
|
||||
FCenter := True;
|
||||
FProportional := True;
|
||||
FStretch := True;
|
||||
FSprite := TSpriteBitmap.Create(self);
|
||||
FSprite.OnChange:=SpriteChange;
|
||||
FSpriteCount := 1;
|
||||
FSpriteFillOpacity := 255;
|
||||
FSpriteFlipMode := flNone;
|
||||
FSpriteKeyColor := clNone;
|
||||
FSpriteResampleFilter := rfLinear;
|
||||
FSpriteResampleMode := rmSimpleStretch;
|
||||
FSpriteRotation := rtNone;
|
||||
FTile := False;
|
||||
|
||||
if csDesigning in ComponentState then
|
||||
FAnimTimer.Enabled := False;
|
||||
end;
|
||||
|
||||
destructor TBGRASpriteAnimation.Destroy;
|
||||
begin
|
||||
FAnimTimer.Enabled := False;
|
||||
FAnimTimer.OnTimer := nil;
|
||||
FAnimTimer.Free;
|
||||
FSprite.Free;
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
end.
|
||||
450
bgracontrols/bgrasvgimagelist.pas
Normal file
450
bgracontrols/bgrasvgimagelist.pas
Normal file
@@ -0,0 +1,450 @@
|
||||
unit BGRASVGImageList;
|
||||
|
||||
{$mode delphi}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, FGL,
|
||||
XMLConf, BGRABitmap, BGRABitmapTypes, BGRASVG;
|
||||
|
||||
type
|
||||
|
||||
TListOfTStringList = TFPGObjectList<TStringList>;
|
||||
|
||||
{ TBGRASVGImageList }
|
||||
|
||||
TBGRASVGImageList = class(TComponent)
|
||||
private
|
||||
FHeight: integer;
|
||||
FHorizontalAlignment: TAlignment;
|
||||
FItems: TListOfTStringList;
|
||||
FReferenceDPI: integer;
|
||||
FTargetRasterImageList: TImageList;
|
||||
FUseSVGAlignment: boolean;
|
||||
FVerticalAlignment: TTextLayout;
|
||||
FWidth: integer;
|
||||
FRasterized: boolean;
|
||||
FDataLineBreak: TTextLineBreakStyle;
|
||||
procedure ReadData(Stream: TStream);
|
||||
procedure SetHeight(AValue: integer);
|
||||
procedure SetTargetRasterImageList(AValue: TImageList);
|
||||
procedure SetWidth(AValue: integer);
|
||||
procedure WriteData(Stream: TStream);
|
||||
protected
|
||||
procedure Load(const XMLConf: TXMLConfig);
|
||||
procedure Save(const XMLConf: TXMLConfig);
|
||||
procedure DefineProperties(Filer: TFiler); override;
|
||||
function GetCount: integer;
|
||||
// Get SVG string
|
||||
function GetSVGString(AIndex: integer): string; overload;
|
||||
procedure Rasterize;
|
||||
procedure RasterizeIfNeeded;
|
||||
procedure QueryRasterize;
|
||||
public
|
||||
constructor Create(AOwner: TComponent); override;
|
||||
destructor Destroy; override;
|
||||
function Add(ASVG: string): integer;
|
||||
procedure Remove(AIndex: integer);
|
||||
procedure Exchange(AIndex1, AIndex2: integer);
|
||||
procedure Replace(AIndex: integer; ASVG: string);
|
||||
function GetScaledSize(ATargetDPI: integer): TSize;
|
||||
// Get TBGRABitmap with custom width and height
|
||||
function GetBGRABitmap(AIndex: integer; AWidth, AHeight: integer): TBGRABitmap; overload;
|
||||
function GetBGRABitmap(AIndex: integer; AWidth, AHeight: integer;
|
||||
AUseSVGAlignment: boolean): TBGRABitmap; overload;
|
||||
// Get TBitmap with custom width and height
|
||||
function GetBitmap(AIndex: integer; AWidth, AHeight: integer): TBitmap; overload;
|
||||
function GetBitmap(AIndex: integer; AWidth, AHeight: integer;
|
||||
AUseSVGAlignment: boolean): TBitmap; overload;
|
||||
// Draw image with custom width and height. The Width and
|
||||
// Height property are in LCL coordinates.
|
||||
procedure Draw(AIndex: integer; AControl: TControl; ACanvas: TCanvas;
|
||||
ALeft, ATop, AWidth, AHeight: integer); overload;
|
||||
procedure Draw(AIndex: integer; AControl: TControl; ACanvas: TCanvas;
|
||||
ALeft, ATop, AWidth, AHeight: integer; AUseSVGAlignment: boolean;
|
||||
AOpacity: byte = 255); overload;
|
||||
// Draw image with custom width, height and canvas scale. The Width and
|
||||
// Height property are in LCL coordinates. CanvasScale is useful on MacOS
|
||||
// where LCL coordinates do not match actual pixels.
|
||||
procedure Draw(AIndex: integer; ACanvasScale: single; ACanvas: TCanvas;
|
||||
ALeft, ATop, AWidth, AHeight: integer); overload;
|
||||
procedure Draw(AIndex: integer; ACanvasScale: single; ACanvas: TCanvas;
|
||||
ALeft, ATop, AWidth, AHeight: integer; AUseSVGAlignment: boolean;
|
||||
AOpacity: byte = 255); overload;
|
||||
// Draw on the target BGRABitmap with specified Width and Height.
|
||||
procedure Draw(AIndex: integer; ABitmap: TBGRABitmap; const ARectF: TRectF); overload;
|
||||
procedure Draw(AIndex: integer; ABitmap: TBGRABitmap; const ARectF: TRectF;
|
||||
AUseSVGAlignment: boolean); overload;
|
||||
|
||||
// Generate bitmaps for an image list
|
||||
procedure PopulateImageList(const AImageList: TImageList; AWidths: array of integer);
|
||||
property SVGString[AIndex: integer]: string read GetSVGString;
|
||||
property Count: integer read GetCount;
|
||||
published
|
||||
property Width: integer read FWidth write SetWidth;
|
||||
property Height: integer read FHeight write SetHeight;
|
||||
property ReferenceDPI: integer read FReferenceDPI write FReferenceDPI default 96;
|
||||
property UseSVGAlignment: boolean read FUseSVGAlignment write FUseSVGAlignment default False;
|
||||
property HorizontalAlignment: TAlignment read FHorizontalAlignment write FHorizontalAlignment default taCenter;
|
||||
property VerticalAlignment: TTextLayout read FVerticalAlignment write FVerticalAlignment default tlCenter;
|
||||
property TargetRasterImageList: TImageList read FTargetRasterImageList write SetTargetRasterImageList default nil;
|
||||
end;
|
||||
|
||||
procedure Register;
|
||||
|
||||
implementation
|
||||
|
||||
uses LCLType;
|
||||
|
||||
procedure Register;
|
||||
begin
|
||||
RegisterComponents('BGRA Themes', [TBGRASVGImageList]);
|
||||
end;
|
||||
|
||||
{ TBGRASVGImageList }
|
||||
|
||||
procedure TBGRASVGImageList.ReadData(Stream: TStream);
|
||||
|
||||
// Detects EOL marker used in the text stream
|
||||
function GetLineEnding(AStream: TStream; AMaxLookAhead: integer = 4096): TTextLineBreakStyle;
|
||||
var c: char;
|
||||
i: integer;
|
||||
begin
|
||||
c := #0;
|
||||
for i := 0 to AMaxLookAhead-1 do
|
||||
begin
|
||||
if AStream.Read(c, sizeof(c)) = 0 then break;
|
||||
Case c of
|
||||
#10: exit(tlbsLF);
|
||||
#13: begin
|
||||
if AStream.Read(c, sizeof(c)) = 0 then c := #0;
|
||||
if c = #10 then
|
||||
exit(tlbsCRLF)
|
||||
else
|
||||
exit(tlbsCR);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
// no marker found, return system default
|
||||
exit(DefaultTextLineBreakStyle);
|
||||
end;
|
||||
|
||||
var
|
||||
FXMLConf: TXMLConfig;
|
||||
begin
|
||||
FXMLConf := TXMLConfig.Create(Self);
|
||||
try
|
||||
// Detect the line EOL marker
|
||||
Stream.Position := 0;
|
||||
FDataLineBreak:= GetLineEnding(Stream);
|
||||
// Actually load the XML file
|
||||
Stream.Position := 0;
|
||||
FXMLConf.LoadFromStream(Stream);
|
||||
Load(FXMLConf);
|
||||
finally
|
||||
FXMLConf.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TBGRASVGImageList.SetHeight(AValue: integer);
|
||||
begin
|
||||
if FHeight = AValue then
|
||||
Exit;
|
||||
FHeight := AValue;
|
||||
QueryRasterize;
|
||||
end;
|
||||
|
||||
procedure TBGRASVGImageList.SetTargetRasterImageList(AValue: TImageList);
|
||||
begin
|
||||
if FTargetRasterImageList=AValue then Exit;
|
||||
if Assigned(FTargetRasterImageList) then FTargetRasterImageList.Clear;
|
||||
FTargetRasterImageList:=AValue;
|
||||
QueryRasterize;
|
||||
end;
|
||||
|
||||
procedure TBGRASVGImageList.SetWidth(AValue: integer);
|
||||
begin
|
||||
if FWidth = AValue then
|
||||
Exit;
|
||||
FWidth := AValue;
|
||||
QueryRasterize;
|
||||
end;
|
||||
|
||||
procedure TBGRASVGImageList.WriteData(Stream: TStream);
|
||||
var
|
||||
FXMLConf: TXMLConfig;
|
||||
FTempStream: TStringStream;
|
||||
FNormalizedData: string;
|
||||
begin
|
||||
FXMLConf := TXMLConfig.Create(Self);
|
||||
FTempStream := TStringStream.Create;
|
||||
try
|
||||
Save(FXMLConf);
|
||||
// Save to temporary string stream.
|
||||
// EOL marker will depend on OS (#13#10 or #10),
|
||||
// because TXMLConfig automatically changes EOL to platform default.
|
||||
FXMLConf.SaveToStream(FTempStream);
|
||||
// Normalize EOL marker, as data will be saved as binary data.
|
||||
// Saving without normalization would lead to different binary
|
||||
// data when saving on different platforms.
|
||||
FNormalizedData := AdjustLineBreaks(FTempStream.DataString, FDataLineBreak);
|
||||
if FNormalizedData <> '' then
|
||||
Stream.WriteBuffer(FNormalizedData[1], Length(FNormalizedData));
|
||||
FXMLConf.Flush;
|
||||
finally
|
||||
FXMLConf.Free;
|
||||
FTempStream.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TBGRASVGImageList.Load(const XMLConf: TXMLConfig);
|
||||
var
|
||||
i, j, index: integer;
|
||||
begin
|
||||
try
|
||||
FItems.Clear;
|
||||
j := XMLConf.GetValue('Count', 0);
|
||||
for i := 0 to j - 1 do
|
||||
begin
|
||||
index := FItems.Add(TStringList.Create);
|
||||
FItems[index].Text := XMLConf.GetValue('Item' + i.ToString + '/SVG', '');
|
||||
end;
|
||||
finally
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TBGRASVGImageList.Save(const XMLConf: TXMLConfig);
|
||||
var
|
||||
i: integer;
|
||||
begin
|
||||
try
|
||||
XMLConf.SetValue('Count', FItems.Count);
|
||||
for i := 0 to FItems.Count - 1 do
|
||||
XMLConf.SetValue('Item' + i.ToString + '/SVG', AdjustLineBreaks(FItems[i].Text, FDataLineBreak));
|
||||
finally
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TBGRASVGImageList.DefineProperties(Filer: TFiler);
|
||||
begin
|
||||
inherited DefineProperties(Filer);
|
||||
Filer.DefineBinaryProperty('Items', ReadData, WriteData, True);
|
||||
end;
|
||||
|
||||
constructor TBGRASVGImageList.Create(AOwner: TComponent);
|
||||
begin
|
||||
inherited Create(AOwner);
|
||||
FItems := TListOfTStringList.Create(True);
|
||||
FWidth := 16;
|
||||
FHeight := 16;
|
||||
FReferenceDPI := 96;
|
||||
FUseSVGAlignment:= false;
|
||||
FHorizontalAlignment := taCenter;
|
||||
FVerticalAlignment := tlCenter;
|
||||
FDataLineBreak := DefaultTextLineBreakStyle;
|
||||
end;
|
||||
|
||||
destructor TBGRASVGImageList.Destroy;
|
||||
begin
|
||||
FItems.Free;
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
function TBGRASVGImageList.Add(ASVG: string): integer;
|
||||
var
|
||||
list: TStringList;
|
||||
begin
|
||||
list := TStringList.Create;
|
||||
list.Text := ASVG;
|
||||
Result := FItems.Add(list);
|
||||
QueryRasterize;
|
||||
end;
|
||||
|
||||
procedure TBGRASVGImageList.Remove(AIndex: integer);
|
||||
begin
|
||||
FItems.Remove(FItems[AIndex]);
|
||||
QueryRasterize;
|
||||
end;
|
||||
|
||||
procedure TBGRASVGImageList.Exchange(AIndex1, AIndex2: integer);
|
||||
begin
|
||||
FItems.Exchange(AIndex1, AIndex2);
|
||||
QueryRasterize;
|
||||
end;
|
||||
|
||||
function TBGRASVGImageList.GetSVGString(AIndex: integer): string;
|
||||
begin
|
||||
Result := FItems[AIndex].Text;
|
||||
end;
|
||||
|
||||
procedure TBGRASVGImageList.Rasterize;
|
||||
begin
|
||||
if Assigned(FTargetRasterImageList) then
|
||||
begin
|
||||
FTargetRasterImageList.Clear;
|
||||
FTargetRasterImageList.Width := Width;
|
||||
FTargetRasterImageList.Height := Height;
|
||||
{$IFDEF DARWIN}
|
||||
PopulateImageList(FTargetRasterImageList, [Width, Width*2]);
|
||||
{$ELSE}
|
||||
PopulateImageList(FTargetRasterImageList, [Width]);
|
||||
{$ENDIF}
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TBGRASVGImageList.RasterizeIfNeeded;
|
||||
begin
|
||||
if not FRasterized then
|
||||
begin
|
||||
Rasterize;
|
||||
FRasterized := true;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TBGRASVGImageList.QueryRasterize;
|
||||
var method: TThreadMethod;
|
||||
begin
|
||||
FRasterized := false;
|
||||
method := RasterizeIfNeeded;
|
||||
TThread.ForceQueue(nil, method);
|
||||
end;
|
||||
|
||||
procedure TBGRASVGImageList.Replace(AIndex: integer; ASVG: string);
|
||||
begin
|
||||
FItems[AIndex].Text := ASVG;
|
||||
QueryRasterize;
|
||||
end;
|
||||
|
||||
function TBGRASVGImageList.GetCount: integer;
|
||||
begin
|
||||
Result := FItems.Count;
|
||||
end;
|
||||
|
||||
function TBGRASVGImageList.GetScaledSize(ATargetDPI: integer): TSize;
|
||||
begin
|
||||
result.cx := MulDiv(Width, ATargetDPI, ReferenceDPI);
|
||||
result.cy := MulDiv(Height, ATargetDPI, ReferenceDPI);
|
||||
end;
|
||||
|
||||
function TBGRASVGImageList.GetBGRABitmap(AIndex: integer; AWidth,
|
||||
AHeight: integer): TBGRABitmap;
|
||||
begin
|
||||
result := GetBGRABitmap(AIndex, AWidth, AHeight, UseSVGAlignment);
|
||||
end;
|
||||
|
||||
function TBGRASVGImageList.GetBGRABitmap(AIndex: integer; AWidth, AHeight: integer;
|
||||
AUseSVGAlignment: boolean): TBGRABitmap;
|
||||
var
|
||||
bmp: TBGRABitmap;
|
||||
svg: TBGRASVG;
|
||||
begin
|
||||
bmp := TBGRABitmap.Create(AWidth, AHeight);
|
||||
svg := TBGRASVG.CreateFromString(FItems[AIndex].Text);
|
||||
try
|
||||
svg.StretchDraw(bmp.Canvas2D, 0, 0, AWidth, AHeight, AUseSVGAlignment);
|
||||
finally
|
||||
svg.Free;
|
||||
end;
|
||||
Result := bmp;
|
||||
end;
|
||||
|
||||
function TBGRASVGImageList.GetBitmap(AIndex: integer; AWidth, AHeight: integer): TBitmap;
|
||||
begin
|
||||
result := GetBitmap(AIndex, AWidth, AHeight, UseSVGAlignment);
|
||||
end;
|
||||
|
||||
function TBGRASVGImageList.GetBitmap(AIndex: integer; AWidth, AHeight: integer;
|
||||
AUseSVGAlignment: boolean): TBitmap;
|
||||
var
|
||||
bmp: TBGRABitmap;
|
||||
ms: TMemoryStream;
|
||||
begin
|
||||
bmp := GetBGRABitmap(AIndex, AWidth, AHeight, AUseSVGAlignment);
|
||||
ms := TMemoryStream.Create;
|
||||
bmp.Bitmap.SaveToStream(ms);
|
||||
bmp.Free;
|
||||
Result := TBitmap.Create;
|
||||
ms.Position := 0;
|
||||
Result.LoadFromStream(ms);
|
||||
ms.Free;
|
||||
end;
|
||||
|
||||
procedure TBGRASVGImageList.Draw(AIndex: integer; AControl: TControl;
|
||||
ACanvas: TCanvas; ALeft, ATop, AWidth, AHeight: integer);
|
||||
begin
|
||||
Draw(AIndex, AControl, ACanvas, ALeft, ATop, AWidth, AHeight, UseSVGAlignment);
|
||||
end;
|
||||
|
||||
procedure TBGRASVGImageList.Draw(AIndex: integer; AControl: TControl; ACanvas: TCanvas;
|
||||
ALeft, ATop, AWidth, AHeight: integer; AUseSVGAlignment: boolean; AOpacity: byte);
|
||||
begin
|
||||
Draw(AIndex, AControl.GetCanvasScaleFactor, ACanvas, ALeft, ATop, AWidth, AHeight,
|
||||
AUseSVGAlignment, AOpacity);
|
||||
end;
|
||||
|
||||
procedure TBGRASVGImageList.Draw(AIndex: integer; ACanvasScale: single;
|
||||
ACanvas: TCanvas; ALeft, ATop, AWidth, AHeight: integer);
|
||||
begin
|
||||
Draw(AIndex, ACanvasScale, ACanvas, ALeft, ATop, AWidth, AHeight, UseSVGAlignment);
|
||||
end;
|
||||
|
||||
procedure TBGRASVGImageList.Draw(AIndex: integer; ACanvasScale: single; ACanvas: TCanvas;
|
||||
ALeft, ATop, AWidth, AHeight: integer; AUseSVGAlignment: boolean; AOpacity: byte);
|
||||
var
|
||||
bmp: TBGRABitmap;
|
||||
begin
|
||||
if (AWidth = 0) or (AHeight = 0) or (ACanvasScale = 0) then
|
||||
Exit;
|
||||
bmp := TBGRABitmap.Create(round(AWidth * ACanvasScale), round(AHeight * ACanvasScale));
|
||||
try
|
||||
Draw(AIndex, bmp, rectF(0, 0, bmp.Width, bmp.Height), AUseSVGAlignment);
|
||||
bmp.ApplyGlobalOpacity(AOpacity);
|
||||
bmp.Draw(ACanvas, RectWithSize(ALeft, ATop, AWidth, AHeight), False);
|
||||
finally
|
||||
bmp.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TBGRASVGImageList.Draw(AIndex: integer; ABitmap: TBGRABitmap; const ARectF: TRectF);
|
||||
begin
|
||||
Draw(AIndex, ABitmap, ARectF, UseSVGAlignment);
|
||||
end;
|
||||
|
||||
procedure TBGRASVGImageList.Draw(AIndex: integer; ABitmap: TBGRABitmap; const ARectF: TRectF;
|
||||
AUseSVGAlignment: boolean);
|
||||
var
|
||||
svg: TBGRASVG;
|
||||
begin
|
||||
svg := TBGRASVG.CreateFromString(FItems[AIndex].Text);
|
||||
try
|
||||
if AUseSVGAlignment then
|
||||
svg.StretchDraw(ABitmap.Canvas2D, ARectF, true)
|
||||
else svg.StretchDraw(ABitmap.Canvas2D, HorizontalAlignment, VerticalAlignment, ARectF.Left, ARectF.Top, ARectF.Width, ARectF.Height);
|
||||
finally
|
||||
svg.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TBGRASVGImageList.PopulateImageList(const AImageList: TImageList;
|
||||
AWidths: array of integer);
|
||||
var
|
||||
i, j: integer;
|
||||
arr: array of TCustomBitmap;
|
||||
begin
|
||||
AImageList.Width := AWidths[0];
|
||||
AImageList.Height := MulDiv(AWidths[0], Height, Width);
|
||||
AImageList.Scaled := True;
|
||||
AImageList.RegisterResolutions(AWidths);
|
||||
SetLength({%H-}arr, Length(AWidths));
|
||||
for j := 0 to Count - 1 do
|
||||
begin
|
||||
for i := 0 to Length(arr) - 1 do
|
||||
arr[i] := GetBitmap(j, AWidths[i], MulDiv(AWidths[i], Height, Width), True);
|
||||
AImageList.AddMultipleResolutions(arr);
|
||||
for i := 0 to Length(arr) - 1 do
|
||||
TBitmap(Arr[i]).Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
end.
|
||||
360
bgracontrols/bgrasvgimagelistform/bgrasvgimagelistform.lfm
Normal file
360
bgracontrols/bgrasvgimagelistform/bgrasvgimagelistform.lfm
Normal file
@@ -0,0 +1,360 @@
|
||||
object frmBGRASVGImageListEditor: TfrmBGRASVGImageListEditor
|
||||
Left = 480
|
||||
Height = 268
|
||||
Top = 141
|
||||
Width = 484
|
||||
Caption = 'BGRA SVG Image List'
|
||||
ClientHeight = 268
|
||||
ClientWidth = 484
|
||||
LCLVersion = '2.0.10.0'
|
||||
object ListBox1: TListBox
|
||||
Left = 8
|
||||
Height = 192
|
||||
Top = 40
|
||||
Width = 315
|
||||
Anchors = [akTop, akLeft, akBottom]
|
||||
ItemHeight = 16
|
||||
OnDrawItem = ListBox1DrawItem
|
||||
OnSelectionChange = ListBox1SelectionChange
|
||||
ScrollWidth = 313
|
||||
Style = lbOwnerDrawFixed
|
||||
TabOrder = 0
|
||||
TopIndex = -1
|
||||
end
|
||||
object btnAdd: TButton
|
||||
Left = 8
|
||||
Height = 25
|
||||
Top = 8
|
||||
Width = 75
|
||||
Caption = 'Add'
|
||||
OnClick = btnAddClick
|
||||
TabOrder = 1
|
||||
end
|
||||
object btnRemove: TButton
|
||||
Left = 88
|
||||
Height = 25
|
||||
Top = 8
|
||||
Width = 75
|
||||
Caption = 'Remove'
|
||||
Enabled = False
|
||||
OnClick = btnRemoveClick
|
||||
TabOrder = 2
|
||||
end
|
||||
object btnUp: TButton
|
||||
Left = 328
|
||||
Height = 25
|
||||
Top = 8
|
||||
Width = 75
|
||||
Caption = 'Up'
|
||||
Enabled = False
|
||||
OnClick = btnUpClick
|
||||
TabOrder = 3
|
||||
end
|
||||
object btnDown: TButton
|
||||
Left = 408
|
||||
Height = 25
|
||||
Top = 8
|
||||
Width = 75
|
||||
Caption = 'Down'
|
||||
Enabled = False
|
||||
OnClick = btnDownClick
|
||||
TabOrder = 4
|
||||
end
|
||||
object BCSVGViewerPreview: TBCSVGViewer
|
||||
Left = 328
|
||||
Height = 192
|
||||
Top = 40
|
||||
Width = 144
|
||||
Anchors = [akTop, akLeft, akRight, akBottom]
|
||||
SVGString = '<?xml version="1.0" encoding="utf-8"?>'#10'<svg width="100%" xmlns="http://www.w3.org/2000/svg" height="100%"/>'#10
|
||||
DrawCheckers = True
|
||||
Color = clForm
|
||||
ColorOpacity = 128
|
||||
Caption = 'BCSVGViewerPreview'
|
||||
end
|
||||
object btnReplace: TButton
|
||||
Left = 168
|
||||
Height = 25
|
||||
Top = 8
|
||||
Width = 75
|
||||
Caption = 'Replace'
|
||||
Enabled = False
|
||||
OnClick = btnReplaceClick
|
||||
TabOrder = 5
|
||||
end
|
||||
object CheckBox_UseSVGAlignment: TCheckBox
|
||||
Left = 13
|
||||
Height = 23
|
||||
Top = 237
|
||||
Width = 239
|
||||
Anchors = [akLeft, akBottom]
|
||||
Caption = 'Use SVG alignment and aspect ratio'
|
||||
OnChange = CheckBox_UseSVGAlignmentChange
|
||||
TabOrder = 6
|
||||
end
|
||||
object ToolBar1: TToolBar
|
||||
Left = 323
|
||||
Height = 26
|
||||
Top = 232
|
||||
Width = 147
|
||||
Align = alNone
|
||||
Caption = 'ToolBar1'
|
||||
Images = ImageList1
|
||||
TabOrder = 7
|
||||
object ToolButton_AlignLeft: TToolButton
|
||||
Left = 1
|
||||
Top = 2
|
||||
Grouped = True
|
||||
ImageIndex = 0
|
||||
OnClick = ToolButton_AlignLeftClick
|
||||
end
|
||||
object ToolButton_AlignCenter: TToolButton
|
||||
Left = 24
|
||||
Top = 2
|
||||
Grouped = True
|
||||
ImageIndex = 1
|
||||
OnClick = ToolButton_AlignCenterClick
|
||||
end
|
||||
object ToolButton_AlignRight: TToolButton
|
||||
Left = 47
|
||||
Top = 2
|
||||
Caption = 'ToolButton_AlignRight'
|
||||
Grouped = True
|
||||
ImageIndex = 2
|
||||
OnClick = ToolButton_AlignRightClick
|
||||
end
|
||||
object ToolButton1: TToolButton
|
||||
Left = 70
|
||||
Height = 22
|
||||
Top = 2
|
||||
Caption = 'ToolButton_Divider'
|
||||
Style = tbsDivider
|
||||
end
|
||||
object ToolButton_AlignTop: TToolButton
|
||||
Left = 75
|
||||
Top = 2
|
||||
Grouped = True
|
||||
ImageIndex = 3
|
||||
OnClick = ToolButton_AlignTopClick
|
||||
end
|
||||
object ToolButton_AlignVCenter: TToolButton
|
||||
Left = 98
|
||||
Top = 2
|
||||
Grouped = True
|
||||
ImageIndex = 4
|
||||
OnClick = ToolButton_AlignVCenterClick
|
||||
end
|
||||
object ToolButton_AlignBottom: TToolButton
|
||||
Left = 121
|
||||
Top = 2
|
||||
Grouped = True
|
||||
ImageIndex = 5
|
||||
OnClick = ToolButton_AlignBottomClick
|
||||
end
|
||||
end
|
||||
object OpenDialog1: TOpenDialog
|
||||
Filter = 'SVG|*.svg'
|
||||
Left = 166
|
||||
Top = 76
|
||||
end
|
||||
object ImageList1: TImageList
|
||||
Scaled = True
|
||||
Left = 247
|
||||
Top = 140
|
||||
Bitmap = {
|
||||
4C69060000001000000010000000000000000000000000000000000000000000
|
||||
0000000000000000000000000000000000000000000000000000000000000000
|
||||
000000000000000000000000000000000000FFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7F0000000000000000FFFFFF7F010000FF010000FF0100
|
||||
00FF010000FF010000FF010000FF010000FF010000FF010000FF010000FF0100
|
||||
00FF010000FFFFFFFF7F0000000000000000FFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7F0000000000000000FFFFFF7F010000FF010000FF0100
|
||||
00FF010000FF010000FFFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7F0000000000000000FFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7F0000000000000000FFFFFF7F010000FF010000FF0100
|
||||
00FF010000FF010000FF010000FF010000FF010000FFFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7F0000000000000000FFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7F0000000000000000FFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7F0000000000000000FFFFFF7F010000FF010000FF0100
|
||||
00FF010000FF010000FF010000FF010000FF010000FF010000FF010000FFFFFF
|
||||
FF7FFFFFFF7FFFFFFF7F0000000000000000FFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7F0000000000000000FFFFFF7F010000FF010000FF0100
|
||||
00FF010000FF010000FF010000FF010000FF010000FF010000FF010000FF0100
|
||||
00FF010000FFFFFFFF7F0000000000000000FFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7F0000000000000000FFFFFF7F010000FF010000FF0100
|
||||
00FF010000FF010000FFFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7F0000000000000000FFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7F00000000000000000000000000000000000000000000
|
||||
0000000000000000000000000000000000000000000000000000000000000000
|
||||
0000000000000000000000000000000000000000000000000000000000000000
|
||||
0000000000000000000000000000000000000000000000000000000000000000
|
||||
000000000000000000000000000000000000FFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7F0000000000000000FFFFFF7F010000FF010000FF0100
|
||||
00FF010000FF010000FF010000FF010000FF010000FF010000FF010000FF0100
|
||||
00FF010000FFFFFFFF7F0000000000000000FFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7F0000000000000000FFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7F010000FF010000FF010000FF010000FF010000FF7B7B7BC6FFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7F0000000000000000FFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7F0000000000000000FFFFFF7FFFFFFF7FFFFFFF7F0100
|
||||
00FF010000FF010000FF010000FF010000FF010000FF010000FF010000FFFFFF
|
||||
FF7FFFFFFF7FFFFFFF7F0000000000000000FFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7F0000000000000000FFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7F0000000000000000FFFFFF7FFFFFFF7F010000FF0100
|
||||
00FF010000FF010000FF010000FF010000FF010000FF010000FF010000FF0100
|
||||
00FFFFFFFF7FFFFFFF7F0000000000000000FFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7F0000000000000000FFFFFF7F010000FF010000FF0100
|
||||
00FF010000FF010000FF010000FF010000FF010000FF010000FF010000FF0100
|
||||
00FF010000FFFFFFFF7F0000000000000000FFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7F0000000000000000FFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7F010000FF010000FF010000FF010000FF010000FF7B7B7BC6FFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7F0000000000000000FFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7F00000000000000000000000000000000000000000000
|
||||
0000000000000000000000000000000000000000000000000000000000000000
|
||||
0000000000000000000000000000000000000000000000000000000000000000
|
||||
0000000000000000000000000000000000000000000000000000000000000000
|
||||
000000000000000000000000000000000000FFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7F0000000000000000FFFFFF7F010000FF010000FF0100
|
||||
00FF010000FF010000FF010000FF010000FF010000FF010000FF010000FF0100
|
||||
00FF010000FFFFFFFF7F0000000000000000FFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7F0000000000000000FFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7F010000FF010000FF010000FF0100
|
||||
00FF010000FFFFFFFF7F0000000000000000FFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7F0000000000000000FFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7F010000FF010000FF010000FF010000FF010000FF010000FF0100
|
||||
00FF010000FFFFFFFF7F0000000000000000FFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7F0000000000000000FFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7F0000000000000000FFFFFF7FFFFFFF7FFFFFFF7F0100
|
||||
00FF010000FF010000FF010000FF010000FF010000FF010000FF010000FF0100
|
||||
00FF010000FFFFFFFF7F0000000000000000FFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7F0000000000000000FFFFFF7F010000FF010000FF0100
|
||||
00FF010000FF010000FF010000FF010000FF010000FF010000FF010000FF0100
|
||||
00FF010000FFFFFFFF7F0000000000000000FFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7F0000000000000000FFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7F010000FF010000FF010000FF0100
|
||||
00FF010000FFFFFFFF7F0000000000000000FFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7F00000000000000000000000000000000000000000000
|
||||
0000000000000000000000000000000000000000000000000000000000000000
|
||||
0000000000000000000000000000000000000000000000000000000000000000
|
||||
0000000000000000000000000000000000000000000000000000000000000000
|
||||
000000000000000000000000000000000000FFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7F0000000000000000FFFFFF7F010000FF010000FF0100
|
||||
00FF010000FF010000FF010000FF010000FF010000FF010000FF010000FF0100
|
||||
00FF010000FFFFFFFF7F0000000000000000FFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7F0000000000000000FFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7F010000FF010000FF010000FF010000FF010000FF7B7B7BC6FFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7F0000000000000000FFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7F0000000000000000FFFFFF7FFFFFFF7FFFFFFF7F0100
|
||||
00FF010000FF010000FF010000FF010000FF010000FF010000FF010000FFFFFF
|
||||
FF7FFFFFFF7FFFFFFF7F0000000000000000FFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7F0000000000000000FFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7F0000000000000000FFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7F0000000000000000FFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7F0000000000000000FFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7F0000000000000000FFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7F0000000000000000FFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7F0000000000000000FFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7F00000000000000000000000000000000000000000000
|
||||
0000000000000000000000000000000000000000000000000000000000000000
|
||||
0000000000000000000000000000000000000000000000000000000000000000
|
||||
0000000000000000000000000000000000000000000000000000000000000000
|
||||
000000000000000000000000000000000000FFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7F0000000000000000FFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7F0000000000000000FFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7F0000000000000000FFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7F0000000000000000FFFFFF7F010000FF010000FF0100
|
||||
00FF010000FF010000FF010000FF010000FF010000FF010000FF010000FF0100
|
||||
00FF010000FFFFFFFF7F0000000000000000FFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7F0000000000000000FFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7F010000FF010000FF010000FF010000FF010000FF7B7B7BC6FFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7F0000000000000000FFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7F0000000000000000FFFFFF7FFFFFFF7FFFFFFF7F0100
|
||||
00FF010000FF010000FF010000FF010000FF010000FF010000FF010000FFFFFF
|
||||
FF7FFFFFFF7FFFFFFF7F0000000000000000FFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7F0000000000000000FFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7F0000000000000000FFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7F0000000000000000FFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7F0000000000000000FFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7F00000000000000000000000000000000000000000000
|
||||
0000000000000000000000000000000000000000000000000000000000000000
|
||||
0000000000000000000000000000000000000000000000000000000000000000
|
||||
0000000000000000000000000000000000000000000000000000000000000000
|
||||
000000000000000000000000000000000000FFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7F0000000000000000FFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7F0000000000000000FFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7F0000000000000000FFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7F0000000000000000FFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7F0000000000000000FFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7F0000000000000000FFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7F0000000000000000FFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7F0000000000000000FFFFFF7F010000FF010000FF0100
|
||||
00FF010000FF010000FF010000FF010000FF010000FF010000FF010000FF0100
|
||||
00FF010000FFFFFFFF7F0000000000000000FFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7F0000000000000000FFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7F010000FF010000FF010000FF010000FF010000FF7B7B7BC6FFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7F0000000000000000FFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7F0000000000000000FFFFFF7FFFFFFF7FFFFFFF7F0100
|
||||
00FF010000FF010000FF010000FF010000FF010000FF010000FF010000FFFFFF
|
||||
FF7FFFFFFF7FFFFFFF7F0000000000000000FFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFFFF7FFFFF
|
||||
FF7FFFFFFF7FFFFFFF7F00000000000000000000000000000000000000000000
|
||||
0000000000000000000000000000000000000000000000000000000000000000
|
||||
0000000000000000000000000000
|
||||
}
|
||||
end
|
||||
end
|
||||
307
bgracontrols/bgrasvgimagelistform/bgrasvgimagelistform.pas
Normal file
307
bgracontrols/bgrasvgimagelistform/bgrasvgimagelistform.pas
Normal file
@@ -0,0 +1,307 @@
|
||||
unit bgrasvgimagelistform;
|
||||
|
||||
{$mode objfpc}{$H+}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils, Forms, Controls, Graphics, Dialogs, StdCtrls, BCSVGViewer,
|
||||
BGRASVGImageList, ComponentEditors, Types, Math, LCLType, ComCtrls;
|
||||
|
||||
type
|
||||
|
||||
{ TfrmBGRASVGImageListEditor }
|
||||
|
||||
TfrmBGRASVGImageListEditor = class(TForm)
|
||||
BCSVGViewerPreview: TBCSVGViewer;
|
||||
btnAdd: TButton;
|
||||
btnRemove: TButton;
|
||||
btnUp: TButton;
|
||||
btnDown: TButton;
|
||||
btnReplace: TButton;
|
||||
CheckBox_UseSVGAlignment: TCheckBox;
|
||||
ImageList1: TImageList;
|
||||
ListBox1: TListBox;
|
||||
OpenDialog1: TOpenDialog;
|
||||
ToolBar1: TToolBar;
|
||||
ToolButton1: TToolButton;
|
||||
ToolButton_AlignTop: TToolButton;
|
||||
ToolButton_AlignLeft: TToolButton;
|
||||
ToolButton_AlignCenter: TToolButton;
|
||||
ToolButton_AlignRight: TToolButton;
|
||||
ToolButton_AlignVCenter: TToolButton;
|
||||
ToolButton_AlignBottom: TToolButton;
|
||||
procedure btnAddClick(Sender: TObject);
|
||||
procedure btnDownClick(Sender: TObject);
|
||||
procedure btnRemoveClick(Sender: TObject);
|
||||
procedure btnReplaceClick(Sender: TObject);
|
||||
procedure btnUpClick(Sender: TObject);
|
||||
procedure CheckBox_UseSVGAlignmentChange(Sender: TObject);
|
||||
procedure ListBox1DrawItem(Control: TWinControl; Index: integer;
|
||||
ARect: TRect; State: TOwnerDrawState);
|
||||
procedure ListBox1SelectionChange(Sender: TObject; User: boolean);
|
||||
procedure ToolButton_AlignBottomClick(Sender: TObject);
|
||||
procedure ToolButton_AlignCenterClick(Sender: TObject);
|
||||
procedure ToolButton_AlignLeftClick(Sender: TObject);
|
||||
procedure ToolButton_AlignRightClick(Sender: TObject);
|
||||
procedure ToolButton_AlignTopClick(Sender: TObject);
|
||||
procedure ToolButton_AlignVCenterClick(Sender: TObject);
|
||||
private
|
||||
FComponent: TComponent;
|
||||
function GetImageList: TBGRASVGImageList;
|
||||
procedure UpdateListBox;
|
||||
procedure UpdateButtons;
|
||||
procedure UpdateToolButtonsAlign;
|
||||
public
|
||||
constructor {%H-}Create(AComponent: TComponent);
|
||||
property ImageList: TBGRASVGImageList read GetImageList;
|
||||
end;
|
||||
|
||||
{ TBGRASVGImageListEditor }
|
||||
|
||||
TBGRASVGImageListEditor = class(TComponentEditor)
|
||||
protected
|
||||
procedure DoShowEditor;
|
||||
public
|
||||
procedure ExecuteVerb(Index: integer); override;
|
||||
function GetVerb({%H-}Index: integer): string; override;
|
||||
function GetVerbCount: integer; override;
|
||||
end;
|
||||
|
||||
var
|
||||
frmBGRASVGImageListEditor: TfrmBGRASVGImageListEditor;
|
||||
|
||||
implementation
|
||||
|
||||
{$R *.lfm}
|
||||
|
||||
{ TBGRASVGImageListEditor }
|
||||
|
||||
procedure TBGRASVGImageListEditor.DoShowEditor;
|
||||
var
|
||||
f: TfrmBGRASVGImageListEditor;
|
||||
begin
|
||||
f := TfrmBGRASVGImageListEditor.Create(Component);
|
||||
try
|
||||
f.ShowModal;
|
||||
Modified;
|
||||
finally
|
||||
f.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TBGRASVGImageListEditor.ExecuteVerb(Index: integer);
|
||||
begin
|
||||
case Index of
|
||||
0: DoShowEditor;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TBGRASVGImageListEditor.GetVerb(Index: integer): string;
|
||||
begin
|
||||
Result := 'Assign style';
|
||||
end;
|
||||
|
||||
function TBGRASVGImageListEditor.GetVerbCount: integer;
|
||||
begin
|
||||
Result := 1;
|
||||
end;
|
||||
|
||||
{ TfrmBGRASVGImageListEditor }
|
||||
|
||||
procedure TfrmBGRASVGImageListEditor.btnAddClick(Sender: TObject);
|
||||
var
|
||||
s: TStringList;
|
||||
begin
|
||||
if OpenDialog1.Execute then
|
||||
begin
|
||||
s := TStringList.Create;
|
||||
try
|
||||
s.LoadFromFile(OpenDialog1.FileName);
|
||||
TBGRASVGImageList(FComponent).Add(s.Text);
|
||||
finally
|
||||
s.Free;
|
||||
UpdateListBox;
|
||||
ListBox1.ItemIndex := ListBox1.Count - 1;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TfrmBGRASVGImageListEditor.btnDownClick(Sender: TObject);
|
||||
begin
|
||||
TBGRASVGImageList(FComponent).Exchange(ListBox1.ItemIndex, ListBox1.ItemIndex + 1);
|
||||
UpdateListBox;
|
||||
ListBox1.ItemIndex := ListBox1.ItemIndex + 1;
|
||||
end;
|
||||
|
||||
procedure TfrmBGRASVGImageListEditor.btnRemoveClick(Sender: TObject);
|
||||
begin
|
||||
TBGRASVGImageList(FComponent).Remove(ListBox1.ItemIndex);
|
||||
UpdateListBox;
|
||||
end;
|
||||
|
||||
procedure TfrmBGRASVGImageListEditor.btnReplaceClick(Sender: TObject);
|
||||
var
|
||||
s: TStringList;
|
||||
begin
|
||||
if OpenDialog1.Execute then
|
||||
begin
|
||||
s := TStringList.Create;
|
||||
try
|
||||
s.LoadFromFile(OpenDialog1.FileName);
|
||||
TBGRASVGImageList(FComponent).Replace(ListBox1.ItemIndex, s.Text);
|
||||
finally
|
||||
s.Free;
|
||||
UpdateListBox;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TfrmBGRASVGImageListEditor.btnUpClick(Sender: TObject);
|
||||
begin
|
||||
TBGRASVGImageList(FComponent).Exchange(ListBox1.ItemIndex, ListBox1.ItemIndex - 1);
|
||||
UpdateListBox;
|
||||
ListBox1.ItemIndex := ListBox1.ItemIndex - 1;
|
||||
end;
|
||||
|
||||
procedure TfrmBGRASVGImageListEditor.CheckBox_UseSVGAlignmentChange(
|
||||
Sender: TObject);
|
||||
begin
|
||||
ImageList.UseSVGAlignment:= CheckBox_UseSVGAlignment.Checked;
|
||||
BCSVGViewerPreview.UseSVGAlignment:= ImageList.UseSVGAlignment;
|
||||
ListBox1.Invalidate;
|
||||
UpdateToolButtonsAlign;
|
||||
end;
|
||||
|
||||
procedure TfrmBGRASVGImageListEditor.ListBox1DrawItem(Control: TWinControl;
|
||||
Index: integer; ARect: TRect; State: TOwnerDrawState);
|
||||
begin
|
||||
ListBox1.Canvas.Brush.Color := clWhite;
|
||||
if (odSelected in State) then
|
||||
ListBox1.Canvas.Brush.Color := clHighlight;
|
||||
ListBox1.Canvas.FillRect(ARect);
|
||||
ListBox1.Canvas.TextOut(ARect.Height + ScaleX(4, 96),
|
||||
ARect.Top, Index.ToString);
|
||||
if (Index <> -1) then
|
||||
TBGRASVGImageList(FComponent).Draw(Index, ListBox1, ListBox1.Canvas,
|
||||
ARect.Left, ARect.Top, ARect.Height, ARect.Height);
|
||||
end;
|
||||
|
||||
procedure TfrmBGRASVGImageListEditor.ListBox1SelectionChange(Sender: TObject;
|
||||
User: boolean);
|
||||
begin
|
||||
UpdateButtons;
|
||||
if ListBox1.ItemIndex <> -1 then
|
||||
BCSVGViewerPreview.SVGString :=
|
||||
TBGRASVGImageList(FComponent).SVGString[ListBox1.ItemIndex];
|
||||
end;
|
||||
|
||||
procedure TfrmBGRASVGImageListEditor.ToolButton_AlignBottomClick(Sender: TObject
|
||||
);
|
||||
begin
|
||||
ImageList.VerticalAlignment:= tlBottom;
|
||||
BCSVGViewerPreview.VertAlign:= ImageList.VerticalAlignment;
|
||||
UpdateToolButtonsAlign;
|
||||
ListBox1.Invalidate;
|
||||
end;
|
||||
|
||||
procedure TfrmBGRASVGImageListEditor.ToolButton_AlignCenterClick(Sender: TObject
|
||||
);
|
||||
begin
|
||||
ImageList.HorizontalAlignment:= taCenter;
|
||||
BCSVGViewerPreview.HorizAlign:= ImageList.HorizontalAlignment;
|
||||
UpdateToolButtonsAlign;
|
||||
ListBox1.Invalidate;
|
||||
end;
|
||||
|
||||
procedure TfrmBGRASVGImageListEditor.ToolButton_AlignLeftClick(Sender: TObject);
|
||||
begin
|
||||
ImageList.HorizontalAlignment:= taLeftJustify;
|
||||
BCSVGViewerPreview.HorizAlign:= ImageList.HorizontalAlignment;
|
||||
UpdateToolButtonsAlign;
|
||||
ListBox1.Invalidate;
|
||||
end;
|
||||
|
||||
procedure TfrmBGRASVGImageListEditor.ToolButton_AlignRightClick(Sender: TObject
|
||||
);
|
||||
begin
|
||||
ImageList.HorizontalAlignment:= taRightJustify;
|
||||
BCSVGViewerPreview.HorizAlign:= ImageList.HorizontalAlignment;
|
||||
UpdateToolButtonsAlign;
|
||||
ListBox1.Invalidate;
|
||||
end;
|
||||
|
||||
procedure TfrmBGRASVGImageListEditor.ToolButton_AlignTopClick(Sender: TObject);
|
||||
begin
|
||||
ImageList.VerticalAlignment:= tlTop;
|
||||
BCSVGViewerPreview.VertAlign:= ImageList.VerticalAlignment;
|
||||
UpdateToolButtonsAlign;
|
||||
ListBox1.Invalidate;
|
||||
end;
|
||||
|
||||
procedure TfrmBGRASVGImageListEditor.ToolButton_AlignVCenterClick(
|
||||
Sender: TObject);
|
||||
begin
|
||||
ImageList.VerticalAlignment:= tlCenter;
|
||||
BCSVGViewerPreview.VertAlign:= ImageList.VerticalAlignment;
|
||||
UpdateToolButtonsAlign;
|
||||
ListBox1.Invalidate;
|
||||
end;
|
||||
|
||||
procedure TfrmBGRASVGImageListEditor.UpdateListBox;
|
||||
var
|
||||
i: integer;
|
||||
index: integer;
|
||||
begin
|
||||
index := ListBox1.ItemIndex;
|
||||
ListBox1.Clear;
|
||||
for i := 0 to TBGRASVGImageList(FComponent).Count - 1 do
|
||||
ListBox1.Items.Add('Image' + i.ToString);
|
||||
if ListBox1.Count > 0 then
|
||||
ListBox1.ItemIndex := index;
|
||||
UpdateButtons;
|
||||
end;
|
||||
|
||||
function TfrmBGRASVGImageListEditor.GetImageList: TBGRASVGImageList;
|
||||
begin
|
||||
result := TBGRASVGImageList(FComponent);
|
||||
end;
|
||||
|
||||
procedure TfrmBGRASVGImageListEditor.UpdateButtons;
|
||||
begin
|
||||
btnUp.Enabled := (ListBox1.Count > 1) and (ListBox1.ItemIndex > 0);
|
||||
btnDown.Enabled := (ListBox1.Count > 1) and (ListBox1.ItemIndex < ListBox1.Count - 1);
|
||||
btnRemove.Enabled := (ListBox1.Count > 0) and (ListBox1.ItemIndex <> -1);
|
||||
btnReplace.Enabled := (ListBox1.Count > 0) and (ListBox1.ItemIndex <> -1);
|
||||
end;
|
||||
|
||||
procedure TfrmBGRASVGImageListEditor.UpdateToolButtonsAlign;
|
||||
begin
|
||||
ToolButton_AlignLeft.Down := (ImageList.HorizontalAlignment = taLeftJustify);
|
||||
ToolButton_AlignCenter.Down := (ImageList.HorizontalAlignment = taCenter);
|
||||
ToolButton_AlignRight.Down := (ImageList.HorizontalAlignment = taRightJustify);
|
||||
ToolButton_AlignTop.Down := (ImageList.VerticalAlignment = tlTop);
|
||||
ToolButton_AlignVCenter.Down := (ImageList.VerticalAlignment = tlCenter);
|
||||
ToolButton_AlignBottom.Down := (ImageList.VerticalAlignment = tlBottom);
|
||||
ToolBar1.Enabled:= not ImageList.UseSVGAlignment;
|
||||
end;
|
||||
|
||||
constructor TfrmBGRASVGImageListEditor.Create(AComponent: TComponent);
|
||||
begin
|
||||
inherited Create(Application);
|
||||
|
||||
FComponent := AComponent;
|
||||
ListBox1.ItemHeight := Max(ImageList.Height,
|
||||
Max(16, ListBox1.Canvas.TextHeight('0')));
|
||||
UpdateListBox;
|
||||
CheckBox_UseSVGAlignment.Checked := ImageList.UseSVGAlignment;
|
||||
BCSVGViewerPreview.UseSVGAlignment:= ImageList.UseSVGAlignment;
|
||||
BCSVGViewerPreview.HorizAlign:= ImageList.HorizontalAlignment;
|
||||
BCSVGViewerPreview.VertAlign:= ImageList.VerticalAlignment;
|
||||
UpdateToolButtonsAlign;
|
||||
end;
|
||||
|
||||
initialization
|
||||
RegisterComponentEditor(TBGRASVGImageList, TBGRASVGImageListEditor);
|
||||
|
||||
end.
|
||||
BIN
bgracontrols/bgrasvgimagelistform/bgrasvgimagelistproject.ico
Normal file
BIN
bgracontrols/bgrasvgimagelistform/bgrasvgimagelistproject.ico
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 134 KiB |
@@ -0,0 +1,86 @@
|
||||
<?xml version="1.0" encoding="UTF-8"?>
|
||||
<CONFIG>
|
||||
<ProjectOptions>
|
||||
<Version Value="12"/>
|
||||
<PathDelim Value="\"/>
|
||||
<General>
|
||||
<Flags>
|
||||
<CompatibilityMode Value="True"/>
|
||||
</Flags>
|
||||
<SessionStorage Value="InProjectDir"/>
|
||||
<Title Value="bgrasvgimagelistproject"/>
|
||||
<Scaled Value="True"/>
|
||||
<ResourceType Value="res"/>
|
||||
<UseXPManifest Value="True"/>
|
||||
<XPManifest>
|
||||
<DpiAware Value="True"/>
|
||||
</XPManifest>
|
||||
<Icon Value="0"/>
|
||||
</General>
|
||||
<BuildModes Count="1">
|
||||
<Item1 Name="Default" Default="True"/>
|
||||
</BuildModes>
|
||||
<PublishOptions>
|
||||
<Version Value="2"/>
|
||||
<UseFileFilters Value="True"/>
|
||||
</PublishOptions>
|
||||
<RunParams>
|
||||
<FormatVersion Value="2"/>
|
||||
</RunParams>
|
||||
<RequiredPackages Count="2">
|
||||
<Item1>
|
||||
<PackageName Value="bgracontrols"/>
|
||||
</Item1>
|
||||
<Item2>
|
||||
<PackageName Value="LCL"/>
|
||||
</Item2>
|
||||
</RequiredPackages>
|
||||
<Units Count="2">
|
||||
<Unit0>
|
||||
<Filename Value="bgrasvgimagelistproject.lpr"/>
|
||||
<IsPartOfProject Value="True"/>
|
||||
</Unit0>
|
||||
<Unit1>
|
||||
<Filename Value="bgrasvgimagelistform.pas"/>
|
||||
<IsPartOfProject Value="True"/>
|
||||
<ComponentName Value="frmBGRASVGImageListEditor"/>
|
||||
<HasResources Value="True"/>
|
||||
<ResourceBaseClass Value="Form"/>
|
||||
</Unit1>
|
||||
</Units>
|
||||
</ProjectOptions>
|
||||
<CompilerOptions>
|
||||
<Version Value="11"/>
|
||||
<PathDelim Value="\"/>
|
||||
<Target>
|
||||
<Filename Value="bgrasvgimagelistproject"/>
|
||||
</Target>
|
||||
<SearchPaths>
|
||||
<IncludeFiles Value="$(ProjOutDir)"/>
|
||||
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
|
||||
</SearchPaths>
|
||||
<Linking>
|
||||
<Debugging>
|
||||
<DebugInfoType Value="dsDwarf2Set"/>
|
||||
</Debugging>
|
||||
<Options>
|
||||
<Win32>
|
||||
<GraphicApplication Value="True"/>
|
||||
</Win32>
|
||||
</Options>
|
||||
</Linking>
|
||||
</CompilerOptions>
|
||||
<Debugging>
|
||||
<Exceptions Count="3">
|
||||
<Item1>
|
||||
<Name Value="EAbort"/>
|
||||
</Item1>
|
||||
<Item2>
|
||||
<Name Value="ECodetoolError"/>
|
||||
</Item2>
|
||||
<Item3>
|
||||
<Name Value="EFOpenError"/>
|
||||
</Item3>
|
||||
</Exceptions>
|
||||
</Debugging>
|
||||
</CONFIG>
|
||||
@@ -0,0 +1,22 @@
|
||||
program bgrasvgimagelistproject;
|
||||
|
||||
{$mode objfpc}{$H+}
|
||||
|
||||
uses
|
||||
{$IFDEF UNIX}{$IFDEF UseCThreads}
|
||||
cthreads,
|
||||
{$ENDIF}{$ENDIF}
|
||||
Interfaces, // this includes the LCL widgetset
|
||||
Forms, bgrasvgimagelistform
|
||||
{ you can add units after this };
|
||||
|
||||
{$R *.res}
|
||||
|
||||
begin
|
||||
RequireDerivedFormResource:=True;
|
||||
Application.Scaled:=True;
|
||||
Application.Initialize;
|
||||
Application.CreateForm(TfrmBGRASVGImageListEditor, frmBGRASVGImageListEditor);
|
||||
Application.Run;
|
||||
end.
|
||||
|
||||
933
bgracontrols/bgrasvgtheme.pas
Normal file
933
bgracontrols/bgrasvgtheme.pas
Normal file
@@ -0,0 +1,933 @@
|
||||
unit BGRASVGTheme;
|
||||
|
||||
{$mode delphi}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs,
|
||||
BGRATheme, BGRABitmap, BGRABitmapTypes, BGRASVG, BGRASVGType, XMLConf,
|
||||
ComponentEditors, PropEdits, Menus, BGRASVGImageList, Math;
|
||||
|
||||
const
|
||||
DEFAULT_CHECKBOX_TEXT_SPACING = 2;
|
||||
DEFAULT_GLYPH_TEXT_SPACING = 6;
|
||||
DEFAULT_BUTTON_TEXT_SPACING = 6;
|
||||
|
||||
type
|
||||
|
||||
{ TBGRASVGTheme }
|
||||
|
||||
TBGRASVGTheme = class(TBGRATheme)
|
||||
private
|
||||
FButtonTextSpacing: integer;
|
||||
FCheckboxTextSpacing: integer;
|
||||
FColorizeActiveOp: TBlendOperation;
|
||||
FColorizeDisabledOp: TBlendOperation;
|
||||
FColorizeHoverOp: TBlendOperation;
|
||||
FColorizeNormalOp: TBlendOperation;
|
||||
FGlyphTextSpacing: integer;
|
||||
FOwner: TComponent;
|
||||
FButtonActive: TStringList;
|
||||
FButtonHover: TStringList;
|
||||
FButtonNormal: TStringList;
|
||||
FButtonSliceScalingBottom: integer;
|
||||
FButtonSliceScalingLeft: integer;
|
||||
FButtonSliceScalingRight: integer;
|
||||
FButtonSliceScalingTop: integer;
|
||||
FCheckBoxChecked: TStringList;
|
||||
FCheckBoxUnchecked: TStringList;
|
||||
FColorizeActive: string;
|
||||
FColorizeDisabled: string;
|
||||
FColorizeHover: string;
|
||||
FColorizeNormal: string;
|
||||
FRadioButtonChecked: TStringList;
|
||||
FRadioButtonUnchecked: TStringList;
|
||||
procedure SetButtonActive(AValue: TStringList);
|
||||
procedure SetButtonHover(AValue: TStringList);
|
||||
procedure SetButtonNormal(AValue: TStringList);
|
||||
procedure SetButtonSliceScalingBottom(AValue: integer);
|
||||
procedure SetButtonSliceScalingLeft(AValue: integer);
|
||||
procedure SetButtonSliceScalingRight(AValue: integer);
|
||||
procedure SetButtonSliceScalingTop(AValue: integer);
|
||||
procedure SetButtonTextSpacing(AValue: integer);
|
||||
procedure SetCheckBoxChecked(AValue: TStringList);
|
||||
procedure SetCheckboxTextSpacing(AValue: integer);
|
||||
procedure SetCheckBoxUnchecked(AValue: TStringList);
|
||||
procedure SetColorizeActive(AValue: string);
|
||||
procedure SetColorizeActiveOp(AValue: TBlendOperation);
|
||||
procedure SetColorizeDisabled(AValue: string);
|
||||
procedure SetColorizeDisabledOp(AValue: TBlendOperation);
|
||||
procedure SetColorizeHover(AValue: string);
|
||||
procedure SetColorizeHoverOp(AValue: TBlendOperation);
|
||||
procedure SetColorizeNormal(AValue: string);
|
||||
procedure SetColorizeNormalOp(AValue: TBlendOperation);
|
||||
procedure SetGlyphTextSpacing(AValue: integer);
|
||||
procedure SetRadioButtonChecked(AValue: TStringList);
|
||||
procedure SetRadioButtonUnchecked(AValue: TStringList);
|
||||
protected
|
||||
procedure LoadTheme(const XMLConf: TXMLConfig);
|
||||
procedure SaveTheme(const XMLConf: TXMLConfig);
|
||||
procedure CheckEmptyResourceException(const aResource: string);
|
||||
procedure SliceScalingDraw(const Source: TBGRASVG;
|
||||
const marginLeft, marginTop, marginRight, marginBottom: integer;
|
||||
const Dest: TBGRABitmap; DestDPI: integer);
|
||||
procedure ColorizeSurface(ASurface: TBGRAThemeSurface; AState: TBGRAThemeButtonState);
|
||||
public
|
||||
constructor Create(AOwner: TComponent); override;
|
||||
destructor Destroy; override;
|
||||
public
|
||||
function PreferredButtonHeight(const hasGlyph: boolean): Integer; override;
|
||||
function PreferredButtonWidth(const hasGlyph: boolean): Integer; override;
|
||||
procedure DrawButton(Caption: string; State: TBGRAThemeButtonState;
|
||||
Focused: boolean; ARect: TRect; ASurface: TBGRAThemeSurface; AImageIndex: Integer = -1; AImageList: TBGRASVGImageList = nil); override;
|
||||
procedure DrawRadioButton(Caption: string; State: TBGRAThemeButtonState;
|
||||
{%H-}Focused: boolean; Checked: boolean; ARect: TRect;
|
||||
ASurface: TBGRAThemeSurface); override;
|
||||
procedure DrawCheckBox(Caption: string; State: TBGRAThemeButtonState;
|
||||
{%H-}Focused: boolean; Checked: boolean; ARect: TRect;
|
||||
ASurface: TBGRAThemeSurface); override;
|
||||
public
|
||||
// XML File
|
||||
procedure SaveToFile(AFileName: string);
|
||||
// XML File
|
||||
procedure LoadFromFile(AFileName: string);
|
||||
// String Stream
|
||||
procedure SaveToStream(AStream: TStream);
|
||||
// String Stream
|
||||
procedure LoadFromStream(AStream: TStream);
|
||||
// Resource
|
||||
procedure LoadFromResource(AResource: string);
|
||||
// Default Theme
|
||||
procedure LoadDefaultTheme;
|
||||
published
|
||||
// Check box unchecked state
|
||||
property CheckBoxUnchecked: TStringList read FCheckBoxUnchecked
|
||||
write SetCheckBoxUnchecked;
|
||||
// Check box checked state
|
||||
property CheckBoxChecked: TStringList read FCheckBoxChecked write SetCheckBoxChecked;
|
||||
// Radio button unchecked state
|
||||
property RadioButtonUnchecked: TStringList
|
||||
read FRadioButtonUnchecked write SetRadioButtonUnchecked;
|
||||
// Radio button checked state
|
||||
property RadioButtonChecked: TStringList
|
||||
read FRadioButtonChecked write SetRadioButtonChecked;
|
||||
// Spacing between checkbox/radiobutton and its text (in 96 DPI)
|
||||
property CheckBoxTextSpacing: integer read FCheckboxTextSpacing write SetCheckboxTextSpacing default DEFAULT_CHECKBOX_TEXT_SPACING;
|
||||
// Button normal state
|
||||
property ButtonNormal: TStringList read FButtonNormal write SetButtonNormal;
|
||||
// Button mouse over state
|
||||
property ButtonHover: TStringList read FButtonHover write SetButtonHover;
|
||||
// Button pressed state
|
||||
property ButtonActive: TStringList read FButtonActive write SetButtonActive;
|
||||
// 9-Slice-Scaling margin left
|
||||
property ButtonSliceScalingLeft: integer
|
||||
read FButtonSliceScalingLeft write SetButtonSliceScalingLeft;
|
||||
// 9-Slice-Scaling margin top
|
||||
property ButtonSliceScalingTop: integer
|
||||
read FButtonSliceScalingTop write SetButtonSliceScalingTop;
|
||||
// 9-Slice-Scaling margin right
|
||||
property ButtonSliceScalingRight: integer
|
||||
read FButtonSliceScalingRight write SetButtonSliceScalingRight;
|
||||
// 9-Slice-Scaling margin bottom
|
||||
property ButtonSliceScalingBottom: integer
|
||||
read FButtonSliceScalingBottom write SetButtonSliceScalingBottom;
|
||||
// Spacing between glyph and its text (in 96 DPI)
|
||||
property GlyphTextSpacing: integer read FGlyphTextSpacing write SetGlyphTextSpacing default DEFAULT_GLYPH_TEXT_SPACING;
|
||||
// Spacing between text and button border (in 96 DPI)
|
||||
property ButtonTextSpacing: integer read FButtonTextSpacing write SetButtonTextSpacing default DEFAULT_BUTTON_TEXT_SPACING;
|
||||
// CSS Color to tint the normal states, use rgba(0,0,0,0) to disable
|
||||
property ColorizeNormal: string read FColorizeNormal write SetColorizeNormal;
|
||||
property ColorizeNormalOp: TBlendOperation read FColorizeNormalOp write SetColorizeNormalOp default boTransparent;
|
||||
// CSS Color to tint the hover states, use rgba(0,0,0,0) to disable
|
||||
property ColorizeHover: string read FColorizeHover write SetColorizeHover;
|
||||
property ColorizeHoverOp: TBlendOperation read FColorizeHoverOp write SetColorizeHoverOp default boTransparent;
|
||||
// CSS Color to tint the active states, use rgba(0,0,0,0) to disable
|
||||
property ColorizeActive: string read FColorizeActive write SetColorizeActive;
|
||||
property ColorizeActiveOp: TBlendOperation read FColorizeActiveOp write SetColorizeActiveOp default boTransparent;
|
||||
// CSS Color to tint the disabled states, use rgba(0,0,0,0) to disable
|
||||
property ColorizeDisabled: string read FColorizeDisabled write SetColorizeDisabled;
|
||||
property ColorizeDisabledOp: TBlendOperation read FColorizeDisabledOp write SetColorizeDisabledOp default boTransparent;
|
||||
end;
|
||||
|
||||
{ TBGRASVGThemeComponentEditor }
|
||||
|
||||
TBGRASVGThemeComponentEditor = class(TBaseComponentEditor)
|
||||
private
|
||||
FComponent: TBGRASVGTheme;
|
||||
public
|
||||
constructor Create({%H-}AComponent: TComponent;
|
||||
{%H-}ADesigner: TComponentEditorDesigner); override;
|
||||
procedure Copy; override;
|
||||
procedure Edit; override;
|
||||
procedure ExecuteVerb(Index: Integer); override;
|
||||
function GetComponent: TComponent; override;
|
||||
function GetCustomHint: String; override;
|
||||
function GetDesigner: TComponentEditorDesigner; override;
|
||||
function GetHook(out Hook: TPropertyEditorHook): boolean; override;
|
||||
function GetVerb(Index: Integer): string; override;
|
||||
function GetVerbCount: Integer; override;
|
||||
function IsInInlined: Boolean; override;
|
||||
procedure PrepareItem({%H-}Index: Integer; const {%H-}AnItem: TMenuItem); override;
|
||||
procedure Modified; override;
|
||||
end;
|
||||
|
||||
procedure Register;
|
||||
|
||||
implementation
|
||||
|
||||
uses BCTypes, BCTools;
|
||||
|
||||
const
|
||||
RES_CHECKBOXUNCHECKED =
|
||||
'<svg xmlns="http://www.w3.org/2000/svg" height="24" viewBox="0 0 24 24" width="24"><path d="M0 0h24v24H0z" fill="none"/><path d="M19 5v14H5V5h14m0-2H5c-1.1 0-2 .9-2 2v14c0 1.1.9 2 2 2h14c1.1 0 2-.9 2-2V5c0-1.1-.9-2-2-2z"/></svg>';
|
||||
RES_CHECKBOXCHECKED =
|
||||
'<svg xmlns="http://www.w3.org/2000/svg" height="24" viewBox="0 0 24 24" width="24"><path d="M0 0h24v24H0z" fill="none"/><path d="M19 3H5c-1.11 0-2 .9-2 2v14c0 1.1.89 2 2 2h14c1.11 0 2-.9 2-2V5c0-1.1-.89-2-2-2zm-9 14l-5-5 1.41-1.41L10 14.17l7.59-7.59L19 8l-9 9z"/></svg>';
|
||||
RES_RADIOBUTTONUNCHECKED =
|
||||
'<svg xmlns="http://www.w3.org/2000/svg" height="24" viewBox="0 0 24 24" width="24"><path d="M0 0h24v24H0z" fill="none"/><path d="M12 2C6.48 2 2 6.48 2 12s4.48 10 10 10 10-4.48 10-10S17.52 2 12 2zm0 18c-4.42 0-8-3.58-8-8s3.58-8 8-8 8 3.58 8 8-3.58 8-8 8z"/></svg>';
|
||||
RES_RADIOBUTTONCHECKED =
|
||||
'<svg xmlns="http://www.w3.org/2000/svg" height="24" viewBox="0 0 24 24" width="24"><path d="M0 0h24v24H0z" fill="none"/><path d="M12 7c-2.76 0-5 2.24-5 5s2.24 5 5 5 5-2.24 5-5-2.24-5-5-5zm0-5C6.48 2 2 6.48 2 12s4.48 10 10 10 10-4.48 10-10S17.52 2 12 2zm0 18c-4.42 0-8-3.58-8-8s3.58-8 8-8 8 3.58 8 8-3.58 8-8 8z"/></svg>';
|
||||
RES_BUTTON =
|
||||
'<?xml version="1.0" encoding="UTF-8" standalone="no"?><svg xmlns:dc="http://purl.org/dc/elements/1.1/" xmlns:cc="http://creativecommons.org/ns#" xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#" xmlns:svg="http://www.w3.org/2000/svg" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" xmlns:sodipodi="http://sodipodi.sourceforge.net/DTD/sodipodi-0.dtd" xmlns:inkscape="http://www.inkscape.org/namespaces/inkscape" width="32" height="32" viewBox="0 0 32 32" version="1.1" id="svg8" inkscape:version="1.0.1 (3bc2e813f5, 2020-09-07)" sodipodi:docname="lime.svg"> <style id="style833"></style> <defs id="defs2"> <linearGradient inkscape:collect="always" id="linearGradient858"> <stop style="stop-color:#87cdde;stop-opacity:1" offset="0" id="stop854" /> <stop style="stop-color:#ffffff;stop-opacity:1" offset="1" id="stop856" /> </linearGradient> <linearGradient inkscape:collect="always" xlink:href="#linearGradient858" id="linearGradient1415" x1="3.9924731" y1="5.9193549" x2="3.9924731" y2="2.788172" gradientUnits="userSpaceOnUse" gradientTransform="matrix(4.1517857,0,0,4.1517856,-1.5758928,-1.5758928)" /> </defs> <sodipodi:namedview id="base" pagecolor="#ffffff" bordercolor="#666666" borderopacity="1.0" inkscape:pageopacity="0.0" inkscape:pageshadow="2" inkscape:zoom="11.313708" inkscape:cx="4.3902273" inkscape:cy="23.941929" inkscape:document-units="px" inkscape:current-layer="layer1" inkscape:document-rotation="0" showgrid="true" units="px" inkscape:window-width="1920" inkscape:window-height="1017" inkscape:window-x="-8" inkscape:window-y="-8" inkscape:window-maximized="1"> <inkscape:grid type="xygrid" id="grid837" /> </sodipodi:namedview> <metadata id="metadata5"> <rdf:RDF> <cc:Work rdf:about=""> <dc:format>image/svg+xml</dc:format> <dc:type rdf:resource="http://purl.org/dc/dcmitype/StillImage" /> <dc:title></dc:title> </cc:Work> </rdf:RDF> </metadata> <g inkscape:label="Capa 1" inkscape:groupmode="layer" id="layer1"> <path vectorEffect="non-scaling-stroke" id="rect835" style="fill:url(#linearGradient1415);fill-opacity:1;stroke:#002255;stroke-width:1;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1" d="M 9.8000004,0.50000004 H 22.2 c 5.1522,0 9.3,4.14779986 9.3,9.30000016 V 22.2 c 0,5.152199 -4.1478,9.3 -9.3,9.3 H 9.8000004 C 4.6478005,31.5 0.50000005,27.352199 0.50000005,22.2 V 9.8000002 c 0,-5.1522003 4.14780045,-9.30000016 9.30000035,-9.30000016 z" /> </g></svg>';
|
||||
RES_COLORIZENORMAL = 'rgba(0,0,0,0)';
|
||||
RES_COLORIZEHOVER = 'rgba(255,255,255,0.5)';
|
||||
RES_COLORIZEACTIVE = 'rgba(0,0,0,0.5)';
|
||||
RES_COLORIZEDISABLED = 'rgba(127,127,127,0.7)';
|
||||
|
||||
procedure Register;
|
||||
begin
|
||||
RegisterComponents('BGRA Themes', [TBGRASVGTheme]);
|
||||
RegisterComponentEditor(TBGRASVGTheme, TBGRASVGThemeComponentEditor);
|
||||
end;
|
||||
|
||||
{ TBGRASVGThemeComponentEditor }
|
||||
|
||||
constructor TBGRASVGThemeComponentEditor.Create(AComponent: TComponent;
|
||||
ADesigner: TComponentEditorDesigner);
|
||||
begin
|
||||
FComponent := TBGRASVGTheme(AComponent);
|
||||
end;
|
||||
|
||||
procedure TBGRASVGThemeComponentEditor.Copy;
|
||||
begin
|
||||
|
||||
end;
|
||||
|
||||
procedure TBGRASVGThemeComponentEditor.Edit;
|
||||
begin
|
||||
|
||||
end;
|
||||
|
||||
procedure TBGRASVGThemeComponentEditor.ExecuteVerb(Index: Integer);
|
||||
var
|
||||
openDlg: TOpenDialog;
|
||||
saveDlg: TSaveDialog;
|
||||
begin
|
||||
case Index of
|
||||
// Load from file
|
||||
0: begin
|
||||
openDlg := TOpenDialog.Create(nil);
|
||||
openDlg.Filter := 'XML|*.xml';
|
||||
try
|
||||
if openDlg.Execute then
|
||||
begin
|
||||
TBGRASVGTheme(GetComponent).LoadFromFile(openDlg.FileName);
|
||||
end;
|
||||
finally
|
||||
openDlg.Free;
|
||||
end;
|
||||
end;
|
||||
// Save to file
|
||||
1: begin
|
||||
saveDlg := TSaveDialog.Create(nil);
|
||||
saveDlg.Filter := 'XML|*.xml';
|
||||
try
|
||||
if saveDlg.Execute then
|
||||
begin
|
||||
TBGRASVGTheme(GetComponent).SaveToFile(saveDlg.FileName);
|
||||
end;
|
||||
finally
|
||||
saveDlg.Free;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TBGRASVGThemeComponentEditor.GetVerb(Index: Integer): string;
|
||||
begin
|
||||
case Index of
|
||||
0: Result := 'Load From File...';
|
||||
1: Result := 'Save To File...';
|
||||
else
|
||||
result := '';
|
||||
end;
|
||||
end;
|
||||
|
||||
function TBGRASVGThemeComponentEditor.GetVerbCount: Integer;
|
||||
begin
|
||||
Result := 2;
|
||||
end;
|
||||
|
||||
function TBGRASVGThemeComponentEditor.IsInInlined: Boolean;
|
||||
begin
|
||||
result := False;
|
||||
end;
|
||||
|
||||
procedure TBGRASVGThemeComponentEditor.PrepareItem(Index: Integer;
|
||||
const AnItem: TMenuItem);
|
||||
begin
|
||||
|
||||
end;
|
||||
|
||||
procedure TBGRASVGThemeComponentEditor.Modified;
|
||||
begin
|
||||
|
||||
end;
|
||||
|
||||
function TBGRASVGThemeComponentEditor.GetComponent: TComponent;
|
||||
begin
|
||||
Result := FComponent;
|
||||
end;
|
||||
|
||||
function TBGRASVGThemeComponentEditor.GetCustomHint: String;
|
||||
begin
|
||||
result := 'SVG Theme';
|
||||
end;
|
||||
|
||||
function TBGRASVGThemeComponentEditor.GetDesigner: TComponentEditorDesigner;
|
||||
begin
|
||||
result := nil;
|
||||
end;
|
||||
|
||||
function TBGRASVGThemeComponentEditor.GetHook(out Hook: TPropertyEditorHook
|
||||
): boolean;
|
||||
begin
|
||||
Hook := nil;
|
||||
result := false;
|
||||
end;
|
||||
|
||||
{ TBGRASVGTheme }
|
||||
|
||||
procedure TBGRASVGTheme.SetCheckBoxUnchecked(AValue: TStringList);
|
||||
begin
|
||||
CheckEmptyResourceException(AValue.Text);
|
||||
if (AValue <> FCheckBoxUnchecked) then
|
||||
begin
|
||||
FCheckBoxUnchecked.Assign(AValue);
|
||||
InvalidateThemedControls;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TBGRASVGTheme.SetColorizeActive(AValue: string);
|
||||
begin
|
||||
if FColorizeActive = AValue then
|
||||
Exit;
|
||||
FColorizeActive := AValue;
|
||||
InvalidateThemedControls;
|
||||
end;
|
||||
|
||||
procedure TBGRASVGTheme.SetColorizeActiveOp(AValue: TBlendOperation);
|
||||
begin
|
||||
if FColorizeActiveOp=AValue then Exit;
|
||||
FColorizeActiveOp:=AValue;
|
||||
InvalidateThemedControls;
|
||||
end;
|
||||
|
||||
procedure TBGRASVGTheme.SetColorizeDisabled(AValue: string);
|
||||
begin
|
||||
if FColorizeDisabled = AValue then
|
||||
Exit;
|
||||
FColorizeDisabled := AValue;
|
||||
InvalidateThemedControls;
|
||||
end;
|
||||
|
||||
procedure TBGRASVGTheme.SetColorizeDisabledOp(AValue: TBlendOperation);
|
||||
begin
|
||||
if FColorizeDisabledOp=AValue then Exit;
|
||||
FColorizeDisabledOp:=AValue;
|
||||
InvalidateThemedControls;
|
||||
end;
|
||||
|
||||
procedure TBGRASVGTheme.SetColorizeHover(AValue: string);
|
||||
begin
|
||||
if FColorizeHover = AValue then
|
||||
Exit;
|
||||
FColorizeHover := AValue;
|
||||
InvalidateThemedControls;
|
||||
end;
|
||||
|
||||
procedure TBGRASVGTheme.SetColorizeHoverOp(AValue: TBlendOperation);
|
||||
begin
|
||||
if FColorizeHoverOp=AValue then Exit;
|
||||
FColorizeHoverOp:=AValue;
|
||||
InvalidateThemedControls;
|
||||
end;
|
||||
|
||||
procedure TBGRASVGTheme.SetColorizeNormal(AValue: string);
|
||||
begin
|
||||
if FColorizeNormal = AValue then
|
||||
Exit;
|
||||
FColorizeNormal := AValue;
|
||||
InvalidateThemedControls;
|
||||
end;
|
||||
|
||||
procedure TBGRASVGTheme.SetColorizeNormalOp(AValue: TBlendOperation);
|
||||
begin
|
||||
if FColorizeNormalOp=AValue then Exit;
|
||||
FColorizeNormalOp:=AValue;
|
||||
InvalidateThemedControls;
|
||||
end;
|
||||
|
||||
procedure TBGRASVGTheme.SetGlyphTextSpacing(AValue: integer);
|
||||
begin
|
||||
if FGlyphTextSpacing=AValue then Exit;
|
||||
FGlyphTextSpacing:=AValue;
|
||||
InvalidateThemedControls;
|
||||
end;
|
||||
|
||||
procedure TBGRASVGTheme.SetRadioButtonChecked(AValue: TStringList);
|
||||
begin
|
||||
CheckEmptyResourceException(AValue.Text);
|
||||
if (AValue <> FRadioButtonChecked) then
|
||||
begin
|
||||
FRadioButtonChecked.Assign(AValue);
|
||||
InvalidateThemedControls;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TBGRASVGTheme.SetRadioButtonUnchecked(AValue: TStringList);
|
||||
begin
|
||||
CheckEmptyResourceException(AValue.Text);
|
||||
if (AValue <> FRadioButtonUnchecked) then
|
||||
begin
|
||||
FRadioButtonUnchecked.Assign(AValue);
|
||||
InvalidateThemedControls;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TBGRASVGTheme.LoadDefaultTheme;
|
||||
begin
|
||||
FCheckBoxUnchecked.Text := RES_CHECKBOXUNCHECKED;
|
||||
FCheckBoxChecked.Text := RES_CHECKBOXCHECKED;
|
||||
FCheckboxTextSpacing:= DEFAULT_CHECKBOX_TEXT_SPACING;
|
||||
FRadioButtonUnchecked.Text := RES_RADIOBUTTONUNCHECKED;
|
||||
FRadioButtonChecked.Text := RES_RADIOBUTTONCHECKED;
|
||||
FButtonNormal.Text := RES_BUTTON;
|
||||
FButtonHover.Text := '';
|
||||
FButtonActive.Text := '';
|
||||
FButtonSliceScalingLeft := 10;
|
||||
FButtonSliceScalingTop := 10;
|
||||
FButtonSliceScalingRight := 10;
|
||||
FButtonSliceScalingBottom := 10;
|
||||
FGlyphTextSpacing := DEFAULT_GLYPH_TEXT_SPACING;
|
||||
FButtonTextSpacing := DEFAULT_BUTTON_TEXT_SPACING;
|
||||
FColorizeNormal := RES_COLORIZENORMAL;
|
||||
FColorizeHover := RES_COLORIZEHOVER;
|
||||
FColorizeActive := RES_COLORIZEACTIVE;
|
||||
FColorizeDisabled := RES_COLORIZEDISABLED;
|
||||
FColorizeNormalOp := boTransparent;
|
||||
FColorizeHoverOp := boTransparent;
|
||||
FColorizeActiveOp := boTransparent;
|
||||
FColorizeDisabledOp := boTransparent;
|
||||
end;
|
||||
|
||||
procedure TBGRASVGTheme.LoadTheme(const XMLConf: TXMLConfig);
|
||||
begin
|
||||
try
|
||||
XMLConf.RootName := 'BGRASVGTheme';
|
||||
// Button
|
||||
FButtonActive.Text := XMLConf.GetValue('Button/Active/SVG', RES_BUTTON){%H-};
|
||||
FButtonHover.Text := XMLConf.GetValue('Button/Hover/SVG', ''){%H-};
|
||||
FButtonNormal.Text := XMLConf.GetValue('Button/Normal/SVG', ''){%H-};
|
||||
FButtonSliceScalingBottom := XMLConf.GetValue('Button/SliceScaling/Bottom', 10);
|
||||
FButtonSliceScalingLeft := XMLConf.GetValue('Button/SliceScaling/Left', 10);
|
||||
FButtonSliceScalingRight := XMLConf.GetValue('Button/SliceScaling/Right', 10);
|
||||
FButtonSliceScalingTop := XMLConf.GetValue('Button/SliceScaling/Top', 10);
|
||||
FGlyphTextSpacing := XMLConf.GetValue('Button/GlyphSpacing', DEFAULT_GLYPH_TEXT_SPACING);
|
||||
FButtonTextSpacing := XMLConf.GetValue('Button/TextSpacing', DEFAULT_BUTTON_TEXT_SPACING);
|
||||
// CheckBox
|
||||
FCheckBoxChecked.Text := XMLConf.GetValue('CheckBox/Checked/SVG',
|
||||
RES_CHECKBOXCHECKED){%H-};
|
||||
FCheckBoxUnchecked.Text := XMLConf.GetValue('CheckBox/Unchecked/SVG',
|
||||
RES_CHECKBOXUNCHECKED){%H-};
|
||||
FCheckBoxTextSpacing := XMLConf.GetValue('CheckBox/TextSpacing', DEFAULT_CHECKBOX_TEXT_SPACING);
|
||||
// Colorize
|
||||
FColorizeActive := XMLConf{%H-}.GetValue('Colorize/Active', RES_COLORIZEACTIVE);
|
||||
FColorizeDisabled := XMLConf{%H-}.GetValue('Colorize/Disabled', RES_COLORIZEDISABLED);
|
||||
FColorizeHover := XMLConf{%H-}.GetValue('Colorize/Hover', RES_COLORIZEHOVER);
|
||||
FColorizeNormal := XMLConf{%H-}.GetValue('Colorize/Normal', RES_COLORIZENORMAL);
|
||||
FColorizeActiveOp := StrToBlendOperation(XMLConf{%H-}.GetValue('Colorize/ActiveOp', BlendOperationStr[boTransparent]));
|
||||
FColorizeDisabledOp := StrToBlendOperation(XMLConf{%H-}.GetValue('Colorize/DisabledOp', BlendOperationStr[boTransparent]));
|
||||
FColorizeHoverOp := StrToBlendOperation(XMLConf{%H-}.GetValue('Colorize/HoverOp', BlendOperationStr[boTransparent]));
|
||||
FColorizeNormalOp := StrToBlendOperation(XMLConf{%H-}.GetValue('Colorize/NormalOp', BlendOperationStr[boTransparent]));
|
||||
// RadioButton
|
||||
FRadioButtonChecked.Text :=
|
||||
XMLConf.GetValue('RadioButton/Checked/SVG', RES_RADIOBUTTONCHECKED{%H-}){%H-};
|
||||
FRadioButtonUnchecked.Text :=
|
||||
XMLConf.GetValue('RadioButton/Unchecked/SVG', RES_RADIOBUTTONUNCHECKED{%H-}){%H-};
|
||||
finally
|
||||
InvalidateThemedControls;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TBGRASVGTheme.SaveTheme(const XMLConf: TXMLConfig);
|
||||
begin
|
||||
XMLConf.RootName := 'BGRASVGTheme';
|
||||
// Button
|
||||
XMLConf.SetValue('Button/Active/SVG', FButtonActive.Text{%H-});
|
||||
XMLConf.SetValue('Button/Hover/SVG', FButtonHover.Text{%H-});
|
||||
XMLConf.SetValue('Button/Normal/SVG', FButtonNormal.Text{%H-});
|
||||
XMLConf.SetValue('Button/SliceScaling/Bottom', FButtonSliceScalingBottom);
|
||||
XMLConf.SetValue('Button/SliceScaling/Left', FButtonSliceScalingLeft);
|
||||
XMLConf.SetValue('Button/SliceScaling/Right', FButtonSliceScalingRight);
|
||||
XMLConf.SetValue('Button/SliceScaling/Top', FButtonSliceScalingTop);
|
||||
XMLConf.SetValue('Button/GlyphSpacing', FGlyphTextSpacing);
|
||||
XMLConf.SetValue('Button/TextSpacing', FButtonTextSpacing);
|
||||
// CheckBox
|
||||
XMLConf.SetValue('CheckBox/Checked/SVG', FCheckBoxChecked.Text{%H-});
|
||||
XMLConf.SetValue('CheckBox/Unchecked/SVG', FCheckBoxUnchecked.Text{%H-});
|
||||
XMLConf.SetValue('CheckBox/TextSpacing', FCheckboxTextSpacing);
|
||||
// Colorize
|
||||
XMLConf.SetValue('Colorize/Active', FColorizeActive{%H-});
|
||||
XMLConf.SetValue('Colorize/Disabled', FColorizeDisabled{%H-});
|
||||
XMLConf.SetValue('Colorize/Hover', FColorizeHover{%H-});
|
||||
XMLConf.SetValue('Colorize/Normal', FColorizeNormal{%H-});
|
||||
XMLConf.SetValue('Colorize/ActiveOp', BlendOperationStr[FColorizeActiveOp{%H-}]);
|
||||
XMLConf.SetValue('Colorize/DisabledOp', BlendOperationStr[FColorizeDisabledOp{%H-}]);
|
||||
XMLConf.SetValue('Colorize/HoverOp', BlendOperationStr[FColorizeHoverOp{%H-}]);
|
||||
XMLConf.SetValue('Colorize/NormalOp', BlendOperationStr[FColorizeNormalOp{%H-}]); // RadioButton
|
||||
XMLConf.SetValue('RadioButton/Checked/SVG', FRadioButtonChecked.Text{%H-});
|
||||
XMLConf.SetValue('RadioButton/Unchecked/SVG', FRadioButtonUnchecked.Text{%H-});
|
||||
end;
|
||||
|
||||
procedure TBGRASVGTheme.CheckEmptyResourceException(const aResource: string);
|
||||
begin
|
||||
if Trim(aResource).IsEmpty then
|
||||
raise Exception.Create('Resource must not be empty.');
|
||||
end;
|
||||
|
||||
procedure TBGRASVGTheme.SliceScalingDraw(const Source: TBGRASVG;
|
||||
const marginLeft, marginTop, marginRight, marginBottom: integer;
|
||||
const Dest: TBGRABitmap; DestDPI: integer);
|
||||
var
|
||||
svgBox: TSVGViewBox;
|
||||
svgTopLeft, svgBottomRight: TPointF;
|
||||
sourcePosX, sourcePosY: array[1..4] of single;
|
||||
destPosX, destPosY: array[1..4] of integer;
|
||||
y, x: integer;
|
||||
|
||||
procedure DrawPart(sourceRect: TRectF; destRect: TRect);
|
||||
var
|
||||
zoom: TPointF;
|
||||
begin
|
||||
if sourceRect.IsEmpty or destRect.IsEmpty then
|
||||
exit;
|
||||
dest.ClipRect := destRect;
|
||||
zoom := PointF(destRect.Width / sourceRect.Width, destRect.Height /
|
||||
sourceRect.Height);
|
||||
Source.Draw(dest.Canvas2D, -sourceRect.Left * zoom.x + destRect.Left,
|
||||
-sourceRect.Top * zoom.y + destRect.Top, Source.DefaultDpi * zoom);
|
||||
end;
|
||||
|
||||
begin
|
||||
svgBox := Source.ViewBoxInUnit[cuPixel];
|
||||
svgTopLeft := svgBox.min;
|
||||
svgBottomRight := svgBox.min + svgBox.size;
|
||||
|
||||
sourcePosX[1] := svgTopLeft.x;
|
||||
sourcePosX[2] := svgTopLeft.x + marginLeft;
|
||||
sourcePosX[3] := svgBottomRight.x - marginRight;
|
||||
sourcePosX[4] := svgBottomRight.x;
|
||||
sourcePosY[1] := svgTopLeft.y;
|
||||
sourcePosY[2] := svgTopLeft.y + marginTop;
|
||||
sourcePosY[3] := svgBottomRight.y - marginBottom;
|
||||
sourcePosY[4] := svgBottomRight.y;
|
||||
if sourcePosX[2] > sourcePosX[3] then
|
||||
begin
|
||||
sourcePosX[2] := (sourcePosX[1] + sourcePosX[4]) / 2;
|
||||
sourcePosX[3] := sourcePosX[2];
|
||||
end;
|
||||
if sourcePosY[2] > sourcePosY[3] then
|
||||
begin
|
||||
sourcePosY[2] := (sourcePosY[1] + sourcePosY[4]) / 2;
|
||||
sourcePosY[3] := sourcePosY[2];
|
||||
end;
|
||||
|
||||
destPosX[1] := 0;
|
||||
destPosX[2] := round(marginLeft * DestDPI / 96);
|
||||
destPosX[3] := dest.Width - round(marginRight * DestDPI / 96);
|
||||
destPosX[4] := dest.Width;
|
||||
destPosY[1] := 0;
|
||||
destPosY[2] := round(marginTop * DestDPI / 96);
|
||||
destPosY[3] := dest.Height - round(marginBottom * DestDPI / 96);
|
||||
destPosY[4] := dest.Height;
|
||||
if destPosX[2] > destPosX[3] then
|
||||
begin
|
||||
destPosX[2] := round((destPosX[1] + destPosX[4]) / 2);
|
||||
destPosX[3] := destPosX[2];
|
||||
end;
|
||||
if destPosY[2] > destPosY[3] then
|
||||
begin
|
||||
destPosY[2] := round((destPosY[1] + destPosY[4]) / 2);
|
||||
destPosY[3] := destPosY[2];
|
||||
end;
|
||||
|
||||
for y := 1 to 3 do
|
||||
for x := 1 to 3 do
|
||||
DrawPart(RectF(sourcePosX[x], sourcePosY[y], sourcePosX[x + 1], sourcePosY[y + 1]),
|
||||
Rect(destPosX[x], destPosY[y], destPosX[x + 1], destPosY[y + 1]));
|
||||
Dest.NoClip;
|
||||
end;
|
||||
|
||||
procedure TBGRASVGTheme.ColorizeSurface(ASurface: TBGRAThemeSurface;
|
||||
AState: TBGRAThemeButtonState);
|
||||
var
|
||||
color: String;
|
||||
op: TBlendOperation;
|
||||
begin
|
||||
case AState of
|
||||
btbsNormal: begin color := FColorizeNormal; op := FColorizeNormalOp; end;
|
||||
btbsHover: begin color := FColorizeHover; op := FColorizeHoverOp; end;
|
||||
btbsActive: begin color := FColorizeActive; op := FColorizeActiveOp; end;
|
||||
else {btbsDisabled} begin color := FColorizeDisabled; op := FColorizeDisabledOp; end;
|
||||
end;
|
||||
ASurface.BitmapColorOverlay(StrToBGRA(color), op);
|
||||
end;
|
||||
|
||||
constructor TBGRASVGTheme.Create(AOwner: TComponent);
|
||||
begin
|
||||
inherited Create(AOwner);
|
||||
FOwner := AOwner;
|
||||
FCheckBoxUnchecked := TStringList.Create;
|
||||
FCheckBoxChecked := TStringList.Create;
|
||||
FRadioButtonUnchecked := TStringList.Create;
|
||||
FRadioButtonChecked := TStringList.Create;
|
||||
FButtonNormal := TStringList.Create;
|
||||
FButtonHover := TStringList.Create;
|
||||
FButtonActive := TStringList.Create;
|
||||
LoadDefaultTheme;
|
||||
end;
|
||||
|
||||
destructor TBGRASVGTheme.Destroy;
|
||||
begin
|
||||
FCheckBoxUnchecked.Free;
|
||||
FCheckBoxChecked.Free;
|
||||
FRadioButtonUnchecked.Free;
|
||||
FRadioButtonChecked.Free;
|
||||
FButtonNormal.Free;
|
||||
FButtonHover.Free;
|
||||
FButtonActive.Free;
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
function TBGRASVGTheme.PreferredButtonHeight(const hasGlyph: boolean): Integer;
|
||||
begin
|
||||
Result := (FButtonTextSpacing * 2);
|
||||
end;
|
||||
|
||||
function TBGRASVGTheme.PreferredButtonWidth(const hasGlyph: boolean): Integer;
|
||||
begin
|
||||
Result := (FButtonTextSpacing * 2);
|
||||
if (hasGlyph) then
|
||||
Result := Result + FGlyphTextSpacing;
|
||||
end;
|
||||
|
||||
procedure TBGRASVGTheme.DrawButton(Caption: string;
|
||||
State: TBGRAThemeButtonState; Focused: boolean; ARect: TRect;
|
||||
ASurface: TBGRAThemeSurface; AImageIndex: Integer;
|
||||
AImageList: TBGRASVGImageList);
|
||||
var
|
||||
svg: TBGRASVG;
|
||||
svgCode: String;
|
||||
gs: TSize;
|
||||
bcFont: TBCFont;
|
||||
actualCaption: string;
|
||||
r, rGlyph: TRect;
|
||||
drawText: boolean = True;
|
||||
|
||||
begin
|
||||
with ASurface do
|
||||
begin
|
||||
case State of
|
||||
btbsNormal: svg := TBGRASVG.CreateFromString(FButtonNormal.Text);
|
||||
btbsHover:
|
||||
begin
|
||||
svgCode := FButtonHover.Text;
|
||||
if trim(svgCode) = '' then svgCode := FButtonNormal.Text;
|
||||
svg := TBGRASVG.CreateFromString(svgCode);
|
||||
end;
|
||||
btbsActive:
|
||||
begin
|
||||
svgCode := FButtonActive.Text;
|
||||
if trim(svgCode) = '' then svgCode := FButtonHover.Text;
|
||||
if trim(svgCode) = '' then svgCode := FButtonNormal.Text;
|
||||
svg := TBGRASVG.CreateFromString(svgCode);
|
||||
end;
|
||||
else {btbsDisabled}
|
||||
svg := TBGRASVG.CreateFromString(FButtonNormal.Text);
|
||||
end;
|
||||
SliceScalingDraw(svg, FButtonSliceScalingLeft, FButtonSliceScalingTop,
|
||||
FButtonSliceScalingRight, FButtonSliceScalingBottom, Bitmap,
|
||||
BitmapDPI);
|
||||
svg.Free;
|
||||
|
||||
if Assigned(AImageList) and (AImageIndex > -1) and (AImageIndex < AImageList.Count) then
|
||||
begin
|
||||
gs := AImageList.GetScaledSize(BitmapDPI);
|
||||
if ARect.Width - gs.cx < ScaleForBitmap(GlyphTextSpacing + 2*ButtonTextSpacing) then
|
||||
drawText := false;
|
||||
end
|
||||
else gs := TSize.Create(0, 0);
|
||||
|
||||
bcFont := TBCFont.Create(nil);
|
||||
bcFont.Assign(DestCanvas.Font);
|
||||
bcFont.Scale(BitmapDPI / DestCanvasDPI, false);
|
||||
bcFont.WordBreak := true;
|
||||
bcFont.PaddingBottom:= ScaleForBitmap(ButtonTextSpacing);
|
||||
bcFont.PaddingTop:= ScaleForBitmap(ButtonTextSpacing);
|
||||
bcFont.PaddingRight:= ScaleForBitmap(ButtonTextSpacing);
|
||||
bcFont.PaddingLeft:= ScaleForBitmap(ButtonTextSpacing);
|
||||
bcFont.TextAlignment:= bcaCenter;
|
||||
|
||||
if drawText then
|
||||
actualCaption := Caption
|
||||
else actualCaption:= '';
|
||||
|
||||
r := ScaleForBitmap(ARect, DestCanvasDPI);
|
||||
rGlyph := ComputeGlyphPosition(r, gs.cx, gs.cy, bcaCenter,
|
||||
ScaleForBitmap(GlyphTextSpacing), actualCaption, bcFont);
|
||||
if not rGlyph.IsEmpty then
|
||||
AImageList.Draw(AImageIndex, Bitmap, RectF(rGlyph));
|
||||
RenderText(r, bcFont, actualCaption, Bitmap, State <> btbsDisabled);
|
||||
|
||||
bcFont.Free;
|
||||
ColorizeSurface(ASurface, State);
|
||||
DrawBitmap;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TBGRASVGTheme.DrawRadioButton(Caption: string;
|
||||
State: TBGRAThemeButtonState; Focused: boolean; Checked: boolean;
|
||||
ARect: TRect; ASurface: TBGRAThemeSurface);
|
||||
var
|
||||
Style: TTextStyle;
|
||||
svg: TBGRASVG;
|
||||
begin
|
||||
with ASurface do
|
||||
begin
|
||||
BitmapRect := RectWithSize(ARect.Left, ARect.Top, ARect.Height, ARect.Height);
|
||||
if Checked then
|
||||
svg := TBGRASVG.CreateFromString(FRadioButtonChecked.Text)
|
||||
else
|
||||
svg := TBGRASVG.CreateFromString(FRadioButtonUnchecked.Text);
|
||||
svg.StretchDraw(Bitmap.Canvas2D, 0, 0, Bitmap.Width, Bitmap.Height);
|
||||
svg.Free;
|
||||
ColorizeSurface(ASurface, State);
|
||||
DrawBitmap;
|
||||
|
||||
if Caption <> '' then
|
||||
begin
|
||||
fillchar(Style, sizeof(Style), 0);
|
||||
Style.Alignment := taLeftJustify;
|
||||
Style.Layout := tlCenter;
|
||||
Style.Wordbreak := True;
|
||||
DestCanvas.TextRect(
|
||||
Rect(Arect.Height + ScaleForCanvas(CheckBoxTextSpacing), 0,
|
||||
ARect.Right, ARect.Bottom),
|
||||
ARect.Height + ScaleForCanvas(CheckBoxTextSpacing), 0, Caption, Style);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TBGRASVGTheme.SetCheckBoxChecked(AValue: TStringList);
|
||||
begin
|
||||
CheckEmptyResourceException(AValue.Text);
|
||||
if (AValue <> FCheckBoxChecked) then
|
||||
begin
|
||||
FCheckBoxChecked.Assign(AValue);
|
||||
InvalidateThemedControls;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TBGRASVGTheme.SetCheckboxTextSpacing(AValue: integer);
|
||||
begin
|
||||
if FCheckboxTextSpacing=AValue then Exit;
|
||||
FCheckboxTextSpacing:=AValue;
|
||||
InvalidateThemedControls;
|
||||
end;
|
||||
|
||||
procedure TBGRASVGTheme.SetButtonActive(AValue: TStringList);
|
||||
begin
|
||||
if (AValue <> FButtonActive) then
|
||||
begin
|
||||
FButtonActive.Assign(AValue);
|
||||
InvalidateThemedControls;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TBGRASVGTheme.SetButtonHover(AValue: TStringList);
|
||||
begin
|
||||
if (AValue <> FButtonHover) then
|
||||
begin
|
||||
FButtonHover.Assign(AValue);
|
||||
InvalidateThemedControls;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TBGRASVGTheme.SetButtonNormal(AValue: TStringList);
|
||||
begin
|
||||
CheckEmptyResourceException(AValue.Text);
|
||||
if (AValue <> FButtonNormal) then
|
||||
begin
|
||||
FButtonNormal.Assign(AValue);
|
||||
InvalidateThemedControls;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TBGRASVGTheme.SetButtonSliceScalingBottom(AValue: integer);
|
||||
begin
|
||||
if FButtonSliceScalingBottom = AValue then
|
||||
Exit;
|
||||
FButtonSliceScalingBottom := AValue;
|
||||
InvalidateThemedControls;
|
||||
end;
|
||||
|
||||
procedure TBGRASVGTheme.SetButtonSliceScalingLeft(AValue: integer);
|
||||
begin
|
||||
if FButtonSliceScalingLeft = AValue then
|
||||
Exit;
|
||||
FButtonSliceScalingLeft := AValue;
|
||||
InvalidateThemedControls;
|
||||
end;
|
||||
|
||||
procedure TBGRASVGTheme.SetButtonSliceScalingRight(AValue: integer);
|
||||
begin
|
||||
if FButtonSliceScalingRight = AValue then
|
||||
Exit;
|
||||
FButtonSliceScalingRight := AValue;
|
||||
InvalidateThemedControls;
|
||||
end;
|
||||
|
||||
procedure TBGRASVGTheme.SetButtonSliceScalingTop(AValue: integer);
|
||||
begin
|
||||
if FButtonSliceScalingTop = AValue then
|
||||
Exit;
|
||||
FButtonSliceScalingTop := AValue;
|
||||
InvalidateThemedControls;
|
||||
end;
|
||||
|
||||
procedure TBGRASVGTheme.SetButtonTextSpacing(AValue: integer);
|
||||
begin
|
||||
if FButtonTextSpacing=AValue then Exit;
|
||||
FButtonTextSpacing:=AValue;
|
||||
InvalidateThemedControls;
|
||||
end;
|
||||
|
||||
procedure TBGRASVGTheme.DrawCheckBox(Caption: string; State: TBGRAThemeButtonState;
|
||||
Focused: boolean; Checked: boolean; ARect: TRect; ASurface: TBGRAThemeSurface);
|
||||
var
|
||||
Style: TTextStyle;
|
||||
svg: TBGRASVG;
|
||||
r: TRect;
|
||||
begin
|
||||
with ASurface do
|
||||
begin
|
||||
BitmapRect := RectWithSize(ARect.Left, ARect.Top, ARect.Height, ARect.Height);
|
||||
if Checked then
|
||||
svg := TBGRASVG.CreateFromString(FCheckBoxChecked.Text)
|
||||
else
|
||||
svg := TBGRASVG.CreateFromString(FCheckBoxUnchecked.Text);
|
||||
svg.StretchDraw(Bitmap.Canvas2D, 0, 0, Bitmap.Width, Bitmap.Height);
|
||||
svg.Free;
|
||||
ColorizeSurface(ASurface, State);
|
||||
DrawBitmap;
|
||||
|
||||
if Caption <> '' then
|
||||
begin
|
||||
fillchar(Style, sizeof(Style), 0);
|
||||
Style.Alignment := taLeftJustify;
|
||||
Style.Layout := tlCenter;
|
||||
Style.Wordbreak := True;
|
||||
DestCanvas.TextRect(
|
||||
Rect(Arect.Height + ScaleForCanvas(CheckBoxTextSpacing), 0,
|
||||
ARect.Right, ARect.Bottom),
|
||||
ARect.Height + ScaleForCanvas(CheckBoxTextSpacing), 0, Caption, Style);
|
||||
end;
|
||||
if Focused then
|
||||
begin
|
||||
DestCanvas.Pen.Color := DestCanvas.Font.Color;
|
||||
DestCanvas.Pen.Style := psDash;
|
||||
DestCanvas.Brush.Style := bsClear;
|
||||
r := ARect;
|
||||
DestCanvas.Rectangle(r);
|
||||
DestCanvas.Pen.Style := psSolid;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TBGRASVGTheme.SaveToFile(AFileName: string);
|
||||
var
|
||||
FXMLConf: TXMLConfig;
|
||||
begin
|
||||
FXMLConf := TXMLConfig.Create(Self);
|
||||
try
|
||||
FXMLConf.Filename := AFileName;
|
||||
SaveTheme(FXMLConf);
|
||||
FXMLConf.Flush;
|
||||
finally
|
||||
FXMLConf.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TBGRASVGTheme.LoadFromFile(AFileName: string);
|
||||
var
|
||||
FXMLConf: TXMLConfig;
|
||||
begin
|
||||
FXMLConf := TXMLConfig.Create(Self);
|
||||
try
|
||||
FXMLConf.Filename := AFileName;
|
||||
LoadTheme(FXMLConf);
|
||||
finally
|
||||
FXMLConf.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TBGRASVGTheme.SaveToStream(AStream: TStream);
|
||||
var
|
||||
FXMLConf: TXMLConfig;
|
||||
begin
|
||||
FXMLConf := TXMLConfig.Create(Self);
|
||||
try
|
||||
SaveTheme(FXMLConf);
|
||||
FXMLConf.SaveToStream(AStream);
|
||||
FXMLConf.Flush;
|
||||
finally
|
||||
FXMLConf.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TBGRASVGTheme.LoadFromStream(AStream: TStream);
|
||||
var
|
||||
FXMLConf: TXMLConfig;
|
||||
begin
|
||||
FXMLConf := TXMLConfig.Create(Self);
|
||||
try
|
||||
FXMLConf.RootName := 'BGRASVGTheme';
|
||||
AStream.Position := 0;
|
||||
FXMLConf.LoadFromStream(AStream);
|
||||
LoadTheme(FXMLConf);
|
||||
finally
|
||||
FXMLConf.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TBGRASVGTheme.LoadFromResource(AResource: string);
|
||||
var
|
||||
AStream: TStream;
|
||||
begin
|
||||
AStream := BGRAResource.GetResourceStream(AResource);
|
||||
LoadFromStream(AStream);
|
||||
AStream.Free;
|
||||
end;
|
||||
|
||||
end.
|
||||
403
bgracontrols/bgratheme.pas
Normal file
403
bgracontrols/bgratheme.pas
Normal file
@@ -0,0 +1,403 @@
|
||||
// SPDX-License-Identifier: LGPL-3.0-linking-exception
|
||||
unit BGRATheme;
|
||||
|
||||
{$mode objfpc}{$H+}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs,
|
||||
BGRABitmap, BGRABitmapTypes, BGRASVGImageList;
|
||||
|
||||
type
|
||||
TBGRAThemeButtonState = (btbsNormal, btbsHover, btbsActive, btbsDisabled);
|
||||
|
||||
{ TBGRAThemeSurface }
|
||||
|
||||
TBGRAThemeSurface = class
|
||||
private
|
||||
FBitmap: TBGRABitmap;
|
||||
FBitmapRect: TRect;
|
||||
FCanvasScale: single;
|
||||
FDestCanvas: TCanvas;
|
||||
FLclDPI: integer;
|
||||
function GetBitmap: TBGRABitmap;
|
||||
function GetBitmapDPI: integer;
|
||||
procedure SetBitmapRect(AValue: TRect);
|
||||
public
|
||||
constructor Create(AControl: TCustomControl);
|
||||
constructor Create(ADestRect: TRect; ADestCanvas: TCanvas; ACanvasScale: single; ALclDPI: integer);
|
||||
destructor Destroy; override;
|
||||
procedure DrawBitmap;
|
||||
procedure DiscardBitmap;
|
||||
procedure BitmapColorOverlay(AColor: TBGRAPixel; AOperation: TBlendOperation = boTransparent); overload;
|
||||
function ScaleForCanvas(AValue: integer; AFromDPI: integer = 96): integer;
|
||||
function ScaleForBitmap(AValue: integer; AFromDPI: integer = 96): integer;
|
||||
function ScaleForBitmap(const ARect: TRect; AFromDPI: integer = 96): TRect;
|
||||
property DestCanvas: TCanvas read FDestCanvas;
|
||||
property DestCanvasDPI: integer read FLclDPI;
|
||||
property Bitmap: TBGRABitmap read GetBitmap;
|
||||
property BitmapRect: TRect read FBitmapRect write SetBitmapRect;
|
||||
property BitmapDPI: integer read GetBitmapDPI;
|
||||
end;
|
||||
|
||||
TBGRATheme = class;
|
||||
|
||||
{ TBGRAThemeControl }
|
||||
|
||||
TBGRAThemeControl = class(TCustomControl)
|
||||
private
|
||||
FTheme: TBGRATheme;
|
||||
procedure SetTheme(AValue: TBGRATheme);
|
||||
public
|
||||
destructor Destroy; override;
|
||||
published
|
||||
property Theme: TBGRATheme read FTheme write SetTheme;
|
||||
end;
|
||||
|
||||
{ TBGRATheme }
|
||||
|
||||
TBGRATheme = class(TComponent)
|
||||
private
|
||||
FThemedControls: TList;
|
||||
function GetThemedControl(AIndex: integer): TBGRAThemeControl;
|
||||
function GetThemedControlCount: integer;
|
||||
procedure AddThemedControl(AControl: TBGRAThemeControl);
|
||||
procedure RemoveThemedControl(AControl: TBGRAThemeControl);
|
||||
|
||||
protected
|
||||
|
||||
public
|
||||
constructor Create(AOwner: TComponent); override;
|
||||
destructor Destroy; override;
|
||||
procedure InvalidateThemedControls;
|
||||
|
||||
function PreferredButtonWidth(const hasGlyph: boolean): Integer; virtual;
|
||||
function PreferredButtonHeight(const hasGlyph: boolean): Integer; virtual;
|
||||
|
||||
procedure DrawButton(Caption: string; State: TBGRAThemeButtonState;
|
||||
Focused: boolean; ARect: TRect; ASurface: TBGRAThemeSurface; AImageIndex: Integer = -1; AImageList: TBGRASVGImageList = nil); virtual;
|
||||
procedure DrawRadioButton(Caption: string; State: TBGRAThemeButtonState;
|
||||
{%H-}Focused: boolean; Checked: boolean; ARect: TRect; ASurface: TBGRAThemeSurface); virtual;
|
||||
procedure DrawCheckBox(Caption: string; State: TBGRAThemeButtonState;
|
||||
{%H-}Focused: boolean; Checked: boolean; ARect: TRect; ASurface: TBGRAThemeSurface); virtual;
|
||||
|
||||
property ThemedControlCount: integer read GetThemedControlCount;
|
||||
property ThemedControl[AIndex: integer]: TBGRAThemeControl read GetThemedControl;
|
||||
published
|
||||
|
||||
end;
|
||||
|
||||
var
|
||||
BGRADefaultTheme: TBGRATheme;
|
||||
|
||||
procedure Register;
|
||||
|
||||
implementation
|
||||
|
||||
uses LCLType;
|
||||
|
||||
procedure Register;
|
||||
begin
|
||||
RegisterComponents('BGRA Themes', [TBGRATheme]);
|
||||
end;
|
||||
|
||||
{ TBGRAThemeControl }
|
||||
|
||||
procedure TBGRAThemeControl.SetTheme(AValue: TBGRATheme);
|
||||
begin
|
||||
if FTheme=AValue then Exit;
|
||||
if Assigned(AValue) then AValue.RemoveThemedControl(self);
|
||||
FTheme:=AValue;
|
||||
if Assigned(AValue) then AValue.AddThemedControl(self);
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
destructor TBGRAThemeControl.Destroy;
|
||||
begin
|
||||
if Assigned(FTheme) then FTheme.RemoveThemedControl(self);
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
{ TBGRAThemeSurface }
|
||||
|
||||
function TBGRAThemeSurface.GetBitmap: TBGRABitmap;
|
||||
begin
|
||||
if FBitmap = nil then
|
||||
FBitmap := TBGRABitmap.Create(round(FBitmapRect.Width * FCanvasScale),
|
||||
round(FBitmapRect.Height * FCanvasScale));
|
||||
result := FBitmap;
|
||||
end;
|
||||
|
||||
function TBGRAThemeSurface.GetBitmapDPI: integer;
|
||||
begin
|
||||
result := round(FLclDPI*FCanvasScale);
|
||||
end;
|
||||
|
||||
procedure TBGRAThemeSurface.SetBitmapRect(AValue: TRect);
|
||||
begin
|
||||
if FBitmapRect=AValue then Exit;
|
||||
DiscardBitmap;
|
||||
FBitmapRect:=AValue;
|
||||
end;
|
||||
|
||||
constructor TBGRAThemeSurface.Create(AControl: TCustomControl);
|
||||
var
|
||||
parentForm: TCustomForm;
|
||||
lclDPI: Integer;
|
||||
begin
|
||||
parentForm := GetParentForm(AControl, False);
|
||||
if Assigned(parentForm) then
|
||||
lclDPI := parentForm.PixelsPerInch
|
||||
else lclDPI := Screen.PixelsPerInch;
|
||||
Create(AControl.ClientRect, AControl.Canvas, AControl.GetCanvasScaleFactor, lclDPI);
|
||||
end;
|
||||
|
||||
constructor TBGRAThemeSurface.Create(ADestRect: TRect; ADestCanvas: TCanvas;
|
||||
ACanvasScale: single; ALclDPI: integer);
|
||||
begin
|
||||
FBitmap := nil;
|
||||
FBitmapRect := ADestRect;
|
||||
FDestCanvas := ADestCanvas;
|
||||
FCanvasScale:= ACanvasScale;
|
||||
FLclDPI:= ALclDPI;
|
||||
end;
|
||||
|
||||
destructor TBGRAThemeSurface.Destroy;
|
||||
begin
|
||||
FBitmap.Free;
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
procedure TBGRAThemeSurface.DrawBitmap;
|
||||
begin
|
||||
if FBitmap = nil then exit;
|
||||
FBitmap.Draw(FDestCanvas, FBitmapRect, false);
|
||||
end;
|
||||
|
||||
procedure TBGRAThemeSurface.DiscardBitmap;
|
||||
begin
|
||||
FreeAndNil(FBitmap);
|
||||
end;
|
||||
|
||||
procedure TBGRAThemeSurface.BitmapColorOverlay(AColor: TBGRAPixel;
|
||||
AOperation: TBlendOperation);
|
||||
begin
|
||||
if AColor.alpha <> 0 then
|
||||
Bitmap.BlendOver(AColor, AOperation, AColor.alpha, false, true);
|
||||
end;
|
||||
|
||||
function TBGRAThemeSurface.ScaleForCanvas(AValue: integer; AFromDPI: integer): integer;
|
||||
begin
|
||||
result := MulDiv(AValue, DestCanvasDPI, AFromDPI);
|
||||
end;
|
||||
|
||||
function TBGRAThemeSurface.ScaleForBitmap(AValue: integer; AFromDPI: integer): integer;
|
||||
begin
|
||||
result := MulDiv(AValue, BitmapDPI, AFromDPI);
|
||||
end;
|
||||
|
||||
function TBGRAThemeSurface.ScaleForBitmap(const ARect: TRect; AFromDPI: integer): TRect;
|
||||
begin
|
||||
result.Left := ScaleForBitmap(ARect.Left, AFromDPI);
|
||||
result.Top := ScaleForBitmap(ARect.Top, AFromDPI);
|
||||
result.Right := ScaleForBitmap(ARect.Right, AFromDPI);
|
||||
result.Bottom := ScaleForBitmap(ARect.Bottom, AFromDPI);
|
||||
end;
|
||||
|
||||
{ TBGRATheme }
|
||||
|
||||
function TBGRATheme.GetThemedControl(AIndex: integer): TBGRAThemeControl;
|
||||
begin
|
||||
result := TBGRAThemeControl(FThemedControls[AIndex]);
|
||||
end;
|
||||
|
||||
function TBGRATheme.GetThemedControlCount: integer;
|
||||
begin
|
||||
result := FThemedControls.Count;
|
||||
end;
|
||||
|
||||
procedure TBGRATheme.AddThemedControl(AControl: TBGRAThemeControl);
|
||||
begin
|
||||
if FThemedControls.IndexOf(AControl) = -1 then
|
||||
FThemedControls.Add(AControl);
|
||||
end;
|
||||
|
||||
procedure TBGRATheme.RemoveThemedControl(AControl: TBGRAThemeControl);
|
||||
begin
|
||||
FThemedControls.Remove(AControl);
|
||||
end;
|
||||
|
||||
constructor TBGRATheme.Create(AOwner: TComponent);
|
||||
begin
|
||||
inherited Create(AOwner);
|
||||
FThemedControls := TList.Create;
|
||||
end;
|
||||
|
||||
destructor TBGRATheme.Destroy;
|
||||
var i: integer;
|
||||
begin
|
||||
for i := ThemedControlCount-1 downto 0 do
|
||||
ThemedControl[i].Theme := nil;
|
||||
FThemedControls.Free;
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
procedure TBGRATheme.InvalidateThemedControls;
|
||||
var
|
||||
i: Integer;
|
||||
begin
|
||||
for i := 0 to ThemedControlCount-1 do
|
||||
ThemedControl[i].Invalidate;
|
||||
end;
|
||||
|
||||
function TBGRATheme.PreferredButtonWidth(const hasGlyph: boolean): Integer;
|
||||
begin
|
||||
Result := 125;
|
||||
end;
|
||||
|
||||
function TBGRATheme.PreferredButtonHeight(const hasGlyph: boolean): Integer;
|
||||
begin
|
||||
Result := 35;
|
||||
end;
|
||||
|
||||
procedure TBGRATheme.DrawButton(Caption: string; State: TBGRAThemeButtonState;
|
||||
Focused: boolean; ARect: TRect; ASurface: TBGRAThemeSurface;
|
||||
AImageIndex: Integer; AImageList: TBGRASVGImageList);
|
||||
var
|
||||
Style: TTextStyle;
|
||||
begin
|
||||
With ASurface do
|
||||
begin
|
||||
DestCanvas.Font.Color := clBlack;
|
||||
case State of
|
||||
btbsNormal: DestCanvas.Brush.Color := RGBToColor(225, 225, 225);
|
||||
btbsHover: DestCanvas.Brush.Color := RGBToColor(229, 241, 251);
|
||||
btbsActive: DestCanvas.Brush.Color := RGBToColor(204, 228, 247);
|
||||
btbsDisabled: DestCanvas.Brush.Color := RGBToColor(204, 204, 204);
|
||||
end;
|
||||
|
||||
DestCanvas.Pen.Color := DestCanvas.Brush.Color;
|
||||
DestCanvas.Rectangle(ARect);
|
||||
|
||||
if Focused then
|
||||
begin
|
||||
DestCanvas.Pen.Color := clBlack;
|
||||
DestCanvas.Rectangle(ARect);
|
||||
end;
|
||||
|
||||
if Caption <> '' then
|
||||
begin
|
||||
fillchar(Style, sizeof(Style), 0);
|
||||
Style.Alignment := taCenter;
|
||||
Style.Layout := tlCenter;
|
||||
Style.Wordbreak := True;
|
||||
DestCanvas.TextRect(ARect, 0, 0, Caption, Style);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TBGRATheme.DrawRadioButton(Caption: string; State: TBGRAThemeButtonState;
|
||||
Focused: boolean; Checked: boolean; ARect: TRect; ASurface: TBGRAThemeSurface);
|
||||
var
|
||||
Style: TTextStyle;
|
||||
Color: TBGRAPixel;
|
||||
begin
|
||||
with ASurface do
|
||||
begin
|
||||
DestCanvas.Font.Color := clBlack;
|
||||
case State of
|
||||
btbsHover: Color := BGRA(0, 120, 215);
|
||||
btbsActive: Color := BGRA(0, 84, 153);
|
||||
btbsDisabled:
|
||||
begin
|
||||
DestCanvas.Font.Color := clGray;
|
||||
Color := BGRA(204, 204, 204);
|
||||
end;
|
||||
else {btbsNormal}
|
||||
Color := BGRABlack;
|
||||
end;
|
||||
|
||||
BitmapRect := RectWithSize(ARect.Left, ARect.Top, ARect.Height, ARect.Height);
|
||||
Bitmap.FillEllipseAntialias(Bitmap.Height / 2, Bitmap.Height / 2,
|
||||
Bitmap.Height / 2 - 2, Bitmap.Height / 2 - 2, BGRAWhite);
|
||||
Bitmap.EllipseAntialias(Bitmap.Height / 2, Bitmap.Height / 2,
|
||||
Bitmap.Height / 2 - 2, Bitmap.Height / 2 - 2, Color{%H-}, 1);
|
||||
if Checked then
|
||||
Bitmap.FillEllipseAntialias(Bitmap.Height / 2, Bitmap.Height /
|
||||
2, Bitmap.Height / 4, Bitmap.Height / 4, Color);
|
||||
DrawBitmap;
|
||||
|
||||
if Caption <> '' then
|
||||
begin
|
||||
fillchar(Style, sizeof(Style), 0);
|
||||
Style.Alignment := taLeftJustify;
|
||||
Style.Layout := tlCenter;
|
||||
Style.Wordbreak := True;
|
||||
DestCanvas.TextRect(Rect(Arect.Height, 0, ARect.Right, ARect.Bottom),
|
||||
ARect.Height, 0, Caption, Style);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TBGRATheme.DrawCheckBox(Caption: string; State: TBGRAThemeButtonState;
|
||||
Focused: boolean; Checked: boolean; ARect: TRect; ASurface: TBGRAThemeSurface);
|
||||
var
|
||||
Style: TTextStyle;
|
||||
Bitmap: TBGRABitmap;
|
||||
Color: TBGRAPixel;
|
||||
aleft, atop, aright, abottom: integer;
|
||||
begin
|
||||
with ASurface do
|
||||
begin
|
||||
DestCanvas.Font.Color := clBlack;
|
||||
case State of
|
||||
btbsHover: Color := BGRA(0, 120, 215);
|
||||
btbsActive: Color := BGRA(0, 84, 153);
|
||||
btbsDisabled:
|
||||
begin
|
||||
DestCanvas.Font.Color := clGray;
|
||||
Color := BGRA(204, 204, 204);
|
||||
end;
|
||||
else {btbsNormal}
|
||||
Color := BGRABlack;
|
||||
end;
|
||||
|
||||
BitmapRect := RectWithSize(ARect.Left, ARect.Top, ARect.Height, ARect.Height);
|
||||
Bitmap.Rectangle(0, 0, Bitmap.Height, Bitmap.Height, Color, BGRAWhite);
|
||||
aleft := 0;
|
||||
aright := Bitmap.Height;
|
||||
atop := 0;
|
||||
abottom := Bitmap.Height;
|
||||
if Checked then
|
||||
Bitmap.DrawPolyLineAntialias(Bitmap.ComputeBezierSpline(
|
||||
[BezierCurve(pointF(aleft + 2, atop + 3), PointF((aleft + aright - 1) / 2, abottom - 3)),
|
||||
BezierCurve(PointF((aleft + aright - 1) / 2, abottom - 3), PointF(
|
||||
(aleft + aright - 1) / 2, (atop * 2 + abottom - 1) / 3), PointF(aright - 2, atop - 2))]),
|
||||
Color, 1.5);
|
||||
DrawBitmap;
|
||||
|
||||
if Caption <> '' then
|
||||
begin
|
||||
fillchar(Style, sizeof(Style), 0);
|
||||
Style.Alignment := taLeftJustify;
|
||||
Style.Layout := tlCenter;
|
||||
Style.Wordbreak := True;
|
||||
DestCanvas.TextRect(Rect(Arect.Height, 0, ARect.Right, ARect.Bottom),
|
||||
ARect.Height, 0, Caption, Style);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
var
|
||||
BasicTheme: TBGRATheme;
|
||||
|
||||
initialization
|
||||
|
||||
BasicTheme := TBGRATheme.Create(nil);
|
||||
BGRADefaultTheme := BasicTheme;
|
||||
|
||||
finalization
|
||||
FreeAndNil(BasicTheme);
|
||||
|
||||
end.
|
||||
253
bgracontrols/bgrathemebutton.pas
Normal file
253
bgracontrols/bgrathemebutton.pas
Normal file
@@ -0,0 +1,253 @@
|
||||
// SPDX-License-Identifier: LGPL-3.0-linking-exception
|
||||
unit BGRAThemeButton;
|
||||
|
||||
{$mode objfpc}{$H+}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs,
|
||||
BGRATheme, Types, ExtCtrls, BGRASVGImageList;
|
||||
|
||||
type
|
||||
|
||||
{ TBGRAThemeButton }
|
||||
|
||||
TBGRAThemeButton = class(TBGRAThemeControl)
|
||||
private
|
||||
FImageIndex: integer;
|
||||
FImageList: TBGRASVGImageList;
|
||||
FModalResult: TModalResult;
|
||||
FState: TBGRAThemeButtonState;
|
||||
FTimerHover: TTimer;
|
||||
procedure SetImageIndex(AValue: integer);
|
||||
procedure SetImageList(AValue: TBGRASVGImageList);
|
||||
procedure SetState(AValue: TBGRAThemeButtonState);
|
||||
procedure TimerHoverElapse(Sender: TObject);
|
||||
protected
|
||||
procedure CalculatePreferredSize(var PreferredWidth, PreferredHeight: integer;
|
||||
WithThemeSpace: Boolean); override;
|
||||
procedure Notification(AComponent: TComponent; Operation: TOperation); override;
|
||||
class function GetControlClassDefaultSize: TSize; override;
|
||||
procedure MouseEnter; override;
|
||||
procedure MouseLeave; override;
|
||||
procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
|
||||
X, Y: integer); override;
|
||||
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: integer); override;
|
||||
procedure Click; override;
|
||||
procedure SetEnabled(Value: boolean); override;
|
||||
procedure TextChanged; override;
|
||||
procedure Paint; override;
|
||||
procedure Resize; override;
|
||||
procedure UpdateHoverState;
|
||||
property State: TBGRAThemeButtonState read FState write SetState;
|
||||
public
|
||||
constructor Create(AOwner: TComponent); override;
|
||||
published
|
||||
property Action;
|
||||
property ModalResult: TModalResult
|
||||
read FModalResult write FModalResult default mrNone;
|
||||
property Align;
|
||||
property Anchors;
|
||||
property BorderSpacing;
|
||||
property Caption;
|
||||
property Enabled;
|
||||
property Font;
|
||||
property ImageList: TBGRASVGImageList read FImageList write SetImageList;
|
||||
property ImageIndex: integer read FImageIndex write SetImageIndex;
|
||||
property OnClick;
|
||||
property OnMouseDown;
|
||||
property OnMouseUp;
|
||||
property OnMouseEnter;
|
||||
property OnMouseLeave;
|
||||
end;
|
||||
|
||||
procedure Register;
|
||||
|
||||
implementation
|
||||
|
||||
uses BGRABitmapTypes;
|
||||
|
||||
procedure Register;
|
||||
begin
|
||||
RegisterComponents('BGRA Themes', [TBGRAThemeButton]);
|
||||
end;
|
||||
|
||||
{ TBGRAThemeButton }
|
||||
|
||||
procedure TBGRAThemeButton.SetState(AValue: TBGRAThemeButtonState);
|
||||
begin
|
||||
if FState = AValue then
|
||||
Exit;
|
||||
FState := AValue;
|
||||
FTimerHover.Enabled := (FState = btbsHover);
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBGRAThemeButton.SetImageIndex(AValue: integer);
|
||||
begin
|
||||
if FImageIndex = AValue then
|
||||
Exit;
|
||||
FImageIndex := AValue;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBGRAThemeButton.SetImageList(AValue: TBGRASVGImageList);
|
||||
begin
|
||||
if FImageList = AValue then
|
||||
Exit;
|
||||
FImageList := AValue;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBGRAThemeButton.TimerHoverElapse(Sender: TObject);
|
||||
begin
|
||||
UpdateHoverState;
|
||||
end;
|
||||
|
||||
procedure TBGRAThemeButton.CalculatePreferredSize(var PreferredWidth,
|
||||
PreferredHeight: integer; WithThemeSpace: Boolean);
|
||||
begin
|
||||
inherited CalculatePreferredSize(PreferredWidth, PreferredHeight,
|
||||
WithThemeSpace);
|
||||
|
||||
if AutoSize then
|
||||
begin
|
||||
PreferredWidth := Canvas.TextWidth(Caption) + Theme.PreferredButtonWidth(Assigned(FImageList));
|
||||
PreferredHeight := Canvas.TextHeight(Caption) + Theme.PreferredButtonHeight(Assigned(FImageList));
|
||||
if Assigned(FImageList) then
|
||||
begin
|
||||
PreferredWidth := PreferredWidth + FImageList.Width;
|
||||
PreferredHeight := PreferredHeight + FImageList.Height;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TBGRAThemeButton.Notification(AComponent: TComponent;
|
||||
Operation: TOperation);
|
||||
begin
|
||||
inherited Notification(AComponent, Operation);
|
||||
if (Operation = opRemove) and (AComponent = FImageList) then
|
||||
FImageList := nil;
|
||||
end;
|
||||
|
||||
class function TBGRAThemeButton.GetControlClassDefaultSize: TSize;
|
||||
begin
|
||||
Result.CX := 125;
|
||||
Result.CY := 35;
|
||||
end;
|
||||
|
||||
procedure TBGRAThemeButton.MouseEnter;
|
||||
begin
|
||||
inherited MouseEnter;
|
||||
if Enabled then
|
||||
State := btbsHover
|
||||
else
|
||||
State := btbsDisabled;
|
||||
end;
|
||||
|
||||
procedure TBGRAThemeButton.MouseLeave;
|
||||
begin
|
||||
inherited MouseLeave;
|
||||
if Enabled then
|
||||
State := btbsNormal
|
||||
else
|
||||
State := btbsDisabled;
|
||||
end;
|
||||
|
||||
procedure TBGRAThemeButton.MouseDown(Button: TMouseButton; Shift: TShiftState;
|
||||
X, Y: integer);
|
||||
begin
|
||||
inherited MouseDown(Button, Shift, X, Y);
|
||||
State := btbsActive;
|
||||
end;
|
||||
|
||||
procedure TBGRAThemeButton.MouseUp(Button: TMouseButton; Shift: TShiftState;
|
||||
X, Y: integer);
|
||||
begin
|
||||
inherited MouseUp(Button, Shift, X, Y);
|
||||
UpdateHoverState;
|
||||
end;
|
||||
|
||||
procedure TBGRAThemeButton.Click;
|
||||
var
|
||||
Form: TCustomForm;
|
||||
begin
|
||||
UpdateHoverState;
|
||||
if ModalResult <> mrNone then
|
||||
begin
|
||||
Form := GetParentForm(Self);
|
||||
if Form <> nil then
|
||||
Form.ModalResult := ModalResult;
|
||||
end;
|
||||
inherited Click;
|
||||
end;
|
||||
|
||||
procedure TBGRAThemeButton.SetEnabled(Value: boolean);
|
||||
begin
|
||||
inherited SetEnabled(Value);
|
||||
if Value then
|
||||
State := btbsNormal
|
||||
else
|
||||
State := btbsDisabled;
|
||||
end;
|
||||
|
||||
procedure TBGRAThemeButton.TextChanged;
|
||||
begin
|
||||
inherited TextChanged;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBGRAThemeButton.Paint;
|
||||
var
|
||||
surface: TBGRAThemeSurface;
|
||||
begin
|
||||
Canvas.Font.Assign(Font);
|
||||
surface := TBGRAThemeSurface.Create(self);
|
||||
try
|
||||
if Assigned(Theme) then
|
||||
Theme.DrawButton(Caption, FState, Focused, ClientRect, surface, FImageIndex, FImageList)
|
||||
else
|
||||
BGRADefaultTheme.DrawButton(Caption, FState, Focused, ClientRect, surface, FImageIndex, FImageList);
|
||||
finally
|
||||
surface.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TBGRAThemeButton.Resize;
|
||||
begin
|
||||
Invalidate;
|
||||
inherited Resize;
|
||||
end;
|
||||
|
||||
procedure TBGRAThemeButton.UpdateHoverState;
|
||||
var
|
||||
p: TPoint;
|
||||
begin
|
||||
p := ScreenToClient(Mouse.CursorPos);
|
||||
if (p.x >= 0) and (p.x <= Width) and (p.y >= 0) and (p.y <= Height) then
|
||||
State := btbsHover
|
||||
else
|
||||
if Enabled then
|
||||
State := btbsNormal
|
||||
else
|
||||
State := btbsDisabled;
|
||||
end;
|
||||
|
||||
constructor TBGRAThemeButton.Create(AOwner: TComponent);
|
||||
begin
|
||||
inherited Create(AOwner);
|
||||
FState := btbsNormal;
|
||||
|
||||
ControlStyle := ControlStyle + [csParentBackground];
|
||||
|
||||
with GetControlClassDefaultSize do
|
||||
SetInitialBounds(0, 0, CX, CY);
|
||||
|
||||
FTimerHover := TTimer.Create(self);
|
||||
FTimerHover.Enabled := False;
|
||||
FTimerHover.Interval := 100;
|
||||
FTimerHover.OnTimer := @TimerHoverElapse;
|
||||
end;
|
||||
|
||||
end.
|
||||
223
bgracontrols/bgrathemecheckbox.pas
Normal file
223
bgracontrols/bgrathemecheckbox.pas
Normal file
@@ -0,0 +1,223 @@
|
||||
// SPDX-License-Identifier: LGPL-3.0-linking-exception
|
||||
unit BGRAThemeCheckBox;
|
||||
|
||||
{$mode delphi}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs,
|
||||
BGRATheme, Types, LMessages, LCLType;
|
||||
|
||||
type
|
||||
|
||||
{ TBGRAThemeCheckBox }
|
||||
|
||||
TBGRAThemeCheckBox = class(TBGRAThemeControl)
|
||||
private
|
||||
FChecked: boolean;
|
||||
FOnChange: TNotifyEvent;
|
||||
FState: TBGRAThemeButtonState;
|
||||
procedure SetChecked(AValue: boolean);
|
||||
protected
|
||||
procedure KeyDown(var Key: word; Shift: TShiftState); override;
|
||||
procedure KeyUp(var Key: word; Shift: TShiftState); override;
|
||||
procedure WMSetFocus(var Message: {$IFDEF FPC}TLMSetFocus{$ELSE}TWMSetFocus{$ENDIF}); message {$IFDEF FPC}LM_SETFOCUS{$ELSE}WM_SETFOCUS{$ENDIF};
|
||||
procedure WMKillFocus(var Message: {$IFDEF FPC}TLMKillFocus{$ELSE}TWMKillFocus{$ENDIF}); message {$IFDEF FPC}LM_KILLFOCUS{$ELSE}WM_KILLFOCUS{$ENDIF};
|
||||
procedure UpdateFocus(AFocused: boolean);
|
||||
class function GetControlClassDefaultSize: TSize; override;
|
||||
procedure MouseEnter; override;
|
||||
procedure MouseLeave; override;
|
||||
procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
|
||||
X, Y: integer); override;
|
||||
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: integer); override;
|
||||
procedure Click; override;
|
||||
procedure SetEnabled(Value: boolean); override;
|
||||
procedure TextChanged; override;
|
||||
procedure Paint; override;
|
||||
procedure Resize; override;
|
||||
public
|
||||
constructor Create(AOwner: TComponent); override;
|
||||
published
|
||||
property Align;
|
||||
property Anchors;
|
||||
property BorderSpacing;
|
||||
property Caption;
|
||||
property Checked: boolean read FChecked write SetChecked;
|
||||
property Font;
|
||||
property Enabled;
|
||||
property OnChange: TNotifyEvent read FOnChange write FOnChange;
|
||||
property TabStop;
|
||||
property TabOrder;
|
||||
end;
|
||||
|
||||
procedure Register;
|
||||
|
||||
implementation
|
||||
|
||||
uses BGRABitmapTypes;
|
||||
|
||||
procedure Register;
|
||||
begin
|
||||
RegisterComponents('BGRA Themes', [TBGRAThemeCheckBox]);
|
||||
end;
|
||||
|
||||
{ TBGRAThemeCheckBox }
|
||||
|
||||
procedure TBGRAThemeCheckBox.SetChecked(AValue: boolean);
|
||||
begin
|
||||
if FChecked = AValue then
|
||||
Exit;
|
||||
FChecked := AValue;
|
||||
Invalidate;
|
||||
if Assigned(FOnChange) then FOnChange(Self);
|
||||
end;
|
||||
|
||||
procedure TBGRAThemeCheckBox.KeyDown(var Key: word; Shift: TShiftState);
|
||||
begin
|
||||
inherited KeyDown(Key, Shift);
|
||||
|
||||
if (Key = VK_SPACE) or (Key = VK_RETURN) then
|
||||
MouseDown(mbLeft, [], 0, 0);
|
||||
end;
|
||||
|
||||
procedure TBGRAThemeCheckBox.KeyUp(var Key: word; Shift: TShiftState);
|
||||
begin
|
||||
if (Key = VK_SPACE) or (Key = VK_RETURN) then
|
||||
begin
|
||||
MouseUp(mbLeft, [], 0, 0);
|
||||
MouseLeave;
|
||||
end;
|
||||
|
||||
inherited KeyUp(Key, Shift);
|
||||
end;
|
||||
|
||||
procedure TBGRAThemeCheckBox.WMSetFocus(var Message: TLMSetFocus);
|
||||
begin
|
||||
inherited;
|
||||
|
||||
UpdateFocus(True);
|
||||
end;
|
||||
|
||||
procedure TBGRAThemeCheckBox.WMKillFocus(var Message: TLMKillFocus);
|
||||
begin
|
||||
inherited;
|
||||
|
||||
if Message.FocusedWnd <> Handle then
|
||||
UpdateFocus(False);
|
||||
end;
|
||||
|
||||
procedure TBGRAThemeCheckBox.UpdateFocus(AFocused: boolean);
|
||||
var
|
||||
lForm: TCustomForm;
|
||||
begin
|
||||
lForm := GetParentForm(Self);
|
||||
if lForm = nil then
|
||||
exit;
|
||||
|
||||
{$IFDEF FPC}//#
|
||||
if AFocused then
|
||||
ActiveDefaultControlChanged(lForm.ActiveControl)
|
||||
else
|
||||
ActiveDefaultControlChanged(nil);
|
||||
{$ENDIF}
|
||||
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
class function TBGRAThemeCheckBox.GetControlClassDefaultSize: TSize;
|
||||
begin
|
||||
Result.CX := 165;
|
||||
Result.CY := 19;
|
||||
end;
|
||||
|
||||
procedure TBGRAThemeCheckBox.MouseEnter;
|
||||
begin
|
||||
inherited MouseEnter;
|
||||
FState := btbsHover;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBGRAThemeCheckBox.MouseLeave;
|
||||
begin
|
||||
inherited MouseLeave;
|
||||
FState := btbsNormal;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBGRAThemeCheckBox.MouseDown(Button: TMouseButton;
|
||||
Shift: TShiftState; X, Y: integer);
|
||||
begin
|
||||
inherited MouseDown(Button, Shift, X, Y);
|
||||
FState := btbsActive;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBGRAThemeCheckBox.MouseUp(Button: TMouseButton;
|
||||
Shift: TShiftState; X, Y: integer);
|
||||
begin
|
||||
inherited MouseUp(Button, Shift, X, Y);
|
||||
if ClientRect.Contains(Point(X, Y)) then
|
||||
FState := btbsHover
|
||||
else
|
||||
FState := btbsNormal;
|
||||
if ClientRect.Contains(Point(X, Y)) then
|
||||
Checked := not FChecked
|
||||
else
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBGRAThemeCheckBox.Click;
|
||||
begin
|
||||
inherited Click;
|
||||
end;
|
||||
|
||||
procedure TBGRAThemeCheckBox.SetEnabled(Value: boolean);
|
||||
begin
|
||||
inherited SetEnabled(Value);
|
||||
if Value then
|
||||
FState := btbsNormal
|
||||
else
|
||||
FState := btbsDisabled;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBGRAThemeCheckBox.TextChanged;
|
||||
begin
|
||||
inherited TextChanged;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBGRAThemeCheckBox.Paint;
|
||||
var
|
||||
surface: TBGRAThemeSurface;
|
||||
begin
|
||||
surface := TBGRAThemeSurface.Create(self);
|
||||
try
|
||||
if Assigned(Theme) then
|
||||
Theme.DrawCheckBox(Caption, FState, Focused, Checked, ClientRect, surface)
|
||||
else
|
||||
BGRADefaultTheme.DrawCheckBox(Caption, FState, Focused, Checked, ClientRect, surface);
|
||||
finally
|
||||
surface.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TBGRAThemeCheckBox.Resize;
|
||||
begin
|
||||
Invalidate;
|
||||
inherited Resize;
|
||||
end;
|
||||
|
||||
constructor TBGRAThemeCheckBox.Create(AOwner: TComponent);
|
||||
begin
|
||||
inherited Create(AOwner);
|
||||
FState := btbsNormal;
|
||||
|
||||
ControlStyle := ControlStyle + [csParentBackground, csAcceptsControls];
|
||||
|
||||
with GetControlClassDefaultSize do
|
||||
SetInitialBounds(0, 0, CX, CY);
|
||||
end;
|
||||
|
||||
end.
|
||||
179
bgracontrols/bgrathemeradiobutton.pas
Normal file
179
bgracontrols/bgrathemeradiobutton.pas
Normal file
@@ -0,0 +1,179 @@
|
||||
// SPDX-License-Identifier: LGPL-3.0-linking-exception
|
||||
unit BGRAThemeRadioButton;
|
||||
|
||||
{$mode delphi}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs,
|
||||
BGRATheme, Types;
|
||||
|
||||
type
|
||||
|
||||
{ TBGRAThemeRadioButton }
|
||||
|
||||
TBGRAThemeRadioButton = class(TBGRAThemeControl)
|
||||
private
|
||||
FChecked: boolean;
|
||||
FOnChange: TNotifyEvent;
|
||||
FState: TBGRAThemeButtonState;
|
||||
procedure SetChecked(AValue: boolean);
|
||||
protected
|
||||
class function GetControlClassDefaultSize: TSize; override;
|
||||
procedure MouseEnter; override;
|
||||
procedure MouseLeave; override;
|
||||
procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
|
||||
X, Y: integer); override;
|
||||
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: integer); override;
|
||||
procedure Click; override;
|
||||
procedure SetEnabled(Value: boolean); override;
|
||||
procedure TextChanged; override;
|
||||
procedure Paint; override;
|
||||
procedure Resize; override;
|
||||
procedure UncheckOthers;
|
||||
public
|
||||
constructor Create(AOwner: TComponent); override;
|
||||
published
|
||||
property Align;
|
||||
property Anchors;
|
||||
property BorderSpacing;
|
||||
property Caption;
|
||||
property Checked: boolean read FChecked write SetChecked;
|
||||
property Font;
|
||||
property Enabled;
|
||||
property OnChange: TNotifyEvent read FOnChange write FOnChange;
|
||||
end;
|
||||
|
||||
procedure Register;
|
||||
|
||||
implementation
|
||||
|
||||
uses BGRABitmapTypes;
|
||||
|
||||
procedure Register;
|
||||
begin
|
||||
RegisterComponents('BGRA Themes', [TBGRAThemeRadioButton]);
|
||||
end;
|
||||
|
||||
{ TBGRAThemeRadioButton }
|
||||
|
||||
procedure TBGRAThemeRadioButton.SetChecked(AValue: boolean);
|
||||
begin
|
||||
if FChecked = AValue then
|
||||
Exit;
|
||||
FChecked := AValue;
|
||||
if FChecked then
|
||||
UncheckOthers;
|
||||
Invalidate;
|
||||
if Assigned(FOnChange) then FOnChange(Self);
|
||||
end;
|
||||
|
||||
class function TBGRAThemeRadioButton.GetControlClassDefaultSize: TSize;
|
||||
begin
|
||||
Result.CX := 165;
|
||||
Result.CY := 19;
|
||||
end;
|
||||
|
||||
procedure TBGRAThemeRadioButton.MouseEnter;
|
||||
begin
|
||||
inherited MouseEnter;
|
||||
FState := btbsHover;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBGRAThemeRadioButton.MouseLeave;
|
||||
begin
|
||||
inherited MouseLeave;
|
||||
FState := btbsNormal;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBGRAThemeRadioButton.MouseDown(Button: TMouseButton;
|
||||
Shift: TShiftState; X, Y: integer);
|
||||
begin
|
||||
inherited MouseDown(Button, Shift, X, Y);
|
||||
FState := btbsActive;
|
||||
Checked := True;
|
||||
end;
|
||||
|
||||
procedure TBGRAThemeRadioButton.MouseUp(Button: TMouseButton;
|
||||
Shift: TShiftState; X, Y: integer);
|
||||
begin
|
||||
inherited MouseUp(Button, Shift, X, Y);
|
||||
if ClientRect.Contains(Point(X, Y)) then
|
||||
FState := btbsHover
|
||||
else
|
||||
FState := btbsNormal;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBGRAThemeRadioButton.Click;
|
||||
begin
|
||||
inherited Click;
|
||||
end;
|
||||
|
||||
procedure TBGRAThemeRadioButton.SetEnabled(Value: boolean);
|
||||
begin
|
||||
inherited SetEnabled(Value);
|
||||
if Value then
|
||||
FState := btbsNormal
|
||||
else
|
||||
FState := btbsDisabled;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBGRAThemeRadioButton.TextChanged;
|
||||
begin
|
||||
inherited TextChanged;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TBGRAThemeRadioButton.Paint;
|
||||
var
|
||||
surface: TBGRAThemeSurface;
|
||||
begin
|
||||
surface := TBGRAThemeSurface.Create(self);
|
||||
try
|
||||
if Assigned(Theme) then
|
||||
Theme.DrawRadioButton(Caption, FState, Focused, Checked, ClientRect, surface)
|
||||
else
|
||||
BGRADefaultTheme.DrawRadioButton(Caption, FState, Focused, Checked, ClientRect, surface);
|
||||
finally
|
||||
surface.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TBGRAThemeRadioButton.Resize;
|
||||
begin
|
||||
Invalidate;
|
||||
inherited Resize;
|
||||
end;
|
||||
|
||||
procedure TBGRAThemeRadioButton.UncheckOthers;
|
||||
var
|
||||
i: integer;
|
||||
control: TWinControl;
|
||||
begin
|
||||
if Parent is TWinControl then
|
||||
begin
|
||||
control := TWinControl(Parent);
|
||||
for i := 0 to control.ControlCount - 1 do
|
||||
if (control.Controls[i] <> Self) and (control.Controls[i] is
|
||||
TBGRAThemeRadioButton) then
|
||||
TBGRAThemeRadioButton(control.Controls[i]).Checked := False;
|
||||
end;
|
||||
end;
|
||||
|
||||
constructor TBGRAThemeRadioButton.Create(AOwner: TComponent);
|
||||
begin
|
||||
inherited Create(AOwner);
|
||||
FState := btbsNormal;
|
||||
|
||||
ControlStyle := ControlStyle + [csParentBackground];
|
||||
|
||||
with GetControlClassDefaultSize do
|
||||
SetInitialBounds(0, 0, CX, CY);
|
||||
end;
|
||||
|
||||
end.
|
||||
572
bgracontrols/bgravirtualscreen.pas
Normal file
572
bgracontrols/bgravirtualscreen.pas
Normal file
@@ -0,0 +1,572 @@
|
||||
// SPDX-License-Identifier: LGPL-3.0-linking-exception
|
||||
{
|
||||
Created by BGRA Controls Team
|
||||
Dibo, Circular, lainz (007) and contributors.
|
||||
For detailed information see readme.txt
|
||||
|
||||
Site: https://sourceforge.net/p/bgra-controls/
|
||||
Wiki: http://wiki.lazarus.freepascal.org/BGRAControls
|
||||
Forum: http://forum.lazarus.freepascal.org/index.php/board,46.0.html
|
||||
}
|
||||
{******************************* CONTRIBUTOR(S) ******************************
|
||||
- Edivando S. Santos Brasil | mailedivando@gmail.com
|
||||
(Compatibility with delphi VCL 11/2018)
|
||||
|
||||
***************************** END CONTRIBUTOR(S) *****************************}
|
||||
unit BGRAVirtualScreen;
|
||||
|
||||
{$I bgracontrols.inc}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils, {$IFDEF FPC}LMessages, LResources, LCLIntf,{$ENDIF} Types, Forms, BCBaseCtrls, Controls, Graphics, Dialogs,
|
||||
{$IFNDEF FPC}Windows, Messages, BGRAGraphics, GraphType, FPImage, {$ENDIF}
|
||||
ExtCtrls, BGRABitmap, BCTypes;
|
||||
|
||||
type
|
||||
{ TCustomBGRAVirtualScreen }
|
||||
|
||||
TCustomBGRAVirtualScreen = class(TBGRACustomPanel)
|
||||
private
|
||||
{ Private declarations }
|
||||
FBGRA: TBGRABitmap;
|
||||
FOnRedraw: TBGRARedrawEvent;
|
||||
FDiscardedRect: TRect;
|
||||
FBevelInner, FBevelOuter: TPanelBevel;
|
||||
FBevelWidth: TBevelWidth;
|
||||
FBorderWidth: TBorderWidth;
|
||||
FAlignment: TAlignment;
|
||||
FBitmapAutoScale: boolean;
|
||||
function GetBitmapHeight: integer;
|
||||
function GetBitmapScale: double;
|
||||
function GetBitmapWidth: integer;
|
||||
function GetVSCaption: string;
|
||||
procedure SetAlignment(const Value: TAlignment);
|
||||
procedure SetBevelInner(const AValue: TPanelBevel);
|
||||
procedure SetBevelOuter(const AValue: TPanelBevel);
|
||||
procedure SetBevelWidth(const AValue: TBevelWidth);
|
||||
procedure SetBitmapAutoScale(AValue: boolean);
|
||||
procedure SetBorderWidth(const AValue: TBorderWidth);
|
||||
procedure SetVSCaption(AValue: string);
|
||||
protected
|
||||
{ Protected declarations }
|
||||
procedure Paint; override;
|
||||
procedure Resize; override;
|
||||
procedure BGRASetSize(AWidth, AHeight: integer);
|
||||
procedure RedrawBitmapContent; virtual;
|
||||
procedure SetColor(Value: TColor); {$IFDEF FPC}override;{$ENDIF}
|
||||
procedure WMEraseBkgnd(var Message: {$IFDEF FPC}TLMEraseBkgnd{$ELSE}TWMEraseBkgnd{$ENDIF}); message {$IFDEF FPC}LM_ERASEBKGND{$ELSE}WM_ERASEBKGND{$ENDIF};
|
||||
procedure SetEnabled(Value: boolean); override;
|
||||
public
|
||||
{ Public declarations }
|
||||
constructor Create(TheOwner: TComponent); override;
|
||||
function BitmapRectToClient(ARect: TRect): TRect;
|
||||
procedure RedrawBitmap; overload;
|
||||
procedure RedrawBitmap(ARect: TRect); overload;
|
||||
procedure RedrawBitmap(ARectArray: array of TRect); overload;
|
||||
procedure DiscardBitmap; overload;
|
||||
procedure DiscardBitmap(ARect: TRect); overload;
|
||||
procedure InvalidateBitmap(ARect: TRect);
|
||||
destructor Destroy; override;
|
||||
public
|
||||
property OnRedraw: TBGRARedrawEvent Read FOnRedraw Write FOnRedraw;
|
||||
property Bitmap: TBGRABitmap Read FBGRA;
|
||||
property BitmapAutoScale: boolean read FBitmapAutoScale write SetBitmapAutoScale default true;
|
||||
property BitmapScale: double read GetBitmapScale;
|
||||
property BitmapWidth: integer read GetBitmapWidth;
|
||||
property BitmapHeight: integer read GetBitmapHeight;
|
||||
property BorderWidth: TBorderWidth Read FBorderWidth Write SetBorderWidth default 0;
|
||||
property BevelInner: TPanelBevel Read FBevelInner Write SetBevelInner default bvNone;
|
||||
property BevelOuter: TPanelBevel Read FBevelOuter Write SetBevelOuter default bvNone;
|
||||
property BevelWidth: TBevelWidth Read FBevelWidth Write SetBevelWidth default 1;
|
||||
property Alignment: TAlignment Read FAlignment Write SetAlignment;
|
||||
property Caption: string read GetVSCaption write SetVSCaption;
|
||||
end;
|
||||
|
||||
TBGRAVirtualScreen = class(TCustomBGRAVirtualScreen)
|
||||
published
|
||||
property OnRedraw;
|
||||
property Bitmap;
|
||||
property BitmapAutoScale;
|
||||
// TPanel
|
||||
property Align;
|
||||
property Alignment;
|
||||
property Anchors;
|
||||
property AutoSize;
|
||||
property BorderSpacing;
|
||||
property ChildSizing;
|
||||
{$IFDEF FPC} //#
|
||||
property OnGetDockCaption;
|
||||
{$ENDIF}
|
||||
property BevelInner;
|
||||
property BevelOuter;
|
||||
property BevelWidth;
|
||||
property BidiMode;
|
||||
property BorderWidth;
|
||||
property BorderStyle;
|
||||
property Caption;
|
||||
property ClientHeight;
|
||||
property ClientWidth;
|
||||
property Color;
|
||||
property Constraints;
|
||||
property DockSite;
|
||||
property DragCursor;
|
||||
property DragKind;
|
||||
property DragMode;
|
||||
property Enabled;
|
||||
property Font;
|
||||
property FullRepaint;
|
||||
property ParentBidiMode;
|
||||
property ParentColor;
|
||||
property ParentFont;
|
||||
property ParentShowHint;
|
||||
property PopupMenu;
|
||||
property ShowHint;
|
||||
property TabOrder;
|
||||
property TabStop;
|
||||
property UseDockManager default True;
|
||||
property Visible;
|
||||
property OnClick;
|
||||
property OnContextPopup;
|
||||
property OnDockDrop;
|
||||
property OnDockOver;
|
||||
property OnDblClick;
|
||||
property OnDragDrop;
|
||||
property OnDragOver;
|
||||
property OnEndDock;
|
||||
property OnEndDrag;
|
||||
property OnEnter;
|
||||
property OnExit;
|
||||
property OnGetSiteInfo;
|
||||
property OnMouseDown;
|
||||
property OnMouseEnter;
|
||||
property OnMouseLeave;
|
||||
property OnMouseMove;
|
||||
property OnMouseUp;
|
||||
property OnMouseWheel;
|
||||
property OnMouseWheelDown;
|
||||
property OnMouseWheelUp;
|
||||
property OnResize;
|
||||
property OnStartDock;
|
||||
property OnStartDrag;
|
||||
property OnUnDock;
|
||||
end;
|
||||
|
||||
{$IFDEF FPC}procedure Register;{$ENDIF}
|
||||
|
||||
implementation
|
||||
|
||||
uses BGRABitmapTypes, math, LazVersion;
|
||||
|
||||
{$IFDEF FPC}
|
||||
procedure Register;
|
||||
begin
|
||||
RegisterComponents('BGRA Controls', [TBGRAVirtualScreen]);
|
||||
end;
|
||||
{$ENDIF}
|
||||
{ TCustomBGRAVirtualScreen }
|
||||
|
||||
procedure TCustomBGRAVirtualScreen.SetAlignment(const Value: TAlignment);
|
||||
begin
|
||||
if FAlignment = Value then
|
||||
exit;
|
||||
FAlignment := Value;
|
||||
DiscardBitmap;
|
||||
end;
|
||||
|
||||
function TCustomBGRAVirtualScreen.GetVSCaption: string;
|
||||
begin
|
||||
result := inherited Caption;
|
||||
end;
|
||||
|
||||
function TCustomBGRAVirtualScreen.GetBitmapScale: double;
|
||||
begin
|
||||
{$if laz_fullversion >= 2000000}
|
||||
if not FBitmapAutoScale then
|
||||
result := GetCanvasScaleFactor
|
||||
else
|
||||
result := 1;
|
||||
{$else}
|
||||
result := 1;
|
||||
{$endif}
|
||||
end;
|
||||
|
||||
function TCustomBGRAVirtualScreen.GetBitmapHeight: integer;
|
||||
begin
|
||||
result := round(ClientHeight * BitmapScale);
|
||||
end;
|
||||
|
||||
function TCustomBGRAVirtualScreen.GetBitmapWidth: integer;
|
||||
begin
|
||||
result := round(ClientWidth * BitmapScale);
|
||||
end;
|
||||
|
||||
procedure TCustomBGRAVirtualScreen.SetBevelInner(const AValue: TPanelBevel);
|
||||
begin
|
||||
if FBevelInner = AValue then
|
||||
exit;
|
||||
FBevelInner := AValue;
|
||||
DiscardBitmap;
|
||||
end;
|
||||
|
||||
procedure TCustomBGRAVirtualScreen.SetBevelOuter(const AValue: TPanelBevel);
|
||||
begin
|
||||
if FBevelOuter = AValue then
|
||||
exit;
|
||||
FBevelOuter := AValue;
|
||||
DiscardBitmap;
|
||||
end;
|
||||
|
||||
procedure TCustomBGRAVirtualScreen.SetBevelWidth(const AValue: TBevelWidth);
|
||||
begin
|
||||
if FBevelWidth = AValue then
|
||||
exit;
|
||||
FBevelWidth := AValue;
|
||||
DiscardBitmap;
|
||||
end;
|
||||
|
||||
procedure TCustomBGRAVirtualScreen.SetBitmapAutoScale(AValue: boolean);
|
||||
begin
|
||||
if FBitmapAutoScale=AValue then Exit;
|
||||
DiscardBitmap; //before to get correct invalidate bounds
|
||||
FBitmapAutoScale:=AValue;
|
||||
end;
|
||||
|
||||
procedure TCustomBGRAVirtualScreen.SetBorderWidth(const AValue: TBorderWidth);
|
||||
begin
|
||||
if FBorderWidth = AValue then
|
||||
exit;
|
||||
FBorderWidth := AValue;
|
||||
DiscardBitmap;
|
||||
end;
|
||||
|
||||
procedure TCustomBGRAVirtualScreen.SetVSCaption(AValue: string);
|
||||
begin
|
||||
inherited Caption := AValue;
|
||||
DiscardBitmap;
|
||||
end;
|
||||
|
||||
procedure TCustomBGRAVirtualScreen.Paint;
|
||||
begin
|
||||
{$IFDEF WINDOWS}
|
||||
// to avoid flickering in Windows running without themes (classic style)
|
||||
DoubleBuffered := ControlCount <> 0;
|
||||
{$ENDIF}
|
||||
BGRASetSize(BitmapWidth, BitmapHeight);
|
||||
if FBGRA <> nil then
|
||||
begin
|
||||
if not FDiscardedRect.IsEmpty then
|
||||
begin
|
||||
FBGRA.ClipRect := FDiscardedRect;
|
||||
FDiscardedRect := EmptyRect;
|
||||
RedrawBitmapContent;
|
||||
FBGRA.NoClip;
|
||||
end;
|
||||
FBGRA.Draw(Canvas, rect(0, 0, ClientWidth, ClientHeight));
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TCustomBGRAVirtualScreen.Resize;
|
||||
begin
|
||||
inherited Resize;
|
||||
if (FBGRA <> nil) and ((ClientWidth <> FBGRA.Width) or (ClientHeight <> FBGRA.Height)) then
|
||||
DiscardBitmap;
|
||||
end;
|
||||
|
||||
procedure TCustomBGRAVirtualScreen.BGRASetSize(AWidth, AHeight: integer);
|
||||
begin
|
||||
if (FBGRA <> nil) and ((AWidth <> FBGRA.Width) or (AHeight <> FBGRA.Height)) then
|
||||
begin
|
||||
FBGRA.SetSize(AWidth, AHeight);
|
||||
RedrawBitmapContent;
|
||||
FDiscardedRect := EmptyRect;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TCustomBGRAVirtualScreen.RedrawBitmapContent;
|
||||
var
|
||||
ARect: TRect;
|
||||
TS: TTextStyle;
|
||||
scale: Double;
|
||||
begin
|
||||
if (FBGRA <> nil) and (FBGRA.NbPixels <> 0) then
|
||||
begin
|
||||
FBGRA.FillRect(FBGRA.ClipRect, ColorToRGB(Color));
|
||||
|
||||
scale := BitmapScale;
|
||||
ARect := GetClientRect;
|
||||
ARect.Left := round(ARect.Left*scale);
|
||||
ARect.Top := round(ARect.Top*scale);
|
||||
ARect.Right := round(ARect.Right*scale);
|
||||
ARect.Bottom := round(ARect.Bottom*scale);
|
||||
|
||||
// if BevelOuter is set then draw a frame with BevelWidth
|
||||
if BevelOuter <> bvNone then
|
||||
FBGRA.CanvasBGRA.Frame3d(ARect, round(BevelWidth*scale), BevelOuter,
|
||||
BGRA(255, 255, 255, 200), BGRA(0, 0, 0, 160)); // Note: Frame3D inflates ARect
|
||||
|
||||
InflateRect(ARect, -round(BorderWidth*scale), -round(BorderWidth*scale));
|
||||
|
||||
// if BevelInner is set then skip the BorderWidth and draw a frame with BevelWidth
|
||||
if BevelInner <> bvNone then
|
||||
FBGRA.CanvasBGRA.Frame3d(ARect, round(BevelWidth*scale), BevelInner,
|
||||
BGRA(255, 255, 255, 160), BGRA(0, 0, 0, 160)); // Note: Frame3D inflates ARect
|
||||
|
||||
if Caption <> '' then
|
||||
begin
|
||||
FBGRA.CanvasBGRA.Font.Assign(Canvas.Font);
|
||||
FBGRA.CanvasBGRA.Font.Height:= round(FBGRA.CanvasBGRA.Font.Height*scale);
|
||||
{$IFDEF FPC}//#
|
||||
TS := Canvas.TextStyle;
|
||||
{$ENDIF}
|
||||
TS.Alignment := Alignment;
|
||||
TS.Layout := tlTop;
|
||||
TS.Opaque := False;
|
||||
TS.Clipping := False;
|
||||
{$IFDEF FPC}//#
|
||||
TS.SystemFont := Canvas.Font.IsDefault;
|
||||
{$ENDIF}
|
||||
|
||||
FBGRA.CanvasBGRA.Font.Color := Color xor $FFFFFF;
|
||||
|
||||
if not Enabled then
|
||||
FBGRA.CanvasBGRA.Font.Style := [fsStrikeOut]
|
||||
else
|
||||
FBGRA.CanvasBGRA.Font.Style := [];
|
||||
|
||||
FBGRA.CanvasBGRA.TextRect(ARect, ARect.Left, ARect.Top, Caption, TS);
|
||||
end;
|
||||
|
||||
if Assigned(FOnRedraw) then
|
||||
FOnRedraw(self, FBGRA);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TCustomBGRAVirtualScreen.SetColor(Value: TColor);
|
||||
begin
|
||||
if Value <> Color then
|
||||
DiscardBitmap;
|
||||
|
||||
{$IFDEF FPC}
|
||||
inherited SetColor(Value);
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
{$hints off}
|
||||
procedure TCustomBGRAVirtualScreen.WMEraseBkgnd(var Message: {$IFDEF FPC}TLMEraseBkgnd{$ELSE}TWMEraseBkgnd{$ENDIF});
|
||||
begin
|
||||
//do nothing
|
||||
end;
|
||||
|
||||
{$hints on}
|
||||
|
||||
procedure TCustomBGRAVirtualScreen.SetEnabled(Value: boolean);
|
||||
begin
|
||||
if Value <> Enabled then
|
||||
DiscardBitmap;
|
||||
inherited SetEnabled(Value);
|
||||
end;
|
||||
|
||||
constructor TCustomBGRAVirtualScreen.Create(TheOwner: TComponent);
|
||||
begin
|
||||
inherited Create(TheOwner);
|
||||
inherited BevelOuter := bvNone;
|
||||
FBGRA := TBGRABitmap.Create;
|
||||
FBitmapAutoScale := true;
|
||||
FBevelWidth := 1;
|
||||
FAlignment := taLeftJustify;
|
||||
FDiscardedRect := EmptyRect;
|
||||
Color := clWhite;
|
||||
end;
|
||||
|
||||
function TCustomBGRAVirtualScreen.BitmapRectToClient(ARect: TRect): TRect;
|
||||
var
|
||||
scale: Double;
|
||||
begin
|
||||
scale := BitmapScale;
|
||||
result := rect(floor(ARect.Left/scale), floor(ARect.Top/scale),
|
||||
ceil(ARect.Right/scale), ceil(ARect.Bottom/scale));
|
||||
end;
|
||||
|
||||
procedure TCustomBGRAVirtualScreen.RedrawBitmap;
|
||||
begin
|
||||
RedrawBitmapContent;
|
||||
FDiscardedRect := EmptyRect;
|
||||
Repaint;
|
||||
end;
|
||||
|
||||
procedure TCustomBGRAVirtualScreen.RedrawBitmap(ARect: TRect);
|
||||
var
|
||||
All, displayRect: TRect;
|
||||
begin
|
||||
if Assigned(FBGRA) then
|
||||
begin
|
||||
All := Rect(0,0,FBGRA.Width,FBGRA.Height);
|
||||
ARect.Intersect(All);
|
||||
if not FDiscardedRect.IsEmpty then
|
||||
begin
|
||||
if ARect.IsEmpty then
|
||||
ARect := FDiscardedRect
|
||||
else
|
||||
ARect.Union(FDiscardedRect);
|
||||
FDiscardedRect := EmptyRect;
|
||||
end;
|
||||
if ARect.IsEmpty then exit;
|
||||
if ARect.Contains(All) then
|
||||
begin
|
||||
RedrawBitmap;
|
||||
end
|
||||
else
|
||||
begin
|
||||
FBGRA.ClipRect := ARect;
|
||||
RedrawBitmapContent;
|
||||
FBGRA.NoClip;
|
||||
displayRect := BitmapRectToClient(ARect);
|
||||
{$IFDEF LINUX}
|
||||
FBGRA.DrawPart(ARect, Canvas, displayRect, True);
|
||||
{$ELSE}
|
||||
InvalidateRect(Handle, @displayRect, False);
|
||||
Update;
|
||||
{$ENDIF}
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TCustomBGRAVirtualScreen.RedrawBitmap(ARectArray: array of TRect);
|
||||
const cellShift = 6;
|
||||
cellSize = 1 shl cellShift;
|
||||
var
|
||||
grid: array of array of boolean;
|
||||
gAll: TRect;
|
||||
|
||||
procedure IncludeRect(ARect: TRect);
|
||||
var
|
||||
gR: TRect;
|
||||
y,x: LongInt;
|
||||
begin
|
||||
with ARect do
|
||||
gR := rect(max(Left,0) shr cellShift, max(Top,0) shr cellShift,
|
||||
(max(Right,0)+cellSize-1) shr cellShift,
|
||||
(max(Bottom,0)+cellSize-1) shr cellShift);
|
||||
gR.Intersect(gAll);
|
||||
if gR.IsEmpty then exit;
|
||||
|
||||
for y := gR.Top to gR.Bottom-1 do
|
||||
for x := gR.Left to gR.Right-1 do
|
||||
grid[y,x] := true;
|
||||
end;
|
||||
|
||||
var
|
||||
gW,gH, i,gCount: integer;
|
||||
gR: TRect;
|
||||
y,x: LongInt;
|
||||
expand: boolean;
|
||||
|
||||
|
||||
begin
|
||||
if not Assigned(FBGRA) then exit;
|
||||
gW := (Bitmap.Width+cellSize-1) shr cellShift;
|
||||
gH := (Bitmap.Height+cellSize-1) shr cellShift;
|
||||
gAll := rect(0,0,gW,gH);
|
||||
|
||||
//determine which cells of the grid to redraw
|
||||
setlength(grid,gH,gW);
|
||||
for i := 0 to high(ARectArray) do
|
||||
IncludeRect(ARectArray[i]);
|
||||
if not FDiscardedRect.IsEmpty then
|
||||
begin
|
||||
IncludeRect(FDiscardedRect);
|
||||
FDiscardedRect := EmptyRect;
|
||||
end;
|
||||
|
||||
gCount := 0;
|
||||
for y := 0 to gH-1 do
|
||||
for x := 0 to gW-1 do
|
||||
if grid[y,x] then inc(gCount);
|
||||
|
||||
if gCount >= gH*gW div 5 then
|
||||
begin
|
||||
RedrawBitmap(rect(0,0,Width,Height));
|
||||
end else
|
||||
for y := 0 to gH-1 do
|
||||
begin
|
||||
x := 0;
|
||||
while x < gW do
|
||||
begin
|
||||
if grid[y,x] then
|
||||
begin
|
||||
gR.Left := x;
|
||||
grid[y,x] := false;
|
||||
inc(x);
|
||||
while (x < gW) and grid[y,x] do
|
||||
begin
|
||||
grid[y,x] := false;
|
||||
inc(x);
|
||||
end;
|
||||
gR.Right := x;
|
||||
gR.Top := y;
|
||||
gR.Bottom := y+1;
|
||||
expand := true;
|
||||
while expand and (gR.Bottom < gH) do
|
||||
begin
|
||||
expand := true;
|
||||
for x := gR.Left to gR.Right-1 do
|
||||
if not grid[gR.Bottom, x] then
|
||||
begin
|
||||
expand := false;
|
||||
break;
|
||||
end;
|
||||
if expand then
|
||||
begin
|
||||
for x := gR.Left to gR.Right-1 do
|
||||
grid[gR.Bottom,x] := false;
|
||||
inc(gR.Bottom);
|
||||
end;
|
||||
end;
|
||||
|
||||
RedrawBitmap(rect(gR.Left shl cellShift,gR.Top shl cellShift,gr.Right shl cellShift,gr.Bottom shl cellShift));
|
||||
end else
|
||||
inc(x);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TCustomBGRAVirtualScreen.DiscardBitmap;
|
||||
begin
|
||||
if FBGRA <> nil then
|
||||
DiscardBitmap(rect(0,0,FBGRA.Width,FBGRA.Height));
|
||||
end;
|
||||
|
||||
procedure TCustomBGRAVirtualScreen.DiscardBitmap(ARect: TRect);
|
||||
var
|
||||
displayRect: TRect;
|
||||
begin
|
||||
ARect.Intersect(rect(0,0,FBGRA.Width,FBGRA.Height));
|
||||
if ARect.IsEmpty then exit;
|
||||
if FBGRA <> nil then
|
||||
begin
|
||||
if FDiscardedRect.IsEmpty then
|
||||
FDiscardedRect := ARect
|
||||
else
|
||||
FDiscardedRect.Union(ARect);
|
||||
displayRect := BitmapRectToClient(ARect);
|
||||
InvalidateRect(self.Handle, @displayRect, false);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TCustomBGRAVirtualScreen.InvalidateBitmap(ARect: TRect);
|
||||
var
|
||||
displayRect: TRect;
|
||||
begin
|
||||
displayRect := BitmapRectToClient(ARect);
|
||||
InvalidateRect(self.Handle, @displayRect, false);
|
||||
end;
|
||||
|
||||
destructor TCustomBGRAVirtualScreen.Destroy;
|
||||
begin
|
||||
FBGRA.Free;
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
end.
|
||||
610
bgracontrols/colorspeedbutton.pas
Normal file
610
bgracontrols/colorspeedbutton.pas
Normal file
@@ -0,0 +1,610 @@
|
||||
// SPDX-License-Identifier: LGPL-3.0-linking-exception
|
||||
{******************************* CONTRIBUTOR(S) ******************************
|
||||
- Edivando S. Santos Brasil | mailedivando@gmail.com
|
||||
(Compatibility with delphi VCL 11/2018)
|
||||
|
||||
***************************** END CONTRIBUTOR(S) *****************************}
|
||||
unit ColorSpeedButton;
|
||||
|
||||
{$I bgracontrols.inc}
|
||||
|
||||
{$ifdef windows}
|
||||
{$define overridepaint}
|
||||
{$endif}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils, Types, {$IFDEF FPC}LCLType, LCLProc, LResources,{$ENDIF}
|
||||
{$IFNDEF FPC}BGRAGraphics, GraphType, FPImage, {$ENDIF}
|
||||
Forms, Controls, Graphics, Dialogs, Buttons, BGRASpeedButton, Themes
|
||||
{$ifdef overridepaint}, Math{$ENDIF};
|
||||
|
||||
type
|
||||
|
||||
{ TColorState }
|
||||
|
||||
TColorState = class(TPersistent)
|
||||
private
|
||||
FOwner: TControl;
|
||||
FBorderColor: TColor;
|
||||
FBorderWidth: integer;
|
||||
FColor: TColor;
|
||||
procedure SetFBorderColor(AValue: TColor);
|
||||
procedure SetFBorderWidth(AValue: integer);
|
||||
procedure SetFColor(AValue: TColor);
|
||||
public
|
||||
constructor Create(AOwner: TControl);
|
||||
published
|
||||
property Color: TColor read FColor write SetFColor;
|
||||
property BorderColor: TColor read FBorderColor write SetFBorderColor;
|
||||
property BorderWidth: integer read FBorderWidth write SetFBorderWidth;
|
||||
end;
|
||||
|
||||
{ TColorSpeedButton }
|
||||
|
||||
TColorSpeedButton = class(TBGRASpeedButton)
|
||||
private
|
||||
{$ifdef overridepaint}
|
||||
FLastDrawDetails: TThemedElementDetails;
|
||||
{$endif}
|
||||
FPopupMode: boolean;
|
||||
FPressed: boolean;
|
||||
FStateActive: TColorState;
|
||||
FStateDisabled: TColorState;
|
||||
FStateHover: TColorState;
|
||||
FStateNormal: TColorState;
|
||||
FTextAutoSize: boolean;
|
||||
FToggle: boolean;
|
||||
procedure SetFPopupMode(AValue: boolean);
|
||||
procedure SetFPressed(AValue: boolean);
|
||||
procedure SetFStateActive(AValue: TColorState);
|
||||
procedure SetFStateDisabled(AValue: TColorState);
|
||||
procedure SetFStateHover(AValue: TColorState);
|
||||
procedure SetFStateNormal(AValue: TColorState);
|
||||
procedure SetFTextAutoSize(AValue: boolean);
|
||||
procedure SetFToggle(AValue: boolean);
|
||||
protected
|
||||
{$ifdef overridepaint}
|
||||
procedure DrawText({%H-}ACanvas: TPersistent; {%H-}Details: TThemedElementDetails;
|
||||
const S: string; R: TRect; Flags, {%H-}Flags2: cardinal);
|
||||
procedure MeasureDraw(Draw: boolean; PaintRect: TRect;
|
||||
out PreferredWidth, PreferredHeight: integer);
|
||||
procedure Paint; override;
|
||||
procedure CalculatePreferredSize(var PreferredWidth, PreferredHeight: integer;
|
||||
{%H-}WithThemeSpace: boolean); override;
|
||||
{$endif}
|
||||
procedure PaintBackground(var PaintRect: TRect); {$IFDEF FPC}override;{$ENDIF}
|
||||
public
|
||||
constructor Create(TheOwner: TComponent); override;
|
||||
destructor Destroy; override;
|
||||
procedure Click; override;
|
||||
published
|
||||
property TextAutoSize: boolean read FTextAutoSize write SetFTextAutoSize;
|
||||
property Toggle: boolean read FToggle write SetFToggle;
|
||||
property Pressed: boolean read FPressed write SetFPressed;
|
||||
property PopupMode: boolean read FPopupMode write SetFPopupMode;
|
||||
property StateNormal: TColorState read FStateNormal write SetFStateNormal;
|
||||
property StateHover: TColorState read FStateHover write SetFStateHover;
|
||||
property StateActive: TColorState read FStateActive write SetFStateActive;
|
||||
property StateDisabled: TColorState read FStateDisabled write SetFStateDisabled;
|
||||
end;
|
||||
|
||||
{$IFDEF FPC}procedure Register;{$ENDIF}
|
||||
|
||||
implementation
|
||||
|
||||
{$IFDEF FPC}
|
||||
procedure Register;
|
||||
begin
|
||||
RegisterComponents('BGRA Button Controls', [TColorSpeedButton]);
|
||||
end;
|
||||
{$ENDIF}
|
||||
|
||||
{ TColorSpeedButton }
|
||||
|
||||
procedure TColorSpeedButton.SetFStateActive(AValue: TColorState);
|
||||
begin
|
||||
if FStateActive = AValue then
|
||||
Exit;
|
||||
FStateActive := AValue;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TColorSpeedButton.SetFPopupMode(AValue: boolean);
|
||||
begin
|
||||
if FPopupMode = AValue then
|
||||
Exit;
|
||||
FPopupMode := AValue;
|
||||
end;
|
||||
|
||||
procedure TColorSpeedButton.SetFPressed(AValue: boolean);
|
||||
begin
|
||||
if FPressed = AValue then
|
||||
Exit;
|
||||
FPressed := AValue;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TColorSpeedButton.SetFStateDisabled(AValue: TColorState);
|
||||
begin
|
||||
if FStateDisabled = AValue then
|
||||
Exit;
|
||||
FStateDisabled := AValue;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TColorSpeedButton.SetFStateHover(AValue: TColorState);
|
||||
begin
|
||||
if FStateHover = AValue then
|
||||
Exit;
|
||||
FStateHover := AValue;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TColorSpeedButton.SetFStateNormal(AValue: TColorState);
|
||||
begin
|
||||
if FStateNormal = AValue then
|
||||
Exit;
|
||||
FStateNormal := AValue;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TColorSpeedButton.SetFTextAutoSize(AValue: boolean);
|
||||
begin
|
||||
if FTextAutoSize = AValue then
|
||||
Exit;
|
||||
FTextAutoSize := AValue;
|
||||
end;
|
||||
|
||||
procedure TColorSpeedButton.SetFToggle(AValue: boolean);
|
||||
begin
|
||||
if FToggle = AValue then
|
||||
Exit;
|
||||
FToggle := AValue;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
{$ifdef overridepaint}
|
||||
procedure TColorSpeedButton.DrawText(ACanvas: TPersistent;
|
||||
Details: TThemedElementDetails; const S: string; R: TRect; Flags, Flags2: cardinal);
|
||||
var
|
||||
TXTStyle: TTextStyle;
|
||||
begin
|
||||
TXTStyle := Canvas.TextStyle;
|
||||
TXTStyle.Opaque := False;
|
||||
TXTStyle.Clipping := (Flags and DT_NOCLIP) = 0;
|
||||
TXTStyle.ShowPrefix := (Flags and DT_NOPREFIX) = 0;
|
||||
TXTStyle.SingleLine := (Flags and DT_SINGLELINE) <> 0;
|
||||
|
||||
if (Flags and DT_CENTER) <> 0 then
|
||||
TXTStyle.Alignment := taCenter
|
||||
else
|
||||
if (Flags and DT_RIGHT) <> 0 then
|
||||
TXTStyle.Alignment := taRightJustify
|
||||
else
|
||||
TXTStyle.Alignment := taLeftJustify;
|
||||
|
||||
if (Flags and DT_VCENTER) <> 0 then
|
||||
TXTStyle.Layout := tlCenter
|
||||
else
|
||||
if (Flags and DT_BOTTOM) <> 0 then
|
||||
TXTStyle.Layout := tlBottom
|
||||
else
|
||||
TXTStyle.Layout := tlTop;
|
||||
TXTStyle.RightToLeft := (Flags and DT_RTLREADING) <> 0;
|
||||
// set color here, otherwise SystemFont is wrong if the button was disabled before
|
||||
TXTStyle.SystemFont := Canvas.Font.IsDefault;//Match System Default Style
|
||||
|
||||
TXTStyle.Wordbreak := (Flags and DT_WORDBREAK) <> 0;
|
||||
if not TXTStyle.Wordbreak then
|
||||
TXTStyle.EndEllipsis := (Flags and DT_END_ELLIPSIS) <> 0
|
||||
else
|
||||
TXTStyle.EndEllipsis := False;
|
||||
Canvas.TextRect(R, R.Left, R.Top, S, TXTStyle);
|
||||
end;
|
||||
|
||||
procedure TColorSpeedButton.MeasureDraw(Draw: boolean; PaintRect: TRect;
|
||||
out PreferredWidth, PreferredHeight: integer);
|
||||
var
|
||||
GlyphWidth, GlyphHeight: integer;
|
||||
Offset, OffsetCap: TPoint;
|
||||
ClientSize, TotalSize, TextSize, GlyphSize: TSize;
|
||||
M, S: integer;
|
||||
SIndex: longint;
|
||||
TMP: string;
|
||||
TextFlags: integer;
|
||||
DrawDetails: TThemedElementDetails;
|
||||
FixedWidth: boolean;
|
||||
FixedHeight: boolean;
|
||||
TextRect: TRect;
|
||||
HasGlyph: boolean;
|
||||
HasText: boolean;
|
||||
CurLayout: TButtonLayout;
|
||||
begin
|
||||
if Glyph = nil then
|
||||
exit;
|
||||
|
||||
DrawDetails := GetDrawDetails;
|
||||
|
||||
PreferredWidth := 0;
|
||||
PreferredHeight := 0;
|
||||
|
||||
if Draw then
|
||||
begin
|
||||
FLastDrawDetails := DrawDetails;
|
||||
PaintBackground(PaintRect);
|
||||
FixedWidth := True;
|
||||
FixedHeight := True;
|
||||
end
|
||||
else
|
||||
begin
|
||||
FixedWidth := WidthIsAnchored;
|
||||
FixedHeight := HeightIsAnchored;
|
||||
end;
|
||||
ClientSize.cx := PaintRect.Right - PaintRect.Left;
|
||||
ClientSize.cy := PaintRect.Bottom - PaintRect.Top;
|
||||
//debugln(['TCustomSpeedButton.MeasureDraw Step1 ',DbgSName(Self),' PaintRect=',dbgs(PaintRect)]);
|
||||
// compute size of glyph
|
||||
GlyphSize := GetGlyphSize(Draw, PaintRect);
|
||||
GlyphWidth := GlyphSize.CX;
|
||||
if NumGlyphs > 1 then
|
||||
GlyphWidth := GlyphWidth div NumGlyphs;
|
||||
GlyphHeight := GlyphSize.CY;
|
||||
HasGlyph := (GlyphWidth <> 0) and (GlyphHeight <> 0);
|
||||
//debugln(['TCustomSpeedButton.MeasureDraw Step2 ',DbgSName(Self),' PaintRect=',dbgs(PaintRect),' GlyphSize=',GlyphWidth,'x',GlyphHeight]);
|
||||
|
||||
// compute size of text
|
||||
CurLayout := BidiAdjustButtonLayout(UseRightToLeftReading, Layout);
|
||||
if ShowCaption and (Caption <> '') then
|
||||
begin
|
||||
TextRect := PaintRect;
|
||||
// for wordbreak compute the maximum size for the text
|
||||
if Margin > 0 then
|
||||
InflateRect(TextRect, -Margin, -Margin);
|
||||
if HasGlyph then
|
||||
begin
|
||||
if (Spacing >= 0) then
|
||||
if CurLayout in [blGlyphLeft, blGlyphRight] then
|
||||
Dec(TextRect.Right, Spacing)
|
||||
else
|
||||
Dec(TextRect.Bottom, Spacing);
|
||||
if CurLayout in [blGlyphLeft, blGlyphRight] then
|
||||
Dec(TextRect.Right, GlyphWidth)
|
||||
else
|
||||
Dec(TextRect.Bottom, GlyphHeight);
|
||||
end;
|
||||
if not FixedWidth then
|
||||
begin
|
||||
TextRect.Left := 0;
|
||||
TextRect.Right := High(TextRect.Right) div 2;
|
||||
end;
|
||||
if not FixedHeight then
|
||||
begin
|
||||
TextRect.Top := 0;
|
||||
TextRect.Bottom := High(TextRect.Bottom) div 2;
|
||||
end;
|
||||
TextSize := GetTextSize(Draw, TextRect);
|
||||
end
|
||||
else
|
||||
begin
|
||||
TextSize.cx := 0;
|
||||
TextSize.cy := 0;
|
||||
end;
|
||||
HasText := (TextSize.cx <> 0) or (TextSize.cy <> 0);
|
||||
|
||||
if Caption <> '' then
|
||||
begin
|
||||
TMP := Caption;
|
||||
SIndex := DeleteAmpersands(TMP);
|
||||
if SIndex > 0 then
|
||||
if SIndex <= Length(TMP) then
|
||||
begin
|
||||
//FShortcut := Ord(TMP[SIndex]);
|
||||
end;
|
||||
end;
|
||||
|
||||
if HasGlyph and HasText then
|
||||
S := Spacing
|
||||
else
|
||||
S := 0;
|
||||
M := Margin;
|
||||
if not Draw then
|
||||
begin
|
||||
if M < 0 then
|
||||
M := 2;
|
||||
if S < 0 then
|
||||
S := M;
|
||||
end;
|
||||
|
||||
// Calculate caption and glyph layout
|
||||
if M = -1 then
|
||||
begin
|
||||
// auto compute margin to center content
|
||||
if S = -1 then
|
||||
begin
|
||||
// use the same value for Spacing and Margin
|
||||
TotalSize.cx := TextSize.cx + GlyphWidth;
|
||||
TotalSize.cy := TextSize.cy + GlyphHeight;
|
||||
if Layout in [blGlyphLeft, blGlyphRight] then
|
||||
M := (ClientSize.cx - TotalSize.cx) div 3
|
||||
else
|
||||
M := (ClientSize.cy - TotalSize.cy) div 3;
|
||||
S := M;
|
||||
end
|
||||
else
|
||||
begin
|
||||
// fixed Spacing and center content
|
||||
TotalSize.cx := GlyphWidth + S + TextSize.cx;
|
||||
TotalSize.cy := GlyphHeight + S + TextSize.cy;
|
||||
if Layout in [blGlyphLeft, blGlyphRight] then
|
||||
M := (ClientSize.cx - TotalSize.cx) div 2
|
||||
else
|
||||
M := (ClientSize.cy - TotalSize.cy) div 2;
|
||||
end;
|
||||
end
|
||||
else
|
||||
begin
|
||||
// fixed Margin
|
||||
if S = -1 then
|
||||
begin
|
||||
// use the rest for Spacing between Glyph and Caption
|
||||
TotalSize.cx := ClientSize.cx - (Margin + GlyphWidth);
|
||||
TotalSize.cy := ClientSize.cy - (Margin + GlyphHeight);
|
||||
if Layout in [blGlyphLeft, blGlyphRight] then
|
||||
S := (TotalSize.cx - TextSize.cx) div 2
|
||||
else
|
||||
S := (TotalSize.cy - TextSize.cy) div 2;
|
||||
end;
|
||||
end;
|
||||
|
||||
//debugln(['TCustomSpeedButton.MeasureDraw Step3 ',DbgSName(Self),' PaintRect=',dbgs(PaintRect),' GlyphSize=',GlyphWidth,'x',GlyphHeight,' TextSize=',TextSize.cx,'x',TextSize.cy,' S=',S,' M=',M]);
|
||||
|
||||
if Draw then
|
||||
begin
|
||||
case CurLayout of
|
||||
blGlyphLeft:
|
||||
begin
|
||||
Offset.X := M;
|
||||
Offset.Y := (ClientSize.cy - GlyphHeight) div 2;
|
||||
OffsetCap.X := Offset.X + GlyphWidth + S;
|
||||
OffsetCap.Y := (ClientSize.cy - TextSize.cy) div 2;
|
||||
end;
|
||||
blGlyphRight:
|
||||
begin
|
||||
Offset.X := ClientSize.cx - M - GlyphWidth;
|
||||
Offset.Y := (ClientSize.cy - GlyphHeight) div 2;
|
||||
OffsetCap.X := Offset.X - S - TextSize.cx;
|
||||
OffsetCap.Y := (ClientSize.cy - TextSize.cy) div 2;
|
||||
end;
|
||||
blGlyphTop:
|
||||
begin
|
||||
Offset.X := (ClientSize.cx - GlyphWidth) div 2;
|
||||
Offset.Y := M;
|
||||
OffsetCap.X := (ClientSize.cx - TextSize.cx) div 2;
|
||||
OffsetCap.Y := Offset.Y + GlyphHeight + S;
|
||||
end;
|
||||
blGlyphBottom:
|
||||
begin
|
||||
Offset.X := (ClientSize.cx - GlyphWidth) div 2;
|
||||
Offset.Y := ClientSize.cy - M - GlyphHeight;
|
||||
OffsetCap.X := (ClientSize.cx - TextSize.cx) div 2;
|
||||
OffsetCap.Y := Offset.Y - S - TextSize.cy;
|
||||
end;
|
||||
end;
|
||||
|
||||
DrawGlyph(Canvas, PaintRect, Offset, FState, Transparent, 0);
|
||||
|
||||
if ShowCaption and (Caption <> '') then
|
||||
begin
|
||||
with PaintRect, OffsetCap do
|
||||
begin
|
||||
Left := Left + X;
|
||||
Top := Top + Y;
|
||||
end;
|
||||
|
||||
TextFlags := DT_LEFT or DT_TOP;
|
||||
if UseRightToLeftReading then
|
||||
TextFlags := TextFlags or DT_RTLREADING;
|
||||
|
||||
if Draw then
|
||||
DrawText(Canvas, DrawDetails, Caption, PaintRect,
|
||||
TextFlags, 0);
|
||||
end;
|
||||
end
|
||||
else
|
||||
begin
|
||||
// measuring, not drawing
|
||||
case CurLayout of
|
||||
blGlyphLeft, blGlyphRight:
|
||||
begin
|
||||
// use text size for autosize
|
||||
if FTextAutoSize then
|
||||
begin
|
||||
PreferredWidth := 2 * M + S + GlyphWidth + TextSize.cx;
|
||||
PreferredHeight := 2 * M + Max(GlyphHeight, TextSize.cy);
|
||||
end
|
||||
else
|
||||
begin
|
||||
// ignore text size width and height
|
||||
PreferredWidth := 2 * M + S + GlyphWidth;
|
||||
PreferredHeight := 2 * M + {Max(}GlyphHeight{, TextSize.cy)};
|
||||
end;
|
||||
end;
|
||||
blGlyphTop, blGlyphBottom:
|
||||
begin
|
||||
if FTextAutoSize then
|
||||
begin
|
||||
PreferredWidth := 2 * M + Max(GlyphWidth, TextSize.cx);
|
||||
PreferredHeight := 2 * M + S + GlyphHeight + TextSize.cy;
|
||||
end
|
||||
else
|
||||
begin
|
||||
// ignore text size width and height
|
||||
PreferredWidth := 2 * M + S + GlyphWidth;
|
||||
PreferredHeight := 2 * M + S + GlyphHeight{ + TextSize.cy};
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TColorSpeedButton.Paint;
|
||||
var
|
||||
PaintRect: TRect;
|
||||
PreferredWidth: integer;
|
||||
PreferredHeight: integer;
|
||||
begin
|
||||
UpdateState(False);
|
||||
if Glyph = nil then
|
||||
exit;
|
||||
|
||||
PaintRect := ClientRect;
|
||||
MeasureDraw(True, PaintRect, PreferredWidth, PreferredHeight);
|
||||
|
||||
if Assigned(OnPaint) then
|
||||
OnPaint(Self);
|
||||
end;
|
||||
|
||||
procedure TColorSpeedButton.CalculatePreferredSize(
|
||||
var PreferredWidth, PreferredHeight: integer; WithThemeSpace: boolean);
|
||||
var
|
||||
r: TRect;
|
||||
begin
|
||||
r := Rect(0, 0, 0, 0);
|
||||
MeasureDraw(False, r, PreferredWidth, PreferredHeight);
|
||||
end;
|
||||
|
||||
{$endif}
|
||||
|
||||
procedure TColorSpeedButton.PaintBackground(var PaintRect: TRect);
|
||||
var
|
||||
TempState: TButtonState;
|
||||
begin
|
||||
TempState := FState;
|
||||
if Toggle and Pressed then
|
||||
TempState := bsDown;
|
||||
|
||||
Canvas.Pen.JoinStyle := pjsMiter; // remove rounded borders
|
||||
Canvas.Pen.Style := psInsideframe; // draws border width inside equally
|
||||
|
||||
case TempState of
|
||||
bsUp:
|
||||
begin
|
||||
Canvas.Pen.Color := FStateNormal.BorderColor;
|
||||
Canvas.Pen.Width := FStateNormal.BorderWidth;
|
||||
Canvas.Brush.Color := FStateNormal.Color;
|
||||
end;
|
||||
bsDisabled:
|
||||
begin
|
||||
Canvas.Pen.Color := FStateDisabled.BorderColor;
|
||||
Canvas.Pen.Width := FStateDisabled.BorderWidth;
|
||||
Canvas.Brush.Color := FStateDisabled.Color;
|
||||
end;
|
||||
bsDown, bsExclusive:
|
||||
begin
|
||||
Canvas.Pen.Color := FStateActive.BorderColor;
|
||||
Canvas.Pen.Width := FStateActive.BorderWidth;
|
||||
Canvas.Brush.Color := FStateActive.Color;
|
||||
end;
|
||||
{$IFDEF FPC}//#
|
||||
bsHot:
|
||||
begin
|
||||
Canvas.Pen.Color := FStateHover.BorderColor;
|
||||
Canvas.Pen.Width := FStateHover.BorderWidth;
|
||||
Canvas.Brush.Color := FStateHover.Color;
|
||||
end;
|
||||
{$ENDIF}
|
||||
end;
|
||||
if Canvas.Pen.Width = 0 then
|
||||
Canvas.Pen.Color := Canvas.Brush.Color;
|
||||
Canvas.Rectangle(PaintRect);
|
||||
end;
|
||||
|
||||
constructor TColorSpeedButton.Create(TheOwner: TComponent);
|
||||
begin
|
||||
inherited Create(TheOwner);
|
||||
FStateNormal := TColorState.Create(Self);
|
||||
FStateHover := TColorState.Create(Self);
|
||||
FStateActive := TColorState.Create(Self);
|
||||
FStateDisabled := TColorState.Create(Self);
|
||||
{ Windows Style }
|
||||
FStateNormal.Color := RGBToColor(225, 225, 225);
|
||||
FStateNormal.BorderColor := RGBToColor(173, 173, 173);
|
||||
FStateHover.Color := RGBToColor(229, 241, 251);
|
||||
FStateHover.BorderColor := RGBToColor(0, 120, 215);
|
||||
FStateActive.Color := RGBToColor(204, 228, 247);
|
||||
FStateActive.BorderColor := RGBToColor(0, 84, 153);
|
||||
FStateDisabled.Color := RGBToColor(204, 204, 204);
|
||||
FStateDisabled.BorderColor := RGBToColor(191, 191, 191);
|
||||
Font.Color := clBlack;
|
||||
FTextAutoSize := True;
|
||||
end;
|
||||
|
||||
destructor TColorSpeedButton.Destroy;
|
||||
begin
|
||||
FStateNormal.Free;
|
||||
FStateHover.Free;
|
||||
FStateActive.Free;
|
||||
FStateDisabled.Free;
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
procedure TColorSpeedButton.Click;
|
||||
var
|
||||
p: TPoint;
|
||||
begin
|
||||
if Toggle then
|
||||
Pressed := not Pressed;
|
||||
|
||||
if PopupMode then
|
||||
begin
|
||||
p := Parent.ClientToScreen(Point(Left, Top));
|
||||
PopupMenu.PopUp(p.x, p.y + Height);
|
||||
end;
|
||||
|
||||
inherited Click;
|
||||
end;
|
||||
|
||||
{ TColorState }
|
||||
|
||||
procedure TColorState.SetFBorderColor(AValue: TColor);
|
||||
begin
|
||||
if FBorderColor = AValue then
|
||||
Exit;
|
||||
FBorderColor := AValue;
|
||||
|
||||
FOwner.Perform(CM_CHANGED, 0, 0);
|
||||
FOwner.Invalidate;
|
||||
end;
|
||||
|
||||
procedure TColorState.SetFBorderWidth(AValue: integer);
|
||||
begin
|
||||
if FBorderWidth = AValue then
|
||||
Exit;
|
||||
FBorderWidth := AValue;
|
||||
|
||||
FOwner.Perform(CM_CHANGED, 0, 0);
|
||||
FOwner.Invalidate;
|
||||
end;
|
||||
|
||||
procedure TColorState.SetFColor(AValue: TColor);
|
||||
begin
|
||||
if FColor = AValue then
|
||||
Exit;
|
||||
FColor := AValue;
|
||||
|
||||
FOwner.Perform(CM_CHANGED, 0, 0);
|
||||
FOwner.Invalidate;
|
||||
end;
|
||||
|
||||
constructor TColorState.Create(AOwner: TControl);
|
||||
begin
|
||||
inherited Create;
|
||||
FOwner := AOwner;
|
||||
BorderWidth := 1;
|
||||
BorderColor := clBlack;
|
||||
Color := clWhite;
|
||||
end;
|
||||
|
||||
end.
|
||||
23
bgracontrols/docs/Boost Software License.txt
Normal file
23
bgracontrols/docs/Boost Software License.txt
Normal file
@@ -0,0 +1,23 @@
|
||||
Boost Software License - Version 1.0 - August 17th, 2003
|
||||
|
||||
Permission is hereby granted, free of charge, to any person or organization
|
||||
obtaining a copy of the software and accompanying documentation covered by
|
||||
this license (the "Software") to use, reproduce, display, distribute,
|
||||
execute, and transmit the Software, and to prepare derivative works of the
|
||||
Software, and to permit third-parties to whom the Software is furnished to
|
||||
do so, all subject to the following:
|
||||
|
||||
The copyright notices in the Software and this entire statement, including
|
||||
the above license grant, this restriction and the following disclaimer,
|
||||
must be included in all copies of the Software, in whole or in part, and
|
||||
all derivative works of the Software, unless such copies or derivative
|
||||
works are solely in the form of machine-executable object code generated by
|
||||
a source language processor.
|
||||
|
||||
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
|
||||
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
|
||||
FITNESS FOR A PARTICULAR PURPOSE, TITLE AND NON-INFRINGEMENT. IN NO EVENT
|
||||
SHALL THE COPYRIGHT HOLDERS OR ANYONE DISTRIBUTING THE SOFTWARE BE LIABLE
|
||||
FOR ANY DAMAGES OR OTHER LIABILITY, WHETHER IN CONTRACT, TORT OR OTHERWISE,
|
||||
ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
|
||||
DEALINGS IN THE SOFTWARE.
|
||||
481
bgracontrols/docs/COPYING.LGPL.txt
Normal file
481
bgracontrols/docs/COPYING.LGPL.txt
Normal file
@@ -0,0 +1,481 @@
|
||||
GNU LIBRARY GENERAL PUBLIC LICENSE
|
||||
Version 2, June 1991
|
||||
|
||||
Copyright (C) 1991 Free Software Foundation, Inc.
|
||||
59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
|
||||
Everyone is permitted to copy and distribute verbatim copies
|
||||
of this license document, but changing it is not allowed.
|
||||
|
||||
[This is the first released version of the library GPL. It is
|
||||
numbered 2 because it goes with version 2 of the ordinary GPL.]
|
||||
|
||||
Preamble
|
||||
|
||||
The licenses for most software are designed to take away your
|
||||
freedom to share and change it. By contrast, the GNU General Public
|
||||
Licenses are intended to guarantee your freedom to share and change
|
||||
free software--to make sure the software is free for all its users.
|
||||
|
||||
This license, the Library General Public License, applies to some
|
||||
specially designated Free Software Foundation software, and to any
|
||||
other libraries whose authors decide to use it. You can use it for
|
||||
your libraries, too.
|
||||
|
||||
When we speak of free software, we are referring to freedom, not
|
||||
price. Our General Public Licenses are designed to make sure that you
|
||||
have the freedom to distribute copies of free software (and charge for
|
||||
this service if you wish), that you receive source code or can get it
|
||||
if you want it, that you can change the software or use pieces of it
|
||||
in new free programs; and that you know you can do these things.
|
||||
|
||||
To protect your rights, we need to make restrictions that forbid
|
||||
anyone to deny you these rights or to ask you to surrender the rights.
|
||||
These restrictions translate to certain responsibilities for you if
|
||||
you distribute copies of the library, or if you modify it.
|
||||
|
||||
For example, if you distribute copies of the library, whether gratis
|
||||
or for a fee, you must give the recipients all the rights that we gave
|
||||
you. You must make sure that they, too, receive or can get the source
|
||||
code. If you link a program with the library, you must provide
|
||||
complete object files to the recipients so that they can relink them
|
||||
with the library, after making changes to the library and recompiling
|
||||
it. And you must show them these terms so they know their rights.
|
||||
|
||||
Our method of protecting your rights has two steps: (1) copyright
|
||||
the library, and (2) offer you this license which gives you legal
|
||||
permission to copy, distribute and/or modify the library.
|
||||
|
||||
Also, for each distributor's protection, we want to make certain
|
||||
that everyone understands that there is no warranty for this free
|
||||
library. If the library is modified by someone else and passed on, we
|
||||
want its recipients to know that what they have is not the original
|
||||
version, so that any problems introduced by others will not reflect on
|
||||
the original authors' reputations.
|
||||
|
||||
Finally, any free program is threatened constantly by software
|
||||
patents. We wish to avoid the danger that companies distributing free
|
||||
software will individually obtain patent licenses, thus in effect
|
||||
transforming the program into proprietary software. To prevent this,
|
||||
we have made it clear that any patent must be licensed for everyone's
|
||||
free use or not licensed at all.
|
||||
|
||||
Most GNU software, including some libraries, is covered by the ordinary
|
||||
GNU General Public License, which was designed for utility programs. This
|
||||
license, the GNU Library General Public License, applies to certain
|
||||
designated libraries. This license is quite different from the ordinary
|
||||
one; be sure to read it in full, and don't assume that anything in it is
|
||||
the same as in the ordinary license.
|
||||
|
||||
The reason we have a separate public license for some libraries is that
|
||||
they blur the distinction we usually make between modifying or adding to a
|
||||
program and simply using it. Linking a program with a library, without
|
||||
changing the library, is in some sense simply using the library, and is
|
||||
analogous to running a utility program or application program. However, in
|
||||
a textual and legal sense, the linked executable is a combined work, a
|
||||
derivative of the original library, and the ordinary General Public License
|
||||
treats it as such.
|
||||
|
||||
Because of this blurred distinction, using the ordinary General
|
||||
Public License for libraries did not effectively promote software
|
||||
sharing, because most developers did not use the libraries. We
|
||||
concluded that weaker conditions might promote sharing better.
|
||||
|
||||
However, unrestricted linking of non-free programs would deprive the
|
||||
users of those programs of all benefit from the free status of the
|
||||
libraries themselves. This Library General Public License is intended to
|
||||
permit developers of non-free programs to use free libraries, while
|
||||
preserving your freedom as a user of such programs to change the free
|
||||
libraries that are incorporated in them. (We have not seen how to achieve
|
||||
this as regards changes in header files, but we have achieved it as regards
|
||||
changes in the actual functions of the Library.) The hope is that this
|
||||
will lead to faster development of free libraries.
|
||||
|
||||
The precise terms and conditions for copying, distribution and
|
||||
modification follow. Pay close attention to the difference between a
|
||||
"work based on the library" and a "work that uses the library". The
|
||||
former contains code derived from the library, while the latter only
|
||||
works together with the library.
|
||||
|
||||
Note that it is possible for a library to be covered by the ordinary
|
||||
General Public License rather than by this special one.
|
||||
|
||||
GNU LIBRARY GENERAL PUBLIC LICENSE
|
||||
TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
|
||||
|
||||
0. This License Agreement applies to any software library which
|
||||
contains a notice placed by the copyright holder or other authorized
|
||||
party saying it may be distributed under the terms of this Library
|
||||
General Public License (also called "this License"). Each licensee is
|
||||
addressed as "you".
|
||||
|
||||
A "library" means a collection of software functions and/or data
|
||||
prepared so as to be conveniently linked with application programs
|
||||
(which use some of those functions and data) to form executables.
|
||||
|
||||
The "Library", below, refers to any such software library or work
|
||||
which has been distributed under these terms. A "work based on the
|
||||
Library" means either the Library or any derivative work under
|
||||
copyright law: that is to say, a work containing the Library or a
|
||||
portion of it, either verbatim or with modifications and/or translated
|
||||
straightforwardly into another language. (Hereinafter, translation is
|
||||
included without limitation in the term "modification".)
|
||||
|
||||
"Source code" for a work means the preferred form of the work for
|
||||
making modifications to it. For a library, complete source code means
|
||||
all the source code for all modules it contains, plus any associated
|
||||
interface definition files, plus the scripts used to control compilation
|
||||
and installation of the library.
|
||||
|
||||
Activities other than copying, distribution and modification are not
|
||||
covered by this License; they are outside its scope. The act of
|
||||
running a program using the Library is not restricted, and output from
|
||||
such a program is covered only if its contents constitute a work based
|
||||
on the Library (independent of the use of the Library in a tool for
|
||||
writing it). Whether that is true depends on what the Library does
|
||||
and what the program that uses the Library does.
|
||||
|
||||
1. You may copy and distribute verbatim copies of the Library's
|
||||
complete source code as you receive it, in any medium, provided that
|
||||
you conspicuously and appropriately publish on each copy an
|
||||
appropriate copyright notice and disclaimer of warranty; keep intact
|
||||
all the notices that refer to this License and to the absence of any
|
||||
warranty; and distribute a copy of this License along with the
|
||||
Library.
|
||||
|
||||
You may charge a fee for the physical act of transferring a copy,
|
||||
and you may at your option offer warranty protection in exchange for a
|
||||
fee.
|
||||
|
||||
2. You may modify your copy or copies of the Library or any portion
|
||||
of it, thus forming a work based on the Library, and copy and
|
||||
distribute such modifications or work under the terms of Section 1
|
||||
above, provided that you also meet all of these conditions:
|
||||
|
||||
a) The modified work must itself be a software library.
|
||||
|
||||
b) You must cause the files modified to carry prominent notices
|
||||
stating that you changed the files and the date of any change.
|
||||
|
||||
c) You must cause the whole of the work to be licensed at no
|
||||
charge to all third parties under the terms of this License.
|
||||
|
||||
d) If a facility in the modified Library refers to a function or a
|
||||
table of data to be supplied by an application program that uses
|
||||
the facility, other than as an argument passed when the facility
|
||||
is invoked, then you must make a good faith effort to ensure that,
|
||||
in the event an application does not supply such function or
|
||||
table, the facility still operates, and performs whatever part of
|
||||
its purpose remains meaningful.
|
||||
|
||||
(For example, a function in a library to compute square roots has
|
||||
a purpose that is entirely well-defined independent of the
|
||||
application. Therefore, Subsection 2d requires that any
|
||||
application-supplied function or table used by this function must
|
||||
be optional: if the application does not supply it, the square
|
||||
root function must still compute square roots.)
|
||||
|
||||
These requirements apply to the modified work as a whole. If
|
||||
identifiable sections of that work are not derived from the Library,
|
||||
and can be reasonably considered independent and separate works in
|
||||
themselves, then this License, and its terms, do not apply to those
|
||||
sections when you distribute them as separate works. But when you
|
||||
distribute the same sections as part of a whole which is a work based
|
||||
on the Library, the distribution of the whole must be on the terms of
|
||||
this License, whose permissions for other licensees extend to the
|
||||
entire whole, and thus to each and every part regardless of who wrote
|
||||
it.
|
||||
|
||||
Thus, it is not the intent of this section to claim rights or contest
|
||||
your rights to work written entirely by you; rather, the intent is to
|
||||
exercise the right to control the distribution of derivative or
|
||||
collective works based on the Library.
|
||||
|
||||
In addition, mere aggregation of another work not based on the Library
|
||||
with the Library (or with a work based on the Library) on a volume of
|
||||
a storage or distribution medium does not bring the other work under
|
||||
the scope of this License.
|
||||
|
||||
3. You may opt to apply the terms of the ordinary GNU General Public
|
||||
License instead of this License to a given copy of the Library. To do
|
||||
this, you must alter all the notices that refer to this License, so
|
||||
that they refer to the ordinary GNU General Public License, version 2,
|
||||
instead of to this License. (If a newer version than version 2 of the
|
||||
ordinary GNU General Public License has appeared, then you can specify
|
||||
that version instead if you wish.) Do not make any other change in
|
||||
these notices.
|
||||
|
||||
Once this change is made in a given copy, it is irreversible for
|
||||
that copy, so the ordinary GNU General Public License applies to all
|
||||
subsequent copies and derivative works made from that copy.
|
||||
|
||||
This option is useful when you wish to copy part of the code of
|
||||
the Library into a program that is not a library.
|
||||
|
||||
4. You may copy and distribute the Library (or a portion or
|
||||
derivative of it, under Section 2) in object code or executable form
|
||||
under the terms of Sections 1 and 2 above provided that you accompany
|
||||
it with the complete corresponding machine-readable source code, which
|
||||
must be distributed under the terms of Sections 1 and 2 above on a
|
||||
medium customarily used for software interchange.
|
||||
|
||||
If distribution of object code is made by offering access to copy
|
||||
from a designated place, then offering equivalent access to copy the
|
||||
source code from the same place satisfies the requirement to
|
||||
distribute the source code, even though third parties are not
|
||||
compelled to copy the source along with the object code.
|
||||
|
||||
5. A program that contains no derivative of any portion of the
|
||||
Library, but is designed to work with the Library by being compiled or
|
||||
linked with it, is called a "work that uses the Library". Such a
|
||||
work, in isolation, is not a derivative work of the Library, and
|
||||
therefore falls outside the scope of this License.
|
||||
|
||||
However, linking a "work that uses the Library" with the Library
|
||||
creates an executable that is a derivative of the Library (because it
|
||||
contains portions of the Library), rather than a "work that uses the
|
||||
library". The executable is therefore covered by this License.
|
||||
Section 6 states terms for distribution of such executables.
|
||||
|
||||
When a "work that uses the Library" uses material from a header file
|
||||
that is part of the Library, the object code for the work may be a
|
||||
derivative work of the Library even though the source code is not.
|
||||
Whether this is true is especially significant if the work can be
|
||||
linked without the Library, or if the work is itself a library. The
|
||||
threshold for this to be true is not precisely defined by law.
|
||||
|
||||
If such an object file uses only numerical parameters, data
|
||||
structure layouts and accessors, and small macros and small inline
|
||||
functions (ten lines or less in length), then the use of the object
|
||||
file is unrestricted, regardless of whether it is legally a derivative
|
||||
work. (Executables containing this object code plus portions of the
|
||||
Library will still fall under Section 6.)
|
||||
|
||||
Otherwise, if the work is a derivative of the Library, you may
|
||||
distribute the object code for the work under the terms of Section 6.
|
||||
Any executables containing that work also fall under Section 6,
|
||||
whether or not they are linked directly with the Library itself.
|
||||
|
||||
6. As an exception to the Sections above, you may also compile or
|
||||
link a "work that uses the Library" with the Library to produce a
|
||||
work containing portions of the Library, and distribute that work
|
||||
under terms of your choice, provided that the terms permit
|
||||
modification of the work for the customer's own use and reverse
|
||||
engineering for debugging such modifications.
|
||||
|
||||
You must give prominent notice with each copy of the work that the
|
||||
Library is used in it and that the Library and its use are covered by
|
||||
this License. You must supply a copy of this License. If the work
|
||||
during execution displays copyright notices, you must include the
|
||||
copyright notice for the Library among them, as well as a reference
|
||||
directing the user to the copy of this License. Also, you must do one
|
||||
of these things:
|
||||
|
||||
a) Accompany the work with the complete corresponding
|
||||
machine-readable source code for the Library including whatever
|
||||
changes were used in the work (which must be distributed under
|
||||
Sections 1 and 2 above); and, if the work is an executable linked
|
||||
with the Library, with the complete machine-readable "work that
|
||||
uses the Library", as object code and/or source code, so that the
|
||||
user can modify the Library and then relink to produce a modified
|
||||
executable containing the modified Library. (It is understood
|
||||
that the user who changes the contents of definitions files in the
|
||||
Library will not necessarily be able to recompile the application
|
||||
to use the modified definitions.)
|
||||
|
||||
b) Accompany the work with a written offer, valid for at
|
||||
least three years, to give the same user the materials
|
||||
specified in Subsection 6a, above, for a charge no more
|
||||
than the cost of performing this distribution.
|
||||
|
||||
c) If distribution of the work is made by offering access to copy
|
||||
from a designated place, offer equivalent access to copy the above
|
||||
specified materials from the same place.
|
||||
|
||||
d) Verify that the user has already received a copy of these
|
||||
materials or that you have already sent this user a copy.
|
||||
|
||||
For an executable, the required form of the "work that uses the
|
||||
Library" must include any data and utility programs needed for
|
||||
reproducing the executable from it. However, as a special exception,
|
||||
the source code distributed need not include anything that is normally
|
||||
distributed (in either source or binary form) with the major
|
||||
components (compiler, kernel, and so on) of the operating system on
|
||||
which the executable runs, unless that component itself accompanies
|
||||
the executable.
|
||||
|
||||
It may happen that this requirement contradicts the license
|
||||
restrictions of other proprietary libraries that do not normally
|
||||
accompany the operating system. Such a contradiction means you cannot
|
||||
use both them and the Library together in an executable that you
|
||||
distribute.
|
||||
|
||||
7. You may place library facilities that are a work based on the
|
||||
Library side-by-side in a single library together with other library
|
||||
facilities not covered by this License, and distribute such a combined
|
||||
library, provided that the separate distribution of the work based on
|
||||
the Library and of the other library facilities is otherwise
|
||||
permitted, and provided that you do these two things:
|
||||
|
||||
a) Accompany the combined library with a copy of the same work
|
||||
based on the Library, uncombined with any other library
|
||||
facilities. This must be distributed under the terms of the
|
||||
Sections above.
|
||||
|
||||
b) Give prominent notice with the combined library of the fact
|
||||
that part of it is a work based on the Library, and explaining
|
||||
where to find the accompanying uncombined form of the same work.
|
||||
|
||||
8. You may not copy, modify, sublicense, link with, or distribute
|
||||
the Library except as expressly provided under this License. Any
|
||||
attempt otherwise to copy, modify, sublicense, link with, or
|
||||
distribute the Library is void, and will automatically terminate your
|
||||
rights under this License. However, parties who have received copies,
|
||||
or rights, from you under this License will not have their licenses
|
||||
terminated so long as such parties remain in full compliance.
|
||||
|
||||
9. You are not required to accept this License, since you have not
|
||||
signed it. However, nothing else grants you permission to modify or
|
||||
distribute the Library or its derivative works. These actions are
|
||||
prohibited by law if you do not accept this License. Therefore, by
|
||||
modifying or distributing the Library (or any work based on the
|
||||
Library), you indicate your acceptance of this License to do so, and
|
||||
all its terms and conditions for copying, distributing or modifying
|
||||
the Library or works based on it.
|
||||
|
||||
10. Each time you redistribute the Library (or any work based on the
|
||||
Library), the recipient automatically receives a license from the
|
||||
original licensor to copy, distribute, link with or modify the Library
|
||||
subject to these terms and conditions. You may not impose any further
|
||||
restrictions on the recipients' exercise of the rights granted herein.
|
||||
You are not responsible for enforcing compliance by third parties to
|
||||
this License.
|
||||
|
||||
11. If, as a consequence of a court judgment or allegation of patent
|
||||
infringement or for any other reason (not limited to patent issues),
|
||||
conditions are imposed on you (whether by court order, agreement or
|
||||
otherwise) that contradict the conditions of this License, they do not
|
||||
excuse you from the conditions of this License. If you cannot
|
||||
distribute so as to satisfy simultaneously your obligations under this
|
||||
License and any other pertinent obligations, then as a consequence you
|
||||
may not distribute the Library at all. For example, if a patent
|
||||
license would not permit royalty-free redistribution of the Library by
|
||||
all those who receive copies directly or indirectly through you, then
|
||||
the only way you could satisfy both it and this License would be to
|
||||
refrain entirely from distribution of the Library.
|
||||
|
||||
If any portion of this section is held invalid or unenforceable under any
|
||||
particular circumstance, the balance of the section is intended to apply,
|
||||
and the section as a whole is intended to apply in other circumstances.
|
||||
|
||||
It is not the purpose of this section to induce you to infringe any
|
||||
patents or other property right claims or to contest validity of any
|
||||
such claims; this section has the sole purpose of protecting the
|
||||
integrity of the free software distribution system which is
|
||||
implemented by public license practices. Many people have made
|
||||
generous contributions to the wide range of software distributed
|
||||
through that system in reliance on consistent application of that
|
||||
system; it is up to the author/donor to decide if he or she is willing
|
||||
to distribute software through any other system and a licensee cannot
|
||||
impose that choice.
|
||||
|
||||
This section is intended to make thoroughly clear what is believed to
|
||||
be a consequence of the rest of this License.
|
||||
|
||||
12. If the distribution and/or use of the Library is restricted in
|
||||
certain countries either by patents or by copyrighted interfaces, the
|
||||
original copyright holder who places the Library under this License may add
|
||||
an explicit geographical distribution limitation excluding those countries,
|
||||
so that distribution is permitted only in or among countries not thus
|
||||
excluded. In such case, this License incorporates the limitation as if
|
||||
written in the body of this License.
|
||||
|
||||
13. The Free Software Foundation may publish revised and/or new
|
||||
versions of the Library General Public License from time to time.
|
||||
Such new versions will be similar in spirit to the present version,
|
||||
but may differ in detail to address new problems or concerns.
|
||||
|
||||
Each version is given a distinguishing version number. If the Library
|
||||
specifies a version number of this License which applies to it and
|
||||
"any later version", you have the option of following the terms and
|
||||
conditions either of that version or of any later version published by
|
||||
the Free Software Foundation. If the Library does not specify a
|
||||
license version number, you may choose any version ever published by
|
||||
the Free Software Foundation.
|
||||
|
||||
14. If you wish to incorporate parts of the Library into other free
|
||||
programs whose distribution conditions are incompatible with these,
|
||||
write to the author to ask for permission. For software which is
|
||||
copyrighted by the Free Software Foundation, write to the Free
|
||||
Software Foundation; we sometimes make exceptions for this. Our
|
||||
decision will be guided by the two goals of preserving the free status
|
||||
of all derivatives of our free software and of promoting the sharing
|
||||
and reuse of software generally.
|
||||
|
||||
NO WARRANTY
|
||||
|
||||
15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO
|
||||
WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW.
|
||||
EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR
|
||||
OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY
|
||||
KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE
|
||||
IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE
|
||||
LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME
|
||||
THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION.
|
||||
|
||||
16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN
|
||||
WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY
|
||||
AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU
|
||||
FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR
|
||||
CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE
|
||||
LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING
|
||||
RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A
|
||||
FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF
|
||||
SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH
|
||||
DAMAGES.
|
||||
|
||||
END OF TERMS AND CONDITIONS
|
||||
|
||||
How to Apply These Terms to Your New Libraries
|
||||
|
||||
If you develop a new library, and you want it to be of the greatest
|
||||
possible use to the public, we recommend making it free software that
|
||||
everyone can redistribute and change. You can do so by permitting
|
||||
redistribution under these terms (or, alternatively, under the terms of the
|
||||
ordinary General Public License).
|
||||
|
||||
To apply these terms, attach the following notices to the library. It is
|
||||
safest to attach them to the start of each source file to most effectively
|
||||
convey the exclusion of warranty; and each file should have at least the
|
||||
"copyright" line and a pointer to where the full notice is found.
|
||||
|
||||
<one line to give the library's name and a brief idea of what it does.>
|
||||
Copyright (C) <year> <name of author>
|
||||
|
||||
This library is free software; you can redistribute it and/or
|
||||
modify it under the terms of the GNU Library General Public
|
||||
License as published by the Free Software Foundation; either
|
||||
version 2 of the License, or (at your option) any later version.
|
||||
|
||||
This library is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||
Library General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU Library General Public
|
||||
License along with this library; if not, write to the Free
|
||||
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
|
||||
|
||||
Also add information on how to contact you by electronic and paper mail.
|
||||
|
||||
You should also get your employer (if you work as a programmer) or your
|
||||
school, if any, to sign a "copyright disclaimer" for the library, if
|
||||
necessary. Here is a sample; alter the names:
|
||||
|
||||
Yoyodyne, Inc., hereby disclaims all copyright interest in the
|
||||
library `Frob' (a library for tweaking knobs) written by James Random Hacker.
|
||||
|
||||
<signature of Ty Coon>, 1 April 1990
|
||||
Ty Coon, President of Vice
|
||||
|
||||
That's all there is to it!
|
||||
Some files were not shown because too many files have changed in this diff Show More
Reference in New Issue
Block a user