├── .gitattributes ├── .gitignore ├── README.md ├── SVGProjects.groupproj ├── examples ├── Embed.svg ├── InitialCoords.svg ├── Linear Fill 1.svg ├── Lines1.svg ├── PathA.svg ├── PolyLine.svg ├── Polygon.svg ├── Radial Fill.svg ├── Rectangle.svg ├── RoundRect.svg ├── Stroke Fill 1.svg ├── Transform1.svg ├── Transform2.svg ├── TransformMatrix.svg ├── TransformMatrix2.svg ├── TransformMatrix3.svg ├── TransformRotate.svg ├── TransformRotate2.svg ├── Use 1.svg ├── Use 2.svg ├── arcs.svg ├── butterfly.svg ├── circles.svg ├── coords-trans-01-b.svg ├── coords-units-03-b.svg ├── cowboy.svg ├── finland.svg ├── linecap.svg ├── lines2.svg ├── lion.svg ├── longhorn.svg ├── otaniemistreet.svg ├── paths.svg └── tiger.svg ├── fmx ├── BitmapCodecSVG.pas ├── FMXSVGImage.dpk ├── FMXSVGImage.dproj ├── FMXSVGViewer.dpr ├── FMXSVGViewer.dproj ├── FMXSVGViewer.res ├── FmxSVGViewerUnit.fmx └── FmxSVGViewerUnit.pas ├── gdip ├── GDIPKerning.pas ├── GDIPOBJ2.pas ├── GDIPPathText.pas └── GDIPUtils.pas ├── license ├── svg ├── SVG.pas ├── SVGColor.pas ├── SVGCommon.pas ├── SVGPackage.dpk ├── SVGPackage.dproj ├── SVGPackage.res ├── SVGPaint.pas ├── SVGParse.pas ├── SVGPath.pas ├── SVGProperties.pas ├── SVGStyle.pas └── SVGTypes.pas └── vcl ├── SvgViewer.dpr ├── SvgViewer.dproj ├── SvgViewer.res ├── SvgViewerUnit.dfm ├── SvgViewerUnit.pas └── svgimage ├── SVGImage.pas ├── SVGImageList.pas ├── SVGImagePackageD.dpk ├── SVGImagePackageD.dproj ├── SVGImagePackageD.res ├── SVGImagePackageR.dpk ├── SVGImagePackageR.dproj ├── SVGImagePackageR.res ├── SVGImageRegister.pas ├── SVGImgLstEditor.dfm ├── SVGImgLstEditor.pas └── SVGSpeedButton.pas /.gitattributes: -------------------------------------------------------------------------------- 1 | # Auto detect text files and perform LF normalization 2 | * text=auto -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # Uncomment these types if you want even more clean repository. But be careful. 2 | # It can make harm to an existing project source. Read explanations below. 3 | # 4 | # Resource files are binaries containing manifest, project icon and version info. 5 | # They can not be viewed as text or compared by diff-tools. Consider replacing them with .rc files. 6 | #*.res 7 | # 8 | # Type library file (binary). In old Delphi versions it should be stored. 9 | # Since Delphi 2009 it is produced from .ridl file and can safely be ignored. 10 | #*.tlb 11 | # 12 | # Diagram Portfolio file. Used by the diagram editor up to Delphi 7. 13 | # Uncomment this if you are not using diagrams or use newer Delphi version. 14 | #*.ddp 15 | # 16 | # Visual LiveBindings file. Added in Delphi XE2. 17 | # Uncomment this if you are not using LiveBindings Designer. 18 | #*.vlb 19 | # 20 | # Deployment Manager configuration file for your project. Added in Delphi XE2. 21 | # Uncomment this if it is not mobile development and you do not use remote debug feature. 22 | #*.deployproj 23 | # 24 | # C++ object files produced when C/C++ Output file generation is configured. 25 | # Uncomment this if you are not using external objects (zlib library for example). 26 | #*.obj 27 | # 28 | 29 | # Delphi compiler-generated binaries (safe to delete) 30 | *.exe 31 | *.dll 32 | *.bpl 33 | *.bpi 34 | *.dcp 35 | *.so 36 | *.apk 37 | *.drc 38 | *.map 39 | *.dres 40 | *.rsm 41 | *.tds 42 | *.dcu 43 | *.lib 44 | *.a 45 | *.o 46 | *.ocx 47 | 48 | # Delphi autogenerated files (duplicated info) 49 | *.cfg 50 | *.hpp 51 | *Resource.rc 52 | 53 | # Delphi local files (user-specific info) 54 | *.local 55 | *.identcache 56 | *.projdata 57 | *.tvsconfig 58 | *.dsk 59 | 60 | # Delphi history and backups 61 | __history/ 62 | __recovery/ 63 | *.~* 64 | 65 | # Castalia statistics file (since XE7 Castalia is distributed with Delphi) 66 | *.stat 67 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # DelphiSVG 2 | 3 | Delphi SVG library originally by Martin Walter 4 | 5 | https://development.mwcs.de/svgimage.html 6 | 7 | 8 | -------------------------------------------------------------------------------- /SVGProjects.groupproj: -------------------------------------------------------------------------------- 1 |  2 | 3 | {740F3D4F-3334-44F6-BC92-84B3F3A6AD9E} 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | Default.Personality.12 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 43 | 44 | 45 | 46 | 47 | 48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57 | 58 | 59 | 60 | 61 | 62 | 63 | 64 | 65 | 66 | 67 | 68 | 69 | 70 | 71 | 72 | 73 | 74 | 75 | 76 | 77 | 78 | 79 | 80 | 81 | 82 | 83 | 84 | 85 | 86 | 87 | 88 | 89 | 90 | 91 | 92 | 93 | 94 | 95 | 96 | 97 | -------------------------------------------------------------------------------- /examples/Embed.svg: -------------------------------------------------------------------------------- 1 | 2 | 3 | 5 | 6 | ]> 7 | 8 | 9 | 10 | -------------------------------------------------------------------------------- /examples/InitialCoords.svg: -------------------------------------------------------------------------------- 1 | 2 | 4 | 6 | Example InitialCoords - SVG's initial coordinate system 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | (0,0) 20 | (200,0) 21 | (0,200) 22 | 23 | 24 | 27 | 28 | 29 | -------------------------------------------------------------------------------- /examples/Linear Fill 1.svg: -------------------------------------------------------------------------------- 1 |  2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | -------------------------------------------------------------------------------- /examples/Lines1.svg: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | -------------------------------------------------------------------------------- /examples/PathA.svg: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 16 | 17 | -------------------------------------------------------------------------------- /examples/PolyLine.svg: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 12 | -------------------------------------------------------------------------------- /examples/Polygon.svg: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 8 | 11 | -------------------------------------------------------------------------------- /examples/Radial Fill.svg: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | -------------------------------------------------------------------------------- /examples/Rectangle.svg: -------------------------------------------------------------------------------- 1 |  2 | 3 | 4 | 5 | 6 | 7 | -------------------------------------------------------------------------------- /examples/RoundRect.svg: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | -------------------------------------------------------------------------------- /examples/Stroke Fill 1.svg: -------------------------------------------------------------------------------- 1 |  2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | -------------------------------------------------------------------------------- /examples/Transform1.svg: -------------------------------------------------------------------------------- 1 | 3 | 4 | 8 | 9 | Hello World 11 | -------------------------------------------------------------------------------- /examples/Transform2.svg: -------------------------------------------------------------------------------- 1 | 3 | 4 | 6 | 7 | 10 | -------------------------------------------------------------------------------- /examples/TransformMatrix.svg: -------------------------------------------------------------------------------- 1 | 3 | 4 | 6 | 7 | 11 | -------------------------------------------------------------------------------- /examples/TransformMatrix2.svg: -------------------------------------------------------------------------------- 1 | 3 | 4 | 6 | 7 | 11 | Gulf Of Botnia 12 | -------------------------------------------------------------------------------- /examples/TransformMatrix3.svg: -------------------------------------------------------------------------------- 1 | 3 | 4 | Gulf Of Botnia 5 | -------------------------------------------------------------------------------- /examples/TransformRotate.svg: -------------------------------------------------------------------------------- 1 | 3 | 4 | 7 | 8 | 12 | -------------------------------------------------------------------------------- /examples/TransformRotate2.svg: -------------------------------------------------------------------------------- 1 | 3 | 4 | 7 | 8 | 12 | Gulf Of Botnia 13 | -------------------------------------------------------------------------------- /examples/Use 1.svg: -------------------------------------------------------------------------------- 1 | 2 | 4 | ]> 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | -------------------------------------------------------------------------------- /examples/Use 2.svg: -------------------------------------------------------------------------------- 1 | 2 | 4 | ]> 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | -------------------------------------------------------------------------------- /examples/arcs.svg: -------------------------------------------------------------------------------- 1 | 2 | 4 | 6 | Example arcs01 - arc commands in path data 7 | Picture of a pie chart with two pie wedges and 8 | a picture of a line with arc blips 9 | 11 | 12 | 14 | 16 | 17 | 23 | 24 | -------------------------------------------------------------------------------- /examples/circles.svg: -------------------------------------------------------------------------------- 1 | 2 | 4 | 5 | 8 | 9 | 10 | 11 | 12 | 13 | -------------------------------------------------------------------------------- /examples/coords-trans-01-b.svg: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | This test verifies the implementation of transforms. It tests elementary transforms 38 | and transform nesting. 39 | Note that for layout purposes, this test uses nesting of translation with the elementary transforms. 40 | 41 | 42 | The rendered picture should match the reference image exactly except for variations in the labeling text. 43 | 44 | 45 | The test uses the rect element, the fill color (solid primary colors) and transforms. 46 | 47 | 48 | 49 | 50 | coords-trans-01-b 51 | Validates elementary transforms and transformation nesting 52 | 53 | 54 | 55 | 56 | 57 | 58 | 59 | 60 | 61 | 62 | 63 | 64 | 65 | 66 | 67 | 68 | 69 | 70 | 71 | 72 | 73 | 74 | 75 | 76 | 77 | 78 | 79 | 80 | 81 | 82 | 83 | 84 | 85 | 86 | 87 | 88 | 89 | 90 | 91 | 92 | 93 | 94 | 95 | 96 | 97 | 98 | 99 | 100 | 101 | 102 | 103 | 104 | 105 | 106 | 107 | 108 | 109 | 110 | 111 | 112 | 113 | 114 | 115 | 116 | 117 | 118 | 119 | 120 | 121 | 122 | 123 | 124 | 125 | 126 | 127 | 128 | 129 | 130 | 131 | 132 | 133 | 134 | 135 | 136 | 137 | 138 | 139 | 140 | 141 | 142 | 143 | 144 | 145 | 146 | 147 | 148 | 149 | 150 | 151 | 152 | 153 | 154 | 155 | 156 | 157 | 158 | 159 | 160 | 161 | 162 | 163 | 164 | 165 | 166 | 167 | 168 | 169 | 170 | 171 | 172 | 173 | 174 | 175 | 176 | translate (50, 50) 177 | 178 | 179 | 180 | 181 | rotate(-90) 182 | 183 | 184 | 185 | 186 | skew x (45) 187 | 188 | 189 | 190 | 191 | skew y (45) 192 | 193 | 194 | 195 | 196 | scale (2) 197 | 198 | 199 | 200 | 201 | 202 | 203 | 204 | 205 | 206 | 207 | 208 | 209 | 210 | 211 | 212 | 213 | 214 | 215 | 216 | 217 | 218 | 219 | 220 | 221 | 222 | 223 | scale(25, 95) and translate(2, 2) 224 | 225 | 226 | 227 | 228 | scale(25, 95) then translate(2, 2) 229 | 230 | 231 | 232 | 233 | 234 | 235 | 236 | 237 | $Revision: 1.5 $ 238 | 239 | 240 | 241 | -------------------------------------------------------------------------------- /examples/coords-units-03-b.svg: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | coords-units-03-b 39 | Validates simple initial viewport size and basic units handling. 40 | 41 | 42 | 43 | 44 | 45 | 46 | 47 | 48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57 | Initial viewport and CSS units test 58 | 59 | 60 | 61 | 62 | 63 | 200 64 | User space units (no specifier) 65 | 66 | 67 | 68 | 69 | 70 | 71 | 72 | 200 px 73 | Pixels (px) 74 | 75 | 76 | 77 | 20 em = 200 px (font-size=10px) 78 | Relative to font size (em) 79 | 80 | 81 | 82 | 83 | 84 | 40 ex 85 | Relative to font x-height (ex) 86 | 87 | 88 | 89 | 90 | 91 | 92 | 93 | 41.67% = 200 px 94 | Percentage (%) 95 | 96 | 97 | 98 | 99 | 100 | 1 in 101 | Inches (in) 102 | 103 | 104 | 105 | 2.54 cm = 1 in 106 | Centimeters (cm) 107 | 108 | 109 | 110 | 25.4 mm = 1 in 111 | Millimeters (mm) 112 | 113 | 114 | 115 | 72pt = 1 in 116 | Points (pt) 117 | 118 | 119 | 120 | 6pc = 1 in 121 | Picas (pc) 122 | 123 | 124 | 125 | 126 | $Revision: 1.4 $ 127 | 128 | 129 | 130 | -------------------------------------------------------------------------------- /examples/linecap.svg: -------------------------------------------------------------------------------- 1 | 2 | 3 | 5 | 6 | ]> 7 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 'butt' cap 17 | 18 | 19 | 20 | 21 | 22 | 23 | 'round' cap 24 | 25 | 26 | 27 | 28 | 29 | 30 | 'square' cap 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 'miter' join 40 | 41 | 42 | 43 | 44 | 45 | 'round' join 46 | 47 | 48 | 49 | 50 | 51 | 'bevel' join 52 | 53 | 54 | 55 | 56 | 57 | 58 | 59 | 60 | 61 | 62 | 63 | 64 | 65 | 66 | 67 | 68 | 69 | 70 | 71 | 72 | 73 | -------------------------------------------------------------------------------- /examples/lines2.svg: -------------------------------------------------------------------------------- 1 | 2 | 3 | 5 | 6 | ]> 7 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | -------------------------------------------------------------------------------- /examples/paths.svg: -------------------------------------------------------------------------------- 1 | 2 | 4 | 8 | 9 | 10 | 11 | Absolute Cubic Beziers 12 | <path d="M 50,150 C 150,10 150,290 250,150 z" 13 | style="stroke:red; stroke-width:5; fill:yellow;"/> 14 | 15 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | Relative Cubic Beziers 27 | <path d="M 50,150 c 100,-140 100,140 200,0 z" 28 | style="stroke:red; stroke-width:5; fill:yellow;"/> 29 | 30 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 42 | 43 | 44 | 45 | 46 | 47 | 48 | 49 | 50 | 51 | Absolute Shorthand/Smooth Curveto 52 | <path d="M 50,150 C 50,75 150,75 150,150 S 250,225 250,150 z" 53 | style="stroke:red; stroke-width:5; fill:yellow;"/> 54 | 55 | 56 | 57 | 58 | 60 | 61 | 62 | 63 | 64 | 65 | 66 | 67 | 68 | 69 | Relative Shorthand/Smooth Curveto 70 | <path d="M 50,150 c 0,-75 100,-75 100,0 s 100,75 100,0 z" 71 | style="stroke:red; stroke-width:5; fill:yellow;"/> 72 | 73 | 74 | -------------------------------------------------------------------------------- /fmx/BitmapCodecSVG.pas: -------------------------------------------------------------------------------- 1 | // This unit requires at least Delphi 10.3.2 to work 2 | unit BitmapCodecSVG; 3 | 4 | interface 5 | 6 | implementation 7 | 8 | uses 9 | Winapi.Windows, Winapi.GDIPAPI, Winapi.GDIPOBJ, 10 | System.Types, System.SysUtils, System.Classes, 11 | FMX.Types, FMX.Graphics, FMX.Surfaces, 12 | SVGTypes, SVG; 13 | 14 | type 15 | TBitmapCodecSVG = class(TCustomBitmapCodec) 16 | strict private 17 | function CopyToSurface(const ASVG: TSVG; const Bitmap: TBitmapSurface): Boolean; 18 | class procedure InitGDIPlus; 19 | public 20 | class constructor Create; 21 | class function GetImageSize(const AFileName: string): TPointF; override; 22 | class function IsValid(const AStream: TStream): Boolean; override; 23 | function LoadFromFile(const AFileName: string; const Bitmap: TBitmapSurface; 24 | const MaxSizeLimit: Cardinal): Boolean; override; 25 | function SaveToFile(const AFileName: string; const Bitmap: TBitmapSurface; 26 | const SaveParams: PBitmapCodecSaveParams = nil): Boolean; override; 27 | function LoadThumbnailFromFile(const AFileName: string; const AFitWidth, AFitHeight: Single; 28 | const UseEmbedded: Boolean; const Bitmap: TBitmapSurface): Boolean; override; 29 | function LoadFromStream(const AStream: TStream; const Bitmap: TBitmapSurface; 30 | const MaxSizeLimit: Cardinal): Boolean; override; 31 | function SaveToStream(const AStream: TStream; const Bitmap: TBitmapSurface; const Extension: string; 32 | const SaveParams: PBitmapCodecSaveParams = nil): Boolean; override; 33 | end; 34 | 35 | const 36 | SSVGImageExtension = '.svg'; // do not localize 37 | SVSVG = 'SVG files'; 38 | 39 | procedure DebugGDIPlus(level: DebugEventLevel; message: PChar); stdcall; 40 | begin 41 | OutputDebugString(PChar('DebugGDIPlus ' + message)); 42 | end; 43 | 44 | 45 | class procedure TBitmapCodecSVG.InitGDIPlus; 46 | var 47 | Status: TStatus; 48 | begin 49 | // Initialize StartupInput structure 50 | StartupInput.DebugEventCallback := DebugGDIPlus; 51 | StartupInput.SuppressBackgroundThread := False; 52 | StartupInput.SuppressExternalCodecs := False; 53 | StartupInput.GdiplusVersion := 1; 54 | 55 | Status := GdiplusStartup(gdiplusToken, @StartupInput, nil); 56 | OutputDebugString(PChar('InitGDIPlus.Status=' + IntToStr(Ord(Status)))); 57 | end; 58 | 59 | class constructor TBitmapCodecSVG.Create; 60 | begin 61 | end; 62 | 63 | class function TBitmapCodecSVG.GetImageSize(const AFileName: string): TPointF; 64 | var 65 | SVG: TSVG; 66 | begin 67 | SVG := TSVG.Create; 68 | try 69 | try 70 | SVG.LoadFromFile(AFileName); 71 | Result := TPointF.Create(SVG.Width, SVG.Height); 72 | finally 73 | SVG.Free; 74 | end; 75 | except 76 | Result := TPointF.Create(0, 0); 77 | end; 78 | end; 79 | 80 | class function TBitmapCodecSVG.IsValid(const AStream: TStream): Boolean; 81 | var 82 | SVG: TSVG; 83 | begin 84 | OutputDebugString('IsValid'); 85 | SVG := TSVG.Create; 86 | try 87 | try 88 | SVG.LoadFromStream(AStream); 89 | Result := (SVG.Width > 0) and (SVG.Height > 0); 90 | OutputDebugString(PChar(BoolToStr(Result, True))); 91 | finally 92 | SVG.Free; 93 | end; 94 | except 95 | Result := False; 96 | end; 97 | end; 98 | 99 | function TBitmapCodecSVG.LoadFromFile(const AFileName: string; const Bitmap: TBitmapSurface; 100 | const MaxSizeLimit: Cardinal): Boolean; 101 | var 102 | Stream: TFileStream; 103 | begin 104 | OutputDebugString('LoadFromFile'); 105 | Stream := TFileStream.Create(AFileName, fmOpenRead); 106 | try 107 | Result := LoadFromStream(Stream, Bitmap, MaxSizeLimit); 108 | finally 109 | Stream.Free; 110 | end; 111 | end; 112 | 113 | function TBitmapCodecSVG.SaveToFile(const AFileName: string; const Bitmap: TBitmapSurface; 114 | const SaveParams: PBitmapCodecSaveParams = nil): Boolean; 115 | begin 116 | Result := False; 117 | end; 118 | 119 | function TBitmapCodecSVG.LoadThumbnailFromFile(const AFileName: string; 120 | const AFitWidth, AFitHeight: Single; const UseEmbedded: Boolean; 121 | const Bitmap: TBitmapSurface): Boolean; 122 | begin 123 | OutputDebugString('LoadThumbnailFromFile'); 124 | Result := False; 125 | end; 126 | 127 | function TBitmapCodecSVG.CopyToSurface(const ASVG: TSVG; const Bitmap: TBitmapSurface): Boolean; 128 | var 129 | GPGraphics: TGPGraphics; 130 | GPBitmap: TGPBitmap; 131 | GPRectF: TGPRectF; 132 | RectArray: TRectarray; 133 | GPRect: TGPRect; 134 | GPBitmapData: Winapi.GDIPAPI.TBitmapData; 135 | Source: PByte; 136 | Dest: PByte; 137 | Y: Integer; 138 | Status: TStatus; 139 | IntWidth: Integer; 140 | IntHeight: Integer; 141 | begin 142 | Result := False; 143 | IntWidth := Trunc(ASVG.Width); 144 | IntHeight := Trunc(ASVG.Height); 145 | OutputDebugString(PChar('CopyToSurface ' + IntToStr(IntWidth) + ' ' + IntToStr(IntHeight))); 146 | GPBitmap := TGPBitmap.Create(IntWidth, IntHeight); 147 | Status := GPBitmap.GetLastStatus; 148 | if Status <> TStatus.Ok then 149 | begin 150 | OutputDebugString(PChar('GPBitmap ' + IntToStr(Ord(Status)))); 151 | Exit; 152 | end; 153 | 154 | GPGraphics := TGPGraphics.Create(GPBitmap); 155 | try 156 | Status := GPGraphics.SetSmoothingMode(SmoothingModeAntiAlias); 157 | OutputDebugString(PChar('SetSmoothingMode ' + IntToStr(Ord(Status)))); 158 | 159 | GPRectF.X := 0; 160 | GPRectF.Y := 0; 161 | GPRectF.Width := ASVG.Width; 162 | GPRectF.Height := ASVG.Height; 163 | 164 | RectArray := TRectArray.Create(TRect.Create(0, 0, Trunc(ASVG.Width), Trunc(ASVG.Height))); 165 | ASVG.PaintTo(GPGraphics, GPRectF, @RectArray, 1); 166 | 167 | GPRect.X := 0; 168 | GPRect.Y := 0; 169 | GPRect.Width := GPBitmap.GetWidth; 170 | GPRect.Height := GPBitmap.GetHeight; 171 | 172 | OutputDebugString(PChar('CopyToSurface.GPRectWidth '+ IntToStr(GPRect.Width))); 173 | Status := GPBitmap.LockBits(GPRect, ImageLockModeRead, PixelFormat32bppPARGB, GPBitmapData); 174 | if Status = TStatus.Ok then 175 | begin 176 | Bitmap.SetSize(Trunc(ASVG.Width), Trunc(ASVG.Height), TPixelFormat.BGRA); 177 | Source := GPBitmapData.Scan0; 178 | Dest := Bitmap.Bits; 179 | for Y := 0 to GPBitmapData.Height - 1 do 180 | begin 181 | Move(Source^, Dest^, GPBitmapData.Stride); 182 | Source := Source + GPBitmapData.Stride; 183 | Dest := Dest + Bitmap.Pitch; 184 | end; 185 | 186 | GPBitmap.UnlockBits(GPBitmapData); 187 | Result := True; 188 | end 189 | else 190 | begin 191 | OutputDebugString(PChar('CopyToSurface.Lockbits error ' + IntToStr(Ord(Status)))); 192 | end; 193 | finally 194 | GPGraphics.Free; 195 | GPBitmap.Free; 196 | end; 197 | end; 198 | 199 | function TBitmapCodecSVG.LoadFromStream(const AStream: TStream; const Bitmap: TBitmapSurface; 200 | const MaxSizeLimit: Cardinal): Boolean; 201 | var 202 | SVG: TSVG; 203 | begin 204 | InitGDIPlus; 205 | OutputDebugString('LoadFromStream'); 206 | try 207 | SVG := TSVG.Create; 208 | try 209 | SVG.LoadFromStream(AStream); 210 | Result := CopyToSurface(SVG, Bitmap); 211 | finally 212 | SVG.Free; 213 | end; 214 | except 215 | on E: Exception do 216 | begin 217 | OutputDebugString(PChar('LoadFromStream.E ' + E.Message)); 218 | Result := False; 219 | end; 220 | end; 221 | end; 222 | 223 | function TBitmapCodecSVG.SaveToStream(const AStream: TStream; const Bitmap: TBitmapSurface; 224 | const Extension: string; const SaveParams: PBitmapCodecSaveParams = nil): Boolean; 225 | begin 226 | Result := False; 227 | end; 228 | 229 | initialization 230 | TBitmapCodecManager.RegisterBitmapCodecClass(SSVGImageExtension, SVSVG, True, 231 | TBitmapCodecSVG); 232 | finalization 233 | TBitmapCodecManager.UnregisterBitmapCodecClass(SSVGImageExtension); 234 | end. 235 | -------------------------------------------------------------------------------- /fmx/FMXSVGImage.dpk: -------------------------------------------------------------------------------- 1 | package FMXSVGImage; 2 | 3 | {$R *.res} 4 | {$IFDEF IMPLICITBUILDING This IFDEF should not be used by users} 5 | {$ALIGN 8} 6 | {$ASSERTIONS ON} 7 | {$BOOLEVAL OFF} 8 | {$DEBUGINFO OFF} 9 | {$EXTENDEDSYNTAX ON} 10 | {$IMPORTEDDATA ON} 11 | {$IOCHECKS ON} 12 | {$LOCALSYMBOLS ON} 13 | {$LONGSTRINGS ON} 14 | {$OPENSTRINGS ON} 15 | {$OPTIMIZATION OFF} 16 | {$OVERFLOWCHECKS OFF} 17 | {$RANGECHECKS OFF} 18 | {$REFERENCEINFO ON} 19 | {$SAFEDIVIDE OFF} 20 | {$STACKFRAMES ON} 21 | {$TYPEDADDRESS OFF} 22 | {$VARSTRINGCHECKS ON} 23 | {$WRITEABLECONST OFF} 24 | {$MINENUMSIZE 1} 25 | {$IMAGEBASE $400000} 26 | {$DEFINE DEBUG} 27 | {$ENDIF IMPLICITBUILDING} 28 | {$IMPLICITBUILD ON} 29 | 30 | requires 31 | rtl, 32 | xmlrtl, 33 | SVGPackage, 34 | fmx; 35 | 36 | contains 37 | BitmapCodecSVG in 'BitmapCodecSVG.pas'; 38 | 39 | end. 40 | -------------------------------------------------------------------------------- /fmx/FMXSVGViewer.dpr: -------------------------------------------------------------------------------- 1 | program FMXSVGViewer; 2 | 3 | uses 4 | System.StartUpCopy, 5 | FMX.Forms, 6 | FmxSVGViewerUnit in 'FmxSVGViewerUnit.pas' {Form2}, 7 | BitmapCodecSVG in 'BitmapCodecSVG.pas'; 8 | 9 | {$R *.res} 10 | 11 | begin 12 | Application.Initialize; 13 | Application.CreateForm(TForm2, Form2); 14 | Application.Run; 15 | end. 16 | -------------------------------------------------------------------------------- /fmx/FMXSVGViewer.res: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ekot1/DelphiSVG/0c2fc478d221a914c8ca1a15f0e65e282396000a/fmx/FMXSVGViewer.res -------------------------------------------------------------------------------- /fmx/FmxSVGViewerUnit.fmx: -------------------------------------------------------------------------------- 1 | object Form2: TForm2 2 | Left = 0 3 | Top = 0 4 | Caption = 'FmxSVGViewer' 5 | ClientHeight = 480 6 | ClientWidth = 849 7 | FormFactor.Width = 320 8 | FormFactor.Height = 480 9 | FormFactor.Devices = [Desktop] 10 | OnCreate = FormCreate 11 | OnDestroy = FormDestroy 12 | DesignerMasterStyle = 0 13 | object PaintBox1: TPaintBox 14 | Align = Client 15 | Size.Width = 729.000000000000000000 16 | Size.Height = 480.000000000000000000 17 | Size.PlatformDefault = False 18 | OnPaint = PaintBox1Paint 19 | end 20 | object Panel1: TPanel 21 | Align = Right 22 | Position.X = 729.000000000000000000 23 | Size.Width = 120.000000000000000000 24 | Size.Height = 480.000000000000000000 25 | Size.PlatformDefault = False 26 | TabOrder = 1 27 | object Panel2: TPanel 28 | Align = Top 29 | Size.Width = 120.000000000000000000 30 | Size.Height = 33.000000000000000000 31 | Size.PlatformDefault = False 32 | TabOrder = 0 33 | object Button1: TButton 34 | Position.X = 24.000000000000000000 35 | Position.Y = 3.000000000000000000 36 | TabOrder = 0 37 | Text = 'Open...' 38 | OnClick = Button1Click 39 | end 40 | end 41 | object ListBox1: TListBox 42 | Align = Client 43 | Size.Width = 120.000000000000000000 44 | Size.Height = 447.000000000000000000 45 | Size.PlatformDefault = False 46 | TabOrder = 1 47 | DisableFocusEffect = True 48 | DefaultItemStyles.ItemStyle = '' 49 | DefaultItemStyles.GroupHeaderStyle = '' 50 | DefaultItemStyles.GroupFooterStyle = '' 51 | OnChange = ListBox1Change 52 | Viewport.Width = 116.000000000000000000 53 | Viewport.Height = 443.000000000000000000 54 | end 55 | end 56 | object OpenDialog1: TOpenDialog 57 | DefaultExt = 'svg' 58 | Filter = 'SVG|*.svg' 59 | Left = 632 60 | Top = 64 61 | end 62 | end 63 | -------------------------------------------------------------------------------- /fmx/FmxSVGViewerUnit.pas: -------------------------------------------------------------------------------- 1 | unit FmxSVGViewerUnit; 2 | 3 | interface 4 | 5 | uses 6 | System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants, 7 | FMX.Types, FMX.Controls, FMX.Forms, FMX.Graphics, FMX.Dialogs, FMX.Controls.Presentation, 8 | FMX.StdCtrls, FMX.Objects, FMX.Layouts, FMX.ListBox, 9 | SVG; 10 | 11 | type 12 | TForm2 = class(TForm) 13 | PaintBox1: TPaintBox; 14 | Panel1: TPanel; 15 | Panel2: TPanel; 16 | ListBox1: TListBox; 17 | Button1: TButton; 18 | OpenDialog1: TOpenDialog; 19 | procedure PaintBox1Paint(Sender: TObject; Canvas: TCanvas); 20 | procedure FormCreate(Sender: TObject); 21 | procedure FormDestroy(Sender: TObject); 22 | procedure ListBox1Change(Sender: TObject); 23 | procedure Button1Click(Sender: TObject); 24 | strict private 25 | { Private declarations } 26 | FSVG: TSVG; 27 | public 28 | { Public declarations } 29 | end; 30 | 31 | var 32 | Form2: TForm2; 33 | 34 | implementation 35 | 36 | uses System.IOUtils, Winapi.GDIPOBJ, Winapi.GDIPUTIL, Winapi.GDIPAPI, SVGTypes; 37 | 38 | {$R *.fmx} 39 | const 40 | CPath = '..\..\..\examples\'; 41 | 42 | procedure TForm2.Button1Click(Sender: TObject); 43 | begin 44 | if OpenDialog1.Execute then 45 | begin 46 | FSVG.LoadFromFile(OpenDialog1.FileName); 47 | end; 48 | end; 49 | 50 | procedure TForm2.FormCreate(Sender: TObject); 51 | var 52 | Files: TStringDynArray; 53 | FileName: string; 54 | F: TArray; 55 | begin 56 | FSVG := TSVG.Create; 57 | 58 | Files := TDirectory.GetFiles(CPath, '*.svg'); 59 | for FileName in Files do 60 | begin 61 | F := F + [ExtractFileName(FileName)]; 62 | end; 63 | ListBox1.Items.AddStrings(F); 64 | end; 65 | 66 | procedure TForm2.FormDestroy(Sender: TObject); 67 | begin 68 | FSVG.Free; 69 | end; 70 | 71 | procedure TForm2.ListBox1Change(Sender: TObject); 72 | begin 73 | FSVG.LoadFromFile(TPath.Combine(CPath, ListBox1.Selected.Text)); 74 | PaintBox1.Repaint; 75 | end; 76 | 77 | procedure PaintToCanvas(const ASVG: TSVG; Canvas: TCanvas); 78 | var 79 | GPGraphics: TGPGraphics; 80 | GPBitmap: TGPBitmap; 81 | GPRectF: TGPRectF; 82 | RectArray: TRectarray; 83 | GPRect: TGPRect; 84 | GPBitmapData: Winapi.GDIPAPI.TBitmapData; 85 | BitmapData: FMX.Graphics.TBitmapData; 86 | Bitmap: TBitmap; 87 | Source: PByte; 88 | Dest: PByte; 89 | Y: Integer; 90 | begin 91 | GPBitmap := TGPBitmap.Create(Canvas.Width, Canvas.Height); 92 | GPGraphics := TGPGraphics.Create(GPBitmap); 93 | try 94 | GPGraphics.SetSmoothingMode(SmoothingModeAntiAlias); 95 | GPRectF.X := 0; 96 | GPRectF.Y := 0; 97 | GPRectF.Width := ASVG.Width; 98 | GPRectF.Height := ASVG.Height; 99 | 100 | RectArray := TRectArray.Create(TRect.Create(0, 0, Canvas.Width, Canvas.Height)); 101 | ASVG.PaintTo(GPGraphics, GPRectF, @RectArray, 1); 102 | 103 | GPRect.X := 0; 104 | GPRect.Y := 0; 105 | GPRect.Width := GPBitmap.GetWidth; 106 | GPRect.Height := GPBitmap.GetHeight; 107 | 108 | GPBitmap.LockBits(GPRect, ImageLockModeRead, PixelFormat32bppPARGB, GPBitmapData); 109 | 110 | Bitmap := TBitmap.Create(GPRect.Width, GPRect.Height); 111 | try 112 | Bitmap.Map(TMapAccess.Write, BitmapData); 113 | 114 | Source := GPBitmapData.Scan0; 115 | Dest := BitmapData.Data; 116 | for Y := 0 to GPBitmapData.Height - 1 do 117 | begin 118 | Move(Source^, Dest^, GPBitmapData.Stride); 119 | Source := Source + GPBitmapData.Stride; 120 | Dest := Dest + BitmapData.Pitch; 121 | end; 122 | 123 | Bitmap.Unmap(BitmapData); 124 | Canvas.DrawBitmap(Bitmap, TRectF.Create(0, 0, Canvas.Width, Canvas.Height), 125 | TRectF.Create(0, 0, Canvas.Width, Canvas.Height), 100); 126 | finally 127 | Bitmap.Free; 128 | end; 129 | 130 | GPBitmap.UnlockBits(GPBitmapData); 131 | finally 132 | GPGraphics.Free; 133 | GPBitmap.Free; 134 | end; 135 | end; 136 | 137 | procedure TForm2.PaintBox1Paint(Sender: TObject; Canvas: TCanvas); 138 | begin 139 | PaintToCanvas(FSVG, Canvas); 140 | end; 141 | 142 | end. 143 | -------------------------------------------------------------------------------- /gdip/GDIPOBJ2.pas: -------------------------------------------------------------------------------- 1 | { *****************************************************************} 2 | { Added Support for RoundRect (GraphicsPath + TGPGraphics) } 3 | { } 4 | { date : 05-11-2006 } 5 | { } 6 | { email : martin.walter@winningcubed.de } 7 | { } 8 | { *****************************************************************} 9 | unit GDIPOBJ2; 10 | 11 | interface 12 | 13 | uses 14 | Winapi.GDIPAPI, Winapi.GDIPOBJ; 15 | 16 | type 17 | TGPGraphicsPath2 = class(TGPGraphicsPath) 18 | public 19 | function AddRoundRect(Rect: TGPRectF; RX, RY: Single): TStatus; overload; 20 | function AddRoundRect(X, Y, Width, Height, RX, RY: Single): TStatus; overload; 21 | function Clone: TGPGraphicsPath2; 22 | end; 23 | 24 | implementation 25 | 26 | { TGPGraphicsPath2 } 27 | 28 | function TGPGraphicsPath2.AddRoundRect(Rect: TGPRectF; RX, RY: Single): TStatus; 29 | begin 30 | Result := AddRoundRect(Rect.X, Rect.Y, Rect.Width, Rect.Height, RX, RY); 31 | end; 32 | 33 | function TGPGraphicsPath2.AddRoundRect(X, Y, Width, Height, RX, RY: Single) : TStatus; 34 | begin 35 | Result := AddLine(X + RX, Y, X + Width - RX, Y); 36 | if Result <> OK then 37 | Exit; 38 | Result := AddArc(X + Width - 2 * RX, Y, 2 * RX, 2 * RY, 270, 90); 39 | if Result <> OK then 40 | Exit; 41 | 42 | Result := AddLine(X + Width, Y + RY,X + Width, Y + Height - RY); 43 | if Result <> OK then 44 | Exit; 45 | Result := AddArc(X + Width - 2 * RX, Y + Height - 2 * RY, 2 * RX, 2 * RY, 0, 90); 46 | if Result <> OK then 47 | Exit; 48 | 49 | Result := AddLine(X + Width - RX, Y + Height, X + RX, Y + Height); 50 | if Result <> OK then 51 | Exit; 52 | Result := AddArc(X, Y + Height - 2 * RY, 2 * RX, 2 * RY, 90, 90); 53 | if Result <> OK then 54 | Exit; 55 | 56 | Result := AddLine(X, Y + Height - RY, X, Y + RY); 57 | if Result <> OK then 58 | Exit; 59 | Result := AddArc(X, Y, 2 * RX, 2 * RY, 180, 90); 60 | if Result <> OK then 61 | Exit; 62 | Result := CloseFigure; 63 | end; 64 | 65 | function TGPGraphicsPath2.Clone: TGPGraphicsPath2; 66 | var 67 | ClonePath: GpPath; 68 | begin 69 | Clonepath := nil; 70 | SetStatus(GdipClonePath(nativePath, Clonepath)); 71 | result := TGPGraphicsPath2.Create(ClonePath); 72 | end; 73 | 74 | end. 75 | -------------------------------------------------------------------------------- /gdip/GDIPPathText.pas: -------------------------------------------------------------------------------- 1 | {******************************************************************} 2 | { GDIPPathText } 3 | { } 4 | { home page : http://www.mwcs.de } 5 | { email : martin.walter@mwcs.de } 6 | { } 7 | { date : 30-11-2007 } 8 | { } 9 | { version : 1.0 } 10 | { } 11 | { Use of this file is permitted for commercial and non-commercial } 12 | { use, as long as the author is credited. } 13 | { This file (c) 2007 Martin Walter } 14 | { } 15 | { This Software is distributed on an "AS IS" basis, WITHOUT } 16 | { WARRANTY OF ANY KIND, either express or implied. } 17 | { } 18 | { *****************************************************************} 19 | 20 | unit GDIPPathText; 21 | 22 | interface 23 | 24 | uses 25 | Winapi.GDIPAPI, Winapi.GDIPOBJ, GDIPKerning; 26 | 27 | type 28 | TPathPosition = Single; 29 | 30 | TGPPathText = class(TObject) 31 | strict private 32 | FRotation: Single; 33 | FGuidePath: TGPGraphicsPath; 34 | 35 | FFamily: TGPFontFamily; 36 | FStyle: Integer; 37 | FSize: Single; 38 | FFormat: TGPStringFormat; 39 | FDistanceFactor: Single; 40 | FKerningFactor: Single; 41 | FAdditionalMatrix: TGPMatrix; 42 | 43 | function AddGlyphToPath(const Path: TGPGraphicsPath; const Char: WideChar; 44 | const Family: TGPFontFamily; const Style: Integer; const Size: Single; 45 | const Origin: TGPPointF; const Format: TGPStringFormat): TStatus; 46 | 47 | function AddCharacter(const Current, Next: WideChar; 48 | const Path: TGPGraphicsPath; const Position: TPathPosition): TPathPosition; 49 | 50 | function GetPathPoint(const Position: TPathPosition): TGPPointF; 51 | function GetPathPointLength(const Position: TPathPosition): Single; 52 | function GetPathPosition(Indent: Single): TPathPosition; 53 | function FindRightPosition(CenterPos: TPathPosition; 54 | const Radius: Single): TPathPosition; 55 | protected 56 | public 57 | constructor Create(const GuidePath: TGPGraphicsPath; 58 | const Flatness: Single = 10 * FlatnessDefault); 59 | 60 | destructor Destroy; override; 61 | 62 | function AddPathText(const Path: TGPGraphicsPath; 63 | const Text: WideString; const Indent: Single; 64 | const Family: TGPFontFamily; Style: Integer; 65 | const Size: Single; const Format: TGPStringFormat; 66 | const DistanceFactor: Single = 1; const KerningFactor: Single = 1): Single; 67 | 68 | class function GetPathLength(const Path: TGPGraphicsPath): Single; 69 | 70 | property Rotation: Single read FRotation write FRotation; 71 | property AdditionalMatrix: TGPMatrix read FAdditionalMatrix write FAdditionalMatrix; 72 | end; 73 | 74 | implementation 75 | 76 | uses 77 | System.Math, System.SysUtils; 78 | 79 | function GetPoint(P: PGPPointF; Index: Integer): TGPPointF; 80 | begin 81 | Inc(P, Index); 82 | Result := P^; 83 | end; 84 | 85 | function AddPoint(A, B: TGPPointF): TGPPointF; 86 | begin 87 | Result.X := A.X + B.X; 88 | Result.Y := A.Y + B.Y; 89 | end; 90 | 91 | function SubPoint(A, B: TGPPointF): TGPPointF; 92 | begin 93 | Result.X := A.X - B.X; 94 | Result.Y := A.Y - B.Y; 95 | end; 96 | 97 | function GetIntersectionFromCircle(PtA, PtB, Center: TGPPointF; 98 | const R2: Single): Single; 99 | var 100 | Diff: TGPPointF; 101 | rA2, rB2: Single; 102 | A, B, C, D, T, T1, T2, SqrtD: Single; 103 | begin 104 | PtA := SubPoint(PtA, Center); 105 | PtB := SubPoint(PtB, Center); 106 | 107 | rA2 := Sqr(PtA.X) + Sqr(PtA.Y); 108 | rB2 := Sqr(PtB.X) + Sqr(PtB.Y); 109 | 110 | if (rA2 > R2) and (rB2 > R2) then 111 | begin 112 | Result := -1; 113 | Exit; 114 | end; 115 | 116 | if (rA2 < R2) and (rB2 < R2) then 117 | begin 118 | Result := -1; 119 | Exit; 120 | end; 121 | 122 | Diff := SubPoint(PtB, PtA); 123 | 124 | A := Sqr(Diff.X) + Sqr(Diff.Y); 125 | B := 2 * (PtA.X * Diff.X + PtA.Y * Diff.Y); 126 | C := rA2 - R2; 127 | D := Sqr(B) - 4 * A * C; 128 | 129 | T := -1; 130 | 131 | A := 2 * A; 132 | if (D = 0) then 133 | T := -B / A 134 | else 135 | if (D > 0) then 136 | begin 137 | SqrtD := Sqrt(D); 138 | T1 := (-B + SqrtD) / A; 139 | T2 := (-B - SqrtD) / A; 140 | 141 | if (T1 >= 0) and (T1 <= 1) then 142 | begin 143 | if (T2 > 0) and (T2 < T1) then 144 | T := T2 145 | else 146 | T := T1; 147 | end 148 | else 149 | if (T2 >= 0) and (T2 <= 1) then 150 | T := T2; 151 | end; 152 | Result := T; 153 | end; 154 | 155 | 156 | { TPathText } 157 | 158 | function TGPPathText.AddCharacter(const Current, Next: WideChar; 159 | const Path: TGPGraphicsPath; const Position: TPathPosition): TPathPosition; 160 | var 161 | CharWidth: Single; 162 | GlyphPath: TGPGraphicsPath; 163 | Left, Right, Diff: TGPPointF; 164 | SinAngle, CosAngle: Single; 165 | Matrix: TGPMatrix; 166 | PosRight: TPathPosition; 167 | begin 168 | GlyphPath := TGPGraphicsPath.Create; 169 | try 170 | CharWidth := KerningText.GetCellWidth(Word(Current), Word(Next), 171 | FDistanceFactor, FKerningFactor); 172 | 173 | if (CharWidth = 0) then 174 | begin 175 | Result := -1; 176 | Exit; 177 | end; 178 | 179 | PosRight := FindRightPosition(Position, CharWidth); 180 | if (PosRight < 0) then 181 | begin 182 | Result := PosRight; 183 | Exit; 184 | end; 185 | 186 | Left := GetPathPoint(Position); 187 | Right := GetPathPoint(PosRight); 188 | 189 | Diff := SubPoint(Right, Left); 190 | 191 | CosAngle := Diff.X / CharWidth; 192 | SinAngle := Diff.Y / CharWidth; 193 | 194 | AddGlyphToPath(GlyphPath, Current, FFamily, FStyle, FSize, 195 | MakePoint(0, -FSize), FFormat); 196 | 197 | if Assigned(FAdditionalMatrix) then 198 | GlyphPath.Transform(FAdditionalMatrix); 199 | 200 | Matrix := TGPMatrix.Create(CosAngle, SinAngle, 201 | - Rotation * SinAngle, 1 + Rotation * (CosAngle - 1), 202 | Left.X, Left.Y); 203 | try 204 | GlyphPath.Transform(Matrix); 205 | finally 206 | Matrix.Free; 207 | end; 208 | 209 | Path.AddPath(GlyphPath, False); 210 | Result := PosRight; 211 | finally 212 | GlyphPath.Free; 213 | end; 214 | end; 215 | 216 | function TGPPathText.AddGlyphToPath(const Path: TGPGraphicsPath; 217 | const Char: WideChar; const Family: TGPFontFamily; const Style: Integer; 218 | const Size: Single; const Origin: TGPPointF; 219 | const Format: TGPStringFormat): TStatus; 220 | begin 221 | Result := Path.AddString(Char, -1, Family, Style, Size, Origin, Format); 222 | end; 223 | 224 | function TGPPathText.AddPathText(const Path: TGPGraphicsPath; 225 | const Text: WideString; const Indent: Single; 226 | const Family: TGPFontFamily; Style: Integer; 227 | const Size: Single; const Format: TGPStringFormat; 228 | const DistanceFactor: Single = 1; const KerningFactor: Single = 1): Single; 229 | var 230 | IndentPosition, Position: TPathPosition; 231 | Current, Next: PWideChar; 232 | begin 233 | Result := 0; 234 | Path.SetFillMode(FillModeWinding); 235 | 236 | IndentPosition := GetPathPosition(Indent); 237 | Position := IndentPosition; 238 | 239 | Current := PWideChar(Text); 240 | 241 | FFamily := Family; 242 | FStyle := Style; 243 | FSize := Size; 244 | FFormat := Format; 245 | FDistanceFactor := DistanceFactor; 246 | FKerningFactor := KerningFactor; 247 | 248 | KerningText.Prepare(FFamily, FStyle, FSize, FFormat); 249 | try 250 | while (Current^ <> #0) and (Position >= 0) do 251 | begin 252 | Next := Current + 1; 253 | Position := AddCharacter(Current^, Next^, Path, Position); 254 | if Position >= 0 then 255 | Result := Position; 256 | Inc(Current); 257 | end; 258 | finally 259 | KerningText.Unprepare; 260 | end; 261 | if Result > 0 then 262 | Result := GetPathPointLength(Result - IndentPosition); 263 | end; 264 | 265 | constructor TGPPathText.Create(const GuidePath: TGPGraphicsPath; 266 | const Flatness: Single); 267 | begin 268 | if not Assigned(GuidePath) then 269 | Exception.Create('Path is invalid'); 270 | 271 | inherited Create; 272 | 273 | FGuidePath := GuidePath.Clone; 274 | FRotation := 1; 275 | FGuidePath.Flatten(nil, Flatness); 276 | end; 277 | 278 | destructor TGPPathText.Destroy; 279 | begin 280 | FGuidePath.Free; 281 | inherited; 282 | end; 283 | 284 | function TGPPathText.FindRightPosition(CenterPos: TPathPosition; 285 | const Radius: Single): TPathPosition; 286 | var 287 | StartSegment: Integer; 288 | PD: TPathData; 289 | DistLeft, DistRight: Single; 290 | Start: TGPPointF; 291 | Diff: TGPPointF; 292 | P1, P2: TGPPointF; 293 | C, PointCount: Integer; 294 | Intersection: Single; 295 | begin 296 | if (CenterPos < 0) then 297 | begin 298 | Result := -1; 299 | Exit; 300 | end; 301 | 302 | StartSegment := Floor(CenterPos); 303 | 304 | PointCount := FGuidePath.GetPointCount; 305 | if (StartSegment >= PointCount - 1) then 306 | begin 307 | Result := -1; 308 | Exit; 309 | end; 310 | 311 | PD := TPathData.Create; 312 | try 313 | if (FGuidePath.GetPathData(PD) = Ok) then 314 | begin 315 | Start := GetPathPoint(CenterPos); 316 | 317 | P1 := GetPoint(PD.Points, StartSegment + 1); 318 | 319 | Diff := SubPoint(Start, P1); 320 | DistRight := Sqrt(Sqr(Diff.X) + Sqr(Diff.Y)); 321 | 322 | if (Radius < DistRight) then 323 | begin 324 | Diff := SubPoint(Start, GetPoint(PD.Points, StartSegment)); 325 | DistLeft := Sqrt(Sqr(Diff.X) + Sqr(Diff.Y)); 326 | 327 | Result := StartSegment + 1 - (DistRight - Radius) / (DistRight + DistLeft); 328 | Exit; 329 | end; 330 | 331 | for C := StartSegment + 1 to PointCount - 2 do 332 | begin 333 | P2 := GetPoint(PD.Points, C + 1); 334 | Intersection := GetIntersectionFromCircle(P1, P2, Start, Sqr(Radius)); 335 | P1 := P2; 336 | 337 | if (Intersection >= 0) then 338 | begin 339 | Result := C + Intersection; 340 | Exit; 341 | end; 342 | end; 343 | end; 344 | Result := -1; 345 | finally 346 | PD.Free; 347 | end; 348 | end; 349 | 350 | class function TGPPathText.GetPathLength(const Path: TGPGraphicsPath): Single; 351 | var 352 | P: TGPGraphicsPath; 353 | Count, C: Integer; 354 | PD: TPathData; 355 | P1, P2: TGPPointF; 356 | begin 357 | Result := 0; 358 | P := Path.Clone; 359 | try 360 | P.Flatten(nil, 10 * FlatnessDefault); 361 | 362 | Count := P.GetPointCount; 363 | if Count > 0 then 364 | begin 365 | PD := TPathData.Create; 366 | try 367 | if (P.GetPathData(PD) = Ok) then 368 | begin 369 | P1 := GetPoint(PD.Points, 0); 370 | for C := 0 to Count - 2 do 371 | begin 372 | P2 := GetPoint(PD.Points, C + 1); 373 | P1 := SubPoint(P2, P1); 374 | Result := Result + Sqrt(Sqr(P1.X) + Sqr(P1.Y)); 375 | P1 := P2; 376 | end; 377 | end; 378 | finally 379 | PD.Free; 380 | end; 381 | end; 382 | finally 383 | P.Free; 384 | end; 385 | end; 386 | 387 | function TGPPathText.GetPathPoint(const Position: TPathPosition): TGPPointF; 388 | var 389 | R: TGPPointF; 390 | Segment, Count: Integer; 391 | PD: TPathData; 392 | Diff: TGPPointF; 393 | T: Single; 394 | begin 395 | R := MakePoint(0.0, 0); 396 | 397 | if Position < 0 then 398 | begin 399 | Result := R; 400 | Exit; 401 | end; 402 | 403 | Segment := Floor(Position); 404 | 405 | Count := FGuidePath.GetPointCount; 406 | if (Segment < Count - 1) then 407 | begin 408 | PD := TPathData.Create; 409 | if (FGuidePath.GetPathData(PD) = Ok) then 410 | begin 411 | R := GetPoint(PD.Points, Segment); 412 | Diff := GetPoint(PD.Points, Segment + 1); 413 | 414 | Diff := SubPoint(Diff, R); 415 | 416 | T := Frac(Position); 417 | 418 | R.X := R.X + T * Diff.X; 419 | R.Y := R.Y + T * Diff.Y; 420 | end; 421 | PD.Free; 422 | end; 423 | 424 | Result := R; 425 | end; 426 | 427 | function TGPPathText.GetPathPointLength(const Position: TPathPosition): Single; 428 | var 429 | P1, P2: TGPPointF; 430 | Diff: TGPPointF; 431 | C, Segment, Count: Integer; 432 | PD: TPathData; 433 | begin 434 | if Position < 0 then 435 | begin 436 | Result := 0; 437 | Exit; 438 | end; 439 | 440 | Segment := Floor(Position); 441 | 442 | Result := 0; 443 | Count := FGuidePath.GetPointCount; 444 | if (Segment < Count - 1) then 445 | begin 446 | PD := TPathData.Create; 447 | try 448 | if (FGuidePath.GetPathData(PD) = Ok) then 449 | begin 450 | P1 := GetPoint(PD.Points, 0); 451 | for C := 0 to Segment - 1 do 452 | begin 453 | P2 := GetPoint(PD.Points, C + 1); 454 | Diff := SubPoint(P2, P1); 455 | Result := Result + Sqrt(Sqr(Diff.X) + Sqr(Diff.Y)); 456 | P1 := P2; 457 | end; 458 | 459 | P2 := GetPoint(PD.Points, Segment + 1); 460 | Diff := SubPoint(P2, P1); 461 | 462 | Result := Result + Sqrt(Sqr(Diff.X) + Sqr(Diff.Y)) * Frac(Position); 463 | end; 464 | finally 465 | PD.Free; 466 | end; 467 | end; 468 | end; 469 | 470 | function TGPPathText.GetPathPosition(Indent: Single): TPathPosition; 471 | var 472 | PD: TPathData; 473 | C, Count: Integer; 474 | A, B: TGPPointF; 475 | Distance: Single; 476 | begin 477 | PD := TPathData.Create; 478 | try 479 | if (FGuidePath.GetPathData(PD) = Ok) then 480 | begin 481 | Count := FGuidePath.GetPointCount; 482 | A := GetPoint(PD.Points, 0); 483 | for C := 0 to Count - 2 do 484 | begin 485 | B := GetPoint(PD.Points, C + 1); 486 | 487 | Distance := Sqrt(Sqr(B.X - A.X) + Sqr(B.Y - A.Y)); 488 | A := B; 489 | 490 | if (Indent < Distance) then 491 | begin 492 | Result := C + Indent / Distance; 493 | Exit; 494 | end; 495 | 496 | Indent := Indent - Distance; 497 | end; 498 | end; 499 | finally 500 | PD.Free; 501 | end; 502 | Result := -1; 503 | end; 504 | 505 | end. 506 | -------------------------------------------------------------------------------- /gdip/GDIPUtils.pas: -------------------------------------------------------------------------------- 1 | unit GDIPUtils; 2 | 3 | interface 4 | 5 | uses 6 | System.Math.Vectors, 7 | Winapi.GDIPAPI, Winapi.GDIPOBJ; 8 | 9 | type 10 | TBoxAlignment = (baTopLeft, baTopCenter, baTopRight, 11 | baCenterLeft, baCenterCenter, baCenterRight, 12 | baBottomLeft, baBottomCenter, baBottomRight); 13 | 14 | function CalcRect(const Bounds: TGPRectF; const Width, Height: Double; 15 | const Alignment: TBoxAlignment): TGPRectF; 16 | 17 | function GetGPMatrix(const Matrix: TMatrix): TGPMatrix; 18 | 19 | implementation 20 | 21 | function CalcRect(const Bounds: TGPRectF; const Width, Height: Double; 22 | const Alignment: TBoxAlignment): TGPRectF; 23 | var 24 | R: Double; 25 | begin 26 | if Height > 0 then 27 | R := Width / Height 28 | else 29 | R := 1; 30 | 31 | if (Bounds.Height <> 0) and 32 | (Bounds.Width / Bounds.Height > R) then 33 | begin 34 | Result.Width := Bounds.Height * R; 35 | Result.Height := Bounds.Height; 36 | end else 37 | begin 38 | Result.Width := Bounds.Width; 39 | Result.Height := Bounds.Width / R; 40 | end; 41 | 42 | case Alignment of 43 | baTopCenter, baCenterCenter, baBottomCenter: 44 | Result.X := (Bounds.Width - Result.Width) / 2; 45 | baTopRight, baCenterRight, baBottomRight: 46 | Result.X := Bounds.Width - Result.Width; 47 | else 48 | Result.X := 0; 49 | end; 50 | 51 | case Alignment of 52 | baCenterLeft, baCenterCenter, baCenterRight: 53 | Result.Y := (Bounds.Height - Result.Height) / 2; 54 | baBottomLeft, baBottomCenter, baBottomRight: 55 | Result.Y := Bounds.Height - Result.Height; 56 | else 57 | Result.Y := 0; 58 | end; 59 | 60 | Result.X := Result.X + Bounds.X; 61 | Result.Y := Result.Y + Bounds.Y; 62 | end; 63 | 64 | function GetGPMatrix(const Matrix: TMatrix): TGPMatrix; 65 | begin 66 | Result := TGPMatrix.Create(Matrix.m11, Matrix.m12, Matrix.m21, Matrix.m22, Matrix.m31, 67 | Matrix.m32); 68 | end; 69 | 70 | end. 71 | -------------------------------------------------------------------------------- /license: -------------------------------------------------------------------------------- 1 | { Use of this library is permitted for commercial and non-commercial } 2 | { use, as long as the author is credited. } 3 | { This file (c) 2005, 2008 Martin Walter } 4 | { This Software is distributed on an "AS IS" basis, WITHOUT } 5 | { WARRANTY OF ANY KIND, either express or implied. } 6 | -------------------------------------------------------------------------------- /svg/SVG.pas: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ekot1/DelphiSVG/0c2fc478d221a914c8ca1a15f0e65e282396000a/svg/SVG.pas -------------------------------------------------------------------------------- /svg/SVGCommon.pas: -------------------------------------------------------------------------------- 1 | {******************************************************************} 2 | { SVG common } 3 | { } 4 | { home page : http://www.mwcs.de } 5 | { email : martin.walter@mwcs.de } 6 | { } 7 | { date : 05-04-2008 } 8 | { } 9 | { Use of this file is permitted for commercial and non-commercial } 10 | { use, as long as the author is credited. } 11 | { This file (c) 2005, 2008 Martin Walter } 12 | { } 13 | { This Software is distributed on an "AS IS" basis, WITHOUT } 14 | { WARRANTY OF ANY KIND, either express or implied. } 15 | { } 16 | { *****************************************************************} 17 | 18 | unit SVGCommon; 19 | 20 | interface 21 | 22 | uses 23 | SVGTypes; 24 | 25 | function TryStrToTFloat(const S: string; out Value: TFloat): Boolean; 26 | 27 | function StrToTFloat(const S: string): TFloat; 28 | 29 | implementation 30 | 31 | uses 32 | System.SysUtils; 33 | 34 | function TryStrToTFloat(const S: string; out Value: TFloat): Boolean; 35 | var 36 | S1: string; 37 | begin 38 | S1 := StringReplace(S, ',', FormatSettings.DecimalSeparator, [rfReplaceAll]); 39 | S1 := StringReplace(S1, '.', FormatSettings.DecimalSeparator, [rfReplaceAll]); 40 | Result := TryStrToFloat(S1, Value); 41 | if not Result then 42 | Value := 0; 43 | end; 44 | 45 | function StrToTFloat(const S: string): TFloat; 46 | begin 47 | TryStrToTFloat(S, Result); 48 | end; 49 | 50 | end. 51 | -------------------------------------------------------------------------------- /svg/SVGPackage.dpk: -------------------------------------------------------------------------------- 1 | package SVGPackage; 2 | 3 | {$R *.res} 4 | {$IFDEF IMPLICITBUILDING This IFDEF should not be used by users} 5 | {$ALIGN 8} 6 | {$ASSERTIONS ON} 7 | {$BOOLEVAL OFF} 8 | {$DEBUGINFO OFF} 9 | {$EXTENDEDSYNTAX ON} 10 | {$IMPORTEDDATA ON} 11 | {$IOCHECKS ON} 12 | {$LOCALSYMBOLS ON} 13 | {$LONGSTRINGS ON} 14 | {$OPENSTRINGS ON} 15 | {$OPTIMIZATION OFF} 16 | {$OVERFLOWCHECKS OFF} 17 | {$RANGECHECKS OFF} 18 | {$REFERENCEINFO ON} 19 | {$SAFEDIVIDE OFF} 20 | {$STACKFRAMES ON} 21 | {$TYPEDADDRESS OFF} 22 | {$VARSTRINGCHECKS ON} 23 | {$WRITEABLECONST OFF} 24 | {$MINENUMSIZE 1} 25 | {$IMAGEBASE $400000} 26 | {$DEFINE DEBUG} 27 | {$ENDIF IMPLICITBUILDING} 28 | {$DESCRIPTION 'MWK - SVG'} 29 | {$IMPLICITBUILD OFF} 30 | 31 | requires 32 | rtl, 33 | xmlrtl; 34 | 35 | contains 36 | SVG in 'SVG.pas', 37 | SVGColor in 'SVGColor.pas', 38 | SVGPaint in 'SVGPaint.pas', 39 | SVGParse in 'SVGParse.pas', 40 | SVGPath in 'SVGPath.pas', 41 | SVGProperties in 'SVGProperties.pas', 42 | SVGStyle in 'SVGStyle.pas', 43 | SVGTypes in 'SVGTypes.pas', 44 | SVGCommon in 'SVGCommon.pas', 45 | GDIPKerning in '..\gdip\GDIPKerning.pas', 46 | GDIPOBJ2 in '..\gdip\GDIPOBJ2.pas', 47 | GDIPPathText in '..\gdip\GDIPPathText.pas', 48 | GDIPUtils in '..\gdip\GDIPUtils.pas'; 49 | 50 | end. 51 | -------------------------------------------------------------------------------- /svg/SVGPackage.res: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ekot1/DelphiSVG/0c2fc478d221a914c8ca1a15f0e65e282396000a/svg/SVGPackage.res -------------------------------------------------------------------------------- /svg/SVGPaint.pas: -------------------------------------------------------------------------------- 1 | {******************************************************************} 2 | { SVG fill classes } 3 | { } 4 | { home page : http://www.mwcs.de } 5 | { email : martin.walter@mwcs.de } 6 | { } 7 | { date : 05-04-2008 } 8 | { } 9 | { Use of this file is permitted for commercial and non-commercial } 10 | { use, as long as the author is credited. } 11 | { This file (c) 2005, 2008 Martin Walter } 12 | { } 13 | { This Software is distributed on an "AS IS" basis, WITHOUT } 14 | { WARRANTY OF ANY KIND, either express or implied. } 15 | { } 16 | { *****************************************************************} 17 | 18 | unit SVGPaint; 19 | 20 | interface 21 | 22 | uses 23 | Winapi.Windows, Winapi.GDIPOBJ, Winapi.GDIPAPI, 24 | System.UITypes, System.Classes, 25 | Xml.XmlIntf, 26 | SVGTypes, SVG; 27 | 28 | type 29 | TColors = record 30 | Colors: packed array of ARGB; 31 | Positions: packed array of Single; 32 | Count: Integer; 33 | end; 34 | 35 | TSVGStop = class(TSVGObject) 36 | strict private 37 | FStop: TFloat; 38 | FStopColor: TColor; 39 | FOpacity: TFloat; 40 | 41 | protected 42 | function New(Parent: TSVGObject): TSVGObject; override; 43 | procedure AssignTo(Dest: TPersistent); override; 44 | public 45 | procedure ReadIn(const Node: IXMLNode); override; 46 | procedure PaintToGraphics(Graphics: TGPGraphics); override; 47 | procedure PaintToPath(Path: TGPGraphicsPath); override; 48 | 49 | property Stop: TFloat read FStop write FStop; 50 | property StopColor: TColor read FStopColor write FStopColor; 51 | 52 | property Opacity: TFloat read FOpacity write FOpacity; 53 | end; 54 | 55 | TSVGFiller = class(TSVGMatrix) 56 | private 57 | protected 58 | function New(Parent: TSVGObject): TSVGObject; override; 59 | public 60 | procedure ReadIn(const Node: IXMLNode); override; 61 | function GetBrush(Alpha: Byte; const DestObject: TSVGBasic): TGPBrush; virtual; abstract; 62 | procedure PaintToGraphics(Graphics: TGPGraphics); override; 63 | procedure PaintToPath(Path: TGPGraphicsPath); override; 64 | end; 65 | 66 | TSVGGradient = class(TSVGFiller) 67 | private 68 | FURI: string; 69 | FGradientUnits: TGradientUnits; 70 | protected 71 | function GetColors(Alpha: Byte): TColors; virtual; 72 | public 73 | procedure ReadIn(const Node: IXMLNode); override; 74 | end; 75 | 76 | TSVGLinearGradient = class(TSVGGradient) 77 | private 78 | FX1: TFloat; 79 | FY1: TFloat; 80 | FX2: TFloat; 81 | FY2: TFloat; 82 | protected 83 | function New(Parent: TSVGObject): TSVGObject; override; 84 | procedure AssignTo(Dest: TPersistent); override; 85 | public 86 | procedure ReadIn(const Node: IXMLNode); override; 87 | function GetBrush(Alpha: Byte; const DestObject: TSVGBasic): TGPBrush; override; 88 | 89 | property X1: TFloat read FX1 write FX1; 90 | property Y1: TFloat read FY1 write FY1; 91 | property X2: TFloat read FX2 write FX2; 92 | property Y2: TFloat read FY2 write FY2; 93 | end; 94 | 95 | TSVGRadialGradient = class(TSVGGradient) 96 | private 97 | FCX: TFloat; 98 | FCY: TFloat; 99 | FR: TFloat; 100 | FFX: TFloat; 101 | FFY: TFloat; 102 | protected 103 | function New(Parent: TSVGObject): TSVGObject; override; 104 | procedure AssignTo(Dest: TPersistent); override; 105 | public 106 | procedure Clear; override; 107 | procedure ReadIn(const Node: IXMLNode); override; 108 | function GetBrush(Alpha: Byte; const DestObject: TSVGBasic): TGPBrush; override; 109 | 110 | property CX: TFloat read FCX write FCX; 111 | property CY: TFloat read FCY write FCY; 112 | property R: TFloat read FR write FR; 113 | property FX: TFloat read FFX write FFX; 114 | property FY: TFloat read FFY write FFY; 115 | end; 116 | 117 | 118 | implementation 119 | 120 | uses 121 | System.SysUtils, System.Math.Vectors, 122 | SVGParse, SVGStyle, SVGProperties, SVGColor, 123 | GDIPUtils; 124 | 125 | // TSVGStop 126 | 127 | procedure TSVGStop.PaintToPath(Path: TGPGraphicsPath); 128 | begin 129 | end; 130 | 131 | procedure TSVGStop.ReadIn(const Node: IXMLNode); 132 | var 133 | S: string; 134 | begin 135 | inherited; 136 | LoadPercent(Node, 'offset', FStop); 137 | 138 | LoadString(Node, 'stop-color', S); 139 | FStopColor := GetColor(S); 140 | 141 | if FStopColor = INHERIT then 142 | begin 143 | S := Style['stop-color']; 144 | FStopColor := GetColor(S); 145 | end; 146 | 147 | S := Style['stop-opacity']; 148 | if (S <> '') then 149 | FOpacity := ParsePercent(S) 150 | else 151 | FOpacity := 1; 152 | 153 | if (FOpacity < 0) then 154 | FOpacity := 0; 155 | 156 | if (FOpacity > 1) then 157 | FOpacity := 1; 158 | end; 159 | 160 | procedure TSVGStop.AssignTo(Dest: TPersistent); 161 | begin 162 | inherited; 163 | if Dest is TSVGStop then 164 | begin 165 | TSVGStop(Dest).FStop := FStop; 166 | TSVGStop(Dest).FStopColor := FStopColor; 167 | end; 168 | end; 169 | 170 | function TSVGStop.New(Parent: TSVGObject): TSVGObject; 171 | begin 172 | Result := TSVGStop.Create(Parent); 173 | end; 174 | 175 | procedure TSVGStop.PaintToGraphics(Graphics: TGPGraphics); 176 | begin 177 | end; 178 | 179 | // TSVGFiller 180 | 181 | procedure TSVGFiller.PaintToPath(Path: TGPGraphicsPath); 182 | begin 183 | end; 184 | 185 | procedure TSVGFiller.ReadIn(const Node: IXMLNode); 186 | begin 187 | inherited; 188 | Display := 0; 189 | end; 190 | 191 | function TSVGFiller.New(Parent: TSVGObject): TSVGObject; 192 | begin 193 | Result := nil; 194 | end; 195 | 196 | procedure TSVGFiller.PaintToGraphics(Graphics: TGPGraphics); 197 | begin 198 | end; 199 | 200 | // TSVGGradient 201 | 202 | procedure TSVGGradient.ReadIn(const Node: IXMLNode); 203 | var 204 | C: Integer; 205 | Stop: TSVGStop; 206 | begin 207 | inherited; 208 | 209 | LoadGradientUnits(Node, FGradientUnits); 210 | 211 | for C := 0 to Node.childNodes.count - 1 do 212 | if Node.childNodes[C].nodeName = 'stop' then 213 | begin 214 | Stop := TSVGStop.Create(Self); 215 | Stop.ReadIn(Node.childNodes[C]); 216 | end; 217 | 218 | FURI := Style['xlink:href']; 219 | if FURI <> '' then 220 | begin 221 | FURI := Trim(FURI); 222 | if (FURI <> '') and (FURI[1] = '#') then 223 | FURI := Copy(FURI, 2, MaxInt); 224 | end; 225 | end; 226 | 227 | // TSVGLinearGradient 228 | 229 | function TSVGLinearGradient.New(Parent: TSVGObject): TSVGObject; 230 | begin 231 | Result := TSVGLinearGradient.Create(Parent); 232 | end; 233 | 234 | procedure TSVGLinearGradient.ReadIn(const Node: IXMLNode); 235 | var 236 | Matrix: TMatrix; 237 | begin 238 | inherited; 239 | LoadLength(Node, 'x1', FX1); 240 | LoadLength(Node, 'y1', FY1); 241 | LoadLength(Node, 'x2', FX2); 242 | LoadLength(Node, 'y2', FY2); 243 | 244 | FillChar(Matrix, SizeOf(Matrix), 0); 245 | LoadTransform(Node, 'gradientTransform', Matrix); 246 | PureMatrix := Matrix; 247 | end; 248 | 249 | procedure TSVGLinearGradient.AssignTo(Dest: TPersistent); 250 | begin 251 | inherited; 252 | if Dest is TSVGLinearGradient then 253 | begin 254 | TSVGLinearGradient(Dest).FX1 := FX1; 255 | TSVGLinearGradient(Dest).FY1 := FY1; 256 | TSVGLinearGradient(Dest).FX2 := FX2; 257 | TSVGLinearGradient(Dest).FY2 := FY2; 258 | end; 259 | end; 260 | 261 | function TSVGLinearGradient.GetBrush(Alpha: Byte; const DestObject: TSVGBasic): TGPBrush; 262 | var 263 | Brush: TGPLinearGradientBrush; 264 | TGP: TGPMatrix; 265 | Colors: TColors; 266 | begin 267 | if Assigned(DestObject) and (FGradientUnits = guObjectBoundingBox) then 268 | Brush := TGPLinearGradientBrush.Create(MakePoint(DestObject.X, DestObject.Y), 269 | MakePoint(DestObject.X + DestObject.Width, DestObject.Y + DestObject.Height), 0, 0) 270 | else 271 | Brush := TGPLinearGradientBrush.Create(MakePoint(FX1, FY1), MakePoint(FX2, FY2), 0, 0); 272 | 273 | Colors := GetColors(Alpha); 274 | 275 | Brush.SetInterpolationColors(PGPColor(Colors.Colors), 276 | PSingle(Colors.Positions), Colors.Count); 277 | 278 | Finalize(Colors); 279 | 280 | if PureMatrix.m33 = 1 then 281 | begin 282 | TGP := GetGPMatrix(PureMatrix); 283 | Brush.SetTransform(TGP); 284 | TGP.Free; 285 | end; 286 | 287 | Result := Brush; 288 | end; 289 | 290 | // TSVGRadialGradient 291 | 292 | procedure TSVGRadialGradient.AssignTo(Dest: TPersistent); 293 | begin 294 | inherited; 295 | if Dest is TSVGRadialGradient then 296 | begin 297 | TSVGRadialGradient(Dest).FCX := FCX; 298 | TSVGRadialGradient(Dest).FCY := FCY; 299 | TSVGRadialGradient(Dest).FFX := FFX; 300 | TSVGRadialGradient(Dest).FFY := FFY; 301 | TSVGRadialGradient(Dest).FR := FR; 302 | end; 303 | end; 304 | 305 | procedure TSVGRadialGradient.Clear; 306 | begin 307 | inherited; 308 | 309 | FCX := 0.5; 310 | FCY := 0.5; 311 | FR := 0.5; 312 | FFX := FCX; 313 | FFY := FCY; 314 | end; 315 | 316 | procedure TSVGRadialGradient.ReadIn(const Node: IXMLNode); 317 | begin 318 | inherited; 319 | 320 | LoadLength(Node, 'cx', FCX); 321 | LoadLength(Node, 'cy', FCY); 322 | LoadLength(Node, 'r', FR); 323 | LoadLength(Node, 'fx', FFX); 324 | LoadLength(Node, 'fy', FFY); 325 | end; 326 | 327 | function TSVGRadialGradient.GetBrush(Alpha: Byte; const DestObject: TSVGBasic): TGPBrush; 328 | var 329 | Brush: TGPPathGradientBrush; 330 | Path: TGPGraphicsPath; 331 | TGP: TGPMatrix; 332 | Colors: TColors; 333 | begin 334 | Path := TGPGraphicsPath.Create; 335 | 336 | if Assigned(DestObject) and (FGradientUnits = guObjectBoundingBox) then 337 | Path.AddEllipse(DestObject.X, DestObject.Y, DestObject.Width, DestObject.Height) 338 | else 339 | Path.AddEllipse(FCX - FR, FCY - FR, 2 * FR, 2 * FR); 340 | 341 | Brush := TGPPathGradientBrush.Create(Path); 342 | Path.Free; 343 | 344 | Colors := GetColors(Alpha); 345 | Brush.SetInterpolationColors(PARGB(Colors.Colors), PSingle(Colors.Positions), Colors.Count); 346 | 347 | Finalize(Colors); 348 | 349 | Brush.SetCenterPoint(MakePoint(FFX, FFY)); 350 | 351 | if PureMatrix.m33 = 1 then 352 | begin 353 | TGP := GetGPMatrix(PureMatrix); 354 | Brush.SetTransform(TGP); 355 | TGP.Free; 356 | end; 357 | 358 | Result := Brush; 359 | end; 360 | 361 | function TSVGRadialGradient.New(Parent: TSVGObject): TSVGObject; 362 | begin 363 | Result := TSVGRadialGradient.Create(Parent); 364 | end; 365 | 366 | function TSVGGradient.GetColors(Alpha: Byte): TColors; 367 | var 368 | C, Start, ColorCount: Integer; 369 | Stop: TSVGStop; 370 | Item: TSVGGradient; 371 | begin 372 | Result.Count := 0; 373 | if FURI = '' then 374 | Item := Self 375 | else 376 | begin 377 | Item := TSVGGradient(GetRoot.FindByID(FURI)); 378 | if not (Item is TSVGGradient) then 379 | Exit; 380 | end; 381 | 382 | Start := 0; 383 | ColorCount := Item.Count; 384 | 385 | if Item.Count = 0 then 386 | Exit; 387 | 388 | if TSVGStop(Item.Items[ColorCount - 1]).Stop < 1 then 389 | Inc(ColorCount); 390 | 391 | if TSVGStop(Item.Items[0]).Stop > 0 then 392 | begin 393 | Inc(ColorCount); 394 | Inc(Start); 395 | end; 396 | 397 | SetLength(Result.Colors, ColorCount); 398 | SetLength(Result.Positions, ColorCount); 399 | 400 | if Start > 0 then 401 | begin 402 | Stop := TSVGStop(Item.Items[0]); 403 | Result.Colors[0] := ConvertColor(Stop.StopColor, Round(Alpha * Stop.Opacity)); 404 | Result.Positions[0] := 0; 405 | end; 406 | 407 | for C := 0 to Item.Count - 1 do 408 | begin 409 | Stop := TSVGStop(Item.Items[C]); 410 | Result.Colors[C + Start] := ConvertColor(Stop.StopColor, Round(Alpha * Stop.Opacity)); 411 | Result.Positions[C + Start] := Stop.Stop; 412 | end; 413 | 414 | if (ColorCount - Start) > Item.Count then 415 | begin 416 | Stop := TSVGStop(Item.Items[Item.Count - 1]); 417 | Result.Colors[ColorCount - 1] := ConvertColor(Stop.StopColor, Round(Alpha * Stop.Opacity)); 418 | Result.Positions[ColorCount - 1] := 1; 419 | end; 420 | 421 | Result.Count := ColorCount; 422 | end; 423 | 424 | end. 425 | -------------------------------------------------------------------------------- /svg/SVGParse.pas: -------------------------------------------------------------------------------- 1 | {******************************************************************} 2 | { Parse of SVG property values } 3 | { } 4 | { home page : http://www.mwcs.de } 5 | { email : martin.walter@mwcs.de } 6 | { } 7 | { date : 05-04-2008 } 8 | { } 9 | { Use of this file is permitted for commercial and non-commercial } 10 | { use, as long as the author is credited. } 11 | { This file (c) 2005, 2008 Martin Walter } 12 | { } 13 | { This Software is distributed on an "AS IS" basis, WITHOUT } 14 | { WARRANTY OF ANY KIND, either express or implied. } 15 | { } 16 | { *****************************************************************} 17 | 18 | unit SVGParse; 19 | 20 | interface 21 | 22 | uses 23 | System.Types, System.Classes, System.Math.Vectors, 24 | SVGTypes; 25 | 26 | function ParseAngle(const Angle: string): TFloat; 27 | 28 | function ParsePercent(const S: string): TFloat; 29 | 30 | function ParseInteger(const S: string): Integer; 31 | 32 | function ParseLength(const S: string): TFloat; 33 | 34 | function ParseUnit(const S: string): TSVGUnit; 35 | 36 | function ParseDRect(const S: string): TRectF; 37 | 38 | function ParseURI(const URI: string): string; 39 | 40 | function ParseTransform(const ATransform: string): TMatrix; 41 | 42 | implementation 43 | 44 | uses 45 | System.SysUtils, System.Math, System.StrUtils, 46 | SVGCommon; 47 | 48 | function ParseAngle(const Angle: string): TFloat; 49 | var 50 | D: TFloat; 51 | C: Integer; 52 | S: string; 53 | begin 54 | if Angle <> '' then 55 | begin 56 | S := Angle; 57 | C := Pos('deg', S); 58 | if C <> 0 then 59 | begin 60 | S := LeftStr(S, C - 1); 61 | if TryStrToTFloat(S, D) then 62 | Result := DegToRad(D) 63 | else 64 | Result := 0; 65 | Exit; 66 | end; 67 | 68 | C := Pos('rad', S); 69 | if C <> 0 then 70 | begin 71 | TryStrToTFloat(S, Result); 72 | Exit; 73 | end; 74 | 75 | C := Pos('grad', S); 76 | if C <> 0 then 77 | begin 78 | S := LeftStr(S, C - 1); 79 | if TryStrToTFloat(S, D) then 80 | Result := GradToRad(D) 81 | else 82 | Result := 0; 83 | Exit; 84 | end; 85 | 86 | if TryStrToTFloat(S, D) then 87 | Result := DegToRad(D) 88 | else 89 | Result := 0; 90 | end else 91 | Result := 0; 92 | end; 93 | 94 | function ParsePercent(const S: string): TFloat; 95 | begin 96 | if Length(S) = 0 then 97 | begin 98 | Result := -1; 99 | end 100 | else 101 | begin 102 | if S[Length(S)] = '%' then 103 | Result := StrToTFloat(LeftStr(S, Length(S) - 1)) / 100 104 | else 105 | Result := StrToTFloat(S); 106 | end; 107 | end; 108 | 109 | function ParseInteger(const S: string): Integer; 110 | begin 111 | Result := StrToInt(S); 112 | end; 113 | 114 | const 115 | CFactors: array [TSVGUnit] of TFloat = 116 | (1, // suNone 117 | 1, // suPX 118 | 1.33, // suPT 119 | 12*1.33, // suPC 120 | 96/25.4, // suMM 121 | 96/2.54, // suCM 122 | 96, // suIN 123 | 16, // suEM 124 | 1, // suEX 125 | 1); // suPercent 126 | 127 | function ParseLength(const S: string): TFloat; 128 | var 129 | SVGUnit: TSVGUnit; 130 | Number: TFloat; 131 | N: string; 132 | begin 133 | SVGUnit := ParseUnit(S); 134 | case SVGUnit of 135 | suPercent: N := Copy(S, 1, Length(S) - 1); 136 | suNone : N := S; 137 | else 138 | N := Copy(S, 1, Length(S) - 2); 139 | end; 140 | Number := StrToTFloat(N); 141 | 142 | Result := Number * CFactors[SVGUnit]; 143 | end; 144 | 145 | function ParseUnit(const S: string): TSVGUnit; 146 | var 147 | Suffix: string; 148 | begin 149 | Suffix := RightStr(S, 2); 150 | if Suffix = 'px' then 151 | begin 152 | Result := suPx; 153 | end 154 | else if Suffix = 'pt' then 155 | begin 156 | Result := suPt; 157 | end 158 | else if Suffix = 'pc' then 159 | begin 160 | Result := suPC; 161 | end 162 | else if Suffix = 'mm' then 163 | begin 164 | Result := suMM; 165 | end 166 | else if Suffix = 'cm' then 167 | begin 168 | Result := suCM; 169 | end 170 | else if Suffix = 'in' then 171 | begin 172 | Result := suIN; 173 | end 174 | else if Suffix = 'em' then 175 | begin 176 | Result := suEM; 177 | end 178 | else if Suffix = 'ex' then 179 | begin 180 | Result := suEX; 181 | end 182 | else if Suffix.EndsWith('%') then 183 | begin 184 | Result := suPercent; 185 | end 186 | else 187 | begin 188 | Result := suNone; 189 | end; 190 | end; 191 | 192 | function GetValues(const S: string; const Delimiter: Char): TStrings; 193 | var 194 | C: Integer; 195 | begin 196 | Result := TStringList.Create; 197 | Result.Delimiter := Delimiter; 198 | Result.DelimitedText := S; 199 | 200 | for C := Result.Count - 1 downto 0 do 201 | begin 202 | if Result[C] = '' then 203 | begin 204 | Result.Delete(C); 205 | end; 206 | end; 207 | end; 208 | 209 | function ParseDRect(const S: string): TRectF; 210 | var 211 | SL: TStrings; 212 | begin 213 | FillChar(Result, SizeOf(Result), 0); 214 | 215 | SL := GetValues(Trim(S), ' '); 216 | 217 | try 218 | if SL.Count = 4 then 219 | begin 220 | Result.Left := ParseLength(SL[0]); 221 | Result.Top := ParseLength(SL[1]); 222 | Result.Width := ParseLength(SL[2]); 223 | Result.Height := ParseLength(SL[3]); 224 | end; 225 | finally 226 | SL.Free; 227 | end; 228 | end; 229 | 230 | function ParseURI(const URI: string): string; 231 | const 232 | CUriPrefix = 'url(#'; 233 | CUriPrefixLength = Length(CUriPrefix); 234 | var 235 | S: string; 236 | begin 237 | if Length(URI) = 0 then 238 | begin 239 | Result := ''; 240 | end 241 | else 242 | begin 243 | S := Trim(URI); 244 | 245 | if S.StartsWith(CUriPrefix) and S.EndsWith(')') then 246 | begin 247 | Result := Copy(S, CUriPrefixLength + 1, Length(S) - (CUriPrefixLength + 1)); 248 | end 249 | else 250 | begin 251 | Result := ''; 252 | end; 253 | end; 254 | end; 255 | 256 | function GetMatrix(const S: string): TMatrix; 257 | var 258 | SL: TStrings; 259 | begin 260 | Result := TMatrix.Identity; 261 | SL := GetValues(S, ','); 262 | try 263 | if SL.Count = 6 then 264 | begin 265 | Result.m11 := StrToTFloat(SL[0]); 266 | Result.m12 := StrToTFloat(SL[1]); 267 | Result.m21 := StrToTFloat(SL[2]); 268 | Result.m22 := StrToTFloat(SL[3]); 269 | Result.m31 := StrToTFloat(SL[4]); 270 | Result.m32 := StrToTFloat(SL[5]); 271 | end; 272 | finally 273 | SL.Free; 274 | end; 275 | end; 276 | 277 | function GetTranslate(const S: string): TMatrix; 278 | var 279 | SL: TStrings; 280 | begin 281 | FillChar(Result, SizeOf(Result), 0); 282 | SL := GetValues(S, ','); 283 | try 284 | if SL.Count = 1 then 285 | SL.Add('0'); 286 | 287 | if SL.Count = 2 then 288 | begin 289 | Result := TMatrix.CreateTranslation(StrToTFloat(SL[0]), StrToTFloat(SL[1])); 290 | end; 291 | finally 292 | SL.Free; 293 | end; 294 | end; 295 | 296 | function GetScale(const S: string): TMatrix; 297 | var 298 | SL: TStrings; 299 | begin 300 | FillChar(Result, SizeOf(Result), 0); 301 | SL := GetValues(S, ','); 302 | try 303 | if SL.Count = 1 then 304 | SL.Add(SL[0]); 305 | if SL.Count = 2 then 306 | begin 307 | Result := TMatrix.CreateScaling(StrToTFloat(SL[0]), StrToTFloat(SL[1])); 308 | end; 309 | finally 310 | SL.Free; 311 | end; 312 | end; 313 | 314 | function GetRotation(const S: string): TMatrix; 315 | var 316 | SL: TStrings; 317 | X, Y, Angle: TFloat; 318 | begin 319 | SL := GetValues(S, ','); 320 | try 321 | Angle := ParseAngle(SL[0]); 322 | 323 | if SL.Count = 3 then 324 | begin 325 | X := StrToTFloat(SL[1]); 326 | Y := StrToTFloat(SL[2]); 327 | end else 328 | begin 329 | X := 0; 330 | Y := 0; 331 | end; 332 | finally 333 | SL.Free; 334 | end; 335 | 336 | Result := TMatrix.CreateTranslation(X, Y); 337 | Result := TMatrix.CreateRotation(Angle) * Result; 338 | Result := TMatrix.CreateTranslation(-X, -Y) * Result; 339 | end; 340 | 341 | function GetSkewX(const S: string): TMatrix; 342 | var 343 | SL: TStrings; 344 | Angle: TFloat; 345 | begin 346 | FillChar(Result, SizeOf(Result), 0); 347 | 348 | SL := GetValues(S, ','); 349 | try 350 | if SL.Count = 1 then 351 | begin 352 | Result := TMatrix.Identity; 353 | Angle := ParseAngle(SL[0]); 354 | Result.m21 := Tan(Angle); 355 | end; 356 | finally 357 | SL.Free; 358 | end; 359 | end; 360 | 361 | function GetSkewY(const S: string): TMatrix; 362 | var 363 | SL: TStrings; 364 | Angle: TFloat; 365 | begin 366 | FillChar(Result, SizeOf(Result), 0); 367 | 368 | SL := GetValues(S, ','); 369 | try 370 | if SL.Count = 1 then 371 | begin 372 | Result := TMatrix.Identity; 373 | Angle := ParseAngle(SL[0]); 374 | Result.m12 := Tan(Angle); 375 | end; 376 | finally 377 | SL.Free; 378 | end; 379 | end; 380 | 381 | function ParseTransform(const ATransform: string): TMatrix; 382 | var 383 | Start: Integer; 384 | Stop: Integer; 385 | TType: string; 386 | Values: string; 387 | S: string; 388 | M: TMatrix; 389 | begin 390 | FillChar(Result, SizeOf(Result), 0); 391 | 392 | S := Trim(ATransform); 393 | 394 | while S <> '' do 395 | begin 396 | Start := Pos('(', S); 397 | Stop := Pos(')', S); 398 | if (Start = 0) or (Stop = 0) then 399 | Exit; 400 | TType := Copy(S, 1, Start - 1); 401 | Values := Trim(Copy(S, Start + 1, Stop - Start - 1)); 402 | Values := StringReplace(Values, ' ', ',', [rfReplaceAll]); 403 | M.m33 := 0; 404 | 405 | if TType = 'matrix' then 406 | begin 407 | M := GetMatrix(Values); 408 | end 409 | else if TType = 'translate' then 410 | begin 411 | M := GetTranslate(Values); 412 | end 413 | else if TType = 'scale' then 414 | begin 415 | M := GetScale(Values); 416 | end 417 | else if TType = 'rotate' then 418 | begin 419 | M := GetRotation(Values); 420 | end 421 | else if TType = 'skewX' then 422 | begin 423 | M := GetSkewX(Values); 424 | end 425 | else if TType = 'skewY' then 426 | begin 427 | M := GetSkewY(Values); 428 | end; 429 | 430 | if M.m33 = 1 then 431 | begin 432 | if Result.m33 = 0 then 433 | Result := M 434 | else 435 | Result := M * Result; 436 | end; 437 | 438 | S := Trim(Copy(S, Stop + 1, Length(S))); 439 | end; 440 | end; 441 | 442 | end. 443 | -------------------------------------------------------------------------------- /svg/SVGProperties.pas: -------------------------------------------------------------------------------- 1 | {******************************************************************} 2 | { Parse of SVG properties } 3 | { } 4 | { home page : http://www.mwcs.de } 5 | { email : martin.walter@mwcs.de } 6 | { } 7 | { date : 05-04-2008 } 8 | { } 9 | { Use of this file is permitted for commercial and non-commercial } 10 | { use, as long as the author is credited. } 11 | { This file (c) 2005, 2008 Martin Walter } 12 | { } 13 | { This Software is distributed on an "AS IS" basis, WITHOUT } 14 | { WARRANTY OF ANY KIND, either express or implied. } 15 | { } 16 | { *****************************************************************} 17 | 18 | unit SVGProperties; 19 | 20 | interface 21 | 22 | uses 23 | System.Math.Vectors, 24 | Xml.XmlIntf, 25 | SVGTypes; 26 | 27 | procedure LoadLength(const Node: IXMLNode; const S: string; var X: TFloat); 28 | 29 | procedure LoadTFloat(const Node: IXMLNode; const S: string; var X: TFloat); 30 | 31 | function LoadString(const Node: IXMLNode; const S: string): string; overload; 32 | procedure LoadString(const Node: IXMLNode; const S: string; var X: string); overload; 33 | 34 | procedure LoadTransform(const Node: IXMLNode; const S: string; var Matrix: TMatrix); 35 | 36 | procedure LoadPercent(const Node: IXMLNode; const S: string; var X: TFloat); overload; 37 | procedure LoadPercent(const Node: IXMLNode; const S: string; Max: Integer; var X: TFloat); overload; 38 | procedure LoadBytePercent(const Node: IXMLNode; const S: string; var X: Integer); 39 | 40 | procedure LoadBoolean(const Node: IXMLNode; const S: string; var X: Boolean); 41 | 42 | procedure LoadDisplay(const Node: IXMLNode; var X: Integer); 43 | 44 | procedure LoadVisible(const Node: IXMLNode; var X: Integer); 45 | 46 | procedure LoadGradientUnits(const Node: IXMLNode; var Units: TGradientUnits); 47 | 48 | implementation 49 | 50 | uses 51 | SVGCommon, SVGParse; 52 | 53 | procedure LoadLength(const Node: IXMLNode; const S: string; var X: TFloat); 54 | var 55 | Attribute: IXMLNode; 56 | begin 57 | Attribute := Node.AttributeNodes.FindNode(S); 58 | if Assigned(Attribute) then 59 | begin 60 | X := ParseLength(Attribute.nodeValue); 61 | end; 62 | end; 63 | 64 | procedure LoadTFloat(const Node: IXMLNode; const S: string; var X: TFloat); 65 | var 66 | Attribute: IXMLNode; 67 | begin 68 | Attribute := Node.AttributeNodes.FindNode(S); 69 | if Assigned(Attribute) then 70 | begin 71 | X := StrToTFloat(Attribute.nodeValue); 72 | end; 73 | end; 74 | 75 | function LoadString(const Node: IXMLNode; const S: string): string; 76 | var 77 | Attribute: IXMLNode; 78 | begin 79 | Attribute := Node.AttributeNodes.FindNode(S); 80 | if Assigned(Attribute) then 81 | begin 82 | Result := Attribute.text; 83 | end 84 | else 85 | begin 86 | Result := ''; 87 | end; 88 | end; 89 | 90 | procedure LoadString(const Node: IXMLNode; const S: string; var X: string); 91 | var 92 | Attribute: IXMLNode; 93 | begin 94 | Attribute := Node.AttributeNodes.FindNode(S); 95 | if Assigned(Attribute) then 96 | begin 97 | X := Attribute.text; 98 | end; 99 | end; 100 | 101 | procedure LoadTransform(const Node: IXMLNode; const S: string; 102 | var Matrix: TMatrix); 103 | var 104 | Attribute: IXMLNode; 105 | begin 106 | Attribute := Node.AttributeNodes.FindNode(S); 107 | if Assigned(Attribute) then 108 | begin 109 | Matrix := ParseTransform(Attribute.nodeValue); 110 | end; 111 | end; 112 | 113 | procedure LoadPercent(const Node: IXMLNode; const S: string; 114 | var X: TFloat); 115 | var 116 | Attribute: IXMLNode; 117 | begin 118 | Attribute := Node.AttributeNodes.FindNode(S); 119 | if Assigned(Attribute) then 120 | X := ParsePercent(Attribute.nodeValue); 121 | end; 122 | 123 | procedure LoadPercent(const Node: IXMLNode; const S: string; 124 | Max: Integer; var X: TFloat); 125 | var 126 | Attribute: IXMLNode; 127 | begin 128 | Attribute := Node.AttributeNodes.FindNode(S); 129 | if Assigned(Attribute) then 130 | begin 131 | X := Max * ParsePercent(Attribute.nodeValue); 132 | end; 133 | end; 134 | 135 | procedure LoadBytePercent(const Node: IXMLNode; const S: string; 136 | var X: Integer); 137 | var 138 | Attribute: IXMLNode; 139 | begin 140 | Attribute := Node.AttributeNodes.FindNode(S); 141 | if Assigned(Attribute) then 142 | begin 143 | X := Round(255 * ParsePercent(Attribute.nodeValue)); 144 | end; 145 | end; 146 | 147 | procedure LoadBoolean(const Node: IXMLNode; const S: string; 148 | var X: Boolean); 149 | var 150 | Attribute: IXMLNode; 151 | begin 152 | Attribute := Node.AttributeNodes.FindNode(S); 153 | if Assigned(Attribute) then 154 | X := Boolean(ParseInteger(Attribute.nodeValue)); 155 | end; 156 | 157 | procedure LoadDisplay(const Node: IXMLNode; var X: Integer); 158 | var 159 | S: string; 160 | Attribute: IXMLNode; 161 | begin 162 | Attribute := Node.AttributeNodes.FindNode('display'); 163 | if Assigned(Attribute) then 164 | begin 165 | S := Attribute.nodeValue; 166 | if S = 'inherit' then 167 | X := -1 168 | else 169 | if S = 'none' then 170 | X := 0 171 | else 172 | X := 1; 173 | end; 174 | end; 175 | 176 | procedure LoadVisible(const Node: IXMLNode; var X: Integer); 177 | var 178 | S: string; 179 | Attribute: IXMLNode; 180 | begin 181 | Attribute := Node.AttributeNodes.FindNode('visibility'); 182 | if Assigned(Attribute) then 183 | begin 184 | S := Attribute.nodeValue; 185 | if S = 'inherit' then 186 | X := -1 187 | else 188 | if S = 'visible' then 189 | X := 1 190 | else 191 | X := 0; 192 | end; 193 | end; 194 | 195 | procedure LoadGradientUnits(const Node: IXMLNode; var Units: TGradientUnits); 196 | var 197 | S: string; 198 | Attribute: IXMLNode; 199 | begin 200 | Units := guObjectBoundingBox; 201 | Attribute := Node.AttributeNodes.FindNode('gradientUnits'); 202 | if Assigned(Attribute) then 203 | begin 204 | S := Attribute.nodeValue; 205 | if S = 'userSpaceOnUse' then 206 | Units := guUserSpaceOnUse 207 | else 208 | if S = 'objectBoundingBox' then 209 | Units := guObjectBoundingBox; 210 | end; 211 | end; 212 | 213 | end. 214 | -------------------------------------------------------------------------------- /svg/SVGStyle.pas: -------------------------------------------------------------------------------- 1 | {******************************************************************} 2 | { SVG style class } 3 | { } 4 | { home page : http://www.mwcs.de } 5 | { email : martin.walter@mwcs.de } 6 | { } 7 | { date : 26-04-2005 } 8 | { } 9 | { Use of this file is permitted for commercial and non-commercial } 10 | { use, as long as the author is credited. } 11 | { This file (c) 2005 Martin Walter } 12 | { } 13 | { This Software is distributed on an "AS IS" basis, WITHOUT } 14 | { WARRANTY OF ANY KIND, either express or implied. } 15 | { } 16 | { *****************************************************************} 17 | 18 | unit SVGStyle; 19 | 20 | interface 21 | 22 | uses 23 | System.Classes, System.Contnrs; 24 | 25 | type 26 | TStyle = class(TObject) 27 | strict private 28 | FValues: TStrings; 29 | function GetCount: Integer; 30 | procedure PutValues(const Key: string; const Value: string); 31 | function GetValues(const Key: string): string; 32 | 33 | procedure PutValuesByNum(const Index: Integer; const Value: string); 34 | function GetValuesByNum(const Index: Integer): string; 35 | 36 | procedure PutKey(const Index: Integer; const Key: string); 37 | function GetKey(const Index: Integer): string; 38 | 39 | function Dequote(const Value: string): string; 40 | private 41 | FName: string; 42 | strict private 43 | FOnChange: TNotifyEvent; 44 | procedure DoOnChange; 45 | public 46 | constructor Create; 47 | destructor Destroy; override; 48 | procedure Clear; 49 | function Clone: TStyle; 50 | procedure SetValues(const Values: string); 51 | 52 | function AddStyle(const Key, Value: string): Integer; 53 | function IndexOf(const Key: string): Integer; 54 | procedure Delete(Index: Integer); 55 | function Remove(const Key: string): Integer; 56 | 57 | property Count: Integer read GetCount; 58 | property Values[const Key: string]: string read GetValues write PutValues; default; 59 | property ValuesByNum[const Index: Integer]: string read GetValuesByNum write PutValuesByNum; 60 | property Keys[const Index: Integer]: string read GetKey write PutKey; 61 | property OnChange: TNotifyEvent read FOnChange write FOnChange; 62 | end; 63 | 64 | TStyleList = class(TObject) 65 | strict private 66 | FList: TObjectList; 67 | 68 | function GetCount: Integer; 69 | function GetStyle(const Index: Integer): TStyle; 70 | procedure PutStyle(const Index: Integer; Style: TStyle); 71 | public 72 | constructor Create; 73 | destructor Destroy; override; 74 | procedure Clear; 75 | function Clone: TStyleList; 76 | 77 | procedure Delete(Index: Integer); 78 | function Remove(const Style: TStyle): Integer; 79 | function Add(const AStyle: TStyle): Integer; overload; 80 | function Add(const Name, Values: string): Integer; overload; 81 | function Add(const AStyle: string): Integer; overload; 82 | 83 | procedure Insert(Index: Integer; Style: TStyle); overload; 84 | procedure Insert(Index: Integer; const Name, Values: string); overload; 85 | procedure Exchange(Index1, Index2: Integer); 86 | procedure Move(CurIndex, NewIndex: Integer); 87 | function IndexOf(Style: TStyle): Integer; 88 | function GetStyleByName(const Name: string): TStyle; 89 | 90 | property Style[const Index: Integer]: TStyle read GetStyle write PutStyle; default; 91 | property Count: Integer read GetCount; 92 | end; 93 | 94 | implementation 95 | 96 | uses 97 | System.SysUtils, System.StrUtils; 98 | 99 | {$REGION 'TStyle'} 100 | 101 | constructor TStyle.Create; 102 | begin 103 | inherited; 104 | FValues := TStringList.Create; 105 | FValues.NameValueSeparator := '"'; 106 | end; 107 | 108 | destructor TStyle.Destroy; 109 | begin 110 | FreeAndNil(FValues); 111 | inherited; 112 | end; 113 | 114 | procedure TStyle.Clear; 115 | begin 116 | if FValues <> nil then 117 | begin 118 | FValues.Clear; 119 | end; 120 | end; 121 | 122 | function TStyle.Clone: TStyle; 123 | begin 124 | Result := TStyle.Create; 125 | Result.FName := FName; 126 | Result.FValues.Assign(FValues); 127 | end; 128 | 129 | function TStyle.GetCount: Integer; 130 | begin 131 | Result := FValues.Count; 132 | end; 133 | 134 | procedure TStyle.DoOnChange; 135 | begin 136 | if Assigned(FOnChange) then 137 | begin 138 | FOnChange(Self); 139 | end; 140 | end; 141 | 142 | procedure TStyle.PutValues(const Key: string; const Value: string); 143 | var 144 | Index: Integer; 145 | begin 146 | Index := IndexOf(Key); 147 | if Index > 0 then 148 | PutValuesByNum(Index, Value) 149 | else 150 | AddStyle(Key, Value); 151 | end; 152 | 153 | function TStyle.GetValues(const Key: string): string; 154 | begin 155 | Result := GetValuesByNum(IndexOf(Key)); 156 | end; 157 | 158 | procedure TStyle.PutValuesByNum(const Index: Integer; const Value: string); 159 | begin 160 | if (Index >= 0) and (Index < FValues.Count) then 161 | FValues.ValueFromIndex[Index] := DeQuote(Value); 162 | end; 163 | 164 | function TStyle.GetValuesByNum(const Index: Integer): string; 165 | begin 166 | if (Index >= 0) and (Index < FValues.Count) then 167 | Result := FValues.ValueFromIndex[Index] 168 | else 169 | Result := ''; 170 | end; 171 | 172 | procedure TStyle.PutKey(const Index: Integer; const Key: string); 173 | begin 174 | if (Index >= 0) and (Index < FValues.Count) then 175 | FValues[Index] := Key + FValues.NameValueSeparator + FValues.ValueFromIndex[Index]; 176 | end; 177 | 178 | function TStyle.GetKey(const Index: Integer): string; 179 | begin 180 | if (Index >= 0) and (Index < FValues.Count) then 181 | Result := FValues.Names[Index] 182 | else 183 | Result := ''; 184 | end; 185 | 186 | function TStyle.Dequote(const Value: string): string; 187 | begin 188 | if Value <> '' then 189 | begin 190 | if (Value[1] = '''') and (Value[Length(Value)] = '''') then 191 | Result := Copy(Value, 2, Length(Value) - 2) 192 | else 193 | if (Value[1] = '"') and (Value[Length(Value)] = '"') then 194 | Result := Copy(Value, 2, Length(Value) - 2) 195 | else 196 | Result := Value; 197 | end else 198 | Result := Value; 199 | end; 200 | 201 | procedure TStyle.SetValues(const Values: string); 202 | var 203 | C: Integer; 204 | Key: string; 205 | Value: string; 206 | Help: string; 207 | begin 208 | Help := Trim(Values); 209 | 210 | while Help <> '' do 211 | begin 212 | C := Pos(';', Help); 213 | if C = 0 then 214 | C := Length(Help) + 1; 215 | Key := Copy(Help, 1, C - 1); 216 | Help := Trim(Copy(Help, C + 1, MaxInt)); 217 | C := Pos(':', Key); 218 | if C <> 0 then 219 | begin 220 | Value := Trim(Copy(Key, C + 1, MaxInt)); 221 | Key := Trim(Copy(Key, 1, C - 1)); 222 | 223 | C := IndexOf(Key); 224 | if C = -1 then 225 | FValues.Add(Key + FValues.NameValueSeparator + DeQuote(Value)) 226 | else 227 | PutValuesByNum(C, Value); 228 | end; 229 | end; 230 | end; 231 | 232 | function TStyle.AddStyle(const Key, Value: string): Integer; 233 | begin 234 | Result := IndexOf(Key); 235 | if Result = -1 then 236 | Result := FValues.Add(Key + FValues.NameValueSeparator + DeQuote(Value)) 237 | else 238 | PutValuesByNum(Result, Value); 239 | DoOnChange; 240 | end; 241 | 242 | function TStyle.IndexOf(const Key: string): Integer; 243 | begin 244 | for Result := 0 to FValues.Count - 1 do 245 | begin 246 | if FValues.Names[Result] = Key then 247 | Exit; 248 | end; 249 | Result := -1; 250 | end; 251 | 252 | procedure TStyle.Delete(Index: Integer); 253 | begin 254 | if (Index >= 0) and (Index < FValues.Count) then 255 | begin 256 | FValues.Delete(Index); 257 | end; 258 | end; 259 | 260 | function TStyle.Remove(const Key: string): Integer; 261 | begin 262 | Result := IndexOf(Key); 263 | Delete(Result); 264 | end; 265 | {$ENDREGION} 266 | 267 | {$REGION 'TStyleList'} 268 | constructor TStyleList.Create; 269 | begin 270 | inherited; 271 | FList := TObjectList.Create(False); 272 | end; 273 | 274 | destructor TStyleList.Destroy; 275 | begin 276 | Clear; 277 | FList.Free; 278 | inherited; 279 | end; 280 | 281 | procedure TStyleList.Clear; 282 | begin 283 | while FList.Count > 0 do 284 | begin 285 | TStyle(FList[0]).Free; 286 | FList.Delete(0); 287 | end; 288 | end; 289 | 290 | function TStyleList.Clone: TStyleList; 291 | var 292 | C: Integer; 293 | begin 294 | Result := TStyleList.Create; 295 | for C := 0 to FList.Count - 1 do 296 | Result.Add(GetStyle(C).Clone); 297 | end; 298 | 299 | function TStyleList.GetCount: Integer; 300 | begin 301 | Result := FList.Count; 302 | end; 303 | 304 | function TStyleList.GetStyle(const Index: Integer): TStyle; 305 | begin 306 | if (Index >= 0) and (Index < FList.Count) then 307 | Result := TStyle(FList[Index]) 308 | else 309 | Result := nil; 310 | end; 311 | 312 | procedure TStyleList.PutStyle(const Index: Integer; Style: TStyle); 313 | begin 314 | if (Index >= 0) and (Index < FList.Count) then 315 | begin 316 | FList[Index].Free; 317 | FList[Index] := Style; 318 | end; 319 | end; 320 | 321 | procedure TStyleList.Delete(Index: Integer); 322 | begin 323 | if (Index >= 0) and (Index < FList.Count) then 324 | begin 325 | FList[Index].Free; 326 | FList.Delete(Index); 327 | end; 328 | end; 329 | 330 | function TStyleList.Remove(const Style: TStyle): Integer; 331 | begin 332 | Result := IndexOf(Style); 333 | Delete(Result); 334 | end; 335 | 336 | function TStyleList.Add(const AStyle: TStyle): Integer; 337 | begin 338 | Result := FList.Add(AStyle); 339 | end; 340 | 341 | function TStyleList.Add(const Name, Values: string): Integer; 342 | var 343 | S: TStyle; 344 | begin 345 | S := TStyle.Create; 346 | S.FName := Name; 347 | S.SetValues(Values); 348 | Result := Add(S); 349 | end; 350 | 351 | function TStyleList.Add(const AStyle: string): Integer; 352 | var 353 | Name: string; 354 | StyleStr: string; 355 | Values: string; 356 | C: Integer; 357 | D: Integer; 358 | begin 359 | Result := -1; 360 | StyleStr := Trim(AStyle); 361 | for C := Low(StyleStr) to High(StyleStr) do 362 | begin 363 | if StyleStr[C] = '{' then 364 | begin 365 | for D := High(StyleStr) downto C + 1 do 366 | begin 367 | if StyleStr[D] = '}' then 368 | begin 369 | Name := Trim(Copy(StyleStr, 1, C - 1)); 370 | 371 | Values := Copy(StyleStr, C + 1, D - C - 1); 372 | Result := Add(Name, Values); 373 | end; 374 | end; 375 | end; 376 | end; 377 | end; 378 | 379 | procedure TStyleList.Insert(Index: Integer; Style: TStyle); 380 | begin 381 | if (Index >= 0) and (Index < FList.Count) then 382 | FList.Insert(Index, Style); 383 | end; 384 | 385 | procedure TStyleList.Insert(Index: Integer; const Name, Values: string); 386 | var 387 | S: TStyle; 388 | begin 389 | if (Index >= 0) and (Index < FList.Count) then 390 | begin 391 | S := TStyle.Create; 392 | S.FName := Name; 393 | S.SetValues(Values); 394 | Insert(Index, S); 395 | end; 396 | end; 397 | 398 | procedure TStyleList.Exchange(Index1, Index2: Integer); 399 | begin 400 | if (Index1 >= 0) and (Index1 < FList.Count) and 401 | (Index2 >= 0) and (Index2 < FList.Count) then 402 | FList.Exchange(Index1, Index2); 403 | end; 404 | 405 | procedure TStyleList.Move(CurIndex, NewIndex: Integer); 406 | begin 407 | if (CurIndex >= 0) and (CurIndex < FList.Count) and 408 | (NewIndex >= 0) and (NewIndex < FList.Count) then 409 | FList.Move(CurIndex, NewIndex); 410 | end; 411 | 412 | function TStyleList.IndexOf(Style: TStyle): Integer; 413 | begin 414 | Result := FList.IndexOf(Style); 415 | end; 416 | 417 | function TStyleList.GetStyleByName(const Name: string): TStyle; 418 | var 419 | C: Integer; 420 | begin 421 | for C := 0 to FList.Count - 1 do 422 | begin 423 | Result := TStyle(FList[C]); 424 | if Result.FName = Name then 425 | Exit; 426 | end; 427 | 428 | Result := nil; 429 | end; 430 | {$ENDREGION} 431 | 432 | end. 433 | -------------------------------------------------------------------------------- /svg/SVGTypes.pas: -------------------------------------------------------------------------------- 1 | {******************************************************************} 2 | { SVG types } 3 | { } 4 | { home page : http://www.mwcs.de } 5 | { email : martin.walter@mwcs.de } 6 | { } 7 | { date : 05-04-2008 } 8 | { } 9 | { Use of this file is permitted for commercial and non-commercial } 10 | { use, as long as the author is credited. } 11 | { This file (c) 2005, 2008 Martin Walter } 12 | { } 13 | { This Software is distributed on an "AS IS" basis, WITHOUT } 14 | { WARRANTY OF ANY KIND, either express or implied. } 15 | { } 16 | { *****************************************************************} 17 | 18 | unit SVGTypes; 19 | 20 | interface 21 | 22 | uses 23 | System.Math, System.Types, 24 | Winapi.Windows, Winapi.GDIPAPI; 25 | 26 | const 27 | INHERIT = -1; 28 | 29 | FontNormal = 0; 30 | FontItalic = 1; 31 | 32 | MaxTFloat = MaxSingle; 33 | 34 | type 35 | TFloat = single; 36 | 37 | TListOfPoints = array of TPointF; 38 | 39 | TRectarray = packed array of TRect; 40 | PRectArray = ^TRectArray; 41 | 42 | TTextDecoration = set of (tdInherit, tdUnderLine, tdOverLine, tdStrikeOut); 43 | 44 | TTextPathMethod = (tpmAlign, tpmStretch); 45 | 46 | TTextPathSpacing = (tpsAuto, tpsExact); 47 | 48 | TSVGUnit = (suNone, suPX, suPT, suPC, suMM, suCM, suIN, suEM, suEX, suPercent); 49 | 50 | TGradientUnits = (guObjectBoundingBox, guUserSpaceOnUse); 51 | 52 | TBounds = record 53 | TopLeft: TPointF; 54 | TopRight: TPointF; 55 | BottomLeft: TPointF; 56 | BottomRight: TPointF; 57 | end; 58 | 59 | function ToGPPoint(const Point: TPointF): TGPPointF; 60 | 61 | function Intersect(const Bounds: TBounds; const Rect: TRect): Boolean; 62 | 63 | implementation 64 | 65 | function ToGPPoint(const Point: TPointF): TGPPointF; 66 | begin 67 | Result := MakePoint(Point.X, Point.Y); 68 | end; 69 | 70 | function Intersect(const Bounds: TBounds; const Rect: TRect): Boolean; 71 | var 72 | R1, R2: THandle; 73 | P: array[0..3] of TPoint; 74 | begin 75 | P[0].X := Round(Bounds.TopLeft.X); 76 | P[0].Y := Round(Bounds.TopLeft.Y); 77 | 78 | P[1].X := Round(Bounds.TopRight.X); 79 | P[1].Y := Round(Bounds.TopRight.Y); 80 | 81 | P[2].X := Round(Bounds.BottomRight.X); 82 | P[2].Y := Round(Bounds.BottomRight.Y); 83 | 84 | P[3].X := Round(Bounds.BottomLeft.X); 85 | P[3].Y := Round(Bounds.BottomLeft.Y); 86 | 87 | R1 := CreatePolygonRgn(P, 4, ALTERNATE); 88 | R2 := CreateRectRgn(Rect.Left, Rect.Top, Rect.Right, Rect.Bottom); 89 | 90 | Result := CombineRgn(R1, R1, R2, RGN_AND) <> NULLREGION; 91 | 92 | DeleteObject(R1); 93 | DeleteObject(R2); 94 | end; 95 | 96 | end. 97 | -------------------------------------------------------------------------------- /vcl/SvgViewer.dpr: -------------------------------------------------------------------------------- 1 | program SvgViewer; 2 | 3 | uses 4 | Vcl.Forms, 5 | SvgViewerUnit in 'SvgViewerUnit.pas' {Form1}; 6 | 7 | {$R *.res} 8 | 9 | begin 10 | Application.Initialize; 11 | Application.MainFormOnTaskbar := True; 12 | Application.CreateForm(TForm1, Form1); 13 | Application.Run; 14 | end. 15 | -------------------------------------------------------------------------------- /vcl/SvgViewer.res: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ekot1/DelphiSVG/0c2fc478d221a914c8ca1a15f0e65e282396000a/vcl/SvgViewer.res -------------------------------------------------------------------------------- /vcl/SvgViewerUnit.dfm: -------------------------------------------------------------------------------- 1 | object Form1: TForm1 2 | Left = 0 3 | Top = 0 4 | Caption = 'Form1' 5 | ClientHeight = 629 6 | ClientWidth = 805 7 | Color = clBtnFace 8 | DoubleBuffered = True 9 | Font.Charset = DEFAULT_CHARSET 10 | Font.Color = clWindowText 11 | Font.Height = -11 12 | Font.Name = 'Tahoma' 13 | Font.Style = [] 14 | OldCreateOrder = False 15 | OnCreate = FormCreate 16 | OnDestroy = FormDestroy 17 | PixelsPerInch = 96 18 | TextHeight = 13 19 | object PaintBox1: TPaintBox 20 | Left = 0 21 | Top = 0 22 | Width = 707 23 | Height = 629 24 | Align = alClient 25 | OnPaint = PaintBox1Paint 26 | ExplicitLeft = -6 27 | ExplicitTop = -1 28 | end 29 | object Panel1: TPanel 30 | Left = 707 31 | Top = 0 32 | Width = 98 33 | Height = 629 34 | Align = alRight 35 | TabOrder = 0 36 | object ListBox1: TListBox 37 | Left = 1 38 | Top = 42 39 | Width = 96 40 | Height = 586 41 | Align = alClient 42 | ItemHeight = 13 43 | TabOrder = 0 44 | OnClick = ListBox1Click 45 | end 46 | object Panel2: TPanel 47 | Left = 1 48 | Top = 1 49 | Width = 96 50 | Height = 41 51 | Align = alTop 52 | BevelOuter = bvNone 53 | Caption = 'Panel2' 54 | TabOrder = 1 55 | object Button1: TButton 56 | Left = 13 57 | Top = 9 58 | Width = 75 59 | Height = 25 60 | Caption = 'Open...' 61 | TabOrder = 0 62 | OnClick = Button1Click 63 | end 64 | end 65 | end 66 | object OpenDialog1: TOpenDialog 67 | Left = 456 68 | Top = 120 69 | end 70 | end 71 | -------------------------------------------------------------------------------- /vcl/SvgViewerUnit.pas: -------------------------------------------------------------------------------- 1 | unit SvgViewerUnit; 2 | 3 | interface 4 | 5 | uses 6 | Winapi.Windows, Winapi.Messages, 7 | System.SysUtils, System.Variants, System.Classes, 8 | Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.ExtCtrls, Vcl.ComCtrls, 9 | SVG; 10 | 11 | type 12 | TForm1 = class(TForm) 13 | PaintBox1: TPaintBox; 14 | OpenDialog1: TOpenDialog; 15 | Panel1: TPanel; 16 | ListBox1: TListBox; 17 | Panel2: TPanel; 18 | Button1: TButton; 19 | procedure PaintBox1Paint(Sender: TObject); 20 | procedure FormCreate(Sender: TObject); 21 | procedure FormDestroy(Sender: TObject); 22 | procedure Button1Click(Sender: TObject); 23 | procedure ListBox1Click(Sender: TObject); 24 | private 25 | { Private declarations } 26 | FSVG: TSVG; 27 | public 28 | { Public declarations } 29 | end; 30 | 31 | var 32 | Form1: TForm1; 33 | 34 | implementation 35 | 36 | {$R *.dfm} 37 | 38 | uses 39 | Winapi.GDIPAPI, System.IOUtils, System.Types, 40 | SVGImage; 41 | 42 | const 43 | CPath = '..\..\..\examples'; 44 | 45 | procedure TForm1.Button1Click(Sender: TObject); 46 | begin 47 | if OpenDialog1.Execute(Handle) then 48 | begin 49 | FSVG.LoadFromFile(OpenDialog1.FileName); 50 | end; 51 | PaintBox1.Invalidate; 52 | end; 53 | 54 | procedure TForm1.FormCreate(Sender: TObject); 55 | var 56 | Files: TStringDynArray; 57 | F: TArray; 58 | FileName: string; 59 | begin 60 | FSVG := TSVG.Create; 61 | Files := TDirectory.GetFiles(CPath, '*.svg'); 62 | for FileName in Files do 63 | begin 64 | F := F + [ExtractFileName(FileName)]; 65 | end; 66 | 67 | ListBox1.Items.AddStrings(F); 68 | end; 69 | 70 | procedure TForm1.FormDestroy(Sender: TObject); 71 | begin 72 | FSVG.Free; 73 | end; 74 | 75 | procedure TForm1.ListBox1Click(Sender: TObject); 76 | begin 77 | FSVG.LoadFromFile(TPath.Combine(CPath, ListBox1.Items[ListBox1.ItemIndex])); 78 | PaintBox1.Invalidate; 79 | end; 80 | 81 | procedure TForm1.PaintBox1Paint(Sender: TObject); 82 | begin 83 | if FSVG.Count > 0 then 84 | begin 85 | FSVG.PaintTo(PaintBox1.Canvas.Handle, 86 | MakeRect(0.0, 0.0, FSVG.Width, FSVG.Height), nil, 0); 87 | end; 88 | end; 89 | 90 | end. 91 | -------------------------------------------------------------------------------- /vcl/svgimage/SVGImage.pas: -------------------------------------------------------------------------------- 1 | {******************************************************************} 2 | { SVG Image in TPicture } 3 | { } 4 | { home page: http://www.mwcs.de } 5 | { email : martin.walter@mwcs.de } 6 | { } 7 | { date : 05-04-2008 } 8 | { } 9 | { Use of this file is permitted for commercial and non-commercial } 10 | { use, as long as the author is credited. } 11 | { This file (c) 2005, 2008 Martin Walter } 12 | { } 13 | { Thanks to: } 14 | { Elias Zurschmiede (imagelist error) } 15 | { } 16 | { This Software is distributed on an "AS IS" basis, WITHOUT } 17 | { WARRANTY OF ANY KIND, either express or implied. } 18 | { } 19 | { *****************************************************************} 20 | 21 | unit SVGImage; 22 | 23 | interface 24 | 25 | uses 26 | Winapi.Windows, Winapi.GDIPOBJ, 27 | System.SysUtils, System.Classes, Vcl.Controls, Vcl.Graphics, 28 | SVG, SVGImageList; 29 | 30 | type 31 | TSVGImage = class(TGraphicControl) 32 | strict private 33 | FSVGImage: TSVG; 34 | FStream: TMemoryStream; 35 | 36 | FCenter: Boolean; 37 | FProportional: Boolean; 38 | FStretch: Boolean; 39 | FAutoSize: Boolean; 40 | FScale: Double; 41 | 42 | FOpacity: Byte; 43 | FFileName: TFileName; 44 | FImageList: TSVGImageList; 45 | FImageIndex: Integer; 46 | 47 | procedure SetCenter(Value: Boolean); 48 | procedure SetProportional(Value: Boolean); 49 | procedure SetOpacity(Value: Byte); 50 | procedure SetFileName(const Value: TFileName); 51 | procedure ReadData(Stream: TStream); 52 | procedure WriteData(Stream: TStream); 53 | procedure SetImageIndex(const Value: Integer); 54 | procedure SetStretch(const Value: Boolean); 55 | procedure SetScale(const Value: Double); 56 | procedure SetAutoSizeImage(const Value: Boolean); 57 | protected 58 | procedure DefineProperties(Filer: TFiler); override; 59 | procedure Notification(AComponent: TComponent; Operation: TOperation); override; 60 | procedure CheckAutoSize; 61 | public 62 | constructor Create(AOwner: TComponent); override; 63 | destructor Destroy; override; 64 | procedure Clear; 65 | function Empty: Boolean; 66 | procedure Paint; override; 67 | procedure LoadFromFile(const FileName: string); 68 | procedure LoadFromStream(Stream: TStream); 69 | procedure Assign(Source: TPersistent); override; 70 | property SVG: TSVG read FSVGImage; 71 | published 72 | property AutoSize: Boolean read FAutoSize write SetAutoSizeImage; 73 | property Center: Boolean read FCenter write SetCenter; 74 | property Proportional: Boolean read FProportional write SetProportional; 75 | property Stretch: Boolean read FStretch write SetStretch; 76 | property Opacity: Byte read FOpacity write SetOpacity; 77 | property Scale: Double read FScale write SetScale; 78 | property FileName: TFileName read FFileName write SetFileName; 79 | property ImageList: TSVGImageList read FImageList write FImageList; 80 | property ImageIndex: Integer read FImageIndex write SetImageIndex; 81 | property Enabled; 82 | property Visible; 83 | property Constraints; 84 | property Anchors; 85 | property Align; 86 | 87 | property OnClick; 88 | property OnDblClick; 89 | property OnMouseDown; 90 | property OnMouseMove; 91 | property OnMouseUp; 92 | end; 93 | 94 | 95 | TSVGGraphic = class(TGraphic) 96 | strict private 97 | FSVGImage: TSVG; 98 | FStream: TMemoryStream; 99 | 100 | FOpacity: Byte; 101 | FFileName: TFileName; 102 | 103 | procedure SetOpacity(Value: Byte); 104 | procedure SetFileName(const Value: TFileName); 105 | protected 106 | procedure DefineProperties(Filer: TFiler); override; 107 | 108 | procedure Draw(ACanvas: TCanvas; const Rect: TRect); override; 109 | 110 | function GetEmpty: Boolean; override; 111 | function GetWidth: Integer; override; 112 | function GetHeight: Integer; override; 113 | procedure SetHeight(Value: Integer); override; 114 | procedure SetWidth(Value: Integer); override; 115 | 116 | procedure ReadData(Stream: TStream); override; 117 | procedure WriteData(Stream: TStream); override; 118 | public 119 | constructor Create; override; 120 | destructor Destroy; override; 121 | procedure Clear; 122 | 123 | procedure Assign(Source: TPersistent); override; 124 | procedure AssignTo(Dest: TPersistent); override; 125 | 126 | procedure AssignSVG(SVG: TSVG); 127 | 128 | procedure LoadFromFile(const Filename: String); override; 129 | procedure LoadFromStream(Stream: TStream); override; 130 | 131 | procedure SaveToStream(Stream: TStream); override; 132 | 133 | procedure LoadFromClipboardFormat(AFormat: Word; AData: THandle; 134 | APalette: HPALETTE); override; 135 | procedure SaveToClipboardFormat(var AFormat: Word; var AData: THandle; 136 | var APalette: HPALETTE); override; 137 | 138 | property Opacity: Byte read FOpacity write SetOpacity; 139 | property FileName: TFileName read FFileName write SetFileName; 140 | end; 141 | 142 | function TGPImageToBitmap(Image: TGPImage): TBitmap; 143 | 144 | implementation 145 | 146 | uses 147 | Vcl.Dialogs, 148 | Winapi.GDIPAPI; 149 | 150 | function TGPImageToBitmap(Image: TGPImage): TBitmap; 151 | var 152 | Graphics: TGPGraphics; 153 | Bitmap: TBitmap; 154 | P: Pointer; 155 | W, H: Cardinal; 156 | begin 157 | Bitmap := nil; 158 | if Assigned(Image) then 159 | begin 160 | W := Image.GetWidth; 161 | H := Image.GetHeight; 162 | if (W > 0) and (H > 0) then 163 | begin 164 | Bitmap := TBitmap.Create; 165 | Bitmap.PixelFormat := pf32Bit; 166 | Bitmap.Width := W; 167 | Bitmap.Height := H; 168 | P := Bitmap.ScanLine[H - 1]; 169 | FillChar(P^, (W * H) shl 2, 0); 170 | Graphics := TGPGraphics.Create(Bitmap.Canvas.Handle); 171 | try 172 | Graphics.DrawImage(Image, 0, 0); 173 | finally 174 | Graphics.Free; 175 | end; 176 | end; 177 | end; 178 | Result := Bitmap; 179 | end; 180 | 181 | constructor TSVGImage.Create(AOwner: TComponent); 182 | begin 183 | inherited; 184 | FSVGImage := TSVG.Create; 185 | FProportional := False; 186 | FCenter := True; 187 | FStretch := True; 188 | FOpacity := 255; 189 | FScale := 1; 190 | FImageIndex := -1; 191 | FStream := TMemoryStream.Create; 192 | end; 193 | 194 | destructor TSVGImage.Destroy; 195 | begin 196 | FSVGImage.Free; 197 | FStream.Free; 198 | inherited; 199 | end; 200 | 201 | procedure TSVGImage.CheckAutoSize; 202 | begin 203 | if FAutoSize and (FSVGImage.Width > 0) and (FSVGImage.Height > 0) then 204 | begin 205 | SetBounds(Left, Top, Round(FSVGImage.Width), Round(FSVGImage.Height)); 206 | end; 207 | end; 208 | 209 | procedure TSVGImage.Clear; 210 | begin 211 | FSVGImage.Clear; 212 | FFileName := ''; 213 | Repaint; 214 | end; 215 | 216 | function TSVGImage.Empty: Boolean; 217 | begin 218 | Empty := FSVGImage.Count = 0; 219 | end; 220 | 221 | procedure TSVGImage.DefineProperties(Filer: TFiler); 222 | begin 223 | Filer.DefineBinaryProperty('Data', ReadData, WriteData, True); 224 | end; 225 | 226 | procedure TSVGImage.Paint; 227 | var 228 | Bounds: TGPRectF; 229 | 230 | procedure CalcWidth(const ImageWidth, ImageHeight: Double); 231 | var 232 | R: Double; 233 | begin 234 | Bounds.Width := ImageWidth * FScale; 235 | Bounds.Height := ImageHeight * FScale; 236 | 237 | if FProportional then 238 | begin 239 | if ImageHeight > 0 then 240 | R := ImageWidth / ImageHeight 241 | else 242 | R := 1; 243 | 244 | if Width / Height > R then 245 | begin 246 | Bounds.Width := Height * R; 247 | Bounds.Height := Height; 248 | end else 249 | begin 250 | Bounds.Width := Width; 251 | Bounds.Height := Width / R; 252 | end; 253 | Exit; 254 | end; 255 | 256 | if FStretch then 257 | begin 258 | Bounds := MakeRect(0.0, 0, Width, Height); 259 | Exit; 260 | end; 261 | end; 262 | 263 | procedure CalcOffset; 264 | begin 265 | Bounds.X := 0; 266 | Bounds.Y := 0; 267 | if FCenter then 268 | begin 269 | Bounds.X := (Width - Bounds.Width) / 2; 270 | Bounds.Y := (Height - Bounds.Height) / 2; 271 | end; 272 | end; 273 | 274 | var 275 | SVG: TSVG; 276 | begin 277 | if Assigned(FImageList) and (FImageIndex >= 0) and 278 | (FImageIndex < FImagelist.Count) then 279 | SVG := FImageList.Images[FImageIndex] 280 | else 281 | SVG := FSVGImage; 282 | 283 | if SVG.Count > 0 then 284 | begin 285 | CalcWidth(SVG.Width, SVG.Height); 286 | CalcOffset; 287 | 288 | SVG.SVGOpacity := FOpacity / 255; 289 | SVG.PaintTo(Canvas.Handle, Bounds, nil, 0); 290 | SVG.SVGOpacity := 1; 291 | end; 292 | 293 | if csDesigning in ComponentState then 294 | begin 295 | Canvas.Brush.Style := bsClear; 296 | Canvas.Pen.Style := psDash; 297 | Canvas.Pen.Color := clBlack; 298 | Canvas.Rectangle(0, 0, Width, Height); 299 | end; 300 | end; 301 | 302 | procedure TSVGImage.LoadFromFile(const FileName: string); 303 | begin 304 | if csLoading in ComponentState then 305 | Exit; 306 | try 307 | FStream.Clear; 308 | FStream.LoadFromFile(FileName); 309 | FSVGImage.LoadFromStream(FStream); 310 | FFileName := FileName; 311 | except 312 | Clear; 313 | end; 314 | CheckAutoSize; 315 | Repaint; 316 | end; 317 | 318 | procedure TSVGImage.LoadFromStream(Stream: TStream); 319 | begin 320 | try 321 | FFileName := ''; 322 | FStream.Clear; 323 | FStream.LoadFromStream(Stream); 324 | FSVGImage.LoadFromStream(FStream); 325 | except 326 | end; 327 | CheckAutoSize; 328 | Repaint; 329 | end; 330 | 331 | procedure TSVGImage.Notification(AComponent: TComponent; Operation: TOperation); 332 | begin 333 | inherited; 334 | if (Operation = opRemove) and (AComponent = FImageList) then 335 | FImageList := nil; 336 | end; 337 | 338 | procedure TSVGImage.Assign(Source: TPersistent); 339 | var 340 | SVG: TSVG; 341 | begin 342 | if (Source is TSVGImage) then 343 | begin 344 | SVG := (Source as TSVGImage).FSVGImage; 345 | FSVGImage.LoadFromText(SVG.Source); 346 | FImageIndex := -1; 347 | CheckAutoSize; 348 | end; 349 | 350 | if (Source.ClassType = TSVG) then 351 | begin 352 | SVG := TSVG(Source); 353 | FSVGImage.LoadFromText(SVG.Source); 354 | FImageIndex := -1; 355 | end; 356 | 357 | Repaint; 358 | end; 359 | 360 | procedure TSVGImage.SetAutoSizeImage(const Value: Boolean); 361 | begin 362 | if (Value = FAutoSize) then 363 | Exit; 364 | FAutoSize := Value; 365 | 366 | CheckAutoSize; 367 | end; 368 | 369 | procedure TSVGImage.SetCenter(Value: Boolean); 370 | begin 371 | if Value = FCenter then 372 | Exit; 373 | 374 | FCenter := Value; 375 | Repaint; 376 | end; 377 | 378 | procedure TSVGImage.SetProportional(Value: Boolean); 379 | begin 380 | if Value = FProportional then 381 | Exit; 382 | 383 | FProportional := Value; 384 | Repaint; 385 | end; 386 | 387 | procedure TSVGImage.SetScale(const Value: Double); 388 | begin 389 | if Value = FScale then 390 | Exit; 391 | FScale := Value; 392 | FAutoSize := False; 393 | Repaint; 394 | end; 395 | 396 | procedure TSVGImage.SetStretch(const Value: Boolean); 397 | begin 398 | if Value = FStretch then 399 | Exit; 400 | 401 | FStretch := Value; 402 | if FStretch then 403 | FAutoSize := False; 404 | Repaint; 405 | end; 406 | 407 | procedure TSVGImage.SetOpacity(Value: Byte); 408 | begin 409 | if Value = FOpacity then 410 | Exit; 411 | 412 | FOpacity := Value; 413 | Repaint; 414 | end; 415 | 416 | procedure TSVGImage.SetFileName(const Value: TFileName); 417 | begin 418 | if Value = FFileName then 419 | Exit; 420 | 421 | LoadFromFile(Value); 422 | end; 423 | 424 | procedure TSVGImage.ReadData(Stream: TStream); 425 | var 426 | Size: LongInt; 427 | begin 428 | Stream.Read(Size, SizeOf(Size)); 429 | FStream.Clear; 430 | if Size > 0 then 431 | begin 432 | FStream.CopyFrom(Stream, Size); 433 | FSVGImage.LoadFromStream(FStream); 434 | end else 435 | FSVGImage.Clear; 436 | end; 437 | 438 | procedure TSVGImage.WriteData(Stream: TStream); 439 | var 440 | Size: LongInt; 441 | begin 442 | Size := FStream.Size; 443 | Stream.Write(Size, SizeOf(Size)); 444 | FStream.Position := 0; 445 | if FStream.Size > 0 then 446 | FStream.SaveToStream(Stream); 447 | end; 448 | 449 | 450 | constructor TSVGGraphic.Create; 451 | begin 452 | inherited; 453 | FSVGImage := TSVG.Create; 454 | FOpacity := 255; 455 | FStream := TMemoryStream.Create; 456 | end; 457 | 458 | destructor TSVGGraphic.Destroy; 459 | begin 460 | FSVGImage.Free; 461 | FStream.Free; 462 | inherited; 463 | end; 464 | 465 | procedure TSVGGraphic.Clear; 466 | begin 467 | FSVGImage.Clear; 468 | FFileName := ''; 469 | Changed(Self); 470 | end; 471 | 472 | procedure TSVGGraphic.Assign(Source: TPersistent); 473 | begin 474 | if (Source is TSVGGraphic) then 475 | begin 476 | try 477 | FSVGImage.Free; 478 | FSVGImage := TSVG(TSVGGraphic(Source).FSVGImage.Clone(nil)); 479 | FStream.Clear; 480 | FStream.LoadFromStream(TSVGGraphic(Source).FStream); 481 | except 482 | end; 483 | Changed(Self); 484 | end; 485 | end; 486 | 487 | procedure TSVGGraphic.AssignSVG(SVG: TSVG); 488 | begin 489 | FSVGImage.LoadFromText(SVG.Source); 490 | Changed(Self); 491 | end; 492 | 493 | procedure TSVGGraphic.AssignTo(Dest: TPersistent); 494 | begin 495 | if Dest is TSVGGraphic then 496 | TSVGGraphic(Dest).Assign(Self); 497 | end; 498 | 499 | procedure TSVGGraphic.SetOpacity(Value: Byte); 500 | begin 501 | if Value = FOpacity then 502 | Exit; 503 | 504 | FOpacity := Value; 505 | Changed(Self); 506 | end; 507 | 508 | procedure TSVGGraphic.SetWidth(Value: Integer); 509 | begin 510 | inherited; 511 | 512 | end; 513 | 514 | procedure TSVGGraphic.SetFileName(const Value: TFileName); 515 | begin 516 | if Value = FFileName then 517 | Exit; 518 | 519 | LoadFromFile(Value); 520 | end; 521 | 522 | procedure TSVGGraphic.SetHeight(Value: Integer); 523 | begin 524 | inherited; 525 | 526 | end; 527 | 528 | procedure TSVGGraphic.ReadData(Stream: TStream); 529 | var 530 | Size: LongInt; 531 | begin 532 | Stream.Read(Size, SizeOf(Size)); 533 | FStream.Clear; 534 | FStream.CopyFrom(Stream, Size); 535 | FSVGImage.LoadFromStream(FStream); 536 | end; 537 | 538 | procedure TSVGGraphic.WriteData(Stream: TStream); 539 | var 540 | Size: LongInt; 541 | begin 542 | Size := FStream.Size; 543 | Stream.Write(Size, SizeOf(Size)); 544 | FStream.Position := 0; 545 | FStream.SaveToStream(Stream); 546 | end; 547 | 548 | procedure TSVGGraphic.DefineProperties(Filer: TFiler); 549 | begin 550 | Filer.DefineBinaryProperty('Data', ReadData, WriteData, True); 551 | end; 552 | 553 | procedure TSVGGraphic.Draw(ACanvas: TCanvas; const Rect: TRect); 554 | var 555 | Bounds: TGPRectF; 556 | begin 557 | if Empty then 558 | Exit; 559 | 560 | Bounds := MakeRect(Rect.Left + 0.0, Rect.Top, 561 | Rect.Right - Rect.Left, Rect.Bottom - Rect.Top); 562 | 563 | FSVGImage.SVGOpacity := FOpacity / 255; 564 | FSVGImage.PaintTo(ACanvas.Handle, Bounds, nil, 0); 565 | end; 566 | 567 | 568 | function TSVGGraphic.GetEmpty: Boolean; 569 | begin 570 | Result := FSVGImage.Count = 0; 571 | end; 572 | 573 | function TSVGGraphic.GetWidth: Integer; 574 | begin 575 | Result := Round(FSVGImage.Width); 576 | end; 577 | 578 | function TSVGGraphic.GetHeight: Integer; 579 | begin 580 | Result := Round(FSVGImage.Height); 581 | end; 582 | 583 | procedure TSVGGraphic.LoadFromClipboardFormat(AFormat: Word; AData: THandle; 584 | APalette: HPALETTE); 585 | begin 586 | inherited; 587 | 588 | end; 589 | 590 | procedure TSVGGraphic.LoadFromFile(const Filename: String); 591 | begin 592 | FStream.Clear; 593 | FStream.LoadFromFile(FileName); 594 | FSVGImage.LoadFromStream(FStream); 595 | Changed(Self); 596 | end; 597 | 598 | procedure TSVGGraphic.LoadFromStream(Stream: TStream); 599 | begin 600 | try 601 | FFileName := ''; 602 | FStream.LoadFromStream(Stream); 603 | FSVGImage.LoadFromStream(FStream); 604 | except 605 | end; 606 | Changed(Self); 607 | end; 608 | 609 | procedure TSVGGraphic.SaveToClipboardFormat(var AFormat: Word; 610 | var AData: THandle; var APalette: HPALETTE); 611 | begin 612 | inherited; 613 | 614 | end; 615 | 616 | procedure TSVGGraphic.SaveToStream(Stream: TStream); 617 | begin 618 | FStream.Position := 0; 619 | FStream.SaveToStream(Stream); 620 | end; 621 | 622 | 623 | procedure TSVGImage.SetImageIndex(const Value: Integer); 624 | begin 625 | if FImageIndex = Value then 626 | Exit; 627 | FImageIndex := Value; 628 | CheckAutoSize; 629 | Repaint; 630 | end; 631 | 632 | initialization 633 | TPicture.RegisterFileFormat('SVG', 'Scalable Vector Graphics', TSVGGraphic); 634 | 635 | finalization 636 | TPicture.UnregisterGraphicClass(TSVGGraphic); 637 | end. 638 | -------------------------------------------------------------------------------- /vcl/svgimage/SVGImageList.pas: -------------------------------------------------------------------------------- 1 | unit SVGImageList; 2 | 3 | interface 4 | 5 | uses 6 | Winapi.Windows, System.SysUtils, System.Classes, 7 | Vcl.Controls, Vcl.Graphics, Vcl.ImgList, 8 | SVG; 9 | 10 | type 11 | TSVGCollectionItem = class(TCollectionItem) 12 | strict private 13 | FName: string; 14 | FSVG: TSVG; 15 | procedure SetName(const Value: string); 16 | procedure SetSVG(const Value: TSVG); 17 | protected 18 | procedure AssignTo(Dest: TPersistent); override; 19 | public 20 | constructor Create(Collection: TCollection); override; 21 | destructor Destroy; override; 22 | property SVG: TSVG read FSVG write SetSVG; 23 | property Name: string read FName write SetName; 24 | end; 25 | 26 | TSVGCollectionItems = class(TCollection) 27 | strict private 28 | FOwner: TPersistent; 29 | function GetItem(Index: Integer): TSVGCollectionItem; 30 | procedure SetItem(Index: Integer; const Value: TSVGCollectionItem); 31 | protected 32 | procedure Update(Item: TCollectionItem); override; 33 | procedure Notify(Item: TCollectionItem; Action: TCollectionNotification); override; 34 | function GetOwner: TPersistent; override; 35 | public 36 | constructor Create(AOwner: TPersistent); 37 | function Add: TSVGCollectionItem; 38 | procedure Assign(Source: TPersistent); override; 39 | property Items[index: Integer]: TSVGCollectionItem read GetItem write SetItem; default; 40 | end; 41 | 42 | TSVGImageList = class(TCustomImageList) 43 | strict private 44 | FImages: TSVGCollectionItems; 45 | FOpacity: Byte; 46 | FUpdating: Boolean; 47 | function GetImages(Index: Integer): TSVG; 48 | function GetNames(Index: Integer): string; 49 | procedure SetImages(Index: Integer; const Value: TSVG); 50 | procedure SetNames(Index: Integer; const Value: string); 51 | function GetHeight: Integer; 52 | function GetWidth: Integer; 53 | procedure SetHeight(const Value: Integer); 54 | procedure SetWidth(const Value: Integer); 55 | procedure SetOpacity(const Value: Byte); 56 | function SVGToIcon(const SVG: TSVG): HICON; 57 | procedure ReadLeft(Reader: TReader); 58 | procedure ReadTop(Reader: TReader); 59 | procedure WriteLeft(Writer: TWriter); 60 | procedure WriteTop(Writer: TWriter); 61 | procedure ReadImageData(Stream: TStream); 62 | procedure WriteImageData(Stream: TStream); 63 | private 64 | procedure RecreateBitmaps; 65 | protected 66 | procedure DefineProperties(Filer: TFiler); override; 67 | procedure AssignTo(Dest: TPersistent); override; 68 | procedure DoDraw(Index: Integer; Canvas: TCanvas; X, Y: Integer; 69 | Style: Cardinal; Enabled: Boolean = True); override; 70 | function GetCount: Integer; override; 71 | public 72 | constructor Create(AOwner: TComponent); override; 73 | destructor Destroy; override; 74 | function Add(const SVG: TSVG; const Name: string): Integer; 75 | procedure Delete(const Index: Integer); 76 | procedure Remove(const Name: string); 77 | function IndexOf(const Name: string): Integer; 78 | procedure Clear; 79 | procedure PaintTo(const DC: HDC; const Index: Integer; 80 | const X, Y, Width, Height: Double); overload; 81 | procedure PaintTo(const DC: HDC; const Name: string; 82 | const X, Y, Width, Height: Double); overload; 83 | property Images[Index: Integer]: TSVG read GetImages write SetImages; 84 | property Names[Index: Integer]: string read GetNames write SetNames; 85 | property Count: Integer read GetCount; 86 | published 87 | property Items: TSVGCollectionItems read FImages; 88 | property Opacity: Byte read FOpacity write SetOpacity; 89 | property Width: Integer read GetWidth write SetWidth default 16; 90 | property Height: Integer read GetHeight write SetHeight default 16; 91 | end; 92 | 93 | implementation 94 | 95 | uses 96 | Winapi.CommCtrl, Winapi.GDIPAPI, Winapi.GDIPOBJ, 97 | Vcl.ComCtrls, 98 | GDIPUtils, SVGTypes; 99 | 100 | { TSVGImageList } 101 | 102 | function TSVGImageList.Add(const SVG: TSVG; 103 | const Name: string): Integer; 104 | var 105 | Item: TSVGCollectionItem; 106 | Updating: Boolean; 107 | begin 108 | Updating := FUpdating; 109 | try 110 | FUpdating := True; 111 | Item := FImages.Add; 112 | 113 | Item.SVG := SVG; 114 | Item.Name := Name; 115 | finally 116 | FUpdating := Updating; 117 | RecreateBitmaps; 118 | end; 119 | Result := FImages.Count - 1; 120 | end; 121 | 122 | procedure TSVGImageList.AssignTo(Dest: TPersistent); 123 | begin 124 | Clear; 125 | inherited; 126 | if Dest is TSVGImageList then 127 | begin 128 | TSVGImageList(Dest).FOpacity := FOpacity; 129 | TSVGImageList(Dest).Width := Width; 130 | TSVGImageList(Dest).Height := Height; 131 | FImages.AssignTo(TSVGImageList(Dest).FImages); 132 | end; 133 | end; 134 | 135 | procedure TSVGImageList.Clear; 136 | begin 137 | inherited Clear; 138 | FUpdating := True; 139 | try 140 | FImages.Clear; 141 | finally 142 | FUpdating := False; 143 | RecreateBitmaps; 144 | end; 145 | end; 146 | 147 | constructor TSVGImageList.Create(AOwner: TComponent); 148 | begin 149 | inherited; 150 | FImages := TSVGCollectionItems.Create(Self); 151 | FOpacity := 255; 152 | end; 153 | 154 | procedure TSVGImageList.DefineProperties(Filer: TFiler); 155 | var 156 | Ancestor: TComponent; 157 | Info: Longint; 158 | begin 159 | Info := 0; 160 | Ancestor := TComponent(Filer.Ancestor); 161 | if Ancestor <> nil then 162 | Info := Ancestor.DesignInfo; 163 | Filer.DefineProperty('Left', ReadLeft, WriteLeft, LongRec(DesignInfo).Lo <> LongRec(Info).Lo); 164 | Filer.DefineProperty('Top', ReadTop, WriteTop, LongRec(DesignInfo).Hi <> LongRec(Info).Hi); 165 | Filer.DefineBinaryProperty('Images', ReadImageData, WriteImageData, True); 166 | end; 167 | 168 | procedure TSVGImageList.Delete(const Index: Integer); 169 | begin 170 | if (Index >= 0) and (Index < FImages.Count) then 171 | FImages.Delete(Index); 172 | end; 173 | 174 | destructor TSVGImageList.Destroy; 175 | begin 176 | Clear; 177 | FImages.Free; 178 | inherited; 179 | end; 180 | 181 | procedure TSVGImageList.DoDraw(Index: Integer; Canvas: TCanvas; X, Y: Integer; 182 | Style: Cardinal; Enabled: Boolean); 183 | begin 184 | PaintTo(Canvas.Handle, Index, X, Y, Width, Height); 185 | end; 186 | 187 | function TSVGImageList.GetCount: Integer; 188 | begin 189 | Result := FImages.Count; 190 | end; 191 | 192 | function TSVGImageList.GetHeight: Integer; 193 | begin 194 | Result := inherited Height; 195 | end; 196 | 197 | function TSVGImageList.GetImages(Index: Integer): TSVG; 198 | begin 199 | if (Index >= 0) and (Index < FImages.Count) then 200 | Result := FImages[Index].SVG 201 | else 202 | Result := nil; 203 | end; 204 | 205 | function TSVGImageList.GetNames(Index: Integer): string; 206 | begin 207 | if (Index >= 0) and (Index < FImages.Count) then 208 | Result := FImages[Index].Name 209 | else 210 | Result := ''; 211 | end; 212 | 213 | function TSVGImageList.GetWidth: Integer; 214 | begin 215 | Result := inherited Width; 216 | end; 217 | 218 | function TSVGImageList.IndexOf(const Name: string): Integer; 219 | begin 220 | for Result := 0 to FImages.Count - 1 do 221 | if FImages[Result].Name = Name then 222 | Exit; 223 | Result := -1; 224 | end; 225 | 226 | procedure TSVGImageList.PaintTo(const DC: HDC; const Index: Integer; 227 | const X, Y, Width, Height: Double); 228 | var 229 | R: TGPRectF; 230 | SVG: TSVG; 231 | begin 232 | if (Index >= 0) and (Index < FImages.Count) then 233 | begin 234 | SVG := FImages[Index].SVG; 235 | SVG.SVGOpacity := FOpacity / 255; 236 | R := CalcRect(MakeRect(X, Y, Width, Height), SVG.Width, SVG.Height, baCenterCenter); 237 | SVG.PaintTo(DC, R, nil, 0); 238 | SVG.SVGOpacity := 1; 239 | end; 240 | end; 241 | 242 | procedure TSVGImageList.PaintTo(const DC: HDC; const Name: string; 243 | const X, Y, Width, Height: Double); 244 | var 245 | Index: Integer; 246 | begin 247 | Index := IndexOf(Name); 248 | PaintTo(DC, Index, X, Y, Width, Height); 249 | end; 250 | 251 | 252 | procedure TSVGImageList.ReadImageData(Stream: TStream); 253 | var 254 | FStream: TMemoryStream; 255 | Count, Size: Integer; 256 | SVG: TSVG; 257 | Name: string; 258 | C: Integer; 259 | begin 260 | try 261 | FUpdating := True; 262 | FStream := TMemoryStream.Create; 263 | Stream.Read(Count, SizeOf(Integer)); 264 | SVG := TSVG.Create(nil); 265 | for C := 0 to Count - 1 do 266 | begin 267 | Stream.Read(Size, SizeOf(Integer)); 268 | SetLength(Name, Size); 269 | Stream.Read(PChar(Name)^, Size * SizeOf(Char)); 270 | 271 | Stream.Read(Size, SizeOf(Integer)); 272 | FStream.CopyFrom(Stream, Size); 273 | SVG.LoadFromStream(FStream); 274 | FStream.Clear; 275 | Add(SVG, Name); 276 | end; 277 | FStream.Free; 278 | SVG.Free; 279 | finally 280 | FUpdating := False; 281 | RecreateBitmaps; 282 | end; 283 | end; 284 | 285 | procedure TSVGImageList.ReadLeft(Reader: TReader); 286 | var 287 | FDesignInfo: LongInt; 288 | begin 289 | FDesignInfo := DesignInfo; 290 | LongRec(FDesignInfo).Lo := Reader.ReadInteger; 291 | DesignInfo := FDesignInfo; 292 | end; 293 | 294 | procedure TSVGImageList.ReadTop(Reader: TReader); 295 | var 296 | FDesignInfo: LongInt; 297 | begin 298 | FDesignInfo := DesignInfo; 299 | LongRec(FDesignInfo).Hi := Reader.ReadInteger; 300 | DesignInfo := FDesignInfo; 301 | end; 302 | 303 | procedure TSVGImageList.RecreateBitmaps; 304 | var 305 | C: Integer; 306 | SVG: TSVG; 307 | Icon: HIcon; 308 | begin 309 | if not FUpdating then 310 | begin 311 | ImageList_Remove(Handle, -1); 312 | Handle := ImageList_Create(Width, Height, 313 | ILC_COLOR32 or (Integer(Masked) * ILC_MASK), 0, AllocBy); 314 | 315 | for C := 0 to FImages.Count - 1 do 316 | begin 317 | SVG := FImages[C].SVG; 318 | if Assigned(SVG) then 319 | begin 320 | Icon := SVGToIcon(SVG); 321 | ImageList_AddIcon(Handle, Icon); 322 | DestroyIcon(Icon); 323 | end; 324 | end; 325 | end; 326 | end; 327 | 328 | procedure TSVGImageList.Remove(const Name: string); 329 | begin 330 | Delete(IndexOf(Name)); 331 | end; 332 | 333 | procedure TSVGImageList.SetHeight(const Value: Integer); 334 | begin 335 | inherited Height := Value; 336 | RecreateBitmaps; 337 | end; 338 | 339 | procedure TSVGImageList.SetImages(Index: Integer; const Value: TSVG); 340 | begin 341 | if (Index >= 0) and (Index < FImages.Count) then 342 | begin 343 | if FImages[Index].SVG <> Value then 344 | FImages[Index].SVG := Value; 345 | end; 346 | end; 347 | 348 | procedure TSVGImageList.SetNames(Index: Integer; const Value: string); 349 | begin 350 | if (Index >= 0) and (Index < FImages.Count) then 351 | FImages[Index].Name := Value; 352 | end; 353 | 354 | procedure TSVGImageList.SetOpacity(const Value: Byte); 355 | begin 356 | FOpacity := Value; 357 | RecreateBitmaps; 358 | end; 359 | 360 | procedure TSVGImageList.SetWidth(const Value: Integer); 361 | begin 362 | inherited Width := Value; 363 | RecreateBitmaps; 364 | end; 365 | 366 | procedure PaintToBitmap(SVG: TSVG; Bitmap: TBitmap; Bounds: TGPRectF; 367 | Rects: PRectArray; RectCount: Integer); 368 | var 369 | Graphics: TGPGraphics; 370 | begin 371 | Graphics := TGPGraphics.Create(Bitmap.Canvas.Handle); 372 | try 373 | Graphics.SetSmoothingMode(SmoothingModeAntiAlias); 374 | SVG.PaintTo(Graphics, Bounds, Rects, RectCount); 375 | finally 376 | Graphics.Free; 377 | end; 378 | end; 379 | 380 | function TSVGImageList.SVGToIcon(const SVG: TSVG): HICON; 381 | var 382 | R: TGPRectF; 383 | 384 | function SVGToIcon24(SVG: TSVG): HIcon; 385 | var 386 | ColorBitmap, MaskBitmap: TBitmap; 387 | X: Integer; 388 | Y: Integer; 389 | Bits: PRGBQuad; 390 | IconInfo: TIconInfo; 391 | TransparentBitmap: TBitmap; 392 | BF: TBlendFunction; 393 | DC: THandle; 394 | begin 395 | ColorBitmap := TBitmap.Create; 396 | MaskBitmap := TBitmap.Create; 397 | TransparentBitmap := TBitmap.Create; 398 | try 399 | TransparentBitmap.PixelFormat := pf32bit; 400 | TransparentBitmap.Width := Width; 401 | TransparentBitmap.Height := Height; 402 | FillChar(TransparentBitmap.Scanline[Height - 1]^, Width * Height * 4, 0); 403 | 404 | PaintToBitmap(SVG, TransparentBitmap, R, nil, 0); 405 | 406 | 407 | ColorBitmap.PixelFormat := pf32bit; 408 | ColorBitmap.Width := Width; 409 | ColorBitmap.Height := Height; 410 | MaskBitmap.PixelFormat := pf32bit; 411 | MaskBitmap.Width := Width; 412 | MaskBitmap.Height := Height; 413 | 414 | 415 | ColorBitmap.Canvas.Brush.Color := BkColor; 416 | ColorBitmap.Canvas.FillRect(Rect(0, 0, Width, Height)); 417 | 418 | BF.BlendOp := AC_SRC_OVER; 419 | BF.BlendFlags := 0; 420 | BF.SourceConstantAlpha := 255; 421 | BF.AlphaFormat := AC_SRC_ALPHA; 422 | AlphaBlend(ColorBitmap.Canvas.Handle, 0, 0, Width, Height, 423 | TransparentBitmap.Canvas.Handle, 0, 0, Width, Height, BF); 424 | 425 | DC := MaskBitmap.Canvas.Handle; 426 | for Y := 0 to Height - 1 do 427 | begin 428 | Bits := TransparentBitmap.ScanLine[Y]; 429 | for X := 0 to Width - 1 do 430 | begin 431 | if Bits.rgbReserved = 0 then 432 | SetPixelV(DC, X, Y, clWhite) 433 | else 434 | SetPixelV(DC, X, Y, clBlack); 435 | Inc(Bits); 436 | end; 437 | end; 438 | 439 | IconInfo.fIcon := True; 440 | IconInfo.hbmColor := ColorBitmap.Handle; 441 | IconInfo.hbmMask := MaskBitmap.Handle; 442 | Result := CreateIconIndirect(IconInfo); 443 | finally 444 | TransparentBitmap.Free; 445 | ColorBitmap.Free; 446 | MaskBitmap.Free; 447 | end; 448 | end; 449 | 450 | function SVGToIcon32(SVG: TSVG): HICON; 451 | var 452 | Bitmap: TGPBitmap; 453 | Graphics: TGPGraphics; 454 | begin 455 | Bitmap := TGPBitmap.Create(Width, Height); 456 | Graphics := TGPGraphics.Create(Bitmap); 457 | Graphics.SetSmoothingMode(SmoothingModeAntiAlias); 458 | SVG.PaintTo(Graphics, R, nil, 0); 459 | Graphics.Free; 460 | 461 | Bitmap.GetHICON(Result); 462 | Bitmap.Free; 463 | end; 464 | 465 | begin 466 | SVG.SVGOpacity := FOpacity / 255; 467 | R := CalcRect(MakeRect(0.0, 0, Width, Height), SVG.Width, SVG.Height, baCenterCenter); 468 | 469 | if GetFileVersion(comctl32) >= ComCtlVersionIE6 then 470 | Result := SVGToIcon32(SVG) 471 | else 472 | Result := SVGToIcon24(SVG); 473 | 474 | SVG.SVGOpacity := 1; 475 | end; 476 | 477 | procedure TSVGImageList.WriteImageData(Stream: TStream); 478 | var 479 | Count, Size: Integer; 480 | SVG: TSVG; 481 | Name: string; 482 | C: Integer; 483 | SVGStream: TMemoryStream; 484 | begin 485 | Count := FImages.Count; 486 | Stream.Write(Count, SizeOf(Integer)); 487 | 488 | SVGStream := TMemoryStream.Create; 489 | for C := 0 to Count - 1 do 490 | begin 491 | Name := FImages[C].Name; 492 | SVG := FImages[C].SVG; 493 | Size := Length(Name); 494 | Stream.Write(Size, SizeOf(Integer)); 495 | Stream.WriteBuffer(PChar(Name)^, Size * SizeOf(Char)); 496 | 497 | SVG.SaveToStream(SVGStream); 498 | Size := SVGStream.Size; 499 | Stream.Write(Size, SizeOf(Integer)); 500 | SVGStream.Position := 0; 501 | Stream.CopyFrom(SVGStream, Size); 502 | SVGStream.Clear; 503 | end; 504 | SVGStream.Free; 505 | end; 506 | 507 | procedure TSVGImageList.WriteLeft(Writer: TWriter); 508 | begin 509 | Writer.WriteInteger(LongRec(DesignInfo).Lo); 510 | end; 511 | 512 | procedure TSVGImageList.WriteTop(Writer: TWriter); 513 | begin 514 | Writer.WriteInteger(LongRec(DesignInfo).Hi); 515 | end; 516 | 517 | { TSVGImageCollectionItem } 518 | 519 | procedure TSVGCollectionItem.AssignTo(Dest: TPersistent); 520 | begin 521 | if Dest is TSVGCollectionItem then 522 | begin 523 | TSVGCollectionItem(Dest).FName := FName; 524 | TSVGCollectionItem(Dest).FSVG.LoadFromText(FSVG.Source); 525 | end; 526 | end; 527 | 528 | constructor TSVGCollectionItem.Create(Collection: TCollection); 529 | begin 530 | inherited Create(Collection); 531 | FSVG := TSVG.Create; 532 | end; 533 | 534 | destructor TSVGCollectionItem.Destroy; 535 | begin 536 | FreeAndNil(FSVG); 537 | inherited; 538 | end; 539 | 540 | procedure TSVGCollectionItem.SetName(const Value: string); 541 | begin 542 | FName := Value; 543 | TSVGCollectionItems(Collection).Update(Self); 544 | end; 545 | 546 | procedure TSVGCollectionItem.SetSVG(const Value: TSVG); 547 | begin 548 | FSVG.LoadFromText(Value.Source); 549 | TSVGCollectionItems(Collection).Update(Self); 550 | end; 551 | 552 | { TSVGImageListCollection } 553 | 554 | function TSVGCollectionItems.Add: TSVGCollectionItem; 555 | begin 556 | Result := TSVGCollectionItem(inherited Add); 557 | end; 558 | 559 | procedure TSVGCollectionItems.Assign(Source: TPersistent); 560 | var 561 | C: Integer; 562 | Item: TSVGCollectionItem; 563 | begin 564 | inherited; 565 | if Source is TSVGCollectionItems then 566 | try 567 | BeginUpdate; 568 | Clear; 569 | for C := 0 to TSVGCollectionItems(Source).Count - 1 do 570 | begin 571 | Item := Add; 572 | TSVGCollectionItems(Source)[C].AssignTo(Item); 573 | end; 574 | finally 575 | EndUpdate; 576 | Update(nil); 577 | end; 578 | end; 579 | 580 | constructor TSVGCollectionItems.Create(AOwner: TPersistent); 581 | begin 582 | inherited Create(TSVGCollectionItem); 583 | FOwner := AOwner; 584 | end; 585 | 586 | function TSVGCollectionItems.GetItem( 587 | Index: Integer): TSVGCollectionItem; 588 | begin 589 | Result := TSVGCollectionItem(inherited GetItem(Index)); 590 | end; 591 | 592 | function TSVGCollectionItems.GetOwner: TPersistent; 593 | begin 594 | Result := FOwner; 595 | end; 596 | 597 | procedure TSVGCollectionItems.Notify(Item: TCollectionItem; 598 | Action: TCollectionNotification); 599 | begin 600 | inherited; 601 | if FOwner is TSVGImageList then 602 | TSVGImageList(FOwner).RecreateBitmaps; 603 | end; 604 | 605 | procedure TSVGCollectionItems.SetItem(Index: Integer; 606 | const Value: TSVGCollectionItem); 607 | begin 608 | inherited SetItem(Index, Value); 609 | end; 610 | 611 | procedure TSVGCollectionItems.Update(Item: TCollectionItem); 612 | begin 613 | inherited; 614 | if FOwner is TSVGImageList then 615 | TSVGImageList(FOwner).RecreateBitmaps; 616 | end; 617 | 618 | end. 619 | -------------------------------------------------------------------------------- /vcl/svgimage/SVGImagePackageD.dpk: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ekot1/DelphiSVG/0c2fc478d221a914c8ca1a15f0e65e282396000a/vcl/svgimage/SVGImagePackageD.dpk -------------------------------------------------------------------------------- /vcl/svgimage/SVGImagePackageD.dproj: -------------------------------------------------------------------------------- 1 |  2 | 3 | {B4EF66C9-50A0-473B-A3E2-04371F0E8F45} 4 | SVGImagePackageD.dpk 5 | True 6 | Debug 7 | 1 8 | Package 9 | VCL 10 | 18.8 11 | Win32 12 | 13 | 14 | true 15 | 16 | 17 | true 18 | Base 19 | true 20 | 21 | 22 | true 23 | Base 24 | true 25 | 26 | 27 | true 28 | Base 29 | true 30 | 31 | 32 | true 33 | Cfg_1 34 | true 35 | true 36 | 37 | 38 | true 39 | Base 40 | true 41 | 42 | 43 | true 44 | Cfg_2 45 | true 46 | true 47 | 48 | 49 | .\Output 50 | false 51 | false 52 | MWK - SVG-Unterstьtzung Designtime 53 | true 54 | SVGImagePackageD 55 | true 56 | false 57 | 1049 58 | false 59 | 00400000 60 | CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=;CFBundleName= 61 | false 62 | true 63 | 64 | 65 | xmlrtl;rtl;vclactnband;vclx;vcl;SVGPackage;SVGImagePackageR;$(DCC_UsePackage) 66 | 1033 67 | CompanyName=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(MSBuildProjectName);FileDescription=$(MSBuildProjectName);ProductName=$(MSBuildProjectName) 68 | true 69 | 70 | 71 | xmlrtl;rtl;vclactnband;vclx;vcl;$(DCC_UsePackage) 72 | 73 | 74 | 0 75 | false 76 | 0 77 | RELEASE;$(DCC_Define) 78 | 79 | 80 | 1033 81 | CompanyName=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(MSBuildProjectName);FileDescription=$(MSBuildProjectName);ProductName=$(MSBuildProjectName) 82 | true 83 | 84 | 85 | DEBUG;$(DCC_Define) 86 | false 87 | true 88 | 89 | 90 | 1033 91 | CompanyName=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(MSBuildProjectName);FileDescription=$(MSBuildProjectName);ProductName=$(MSBuildProjectName) 92 | true 93 | 94 | 95 | 96 | MainSource 97 | 98 | 99 | 100 | 101 | 102 | 103 | 104 | 105 | 106 | 107 |
ImageListEditor
108 | 109 | 110 | 111 | Cfg_2 112 | Base 113 | 114 | 115 | Base 116 | 117 | 118 | Cfg_1 119 | Base 120 | 121 | 122 | 123 | Delphi.Personality.12 124 | Package 125 | 126 | 127 | 128 | SVGImagePackageD.dpk 129 | 130 | 131 | Microsoft Office 2000 Sample Automation Server Wrapper Components 132 | Microsoft Office XP Sample Automation Server Wrapper Components 133 | 134 | 135 | 136 | True 137 | False 138 | 139 | 140 | 12 141 | 142 | 143 | 144 | 145 | -------------------------------------------------------------------------------- /vcl/svgimage/SVGImagePackageD.res: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ekot1/DelphiSVG/0c2fc478d221a914c8ca1a15f0e65e282396000a/vcl/svgimage/SVGImagePackageD.res -------------------------------------------------------------------------------- /vcl/svgimage/SVGImagePackageR.dpk: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ekot1/DelphiSVG/0c2fc478d221a914c8ca1a15f0e65e282396000a/vcl/svgimage/SVGImagePackageR.dpk -------------------------------------------------------------------------------- /vcl/svgimage/SVGImagePackageR.res: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ekot1/DelphiSVG/0c2fc478d221a914c8ca1a15f0e65e282396000a/vcl/svgimage/SVGImagePackageR.res -------------------------------------------------------------------------------- /vcl/svgimage/SVGImageRegister.pas: -------------------------------------------------------------------------------- 1 | unit SVGImageRegister; 2 | 3 | interface 4 | 5 | procedure Register; 6 | 7 | implementation 8 | 9 | uses 10 | System.Classes, 11 | SVGImage, SVGImageList, SVGSpeedButton; 12 | 13 | procedure Register; 14 | begin 15 | RegisterComponents('MWK', [TSVGImage, TSVGImageList, TSVGSpeedButton]); 16 | end; 17 | 18 | 19 | end. 20 | -------------------------------------------------------------------------------- /vcl/svgimage/SVGImgLstEditor.dfm: -------------------------------------------------------------------------------- 1 | object ImageListEditor: TImageListEditor 2 | Left = 392 3 | Top = 450 4 | ActiveControl = OkButton 5 | Caption = 'ImageListEditor' 6 | ClientHeight = 316 7 | ClientWidth = 547 8 | Color = clBtnFace 9 | Font.Charset = DEFAULT_CHARSET 10 | Font.Color = clWindowText 11 | Font.Height = -11 12 | Font.Name = 'MS Sans Serif' 13 | Font.Style = [] 14 | OldCreateOrder = True 15 | Position = poScreenCenter 16 | OnCreate = FormCreate 17 | OnDestroy = FormDestroy 18 | OnShow = FormShow 19 | DesignSize = ( 20 | 547 21 | 316) 22 | PixelsPerInch = 96 23 | TextHeight = 13 24 | object GroupBox1: TGroupBox 25 | Left = 8 26 | Top = 8 27 | Width = 435 28 | Height = 129 29 | Anchors = [akLeft, akTop, akRight] 30 | Caption = 'Graphic' 31 | TabOrder = 0 32 | DesignSize = ( 33 | 435 34 | 129) 35 | object Label1: TLabel 36 | Left = 128 37 | Top = 24 38 | Width = 31 39 | Height = 13 40 | Caption = 'Name:' 41 | end 42 | object ImagePanel: TPanel 43 | Left = 8 44 | Top = 16 45 | Width = 105 46 | Height = 105 47 | BevelOuter = bvNone 48 | BorderStyle = bsSingle 49 | Color = clWhite 50 | ParentBackground = False 51 | TabOrder = 0 52 | object ActImage: TImage 53 | Left = 7 54 | Top = 7 55 | Width = 89 56 | Height = 89 57 | Center = True 58 | Proportional = True 59 | Stretch = True 60 | Transparent = True 61 | end 62 | end 63 | object ImageName: TEdit 64 | Left = 128 65 | Top = 40 66 | Width = 291 67 | Height = 21 68 | Anchors = [akLeft, akTop, akRight] 69 | TabOrder = 1 70 | OnExit = ImageNameExit 71 | end 72 | end 73 | object GroupBox2: TGroupBox 74 | Left = 8 75 | Top = 144 76 | Width = 531 77 | Height = 129 78 | Anchors = [akLeft, akTop, akRight, akBottom] 79 | Caption = 'Pictures list' 80 | TabOrder = 1 81 | DesignSize = ( 82 | 531 83 | 129) 84 | object ListView1: TListView 85 | Left = 8 86 | Top = 16 87 | Width = 515 88 | Height = 105 89 | Anchors = [akLeft, akTop, akRight, akBottom] 90 | Columns = <> 91 | DragMode = dmAutomatic 92 | FullDrag = True 93 | HideSelection = False 94 | IconOptions.Arrangement = iaLeft 95 | IconOptions.AutoArrange = True 96 | LargeImages = SVGImageList1 97 | MultiSelect = True 98 | ReadOnly = True 99 | ShowWorkAreas = True 100 | TabOrder = 0 101 | OnDragDrop = ListView1DragDrop 102 | OnDragOver = ListView1DragOver 103 | OnSelectItem = ListView1SelectItem 104 | end 105 | end 106 | object OkButton: TButton 107 | Left = 450 108 | Top = 16 109 | Width = 89 110 | Height = 25 111 | Anchors = [akTop, akRight] 112 | Caption = '&Ok' 113 | Default = True 114 | ModalResult = 1 115 | TabOrder = 2 116 | OnClick = OkButtonClick 117 | end 118 | object CancelButton: TButton 119 | Left = 450 120 | Top = 48 121 | Width = 89 122 | Height = 25 123 | Anchors = [akTop, akRight] 124 | Cancel = True 125 | Caption = '&Cancel' 126 | ModalResult = 2 127 | TabOrder = 3 128 | end 129 | object ApplyButton: TButton 130 | Left = 450 131 | Top = 80 132 | Width = 89 133 | Height = 25 134 | Anchors = [akTop, akRight] 135 | Caption = 'A&pply' 136 | TabOrder = 4 137 | OnClick = ApplyButtonClick 138 | end 139 | object AddButton: TButton 140 | Left = 20 141 | Top = 279 142 | Width = 81 143 | Height = 25 144 | Anchors = [akBottom] 145 | Caption = '&Add...' 146 | TabOrder = 5 147 | OnClick = AddButtonClick 148 | end 149 | object DeleteButton: TButton 150 | Left = 231 151 | Top = 279 152 | Width = 81 153 | Height = 25 154 | Anchors = [akBottom] 155 | Caption = '&Delete' 156 | TabOrder = 6 157 | OnClick = DeleteButtonClick 158 | end 159 | object ClearButton: TButton 160 | Left = 336 161 | Top = 279 162 | Width = 81 163 | Height = 25 164 | Anchors = [akBottom] 165 | Caption = 'Empty' 166 | TabOrder = 7 167 | OnClick = ClearButtonClick 168 | end 169 | object ExportButton: TButton 170 | Left = 441 171 | Top = 279 172 | Width = 81 173 | Height = 25 174 | Anchors = [akBottom] 175 | Caption = '&Export...' 176 | TabOrder = 8 177 | OnClick = ExportButtonClick 178 | end 179 | object ReplaceButton: TButton 180 | Left = 125 181 | Top = 279 182 | Width = 81 183 | Height = 25 184 | Anchors = [akBottom] 185 | Caption = '&Replace...' 186 | TabOrder = 9 187 | OnClick = ReplaceButtonClick 188 | end 189 | object OpenPictureDialog1: TOpenPictureDialog 190 | Filter = 'Scalable Vector Graphics (*.svg)|*.svg' 191 | Options = [ofHideReadOnly, ofAllowMultiSelect, ofPathMustExist, ofFileMustExist, ofEnableSizing] 192 | Left = 24 193 | Top = 168 194 | end 195 | object SavePictureDialog1: TSavePictureDialog 196 | DefaultExt = 'svg' 197 | Filter = 'Scalable Vector Graphics (*.svg)|*.svg' 198 | Options = [ofHideReadOnly, ofPathMustExist, ofEnableSizing] 199 | Left = 56 200 | Top = 168 201 | end 202 | object SVGImageList1: TSVGImageList 203 | Opacity = 255 204 | Width = 32 205 | Height = 32 206 | Left = 96 207 | Top = 168 208 | Images = {00000000} 209 | end 210 | end 211 | -------------------------------------------------------------------------------- /vcl/svgimage/SVGImgLstEditor.pas: -------------------------------------------------------------------------------- 1 | unit SVGImgLstEditor; 2 | 3 | interface 4 | 5 | uses 6 | Winapi.Windows, Winapi.Messages, 7 | System.SysUtils, System.Variants, System.Classes, System.ImageList, 8 | Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.ComCtrls, Vcl.StdCtrls, Vcl.ImgList, 9 | Vcl.ExtDlgs, Vcl.ExtCtrls, 10 | DesignIntf, DesignEditors, 11 | SVGImageList; 12 | 13 | type 14 | TImageListEditor = class(TForm) 15 | GroupBox1: TGroupBox; 16 | GroupBox2: TGroupBox; 17 | ImagePanel: TPanel; 18 | Label1: TLabel; 19 | ImageName: TEdit; 20 | OkButton: TButton; 21 | CancelButton: TButton; 22 | ApplyButton: TButton; 23 | ListView1: TListView; 24 | AddButton: TButton; 25 | DeleteButton: TButton; 26 | ClearButton: TButton; 27 | ExportButton: TButton; 28 | OpenPictureDialog1: TOpenPictureDialog; 29 | SavePictureDialog1: TSavePictureDialog; 30 | ActImage: TImage; 31 | SVGImageList1: TSVGImageList; 32 | ReplaceButton: TButton; 33 | procedure FormCreate(Sender: TObject); 34 | procedure ApplyButtonClick(Sender: TObject); 35 | procedure ClearButtonClick(Sender: TObject); 36 | procedure AddButtonClick(Sender: TObject); 37 | procedure DeleteButtonClick(Sender: TObject); 38 | procedure ListView1SelectItem(Sender: TObject; Item: TListItem; 39 | Selected: Boolean); 40 | procedure ExportButtonClick(Sender: TObject); 41 | procedure OkButtonClick(Sender: TObject); 42 | procedure FormDestroy(Sender: TObject); 43 | procedure ImageNameExit(Sender: TObject); 44 | procedure FormShow(Sender: TObject); 45 | procedure ListView1DragOver(Sender, Source: TObject; X, Y: Integer; 46 | State: TDragState; var Accept: Boolean); 47 | procedure ListView1DragDrop(Sender, Source: TObject; X, Y: Integer); 48 | procedure ReplaceButtonClick(Sender: TObject); 49 | private 50 | FImages: TSVGCollectionItems; 51 | FComponentList: TSVGImageList; 52 | FChanged: Boolean; 53 | FModified: Boolean; 54 | 55 | procedure BuildList(Selected: Integer); 56 | procedure PaintActive; 57 | procedure Apply; 58 | public 59 | constructor CreateImgListEditor(AOwner: TComponent; 60 | ASVGImgList: TSVGImageList); 61 | property Modified: Boolean read FModified; 62 | end; 63 | 64 | TSVGImageListProperty = class(TClassProperty) 65 | public 66 | procedure Edit; override; 67 | function GetAttributes: TPropertyAttributes; override; 68 | function GetValue: string; override; 69 | end; 70 | 71 | TSVGImageListEditor = class(TDefaultEditor) 72 | protected 73 | procedure EditProperty(const PropertyEditor: IProperty; 74 | var Continue: Boolean); override; 75 | end; 76 | 77 | procedure Register; 78 | 79 | implementation 80 | 81 | {$R *.dfm} 82 | 83 | uses 84 | Winapi.GDIPAPI, 85 | SVG, SVGImage; 86 | 87 | procedure Register; 88 | begin 89 | RegisterComponentEditor(TSVGImageList, TSVGImageListEditor); 90 | 91 | RegisterPropertyEditor(TypeInfo(TSVGCollectionItems), TSVGImageList, 'Items', TSVGImageListProperty); 92 | end; 93 | 94 | procedure TImageListEditor.FormCreate(Sender: TObject); 95 | begin 96 | ApplyButton.Enabled := False; 97 | ImageName.Enabled := False; 98 | DeleteButton.Enabled := False; 99 | ExportButton.Enabled := False; 100 | FImages := TSVGCollectionItems.Create(Self); 101 | FChanged := False; 102 | FModified := False; 103 | end; 104 | 105 | procedure TImageListEditor.ApplyButtonClick(Sender: TObject); 106 | begin 107 | ApplyButton.Enabled := False; 108 | Apply; 109 | end; 110 | 111 | procedure TImageListEditor.ClearButtonClick(Sender: TObject); 112 | begin 113 | ApplyButton.Enabled := True; 114 | ImageName.Enabled := False; 115 | ImageName.Text := ''; 116 | ListView1.Clear; 117 | ActImage.Picture := nil; 118 | SVGImageList1.Clear; 119 | FChanged := True; 120 | FImages.Clear; 121 | ClearButton.Enabled := FImages.Count > 0; 122 | end; 123 | 124 | procedure TImageListEditor.AddButtonClick(Sender: TObject); 125 | var 126 | C: Integer; 127 | SVG: TSVG; 128 | FileName: string; 129 | Item: TSVGCollectionItem; 130 | begin 131 | if OpenPictureDialog1.Execute then 132 | begin 133 | ApplyButton.Enabled := True; 134 | SVG := TSVG.Create; 135 | for C := 0 to OpenPictureDialog1.Files.Count - 1 do 136 | begin 137 | FileName := ChangeFileExt(ExtractFileName(OpenPictureDialog1.Files[C]), ''); 138 | try 139 | SVG.LoadFromFile(OpenPictureDialog1.Files[C]); 140 | Item := FImages.Add; 141 | Item.Name := FileName; 142 | Item.SVG := SVG; 143 | FChanged := True; 144 | finally 145 | end; 146 | end; 147 | SVG.Free; 148 | BuildList(MaxInt); 149 | ClearButton.Enabled := FImages.Count > 0; 150 | end; 151 | end; 152 | 153 | procedure TImageListEditor.DeleteButtonClick(Sender: TObject); 154 | var 155 | C: Integer; 156 | Selected: Integer; 157 | begin 158 | ApplyButton.Enabled := True; 159 | DeleteButton.Enabled := ListView1.SelCount > 0; 160 | ReplaceButton.Enabled := ListView1.SelCount = 1; 161 | 162 | Selected := ListView1.ItemIndex; 163 | for C := ListView1.Items.Count - 1 downto 0 do 164 | if ListView1.Items[C].Selected then 165 | FImages.Delete(C); 166 | 167 | FChanged := True; 168 | BuildList(Selected); 169 | ClearButton.Enabled := FImages.Count > 0; 170 | PaintActive; 171 | end; 172 | 173 | procedure TImageListEditor.ListView1DragDrop(Sender, Source: TObject; X, 174 | Y: Integer); 175 | var 176 | Target: TListItem; 177 | Item: TCollectionItem; 178 | SIndex, DIndex: Integer; 179 | begin 180 | SIndex := ListView1.ItemIndex; 181 | Target := ListView1.GetItemAt(X, Y); 182 | if Target = nil then 183 | Target := ListView1.GetNearestItem(Point(X, Y), sdRight); 184 | 185 | if Assigned(Target) then 186 | DIndex := ListView1.Items.IndexOf(Target) 187 | else 188 | DIndex := ListView1.Items.Count - 1; 189 | 190 | Item := FImages[SIndex]; 191 | Item.Index := DIndex; 192 | BuildList(Item.Index); 193 | if SIndex <> DIndex then 194 | begin 195 | FChanged := True; 196 | ApplyButton.Enabled := True; 197 | end; 198 | end; 199 | 200 | procedure TImageListEditor.ListView1DragOver(Sender, Source: TObject; X, 201 | Y: Integer; State: TDragState; var Accept: Boolean); 202 | begin 203 | Accept := Source = Sender; 204 | end; 205 | 206 | procedure TImageListEditor.ListView1SelectItem(Sender: TObject; 207 | Item: TListItem; Selected: Boolean); 208 | begin 209 | DeleteButton.Enabled := ListView1.SelCount > 0; 210 | ReplaceButton.Enabled := ListView1.SelCount = 1; 211 | PaintActive; 212 | ExportButton.Enabled := ListView1.SelCount = 1; 213 | end; 214 | 215 | procedure TImageListEditor.PaintActive; 216 | var 217 | SVGGraphic: TSVGGraphic; 218 | begin 219 | if ListView1.SelCount <> 1 then 220 | begin 221 | ActImage.Picture := nil; 222 | ImageName.Text := ''; 223 | ImageName.Enabled := False; 224 | Exit; 225 | end; 226 | 227 | ActImage.Picture := nil; 228 | ActImage.Repaint; 229 | ImageName.Text := ListView1.Selected.Caption; 230 | ImageName.Enabled := True; 231 | SVGGraphic := TSVGGraphic.Create; 232 | SVGGraphic.AssignSVG(FImages[ListView1.ItemIndex].SVG); 233 | ActImage.Picture.Assign(SVGGraphic); 234 | SVGGraphic.Free; 235 | end; 236 | 237 | procedure TImageListEditor.ReplaceButtonClick(Sender: TObject); 238 | var 239 | C: Integer; 240 | SVG: TSVG; 241 | FileName: string; 242 | Item: TSVGCollectionItem; 243 | begin 244 | if OpenPictureDialog1.Execute then 245 | begin 246 | ApplyButton.Enabled := True; 247 | SVG := TSVG.Create; 248 | for C := 0 to OpenPictureDialog1.Files.Count - 1 do 249 | begin 250 | FileName := ChangeFileExt(ExtractFileName(OpenPictureDialog1.Files[C]), ''); 251 | try 252 | SVG.LoadFromFile(OpenPictureDialog1.Files[C]); 253 | Item := FImages[ListView1.ItemIndex]; 254 | Item.Name := FileName; 255 | Item.SVG := SVG; 256 | FChanged := True; 257 | finally 258 | end; 259 | end; 260 | SVG.Free; 261 | BuildList(MaxInt); 262 | ClearButton.Enabled := FImages.Count > 0; 263 | end; 264 | end; 265 | 266 | procedure TImageListEditor.BuildList(Selected: Integer); 267 | var 268 | C: Integer; 269 | LI: TListItem; 270 | begin 271 | ListView1.Clear; 272 | SVGImageList1.Clear; 273 | for C := 0 to FImages.Count - 1 do 274 | begin 275 | SVGImageList1.Add(FImages[C].SVG, FImages[C].Name); 276 | LI := ListView1.Items.Add; 277 | LI.ImageIndex := C; 278 | LI.Caption := FImages[C].Name; 279 | end; 280 | 281 | if Selected < -1 then 282 | Selected := -1; 283 | if Selected >= FImages.Count then 284 | Selected := FImages.Count - 1; 285 | 286 | ListView1.ItemIndex := Selected; 287 | end; 288 | 289 | procedure TImageListEditor.ExportButtonClick(Sender: TObject); 290 | begin 291 | if SavePictureDialog1.Execute then 292 | FImages[ListView1.ItemIndex].SVG.SaveToFile(SavePictureDialog1.FileName); 293 | end; 294 | 295 | procedure TImageListEditor.Apply; 296 | begin 297 | if not FChanged then 298 | Exit; 299 | FComponentList.Items.Assign(FImages); 300 | FChanged := False; 301 | FModified := True; 302 | end; 303 | 304 | constructor TImageListEditor.CreateImgListEditor(AOwner: TComponent; 305 | ASVGImgList: TSVGImageList); 306 | begin 307 | inherited Create(AOwner); 308 | FComponentList := ASVGImgList; 309 | end; 310 | 311 | procedure TImageListEditor.OkButtonClick(Sender: TObject); 312 | begin 313 | Apply; 314 | end; 315 | 316 | procedure TImageListEditor.FormDestroy(Sender: TObject); 317 | begin 318 | FImages.Free; 319 | end; 320 | 321 | { TSVGImageListPropertity } 322 | 323 | procedure TSVGImageListProperty.Edit; 324 | var 325 | Editor: TImageListEditor; 326 | SVGImageList: TSVGImageList; 327 | begin 328 | SVGImageList := TSVGImageList(GetComponent(0)); 329 | Editor := TImageListEditor.CreateImgListEditor(Application, SVGImageList); 330 | try 331 | Editor.ShowModal; 332 | if Editor.Modified then 333 | Modified; 334 | finally 335 | Editor.Free; 336 | end; 337 | end; 338 | 339 | function TSVGImageListProperty.GetAttributes: TPropertyAttributes; 340 | begin 341 | Result := inherited GetAttributes + [paDialog, paReadOnly]; 342 | end; 343 | 344 | function TSVGImageListProperty.GetValue: string; 345 | begin 346 | Result := 'SVGImages'; 347 | end; 348 | 349 | { TSVGImageListEditor } 350 | 351 | procedure TSVGImageListEditor.EditProperty(const PropertyEditor: IProperty; 352 | var Continue: Boolean); 353 | var 354 | PropName: string; 355 | begin 356 | PropName := PropertyEditor.GetName; 357 | if (CompareText(PropName, 'Items') = 0) then 358 | begin 359 | PropertyEditor.Edit; 360 | Continue := False; 361 | end; 362 | end; 363 | 364 | 365 | procedure TImageListEditor.ImageNameExit(Sender: TObject); 366 | begin 367 | if FImages[ListView1.ItemIndex].Name <> ImageName.Text then 368 | begin 369 | FChanged := True; 370 | FImages[ListView1.ItemIndex].Name := ImageName.Text; 371 | ListView1.Selected.Caption := ImageName.Text; 372 | ApplyButton.Enabled := True; 373 | end; 374 | end; 375 | 376 | procedure TImageListEditor.FormShow(Sender: TObject); 377 | begin 378 | FImages.Assign(FComponentList.Items); 379 | 380 | BuildList(0); 381 | ClearButton.Enabled := FImages.Count > 0; 382 | end; 383 | 384 | end. 385 | -------------------------------------------------------------------------------- /vcl/svgimage/SVGSpeedButton.pas: -------------------------------------------------------------------------------- 1 | unit SVGSpeedButton; 2 | 3 | interface 4 | 5 | uses 6 | System.Classes, VCL.Buttons, SVG; 7 | 8 | type 9 | TSVGSpeedButton = class(TSpeedButton) 10 | private 11 | FSVG: TSVG; 12 | function GetSVG: TSVG; 13 | procedure SetSVG(const Value: TSVG); 14 | protected 15 | procedure Paint; override; 16 | public 17 | constructor Create(AOwner: TComponent); override; 18 | destructor Destroy; override; 19 | published 20 | property SVG: TSVG read GetSVG write SetSVG; 21 | end; 22 | 23 | implementation 24 | 25 | uses 26 | Winapi.Windows, 27 | Vcl.Themes, Vcl.Controls, Vcl.ActnList, Vcl.Graphics, 28 | SVGImageList, 29 | Winapi.GDIPAPI, GDIPUtils, 30 | System.Types, System.Math; 31 | 32 | { TSVGSpeedButton } 33 | 34 | constructor TSVGSpeedButton.Create(AOwner: TComponent); 35 | begin 36 | inherited; 37 | FSVG := TSVG.Create; 38 | end; 39 | 40 | destructor TSVGSpeedButton.Destroy; 41 | begin 42 | FSVG.Free; 43 | inherited; 44 | end; 45 | 46 | function TSVGSpeedButton.GetSVG: TSVG; 47 | begin 48 | Result := FSVG; 49 | end; 50 | 51 | procedure TSVGSpeedButton.Paint; 52 | const 53 | DownStyles: array[Boolean] of Integer = (BDR_RAISEDINNER, BDR_SUNKENOUTER); 54 | FillStyles: array[Boolean] of Integer = (BF_MIDDLE, 0); 55 | var 56 | PaintRect: TRect; 57 | DrawFlags: Integer; 58 | Offset: TPoint; 59 | Button: TThemedButton; 60 | ToolButton: TThemedToolBar; 61 | Details: TThemedElementDetails; 62 | Image: TSVG; 63 | FMargin: Integer; 64 | R: TGPRectF; 65 | begin 66 | if Assigned(Action) and (Action is TCustomAction) and 67 | (TCustomAction(Action).ImageIndex <> -1) and 68 | (TCustomAction(Action).ActionList.Images is TSVGImageList) then 69 | Image := TSVGImageList(TCustomAction(Action).ActionList.Images).Images[TCustomAction(Action).ImageIndex] 70 | else 71 | Image := FSVG; 72 | 73 | if not Enabled then 74 | begin 75 | FState := bsDisabled; 76 | end 77 | else if FState = bsDisabled then 78 | if Down and (GroupIndex <> 0) then 79 | FState := bsExclusive 80 | else 81 | FState := bsUp; 82 | 83 | if StyleServices.Enabled then 84 | begin 85 | //PerformEraseBackground(Self, Canvas.Handle); 86 | 87 | if not Enabled then 88 | Button := tbPushButtonDisabled 89 | else 90 | if FState in [bsDown, bsExclusive] then 91 | Button := tbPushButtonPressed 92 | else 93 | if MouseInControl then 94 | Button := tbPushButtonHot 95 | else 96 | Button := tbPushButtonNormal; 97 | 98 | ToolButton := ttbToolbarDontCare; 99 | if Flat then 100 | begin 101 | case Button of 102 | tbPushButtonDisabled: 103 | Toolbutton := ttbButtonDisabled; 104 | tbPushButtonPressed: 105 | Toolbutton := ttbButtonPressed; 106 | tbPushButtonHot: 107 | Toolbutton := ttbButtonHot; 108 | tbPushButtonNormal: 109 | Toolbutton := ttbButtonNormal; 110 | end; 111 | end; 112 | 113 | PaintRect := ClientRect; 114 | if ToolButton = ttbToolbarDontCare then 115 | begin 116 | Details := StyleServices.GetElementDetails(Button); 117 | StyleServices.DrawElement(Canvas.Handle, Details, PaintRect); 118 | StyleServices.GetElementContentRect(Canvas.Handle, Details, ClientRect, PaintRect); 119 | end 120 | else 121 | begin 122 | Details := StyleServices.GetElementDetails(ToolButton); 123 | StyleServices.DrawElement(Canvas.Handle, Details, PaintRect); 124 | StyleServices.GetElementContentRect(Canvas.Handle, Details, ClientRect, PaintRect); 125 | end; 126 | 127 | // A pressed speed button has a white text. This applies however only to flat buttons. 128 | Offset := Point(IfThen(Button = tbPushButtonPressed, 1, 0), 0); 129 | end 130 | else 131 | begin 132 | PaintRect := Rect(0, 0, Width, Height); 133 | if not Flat then 134 | begin 135 | DrawFlags := DFCS_BUTTONPUSH or DFCS_ADJUSTRECT; 136 | if FState in [bsDown, bsExclusive] then 137 | DrawFlags := DrawFlags or DFCS_PUSHED; 138 | DrawFrameControl(Canvas.Handle, PaintRect, DFC_BUTTON, DrawFlags); 139 | end 140 | else 141 | begin 142 | if (FState in [bsDown, bsExclusive]) or 143 | (MouseInControl and (FState <> bsDisabled)) or 144 | (csDesigning in ComponentState) then 145 | DrawEdge(Canvas.Handle, PaintRect, DownStyles[FState in [bsDown, bsExclusive]], 146 | FillStyles[Transparent] or BF_RECT) 147 | else if not Transparent then 148 | begin 149 | Canvas.Brush.Color := Color; 150 | Canvas.FillRect(PaintRect); 151 | end; 152 | InflateRect(PaintRect, -1, -1); 153 | end; 154 | if FState in [bsDown, bsExclusive] then 155 | begin 156 | if (FState = bsExclusive) and (not Flat or not MouseInControl) then 157 | begin 158 | Canvas.Brush.Bitmap := AllocPatternBitmap(clBtnFace, clBtnHighlight); 159 | Canvas.FillRect(PaintRect); 160 | end; 161 | Offset.X := 1; 162 | Offset.Y := 1; 163 | end 164 | else 165 | begin 166 | Offset.X := 0; 167 | Offset.Y := 0; 168 | end; 169 | end; 170 | 171 | if Assigned(Image) then 172 | begin 173 | FMargin := 2 + Margin; 174 | R.X := PaintRect.Left + Margin + Offset.X + 1; 175 | R.Y := PaintRect.Top + Margin + Offset.Y + 1; 176 | R.Width := (PaintRect.Right - PaintRect.Left + 1) - 2 * FMargin; 177 | R.Height := (PaintRect.Bottom - PaintRect.Top + 1) - 2 * FMargin; 178 | R := CalcRect(R, Image.Width, Image.Height, baCenterCenter); 179 | Image.PaintTo(Canvas.Handle, R, nil, 0); 180 | end; 181 | end; 182 | 183 | procedure TSVGSpeedButton.SetSVG(const Value: TSVG); 184 | begin 185 | FSVG.LoadFromText(Value.Source); 186 | Invalidate; 187 | end; 188 | 189 | end. 190 | --------------------------------------------------------------------------------