├── LICENSE ├── README.md ├── fontfinder.pas ├── fpreadjpegthumb.pas ├── fpthumbresize.pas ├── images.lrs ├── scrollingcontrol.pas ├── threadedimageloader.pas ├── thumbcontrol.pas ├── thumbctrl.lpk ├── thumbctrl.lrs └── thumbctrl.pas /LICENSE: -------------------------------------------------------------------------------- 1 | GNU LESSER GENERAL PUBLIC LICENSE 2 | Version 2.1, February 1999 3 | 4 | Copyright (C) 1991, 1999 Free Software Foundation, Inc. 5 | 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA 6 | Everyone is permitted to copy and distribute verbatim copies 7 | of this license document, but changing it is not allowed. 8 | 9 | [This is the first released version of the Lesser GPL. It also counts 10 | as the successor of the GNU Library Public License, version 2, hence 11 | the version number 2.1.] 12 | 13 | Preamble 14 | 15 | The licenses for most software are designed to take away your 16 | freedom to share and change it. By contrast, the GNU General Public 17 | Licenses are intended to guarantee your freedom to share and change 18 | free software--to make sure the software is free for all its users. 19 | 20 | This license, the Lesser General Public License, applies to some 21 | specially designated software packages--typically libraries--of the 22 | Free Software Foundation and other authors who decide to use it. You 23 | can use it too, but we suggest you first think carefully about whether 24 | this license or the ordinary General Public License is the better 25 | strategy to use in any particular case, based on the explanations below. 26 | 27 | When we speak of free software, we are referring to freedom of use, 28 | not price. Our General Public Licenses are designed to make sure that 29 | you have the freedom to distribute copies of free software (and charge 30 | for this service if you wish); that you receive source code or can get 31 | it if you want it; that you can change the software and use pieces of 32 | it in new free programs; and that you are informed that you can do 33 | these things. 34 | 35 | To protect your rights, we need to make restrictions that forbid 36 | distributors to deny you these rights or to ask you to surrender these 37 | rights. These restrictions translate to certain responsibilities for 38 | you if you distribute copies of the library or if you modify it. 39 | 40 | For example, if you distribute copies of the library, whether gratis 41 | or for a fee, you must give the recipients all the rights that we gave 42 | you. You must make sure that they, too, receive or can get the source 43 | code. If you link other code with the library, you must provide 44 | complete object files to the recipients, so that they can relink them 45 | with the library after making changes to the library and recompiling 46 | it. And you must show them these terms so they know their rights. 47 | 48 | We protect your rights with a two-step method: (1) we copyright the 49 | library, and (2) we offer you this license, which gives you legal 50 | permission to copy, distribute and/or modify the library. 51 | 52 | To protect each distributor, we want to make it very clear that 53 | there is no warranty for the free library. Also, if the library is 54 | modified by someone else and passed on, the recipients should know 55 | that what they have is not the original version, so that the original 56 | author's reputation will not be affected by problems that might be 57 | introduced by others. 58 | 59 | Finally, software patents pose a constant threat to the existence of 60 | any free program. We wish to make sure that a company cannot 61 | effectively restrict the users of a free program by obtaining a 62 | restrictive license from a patent holder. Therefore, we insist that 63 | any patent license obtained for a version of the library must be 64 | consistent with the full freedom of use specified in this license. 65 | 66 | Most GNU software, including some libraries, is covered by the 67 | ordinary GNU General Public License. This license, the GNU Lesser 68 | General Public License, applies to certain designated libraries, and 69 | is quite different from the ordinary General Public License. We use 70 | this license for certain libraries in order to permit linking those 71 | libraries into non-free programs. 72 | 73 | When a program is linked with a library, whether statically or using 74 | a shared library, the combination of the two is legally speaking a 75 | combined work, a derivative of the original library. The ordinary 76 | General Public License therefore permits such linking only if the 77 | entire combination fits its criteria of freedom. The Lesser General 78 | Public License permits more lax criteria for linking other code with 79 | the library. 80 | 81 | We call this license the "Lesser" General Public License because it 82 | does Less to protect the user's freedom than the ordinary General 83 | Public License. It also provides other free software developers Less 84 | of an advantage over competing non-free programs. These disadvantages 85 | are the reason we use the ordinary General Public License for many 86 | libraries. However, the Lesser license provides advantages in certain 87 | special circumstances. 88 | 89 | For example, on rare occasions, there may be a special need to 90 | encourage the widest possible use of a certain library, so that it becomes 91 | a de-facto standard. To achieve this, non-free programs must be 92 | allowed to use the library. A more frequent case is that a free 93 | library does the same job as widely used non-free libraries. In this 94 | case, there is little to gain by limiting the free library to free 95 | software only, so we use the Lesser General Public License. 96 | 97 | In other cases, permission to use a particular library in non-free 98 | programs enables a greater number of people to use a large body of 99 | free software. For example, permission to use the GNU C Library in 100 | non-free programs enables many more people to use the whole GNU 101 | operating system, as well as its variant, the GNU/Linux operating 102 | system. 103 | 104 | Although the Lesser General Public License is Less protective of the 105 | users' freedom, it does ensure that the user of a program that is 106 | linked with the Library has the freedom and the wherewithal to run 107 | that program using a modified version of the Library. 108 | 109 | The precise terms and conditions for copying, distribution and 110 | modification follow. Pay close attention to the difference between a 111 | "work based on the library" and a "work that uses the library". The 112 | former contains code derived from the library, whereas the latter must 113 | be combined with the library in order to run. 114 | 115 | GNU LESSER GENERAL PUBLIC LICENSE 116 | TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 117 | 118 | 0. This License Agreement applies to any software library or other 119 | program which contains a notice placed by the copyright holder or 120 | other authorized party saying it may be distributed under the terms of 121 | this Lesser General Public License (also called "this License"). 122 | Each licensee is addressed as "you". 123 | 124 | A "library" means a collection of software functions and/or data 125 | prepared so as to be conveniently linked with application programs 126 | (which use some of those functions and data) to form executables. 127 | 128 | The "Library", below, refers to any such software library or work 129 | which has been distributed under these terms. A "work based on the 130 | Library" means either the Library or any derivative work under 131 | copyright law: that is to say, a work containing the Library or a 132 | portion of it, either verbatim or with modifications and/or translated 133 | straightforwardly into another language. (Hereinafter, translation is 134 | included without limitation in the term "modification".) 135 | 136 | "Source code" for a work means the preferred form of the work for 137 | making modifications to it. For a library, complete source code means 138 | all the source code for all modules it contains, plus any associated 139 | interface definition files, plus the scripts used to control compilation 140 | and installation of the library. 141 | 142 | Activities other than copying, distribution and modification are not 143 | covered by this License; they are outside its scope. The act of 144 | running a program using the Library is not restricted, and output from 145 | such a program is covered only if its contents constitute a work based 146 | on the Library (independent of the use of the Library in a tool for 147 | writing it). Whether that is true depends on what the Library does 148 | and what the program that uses the Library does. 149 | 150 | 1. You may copy and distribute verbatim copies of the Library's 151 | complete source code as you receive it, in any medium, provided that 152 | you conspicuously and appropriately publish on each copy an 153 | appropriate copyright notice and disclaimer of warranty; keep intact 154 | all the notices that refer to this License and to the absence of any 155 | warranty; and distribute a copy of this License along with the 156 | Library. 157 | 158 | You may charge a fee for the physical act of transferring a copy, 159 | and you may at your option offer warranty protection in exchange for a 160 | fee. 161 | 162 | 2. You may modify your copy or copies of the Library or any portion 163 | of it, thus forming a work based on the Library, and copy and 164 | distribute such modifications or work under the terms of Section 1 165 | above, provided that you also meet all of these conditions: 166 | 167 | a) The modified work must itself be a software library. 168 | 169 | b) You must cause the files modified to carry prominent notices 170 | stating that you changed the files and the date of any change. 171 | 172 | c) You must cause the whole of the work to be licensed at no 173 | charge to all third parties under the terms of this License. 174 | 175 | d) If a facility in the modified Library refers to a function or a 176 | table of data to be supplied by an application program that uses 177 | the facility, other than as an argument passed when the facility 178 | is invoked, then you must make a good faith effort to ensure that, 179 | in the event an application does not supply such function or 180 | table, the facility still operates, and performs whatever part of 181 | its purpose remains meaningful. 182 | 183 | (For example, a function in a library to compute square roots has 184 | a purpose that is entirely well-defined independent of the 185 | application. Therefore, Subsection 2d requires that any 186 | application-supplied function or table used by this function must 187 | be optional: if the application does not supply it, the square 188 | root function must still compute square roots.) 189 | 190 | These requirements apply to the modified work as a whole. If 191 | identifiable sections of that work are not derived from the Library, 192 | and can be reasonably considered independent and separate works in 193 | themselves, then this License, and its terms, do not apply to those 194 | sections when you distribute them as separate works. But when you 195 | distribute the same sections as part of a whole which is a work based 196 | on the Library, the distribution of the whole must be on the terms of 197 | this License, whose permissions for other licensees extend to the 198 | entire whole, and thus to each and every part regardless of who wrote 199 | it. 200 | 201 | Thus, it is not the intent of this section to claim rights or contest 202 | your rights to work written entirely by you; rather, the intent is to 203 | exercise the right to control the distribution of derivative or 204 | collective works based on the Library. 205 | 206 | In addition, mere aggregation of another work not based on the Library 207 | with the Library (or with a work based on the Library) on a volume of 208 | a storage or distribution medium does not bring the other work under 209 | the scope of this License. 210 | 211 | 3. You may opt to apply the terms of the ordinary GNU General Public 212 | License instead of this License to a given copy of the Library. To do 213 | this, you must alter all the notices that refer to this License, so 214 | that they refer to the ordinary GNU General Public License, version 2, 215 | instead of to this License. (If a newer version than version 2 of the 216 | ordinary GNU General Public License has appeared, then you can specify 217 | that version instead if you wish.) Do not make any other change in 218 | these notices. 219 | 220 | Once this change is made in a given copy, it is irreversible for 221 | that copy, so the ordinary GNU General Public License applies to all 222 | subsequent copies and derivative works made from that copy. 223 | 224 | This option is useful when you wish to copy part of the code of 225 | the Library into a program that is not a library. 226 | 227 | 4. You may copy and distribute the Library (or a portion or 228 | derivative of it, under Section 2) in object code or executable form 229 | under the terms of Sections 1 and 2 above provided that you accompany 230 | it with the complete corresponding machine-readable source code, which 231 | must be distributed under the terms of Sections 1 and 2 above on a 232 | medium customarily used for software interchange. 233 | 234 | If distribution of object code is made by offering access to copy 235 | from a designated place, then offering equivalent access to copy the 236 | source code from the same place satisfies the requirement to 237 | distribute the source code, even though third parties are not 238 | compelled to copy the source along with the object code. 239 | 240 | 5. A program that contains no derivative of any portion of the 241 | Library, but is designed to work with the Library by being compiled or 242 | linked with it, is called a "work that uses the Library". Such a 243 | work, in isolation, is not a derivative work of the Library, and 244 | therefore falls outside the scope of this License. 245 | 246 | However, linking a "work that uses the Library" with the Library 247 | creates an executable that is a derivative of the Library (because it 248 | contains portions of the Library), rather than a "work that uses the 249 | library". The executable is therefore covered by this License. 250 | Section 6 states terms for distribution of such executables. 251 | 252 | When a "work that uses the Library" uses material from a header file 253 | that is part of the Library, the object code for the work may be a 254 | derivative work of the Library even though the source code is not. 255 | Whether this is true is especially significant if the work can be 256 | linked without the Library, or if the work is itself a library. The 257 | threshold for this to be true is not precisely defined by law. 258 | 259 | If such an object file uses only numerical parameters, data 260 | structure layouts and accessors, and small macros and small inline 261 | functions (ten lines or less in length), then the use of the object 262 | file is unrestricted, regardless of whether it is legally a derivative 263 | work. (Executables containing this object code plus portions of the 264 | Library will still fall under Section 6.) 265 | 266 | Otherwise, if the work is a derivative of the Library, you may 267 | distribute the object code for the work under the terms of Section 6. 268 | Any executables containing that work also fall under Section 6, 269 | whether or not they are linked directly with the Library itself. 270 | 271 | 6. As an exception to the Sections above, you may also combine or 272 | link a "work that uses the Library" with the Library to produce a 273 | work containing portions of the Library, and distribute that work 274 | under terms of your choice, provided that the terms permit 275 | modification of the work for the customer's own use and reverse 276 | engineering for debugging such modifications. 277 | 278 | You must give prominent notice with each copy of the work that the 279 | Library is used in it and that the Library and its use are covered by 280 | this License. You must supply a copy of this License. If the work 281 | during execution displays copyright notices, you must include the 282 | copyright notice for the Library among them, as well as a reference 283 | directing the user to the copy of this License. Also, you must do one 284 | of these things: 285 | 286 | a) Accompany the work with the complete corresponding 287 | machine-readable source code for the Library including whatever 288 | changes were used in the work (which must be distributed under 289 | Sections 1 and 2 above); and, if the work is an executable linked 290 | with the Library, with the complete machine-readable "work that 291 | uses the Library", as object code and/or source code, so that the 292 | user can modify the Library and then relink to produce a modified 293 | executable containing the modified Library. (It is understood 294 | that the user who changes the contents of definitions files in the 295 | Library will not necessarily be able to recompile the application 296 | to use the modified definitions.) 297 | 298 | b) Use a suitable shared library mechanism for linking with the 299 | Library. A suitable mechanism is one that (1) uses at run time a 300 | copy of the library already present on the user's computer system, 301 | rather than copying library functions into the executable, and (2) 302 | will operate properly with a modified version of the library, if 303 | the user installs one, as long as the modified version is 304 | interface-compatible with the version that the work was made with. 305 | 306 | c) Accompany the work with a written offer, valid for at 307 | least three years, to give the same user the materials 308 | specified in Subsection 6a, above, for a charge no more 309 | than the cost of performing this distribution. 310 | 311 | d) If distribution of the work is made by offering access to copy 312 | from a designated place, offer equivalent access to copy the above 313 | specified materials from the same place. 314 | 315 | e) Verify that the user has already received a copy of these 316 | materials or that you have already sent this user a copy. 317 | 318 | For an executable, the required form of the "work that uses the 319 | Library" must include any data and utility programs needed for 320 | reproducing the executable from it. However, as a special exception, 321 | the materials to be distributed need not include anything that is 322 | normally distributed (in either source or binary form) with the major 323 | components (compiler, kernel, and so on) of the operating system on 324 | which the executable runs, unless that component itself accompanies 325 | the executable. 326 | 327 | It may happen that this requirement contradicts the license 328 | restrictions of other proprietary libraries that do not normally 329 | accompany the operating system. Such a contradiction means you cannot 330 | use both them and the Library together in an executable that you 331 | distribute. 332 | 333 | 7. You may place library facilities that are a work based on the 334 | Library side-by-side in a single library together with other library 335 | facilities not covered by this License, and distribute such a combined 336 | library, provided that the separate distribution of the work based on 337 | the Library and of the other library facilities is otherwise 338 | permitted, and provided that you do these two things: 339 | 340 | a) Accompany the combined library with a copy of the same work 341 | based on the Library, uncombined with any other library 342 | facilities. This must be distributed under the terms of the 343 | Sections above. 344 | 345 | b) Give prominent notice with the combined library of the fact 346 | that part of it is a work based on the Library, and explaining 347 | where to find the accompanying uncombined form of the same work. 348 | 349 | 8. You may not copy, modify, sublicense, link with, or distribute 350 | the Library except as expressly provided under this License. Any 351 | attempt otherwise to copy, modify, sublicense, link with, or 352 | distribute the Library is void, and will automatically terminate your 353 | rights under this License. However, parties who have received copies, 354 | or rights, from you under this License will not have their licenses 355 | terminated so long as such parties remain in full compliance. 356 | 357 | 9. You are not required to accept this License, since you have not 358 | signed it. However, nothing else grants you permission to modify or 359 | distribute the Library or its derivative works. These actions are 360 | prohibited by law if you do not accept this License. Therefore, by 361 | modifying or distributing the Library (or any work based on the 362 | Library), you indicate your acceptance of this License to do so, and 363 | all its terms and conditions for copying, distributing or modifying 364 | the Library or works based on it. 365 | 366 | 10. Each time you redistribute the Library (or any work based on the 367 | Library), the recipient automatically receives a license from the 368 | original licensor to copy, distribute, link with or modify the Library 369 | subject to these terms and conditions. You may not impose any further 370 | restrictions on the recipients' exercise of the rights granted herein. 371 | You are not responsible for enforcing compliance by third parties with 372 | this License. 373 | 374 | 11. If, as a consequence of a court judgment or allegation of patent 375 | infringement or for any other reason (not limited to patent issues), 376 | conditions are imposed on you (whether by court order, agreement or 377 | otherwise) that contradict the conditions of this License, they do not 378 | excuse you from the conditions of this License. If you cannot 379 | distribute so as to satisfy simultaneously your obligations under this 380 | License and any other pertinent obligations, then as a consequence you 381 | may not distribute the Library at all. For example, if a patent 382 | license would not permit royalty-free redistribution of the Library by 383 | all those who receive copies directly or indirectly through you, then 384 | the only way you could satisfy both it and this License would be to 385 | refrain entirely from distribution of the Library. 386 | 387 | If any portion of this section is held invalid or unenforceable under any 388 | particular circumstance, the balance of the section is intended to apply, 389 | and the section as a whole is intended to apply in other circumstances. 390 | 391 | It is not the purpose of this section to induce you to infringe any 392 | patents or other property right claims or to contest validity of any 393 | such claims; this section has the sole purpose of protecting the 394 | integrity of the free software distribution system which is 395 | implemented by public license practices. Many people have made 396 | generous contributions to the wide range of software distributed 397 | through that system in reliance on consistent application of that 398 | system; it is up to the author/donor to decide if he or she is willing 399 | to distribute software through any other system and a licensee cannot 400 | impose that choice. 401 | 402 | This section is intended to make thoroughly clear what is believed to 403 | be a consequence of the rest of this License. 404 | 405 | 12. If the distribution and/or use of the Library is restricted in 406 | certain countries either by patents or by copyrighted interfaces, the 407 | original copyright holder who places the Library under this License may add 408 | an explicit geographical distribution limitation excluding those countries, 409 | so that distribution is permitted only in or among countries not thus 410 | excluded. In such case, this License incorporates the limitation as if 411 | written in the body of this License. 412 | 413 | 13. The Free Software Foundation may publish revised and/or new 414 | versions of the Lesser General Public License from time to time. 415 | Such new versions will be similar in spirit to the present version, 416 | but may differ in detail to address new problems or concerns. 417 | 418 | Each version is given a distinguishing version number. If the Library 419 | specifies a version number of this License which applies to it and 420 | "any later version", you have the option of following the terms and 421 | conditions either of that version or of any later version published by 422 | the Free Software Foundation. If the Library does not specify a 423 | license version number, you may choose any version ever published by 424 | the Free Software Foundation. 425 | 426 | 14. If you wish to incorporate parts of the Library into other free 427 | programs whose distribution conditions are incompatible with these, 428 | write to the author to ask for permission. For software which is 429 | copyrighted by the Free Software Foundation, write to the Free 430 | Software Foundation; we sometimes make exceptions for this. Our 431 | decision will be guided by the two goals of preserving the free status 432 | of all derivatives of our free software and of promoting the sharing 433 | and reuse of software generally. 434 | 435 | NO WARRANTY 436 | 437 | 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO 438 | WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. 439 | EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR 440 | OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY 441 | KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE 442 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR 443 | PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE 444 | LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME 445 | THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 446 | 447 | 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN 448 | WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY 449 | AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU 450 | FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR 451 | CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE 452 | LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING 453 | RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A 454 | FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF 455 | SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH 456 | DAMAGES. 457 | 458 | END OF TERMS AND CONDITIONS 459 | 460 | How to Apply These Terms to Your New Libraries 461 | 462 | If you develop a new library, and you want it to be of the greatest 463 | possible use to the public, we recommend making it free software that 464 | everyone can redistribute and change. You can do so by permitting 465 | redistribution under these terms (or, alternatively, under the terms of the 466 | ordinary General Public License). 467 | 468 | To apply these terms, attach the following notices to the library. It is 469 | safest to attach them to the start of each source file to most effectively 470 | convey the exclusion of warranty; and each file should have at least the 471 | "copyright" line and a pointer to where the full notice is found. 472 | 473 | 474 | Copyright (C) 475 | 476 | This library is free software; you can redistribute it and/or 477 | modify it under the terms of the GNU Lesser General Public 478 | License as published by the Free Software Foundation; either 479 | version 2.1 of the License, or (at your option) any later version. 480 | 481 | This library is distributed in the hope that it will be useful, 482 | but WITHOUT ANY WARRANTY; without even the implied warranty of 483 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 484 | Lesser General Public License for more details. 485 | 486 | You should have received a copy of the GNU Lesser General Public 487 | License along with this library; if not, write to the Free Software 488 | Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 489 | USA 490 | 491 | Also add information on how to contact you by electronic and paper mail. 492 | 493 | You should also get your employer (if you work as a programmer) or your 494 | school, if any, to sign a "copyright disclaimer" for the library, if 495 | necessary. Here is a sample; alter the names: 496 | 497 | Yoyodyne, Inc., hereby disclaims all copyright interest in the 498 | library `Frob' (a library for tweaking knobs) written by James Random 499 | Hacker. 500 | 501 | , 1 April 1990 502 | Ty Coon, President of Vice 503 | 504 | That's all there is to it! 505 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | lazarus-thumbviewer 2 | =================== 3 | 4 | Thumbnail Viewer Component for Lazarus Freepascal 5 | -------------------------------------------------------------------------------- /fontfinder.pas: -------------------------------------------------------------------------------- 1 | unit fontfinder; 2 | 3 | //2008 Theo 4 | 5 | interface 6 | 7 | uses Classes, SysUtils; 8 | 9 | const 10 | Font_Sans = 'sans-serif'; 11 | Font_Serif = 'serif'; 12 | Font_Monospace = 'monospace'; 13 | Font_Sans_ExportList = 'Helvetica,Arial,sans-serif'; 14 | Font_Serif_ExportList = 'Times New Roman,Times,serif'; 15 | Font_Mono_ExportList = 'Courier New,Courier,monospace'; 16 | 17 | type 18 | 19 | { TFontFinder } 20 | 21 | TFontFinder = class 22 | private 23 | fScreenFontsLo: TStringList; 24 | fScreenFonts: TStringList; 25 | fFontSubst: TStringList; 26 | fSans: string; 27 | fSerif: string; 28 | fMono: string; 29 | fDefaultName: string; 30 | protected 31 | function FindAFontSubstr(Inp: string): string; 32 | function FindAFontIdent(Inp: string): string; 33 | function FindAFontSubstit(Inp: string): string; 34 | public 35 | constructor Create; 36 | destructor Destroy; override; 37 | 38 | function FindAFont(Inp: string): string; 39 | function FindAFontFromList(Inp: TStrings): string; 40 | function FindAFontFromDelimitedString(Inp: string; Delim: char = ','): string; 41 | property FontSubst: TStringList read fFontSubst write fFontSubst; 42 | property Sans: string read fSans write fSans; 43 | property Serif: string read fSerif write fSerif; 44 | property Mono: string read fMono write fMono; 45 | property Defaultname: string read fDefaultName write fDefaultName; 46 | published 47 | 48 | end; 49 | 50 | procedure EnumFonts(List: TStrings); 51 | 52 | implementation 53 | 54 | uses LCLType, LCLIntf, Forms; 55 | 56 | function EnumFontsNoDups(var LogFont: TEnumLogFontEx; 57 | var Metric: TNewTextMetricEx; FontType: longint; Data: LParam): longint; stdcall; 58 | var 59 | L: TStringList; 60 | S: string; 61 | begin 62 | L := TStringList(ptrint(Data)); 63 | S := LogFont.elfLogFont.lfFaceName; 64 | if L.IndexOf(S) < 0 then 65 | L.Add(S); 66 | Result := 1; 67 | end; 68 | 69 | procedure EnumFonts(List: TStrings); 70 | var 71 | DC: HDC; 72 | lf: TagLogFontA; 73 | i, p: integer; 74 | L: TStringList; 75 | haveac: boolean; 76 | begin 77 | haveac := False; 78 | lf.lfCharSet := FCS_ISO_10646_1; 79 | lf.lfFaceName := ''; 80 | lf.lfPitchAndFamily := DEFAULT_PITCH; 81 | L := TStringList.Create; 82 | 83 | DC := GetDC(0); 84 | try 85 | EnumFontFamiliesEX(DC, @lf, @EnumFontsNoDups, ptrint(L), 0); 86 | if L.Count > 0 then 87 | begin 88 | for i := 0 to L.Count - 1 do 89 | begin 90 | if not haveac and (Pos('courier [adobe]', L[i]) > 0) then 91 | begin 92 | L[i] := 'adobe courier'; 93 | haveac := True; 94 | end; 95 | P := Pos('[', L[i]); 96 | if P > 0 then 97 | L[i] := Trim(Copy(L[i], 1, p - 1)); 98 | end; 99 | L.Sort; 100 | List.Assign(L); 101 | end 102 | else 103 | List.Assign(Screen.Fonts); 104 | finally 105 | ReleaseDC(0, DC); 106 | L.Free; 107 | end; 108 | end; 109 | 110 | 111 | { TFontFinder } 112 | 113 | constructor TFontFinder.Create; 114 | begin 115 | fScreenFontsLo := TStringList.Create; 116 | fScreenFonts := TStringList.Create; 117 | EnumFonts(fScreenFonts); 118 | fScreenFontsLo.Text := Lowercase(fScreenFonts.Text); 119 | fFontSubst := TStringList.Create; 120 | 121 | {$IFDEF mswindows} 122 | fSans := 'Arial'; 123 | fSerif := 'Times New Roman'; 124 | fMono := 'Courier New'; 125 | fFontSubst.add('helvetica=' + fSans); 126 | fFontSubst.add('times=' + fSerif); 127 | fFontSubst.add('courier=' + fMono); 128 | {$ELSE} 129 | fSans := 'helvetica'; 130 | fSerif := 'times'; 131 | fMono := 'courier'; 132 | fFontSubst.add('arial=' + fSans); 133 | fFontSubst.add('times new roman=' + fSerif); 134 | fFontSubst.add('courier new=' + fMono); 135 | {$ENDIF} 136 | 137 | fFontSubst.add(Font_Sans + '=' + fSans); 138 | fFontSubst.add(Font_Serif + '=' + fSerif); 139 | fFontSubst.add(Font_Monospace + '=' + fMono); 140 | 141 | fDefaultName := fSerif; 142 | end; 143 | 144 | destructor TFontFinder.Destroy; 145 | begin 146 | fScreenFonts.Free; 147 | fScreenFontsLo.Free; 148 | fFontSubst.Free; 149 | inherited; 150 | end; 151 | 152 | function TFontFinder.FindAFont(Inp: string): string; 153 | begin 154 | Result := FindAFontIdent(Inp); 155 | if Result <> '' then 156 | exit; 157 | Result := FindAFontSubstit(Inp); 158 | if Result <> '' then 159 | exit; 160 | Result := FindAFontSubstr(Inp); 161 | if Result <> '' then 162 | exit; 163 | Result := fDefaultName; 164 | 165 | end; 166 | 167 | procedure StrictSetDelimitedText(AText: string; ADelim: char; AList: TStringList); 168 | var 169 | i: integer; 170 | Buf: string; 171 | begin 172 | AList.Clear; 173 | Buf:=''; 174 | for i := 1 to Length(AText) do 175 | if AText[i] = ADelim then 176 | begin 177 | AList.Add(Trim(Buf)); 178 | Buf := ''; 179 | end 180 | else 181 | Buf := Buf + AText[i]; 182 | if Trim(Buf) <> '' then 183 | AList.Add(Trim(Buf)); 184 | end; 185 | 186 | 187 | function TFontFinder.FindAFontFromDelimitedString(Inp: string; Delim: char): string; 188 | var 189 | SL: TStringList; 190 | begin 191 | SL := TStringList.Create; 192 | StrictSetDelimitedText(Inp, Delim, SL); 193 | Result := FindAFontFromList(SL); 194 | SL.Free; 195 | end; 196 | 197 | function TFontFinder.FindAFontFromList(Inp: TStrings): string; 198 | var 199 | i: integer; 200 | begin 201 | for i := 0 to Inp.Count - 1 do 202 | begin 203 | Result := FindAFontIdent((Inp[i])); 204 | if Result <> '' then 205 | Exit; 206 | end; 207 | 208 | for i := 0 to Inp.Count - 1 do 209 | begin 210 | Result := FindAFontSubstit((Inp[i])); 211 | if Result <> '' then 212 | Exit; 213 | end; 214 | 215 | for i := 0 to Inp.Count - 1 do 216 | begin 217 | Result := FindAFontSubstr((Inp[i])); 218 | if Result <> '' then 219 | Exit; 220 | end; 221 | Result := fDefaultName; 222 | end; 223 | 224 | function TFontFinder.FindAFontIdent(Inp: string): string; 225 | var 226 | i: integer; 227 | begin 228 | Result := ''; 229 | inp := Lowercase(Trim(inp)); 230 | i := fScreenFontsLo.IndexOf(Inp); 231 | if i > -1 then 232 | Result := fScreenFonts[i]; 233 | end; 234 | 235 | function TFontFinder.FindAFontSubstit(Inp: string): string; 236 | begin 237 | Result := ''; 238 | inp := Lowercase(Trim(inp)); 239 | Result := fFontSubst.Values[inp]; 240 | end; 241 | 242 | function TFontFinder.FindAFontSubstr(Inp: string): string; 243 | var 244 | i: integer; 245 | begin 246 | Result := ''; 247 | inp := Lowercase(Trim(inp)); 248 | if pos(' ', inp) > 0 then 249 | inp := Copy(inp, 1, pos(' ', inp) - 1); 250 | for i := 0 to fScreenFontsLo.Count - 1 do 251 | if Pos(inp, fScreenFontsLo[i]) > 0 then 252 | begin 253 | Result := fScreenFonts[i]; 254 | exit; 255 | end; 256 | end; 257 | 258 | end. 259 | 260 | -------------------------------------------------------------------------------- /fpreadjpegthumb.pas: -------------------------------------------------------------------------------- 1 | { Copyright (C) 2003 Mattias Gaertner 2 | 3 | This library is free software; you can redistribute it and/or modify it 4 | under the terms of the GNU Library General Public License as published by 5 | the Free Software Foundation; either version 2 of the License, or (at your 6 | option) any later version. 7 | 8 | This program is distributed in the hope that it will be useful, but WITHOUT 9 | ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or 10 | FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License 11 | for more details. 12 | 13 | You should have received a copy of the GNU Library General Public License 14 | along with this library; if not, write to the Free Software Foundation, 15 | Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. 16 | 17 | ToDo: 18 | - palette 19 | } 20 | 21 | //Specialized version for loading prescaled (Thumbnails) 22 | 23 | unit FPReadJPEGthumb; 24 | 25 | {$mode objfpc}{$H+} 26 | 27 | interface 28 | 29 | uses 30 | Classes, SysUtils, FPImage, JPEGLib, JdAPImin, JDataSrc, JdAPIstd, JmoreCfg; 31 | 32 | type 33 | { TFPReaderJPEG } 34 | { This is a FPImage reader for jpeg images. } 35 | 36 | TFPReaderJPEG = class; 37 | 38 | PFPJPEGProgressManager = ^TFPJPEGProgressManager; 39 | TFPJPEGProgressManager = record 40 | pub : jpeg_progress_mgr; 41 | instance: TObject; 42 | last_pass: Integer; 43 | last_pct: Integer; 44 | last_time: Integer; 45 | last_scanline: Integer; 46 | end; 47 | 48 | TJPEGScale = (jsFullSize, jsHalf, jsQuarter, jsEighth); 49 | TJPEGReadPerformance = (jpBestQuality, jpBestSpeed); 50 | 51 | TFPReaderJPEG = class(TFPCustomImageReader) 52 | private 53 | FSmoothing: boolean; 54 | FMinHeight:integer; 55 | FMinWidth:integer; 56 | FWidth: Integer; 57 | FHeight: Integer; 58 | FGrayscale: boolean; 59 | FProgressiveEncoding: boolean; 60 | FError: jpeg_error_mgr; 61 | FProgressMgr: TFPJPEGProgressManager; 62 | FInfo: jpeg_decompress_struct; 63 | FScale: TJPEGScale; 64 | FPerformance: TJPEGReadPerformance; 65 | procedure SetPerformance(const AValue: TJPEGReadPerformance); 66 | procedure SetSmoothing(const AValue: boolean); 67 | protected 68 | procedure InternalRead(Str: TStream; Img: TFPCustomImage); override; 69 | function InternalCheck(Str: TStream): boolean; override; 70 | public 71 | constructor Create; override; 72 | destructor Destroy; override; 73 | property GrayScale: boolean read FGrayscale; 74 | property ProgressiveEncoding: boolean read FProgressiveEncoding; 75 | property Smoothing: boolean read FSmoothing write SetSmoothing; 76 | property Performance: TJPEGReadPerformance read FPerformance write SetPerformance; 77 | property Scale: TJPEGScale read FScale write FScale; 78 | property MinWidth:integer read FMinWidth write FMinWidth; 79 | property MinHeight:integer read FMinHeight write FMinHeight; 80 | end; 81 | 82 | var 83 | tn, ext:String; 84 | Om:TImageHandlersManager; 85 | ir:TFPCustomImageReaderClass; 86 | iw:TFPCustomImageWriterClass; 87 | i:integer; 88 | 89 | 90 | implementation 91 | 92 | procedure ReadCompleteStreamToStream(SrcStream, DestStream: TStream; 93 | StartSize: integer); 94 | var 95 | NewLength: Integer; 96 | ReadLen: Integer; 97 | Buffer: string; 98 | begin 99 | if (SrcStream is TMemoryStream) or (SrcStream is TFileStream) 100 | or (SrcStream is TStringStream) 101 | then begin 102 | // read as one block 103 | DestStream.CopyFrom(SrcStream,SrcStream.Size-SrcStream.Position); 104 | end else begin 105 | // read exponential 106 | if StartSize<=0 then StartSize:=1024; 107 | SetLength(Buffer,StartSize); 108 | NewLength:=0; 109 | repeat 110 | ReadLen:=SrcStream.Read(Buffer[NewLength+1],length(Buffer)-NewLength); 111 | inc(NewLength,ReadLen); 112 | if NewLength0 then 116 | DestStream.Write(Buffer[1],NewLength); 117 | end; 118 | end; 119 | 120 | procedure JPEGError(CurInfo: j_common_ptr); 121 | begin 122 | if CurInfo=nil then exit; 123 | raise Exception.CreateFmt('JPEG error',[CurInfo^.err^.msg_code]); 124 | end; 125 | 126 | procedure EmitMessage(CurInfo: j_common_ptr; msg_level: Integer); 127 | begin 128 | if CurInfo=nil then exit; 129 | if msg_level=0 then ; 130 | end; 131 | 132 | procedure OutputMessage(CurInfo: j_common_ptr); 133 | begin 134 | if CurInfo=nil then exit; 135 | end; 136 | 137 | procedure FormatMessage(CurInfo: j_common_ptr; var buffer: string); 138 | begin 139 | if CurInfo=nil then exit; 140 | {$ifdef FPC_Debug_Image} 141 | writeln('FormatMessage ',buffer); 142 | {$endif} 143 | end; 144 | 145 | procedure ResetErrorMgr(CurInfo: j_common_ptr); 146 | begin 147 | if CurInfo=nil then exit; 148 | CurInfo^.err^.num_warnings := 0; 149 | CurInfo^.err^.msg_code := 0; 150 | end; 151 | 152 | 153 | var 154 | jpeg_std_error: jpeg_error_mgr; 155 | 156 | procedure ProgressCallback(CurInfo: j_common_ptr); 157 | begin 158 | if CurInfo=nil then exit; 159 | // ToDo 160 | end; 161 | 162 | { TFPReaderJPEG } 163 | 164 | procedure TFPReaderJPEG.SetSmoothing(const AValue: boolean); 165 | begin 166 | if FSmoothing=AValue then exit; 167 | FSmoothing:=AValue; 168 | end; 169 | 170 | procedure TFPReaderJPEG.SetPerformance(const AValue: TJPEGReadPerformance); 171 | begin 172 | if FPerformance=AValue then exit; 173 | FPerformance:=AValue; 174 | end; 175 | 176 | procedure TFPReaderJPEG.InternalRead(Str: TStream; Img: TFPCustomImage); 177 | var 178 | MemStream: TMemoryStream; 179 | 180 | procedure SetSource; 181 | begin 182 | MemStream.Position:=0; 183 | jpeg_stdio_src(@FInfo, @MemStream); 184 | end; 185 | 186 | procedure ReadHeader; 187 | begin 188 | jpeg_read_header(@FInfo, TRUE); 189 | FWidth := FInfo.image_width; 190 | FHeight := FInfo.image_height; 191 | FGrayscale := FInfo.jpeg_color_space = JCS_GRAYSCALE; 192 | FProgressiveEncoding := jpeg_has_multiple_scans(@FInfo); 193 | end; 194 | 195 | procedure InitReadingPixels; 196 | var d1,d2:integer; 197 | 198 | function DToScale(inp:integer):TJPEGScale; 199 | begin 200 | if inp>7 then Result:=jsEighth else 201 | if inp>3 then Result:=jsQuarter else 202 | if inp>1 then Result:=jsHalf else 203 | Result:=jsFullSize; 204 | end; 205 | 206 | begin 207 | FInfo.scale_num := 1; 208 | 209 | if (FMinWidth>0) and (FMinHeight>0) then 210 | if (FInfo.image_width>FMinWidth) or (FInfo.image_height>FMinHeight) then 211 | begin 212 | d1:=Round((FInfo.image_width / FMinWidth)-0.5); 213 | d2:=Round((FInfo.image_height / FMinHeight)-0.5); 214 | if d1>d2 then fScale:=DToScale(d2) else fScale:=DtoScale(d1); 215 | end; 216 | 217 | FInfo.scale_denom :=1 shl Byte(FScale); //1 218 | FInfo.do_block_smoothing := FSmoothing; 219 | 220 | if FGrayscale then FInfo.out_color_space := JCS_GRAYSCALE; 221 | if (FInfo.out_color_space = JCS_GRAYSCALE) then begin 222 | FInfo.quantize_colors := True; 223 | FInfo.desired_number_of_colors := 236; 224 | end; 225 | 226 | if FPerformance = jpBestSpeed then begin 227 | FInfo.dct_method := JDCT_IFAST; 228 | FInfo.two_pass_quantize := False; 229 | FInfo.dither_mode := JDITHER_ORDERED; 230 | // FInfo.do_fancy_upsampling := False; can create an AV inside jpeglib 231 | end; 232 | 233 | if FProgressiveEncoding then begin 234 | FInfo.enable_2pass_quant := FInfo.two_pass_quantize; 235 | FInfo.buffered_image := True; 236 | end; 237 | end; 238 | 239 | function CorrectCMYK(const C: TFPColor): TFPColor; 240 | var 241 | MinColor: word; 242 | begin 243 | if C.red$FF then MinColor:=$FF-C.alpha; 247 | Result.red:=(C.red-MinColor) shl 8; 248 | Result.green:=(C.green-MinColor) shl 8; 249 | Result.blue:=(C.blue-MinColor) shl 8; 250 | Result.alpha:=alphaOpaque; 251 | end; 252 | procedure ReadPixels; 253 | var 254 | Continue: Boolean; 255 | SampArray: JSAMPARRAY; 256 | SampRow: JSAMPROW; 257 | Color: TFPColor; 258 | LinesRead: Cardinal; 259 | x: Integer; 260 | y: Integer; 261 | c: word; 262 | Status,Scan: integer; 263 | ReturnValue,RestartLoop: Boolean; 264 | procedure OutputScanLines(); 265 | var 266 | x: integer; 267 | begin 268 | Color.Alpha:=alphaOpaque; 269 | y:=0; 270 | while (FInfo.output_scanline < FInfo.output_height) do begin 271 | // read one line per call 272 | LinesRead := jpeg_read_scanlines(@FInfo, SampArray, 1); 273 | if LinesRead<1 then begin 274 | ReturnValue:=false; 275 | break; 276 | end; 277 | if (FInfo.jpeg_color_space = JCS_CMYK) then 278 | for x:=0 to FInfo.output_width-1 do begin 279 | Color.Red:=SampRow^[x*4+0]; 280 | Color.Green:=SampRow^[x*4+1]; 281 | Color.Blue:=SampRow^[x*4+2]; 282 | Color.alpha:=SampRow^[x*4+3]; 283 | Img.Colors[x,y]:=CorrectCMYK(Color); 284 | end 285 | else 286 | if fgrayscale then begin 287 | for x:=0 to FInfo.output_width-1 do begin 288 | c:= SampRow^[x] shl 8; 289 | Color.Red:=c; 290 | Color.Green:=c; 291 | Color.Blue:=c; 292 | Img.Colors[x,y]:=Color; 293 | end; 294 | end 295 | else begin 296 | for x:=0 to FInfo.output_width-1 do begin 297 | Color.Red:=SampRow^[x*3+0] shl 8; 298 | Color.Green:=SampRow^[x*3+1] shl 8; 299 | Color.Blue:=SampRow^[x*3+2] shl 8; 300 | Img.Colors[x,y]:=Color; 301 | end; 302 | end; 303 | inc(y); 304 | end; 305 | end; 306 | begin 307 | InitReadingPixels; 308 | 309 | Continue:=true; 310 | Progress(psStarting, 0, False, Rect(0,0,0,0), '', Continue); 311 | if not Continue then exit; 312 | 313 | jpeg_start_decompress(@FInfo); 314 | 315 | Img.SetSize(FInfo.output_width,FInfo.output_height); 316 | 317 | GetMem(SampArray,SizeOf(JSAMPROW)); 318 | GetMem(SampRow,FInfo.output_width*FInfo.output_components); 319 | SampArray^[0]:=SampRow; 320 | try 321 | case FProgressiveEncoding of 322 | false: 323 | begin 324 | ReturnValue:=true; 325 | OutputScanLines(); 326 | if FInfo.buffered_image then jpeg_finish_output(@FInfo); 327 | end; 328 | true: 329 | begin 330 | while true do begin 331 | (* The RestartLoop variable drops a placeholder for suspension 332 | mode, or partial jpeg decode, return and continue. In case 333 | of support this suspension, the RestartLoop:=True should be 334 | changed by an Exit and in the routine enter detects that it 335 | is being called from a suspended state to not 336 | reinitialize some buffer *) 337 | RestartLoop:=false; 338 | repeat 339 | status := jpeg_consume_input(@FInfo); 340 | until (status=JPEG_SUSPENDED) or (status=JPEG_REACHED_EOI); 341 | ReturnValue:=true; 342 | if FInfo.output_scanline = 0 then begin 343 | Scan := FInfo.input_scan_number; 344 | (* if we haven't displayed anything yet (output_scan_number==0) 345 | and we have enough data for a complete scan, force output 346 | of the last full scan *) 347 | if (FInfo.output_scan_number = 0) and (Scan > 1) and 348 | (status <> JPEG_REACHED_EOI) then Dec(Scan); 349 | 350 | if not jpeg_start_output(@FInfo, Scan) then begin 351 | RestartLoop:=true; (* I/O suspension *) 352 | end; 353 | end; 354 | 355 | if not RestartLoop then begin 356 | if (FInfo.output_scanline = $ffffff) then 357 | FInfo.output_scanline := 0; 358 | 359 | OutputScanLines(); 360 | 361 | if ReturnValue=false then begin 362 | if (FInfo.output_scanline = 0) then begin 363 | (* didn't manage to read any lines - flag so we don't call 364 | jpeg_start_output() multiple times for the same scan *) 365 | FInfo.output_scanline := $ffffff; 366 | end; 367 | RestartLoop:=true; (* I/O suspension *) 368 | end; 369 | 370 | if not RestartLoop then begin 371 | if (FInfo.output_scanline = FInfo.output_height) then begin 372 | if not jpeg_finish_output(@FInfo) then begin 373 | RestartLoop:=true; (* I/O suspension *) 374 | end; 375 | 376 | if not RestartLoop then begin 377 | if (jpeg_input_complete(@FInfo) and 378 | (FInfo.input_scan_number = FInfo.output_scan_number)) then 379 | break; 380 | 381 | FInfo.output_scanline := 0; 382 | end; 383 | end; 384 | end; 385 | end; 386 | if RestartLoop then begin 387 | (* Suspension mode, but as not supported by this implementation 388 | it will simple break the loop to avoid endless looping. *) 389 | break; 390 | end; 391 | end; 392 | end; 393 | end; 394 | finally 395 | FreeMem(SampRow); 396 | FreeMem(SampArray); 397 | end; 398 | 399 | jpeg_finish_decompress(@FInfo); 400 | 401 | Progress(psEnding, 100, false, Rect(0,0,0,0), '', Continue); 402 | end; 403 | 404 | begin 405 | FWidth:=0; 406 | FHeight:=0; 407 | MemStream:=nil; 408 | FillChar(FInfo,SizeOf(FInfo),0); 409 | try 410 | if Str is TMemoryStream then 411 | MemStream:=TMemoryStream(Str) 412 | else begin 413 | MemStream:=TMemoryStream.Create; 414 | ReadCompleteStreamToStream(Str,MemStream,1024); 415 | MemStream.Position:=0; 416 | end; 417 | if MemStream.Size > 0 then begin 418 | FError:=jpeg_std_error; 419 | FInfo.err := @FError; 420 | jpeg_CreateDecompress(@FInfo, JPEG_LIB_VERSION, SizeOf(FInfo)); 421 | try 422 | FProgressMgr.pub.progress_monitor := @ProgressCallback; 423 | FProgressMgr.instance := Self; 424 | FInfo.progress := @FProgressMgr.pub; 425 | SetSource; 426 | ReadHeader; 427 | ReadPixels; 428 | finally 429 | jpeg_Destroy_Decompress(@FInfo); 430 | end; 431 | end; 432 | finally 433 | if (MemStream<>nil) and (MemStream<>Str) then 434 | MemStream.Free; 435 | end; 436 | end; 437 | 438 | function TFPReaderJPEG.InternalCheck(Str: TStream): boolean; 439 | begin 440 | // ToDo: read header and check 441 | Result:=false; 442 | if Str=nil then exit; 443 | Result:=true; 444 | end; 445 | 446 | constructor TFPReaderJPEG.Create; 447 | begin 448 | FScale:=jsFullSize; 449 | FPerformance:=jpBestSpeed; 450 | inherited Create; 451 | end; 452 | 453 | destructor TFPReaderJPEG.Destroy; 454 | begin 455 | inherited Destroy; 456 | end; 457 | 458 | initialization 459 | with jpeg_std_error do begin 460 | error_exit:=@JPEGError; 461 | emit_message:=@EmitMessage; 462 | output_message:=@OutputMessage; 463 | format_message:=@FormatMessage; 464 | reset_error_mgr:=@ResetErrorMgr; 465 | end; 466 | 467 | Om:=ImageHandlers; 468 | ImageHandlers:=TImageHandlersManager.Create; 469 | for i:=0 to Om.Count-1 do 470 | begin 471 | tn:=Om.TypeNames[i]; 472 | ext:=Om.Extensions[tn]; 473 | ir:=Om.ImageReader[tn]; 474 | iw:=Om.ImageWriter[tn]; 475 | if tn<>'JPEG Graphics'then if ir<>nil then ImageHandlers.RegisterImageReader(tn,ext,ir); 476 | if iw<>nil then ImageHandlers.RegisterImageWriter(tn,ext,iw); 477 | end; 478 | Om.Free; 479 | 480 | ImageHandlers.RegisterImageReader ('JPEG Graphics', 'jpg;jpeg', TFPReaderJPEG); 481 | end. 482 | -------------------------------------------------------------------------------- /fpthumbresize.pas: -------------------------------------------------------------------------------- 1 | unit fpthumbresize; 2 | 3 | //22.6.2010 Theo 4 | 5 | {$MODE objfpc}{$H+} 6 | 7 | interface 8 | 9 | uses 10 | Classes, SysUtils, fpimage, FPImgCanv, FPCanvas; 11 | 12 | function ThumbResize(SImg: TFPMemoryImage; W, H: integer; out Area: TRect): TFPMemoryImage; 13 | function FpRawResize(w, h: integer; bmp: TFPMemoryImage): TFPMemoryImage; 14 | procedure Proportional(sw, sh, tw, th: integer; out w, h: integer; out area: TRect); 15 | 16 | 17 | implementation 18 | 19 | function ThumbResize(SImg: TFPMemoryImage; W, H: integer; out Area: TRect): TFPMemoryImage; 20 | var Canv: TFPImageCanvas; 21 | TmpI: TFPMemoryImage; 22 | rw, rh: integer; 23 | begin 24 | if (SImg.Width > 2 * W) or (SImg.Height > 2 * H) then 25 | begin 26 | Proportional(SImg.Width, SImg.Height, 2 * W, 2 * H, rw, rh, Area); 27 | TmpI := FpRawResize(rw, rh, SImg); 28 | SImg.Assign(TmpI); 29 | TmpI.free; 30 | end; 31 | 32 | Proportional(SImg.Width, SImg.Height, W, H, rw, rh, Area); 33 | Result := TFPMemoryImage.Create(0, 0); 34 | Result.UsePalette:=false; 35 | Result.Width:=rw; 36 | Result.Height:=rh; 37 | 38 | Canv := TFPImageCanvas.create(Result); 39 | Canv.StretchDraw(0, 0, rw, rh, SImg); 40 | Canv.free; 41 | end; 42 | 43 | function MulDiv(Number, Num, Den: Integer): Integer; 44 | begin 45 | if Den = 0 then 46 | begin 47 | Result := -1; 48 | Exit; 49 | end; 50 | Result := (Int64(Number) * Num) div Den; 51 | end; 52 | 53 | 54 | procedure Proportional(sw, sh, tw, th: integer; out w, h: integer; out area: TRect); 55 | var half: integer; 56 | begin 57 | if sw / sh < tw / th 58 | then begin 59 | area.Top := 0; 60 | area.Bottom := tw; 61 | w := MulDiv(th, sw, sh); 62 | h := th; 63 | half := (tw - w) div 2; 64 | area.Left := half; 65 | area.Right := area.Left + w; 66 | end 67 | else begin 68 | area.Left := 0; 69 | area.Right := tw; 70 | h := MulDiv(tw, sh, sw); 71 | w := tw; 72 | Half := (th - h) div 2; 73 | area.Top := half; 74 | area.Bottom := area.Top + h; 75 | end; 76 | end; 77 | 78 | 79 | 80 | function FpRawResize(w, h: integer; bmp: TFPMemoryImage): TFPMemoryImage; 81 | var x, y: integer; 82 | zoomh, zoomw: single; 83 | begin 84 | Result := TFPMemoryImage.Create(0, 0); 85 | Result.UsePalette:=false; 86 | 87 | if h > 0 then zoomh := h / bmp.Height; 88 | if w > 0 then zoomw := w / bmp.Width; 89 | 90 | if h = 0 then zoomh := zoomw; 91 | if w = 0 then zoomw := zoomh; 92 | 93 | w := Round(Bmp.Width * zoomw); 94 | h := Round(Bmp.Height * zoomh); 95 | 96 | Result.Height := h; 97 | Result.Width := w; 98 | for y := 0 to h - 1 do 99 | for x := 0 to w - 1 do 100 | begin 101 | Result.Colors[X, Y] := bmp.Colors[Round(x / zoomw), Round(y / zoomh)] 102 | end; 103 | end; 104 | 105 | 106 | end. -------------------------------------------------------------------------------- /images.lrs: -------------------------------------------------------------------------------- 1 | LazarusResources.Add('framecropab','PNG',[ 2 | #137'PNG'#13#10#26#10#0#0#0#13'IHDR'#0#0#1#157#0#0#1#156#8#6#0#0#0#2#131'}'#7 3 | +#0#0#0#1'sRGB'#0#174#206#28#233#0#0#0#6'bKGD'#0#255#0#255#0#255#160#189#167 4 | +#147#0#0#0#9'pHYs'#0#0#13#18#0#0#13#18#1#181#128'7t'#0#0' '#0'IDATx'#218#237 5 | +#221'[o\'#231#189#223#241#223#243#172'5'''#30'D'#234'@'#145#20'EZ'#178'd'#201 6 | +#218#145','#167'Fba'#219#141#157#4#187#14'z'#211'l'#160';'#13#208#139#222#6 7 | +#189#233';('#218'w'#176's'#217#2#189')'#176'[$'#13#144#235'6'#13#18'g'#215 8 | +#167#198#145'j'#199'rt2)['#146'M'#147'"9'#226'qf'#214'Z'#207#211#139#225#26 9 | +#13#135'Cj8'#156#25#29#252#253#0#11'<'#136#154#195'f'#214'o'#253#159'ux'#140 10 | +#247'^O'#130'$I'#182'='#16'k'#173'1'#198#8'O'#22#239#165'$q-'#189'q'#140'1j' 11 | +#229'5'#220#203#251#176#213#247#132's'#174#165#191#11#2'cZ}'#140#206#181#254 12 | +#188';'#249#24#247#162#213#251#238#198'g'#171#211#235#147#250#219#219#237#241 13 | +'n'#190#207#204'.u'#246'O'#226#227#170#187'='#191#211'm'#214#255''#239#189 14 | +#223#239'{&'#12'C'#227#189'Wz'#135#155#223#203'{/k'#173#130' 0'#245'u'#179 15 | +#214'v'#244#141'bz'#29':'#229'r'#217';'#231'v]'#25#165#5'H'#146#164#165'7q' 16 | +#171'+'#182'n|'#208#186#177#178'l'#253#190';'#255'\Z'#173'w'#16#4#143'm'#197 17 | +#214#233#215'&I'#162#150'V'#254'a'#24'*'#147#201#180't'#155#214#218#150'C' 18 | +#167#211#159#193#199#21'x'#173#190''#218'}'#140#141#255#167'a'#197#220#145 19 | +#231#218#235#199#213#176'AS'#251#251#198#219#168#255#185#213#26'[k'#155#222 20 | +''#20'E'#181''#171#251'j'#140'1J'#146#196'''I'#162'0'#12#213',l6'#131#201 21 | +'n~'#223#214#27'('#236#198#135'}cc'#195#151'J%U*'#149#218#178#177#177#161'R' 22 | +#169#164'8'#142'e'#173'm'#186#164#197#172'O'#221'V^'#180'V'#255#238'q'#175#4 23 | +';'#205#218'@'#146#233#216#138'-}'#227#183#242'wQ'#20#181'\'#239''''#189#211 24 | +'i'#245#253#19#199'q'#203#207'{/'#161#243#184#194#246'i'#13#157'f+'#249'G' 25 | +#221#239#147#250#184#154#213#174#254'3'#211#248#249'I'#131'b?'#159#189#165 26 | +#165#165#218#191#165#139#181#214'K'#210#224#224#160#14#30'<'#168' '#8#148#207 27 | +#231'}__'#159#242#249#188'2'#153'j'#247'S'#189#189#255' '#233'j'#219'+'#210 28 | +#142'u:'#235#235#235'~aaA'#139#139#139#154#157#157'U'#177'XT'#165'RQ'#16#4 29 | +#234#239#239'W'#161'PP.'#151'S.'#151#211#192#192#128#130' P'#24#134#10#195'P' 30 | +'A'#16'('#8#130#218#139#244'4u:{'#185#189'No'#209#182#186#206#216#203#214#214 31 | +'^>$'#207'J'#232#236#229#189#211#234#223#182#186'b'#232#198'HC7'#134#184#186 32 | +'9l'#182#215'a'#172'f'#157#196#163'6'#28#226'8~"'#31'W'#227'm6'#11#153#189 33 | +#188#239'Zy.'#11#11#11#138#162'h'#203#146'$'#137#146'$'#209#198#198#134'VVVT' 34 | +#169'T'#228#189'W__'#159#14#31'>'#172#241#241'q'#141#142#142'jhhH'#133'B'#214 35 | +#236#231#237'`Z\'#169'g$E'#155#157'QNR'#228#189#175'T*'#21'?33'#163#217#217 36 | +'Y'#221#185'sG'#139#139#139#26#30#30#214#161'C'#135'444'#164#193#193'A'#13#14 37 | +#14#214'B&I'#18'EQ'#164'8'#142'kK'#250#132#211#130'?'#9#31#178#189#134'N'#171 38 | +'+'#213'Nv'#27#155#171#182#199#22#16#141#143'q'#183#173#189'no'#12#236't'#223 39 | +#173'n'#253#238'v'#223#141'+'#151#221#134#132#31#181'5'#218#236#241'4'#254'n' 40 | +#167#199'\'#223#143'z^'#173'nawr'#3#172#217#10#179#157#247'c'#227#191'5[i7[' 41 | +#185'7'#187#223'v'#135#185':'#177#225#208#236'w;'#189'~'#141#235#134't'#131 42 | +#187#147#235#189#250'Q'#164#244#185'e2'#25'e'#179'Y'#229#243'y'#229'r9e2'#25 43 | +#197'q'#172#141#141#13'mllh}}]'#203#203#203'ZXX'#208#220#220#156'J'#165#146 44 | +'FGG'#245#252#243#207#235#196#137#231't'#240#224#176'r'#185'\F'#146#215#230 45 | +#238#166'N'#134#142'$'#217#244'Fggg'#253#205#155'7u'#243#230'M'#173#173#173 46 | +'I'#146'&''''u'#250#244'i'#21#10#5#133'a'#168'r'#185'\'#235'z'#238#221#187 47 | +#167#249#249'y'#21#139'E=x'#240'@'#239#191#255#190#174']'#187'&'#0#192#227 48 | +#241#163#31#253#243#205#206#165#160#190#190'>e2'#25#29'?~\'#167'N'#157'R'#161 49 | +'P'#208#240#240#176#134#135#135'U('#20#148'$'#137#238#223#191#175';w'#238'hv' 50 | +'vV'#165'RI'#19#19#227':'#254#188'.\'#184'0$iYR'#176#185'$'#222#251#164#173 51 | +#208'1'#198'XUw'#26#248'('#138#146#149#149#21#221#184'qC'#211#211#211'*'#22 52 | +#139#202#231#243#154#156#156#212#232#232#168#172#181'*'#22#139#186'w'#239#158 53 | +'n'#221#186#165#207'?'#255'\'#179#179#179'Z\\'#212#242#242#178#230#230#230'4' 54 | +';;'#203'+'#13#0'O'#184'W'#191#251#154#142#29';'#166#19'''N'#232#244#233#211 55 | +'z'#225#133#23't'#236#216'1e2'#25'EQEK'#197#5'MO&'#231#156'&&&t'#230#204#25 56 | +'='#247#220's'#166#190#203#222#169#227'6;'#180#129#225'f'#203'd'#254#243#159 57 | +#219#159#253#236'g'#165#165#165'%}'#242#201''''#250#252#243#207#149#207#231 58 | +'5::'#170#131#7#15'jeeE'#15#30'<'#208'_'#254#242#23']'#190'|Y'#247#238#221 59 | +#211';'#239#188#195#171#6#0#207#136'K'#175#190#174's'#231#206#233#219#223#254 60 | +#182#254#234#175#206#233#216#196#184#194'0'#212'g'#159#221#210#226#226#130'r' 61 | +#185#156'N'#156'8'#161#23'^xACCC'#161#247'>1'#198#232#211'O?=|'#238#220#185 62 | +#133']C'#199#24#19#168'n|'#206'{'#175#219#183'o'#251#143'?'#254'X'#179#179 63 | +#179#154#152#152#208#145'#G'#20#199#177#166#167#167#245#254#251#239#235#234 64 | +#213#171#186'q'#227#6#157#12#128'}96>'#177#229#231'/'#191#186'GQ'#30#163#31 65 | +'|'#255#159#233#254#253#251#250#248#207#151'%I'#23'_zE'#19#19#199#244#226#185 66 | ,#179#250#209#143'~'#164'3gNkmmM'#211#211#211#250#242#203'/u'#246#236'Y'#189 67 | +#240#194#11#250#226#139'/.'#150#203#229#197'7'#222'x'#227#238#174#157#206#215 68 | +'_'#253#131'\.'#183'8<<'#252#255'6'#15#13#245'7o'#222#212#181'k'#215#180#176 69 | +#176#160#169#169')'#29';vL'#183'n'#221#210'{'#239#189#167#143'?'#254'X'#197 70 | +'bQ'#31'|'#240#1#175#14#128#199#22'P'#132'S'#247#253#240#7'o'#169'X,j}}]'#153 71 | +'L'#168#227#147#19'z'#235#173#191#209#235#175#191#174#209#209'Q'#205#205#205 72 | +#233#214#173'['#26#30#30#214#169'S'#167'455'#165'0'#12'M'#211#208#217#220'w' 73 | +#147#153#159#159#255#235#190#190#190'5I'#154#159#159'?'#181#190#190#254#223 74 | +#174'\'#185#162'('#138'499'#169#241#241'q'#221#184'qC'#191#251#221#239#244 75 | +#238#187#239#234#143''#252'#'#175#4#0'|'#131'\z'#245#159'jiiQ'#203'+E'#29'>' 76 | +'|Po'#189#245#150'~'#252#227#31#235#165#151'^'#210#245#235#215'kG1'#159'>'#174#161#161'!'#189#255#254#251#250#213 79 | +#175'~'#165#223#255#254#247'T'#30#0#190#193'^y'#229';Z[[S'#161'P'#208#133#11 80 | +#23#244#183''#251'/'#244#189#239#189#169#249#249'9}'#249#229'='#5'A'#160'K' 81 | +#151'.)'#147#201'l'#185#18#144#221#236'r$'#201#172#175#175#255#235'8'#142#255 82 | +'c'#28#199''#245#234'UEQ'#164#179'g'#207'j``@'#31'|'#240#129'~'#253#235'_' 83 | +#19'8'#0#0#253#233'O'#212#145#145'Q'#173#174'm'#232#253#15#254#175#254#211 84 | +''#254'/'#250#253#219#255#168#190#254'AM'#28#159'R'#20';}'#250#151#235'Z*.' 85 | +#251'(N'#188#249#254#247'C'#169'zv'#161'S'#245#216'j300'#240#15'kkk'#255#254 86 | +#254#253#251#242#222'kbbB'#185'\N'#211#211#211#250#195#31#254#160#223#254#246 87 | +#183'T'#26#0' I'#250'?'#255#248#187#205'C'#169#179#154#153#185#173#183#223'~' 88 | +'[7o'#222#146'1VG'#142#28#209#234#234#170'VWW'#171#151#143#250#183'#^'#170'^' 89 | +'a '#168#11#31#205#207#207#235#171#175#190'R&'#147#209#248#248#184'fff'#244 90 | +#238#187#239#234#23#191#248#5#21#6#0'l'#241#246#239#255#183#254#250#181'7' 91 | +#244#238';o'#235#250#181'Ot'#236#216'1'#13#14#14'ht'#244#168'VVV'#180#188#188 92 | +#172#254#254'~%'#255#242#151#177#147#151'U'#245'|'#28#231#189'O'#202#229#178 93 | +'_\\T'#169'T'#210#240#240#176#226'8'#214';'#239#188#163#15'?'#252#144#202#2#0 94 | +#154'z'#247#157#183'k'#223'_'#190'|Y'#215#174']S'#28#199':|'#248#176'J'#165 95 | +#146#214#214#214'j'#23#203#181#170#30'L'#144#164']'#206#250#250#186#10#133 96 | +#130#134#134#134't'#253#250'u]'#185'rE'#239#189#247#30'U'#5#0'<'#210'/'#241 97 | +#15#250#228#147'O477'#167'C'#135#14#201#24#163'R'#169#164'R'#169'$#cl'#185'\' 98 | +#174']~5'#189#228#245#224#224#160#226'8'#214#229#203#151#181#176#176'@'#21#1 99 | +#0'-'#155#153#153#209#237#219#183#229#189'W6'#155'U'#20'EZ[_W'#156#196#222'n' 100 | +'^'#253#217#175#173#173#249#141#141#13'e'#179'Ye'#179'Y'#205#205#205#233#218 101 | +#181'k'#218#216#216#160#130#0#128#150#253#143'_'#254'w]'#187'vM'#15#30''#147#247'^' 106 | +#153'LF'#222'{U*'#149'j'#232'$IR'#155'Y/'#13#161'tji'#0#0#246#234'7'#255#235 107 | +'jyyYq'#28'W'#175'zc'#140#188#243#213#208'q'#206')'#138#162#218#140#144#229 108 | +'r'#249#225#9'='#0#0#180'a~~^'#229'r'#185':'#155#174'1'#138#226#168#186'O''' 109 | +#237'n'#210#169'a'#163'('#210#242#242'rKS'#166#2#0#208#204#194#194'B'#245'P' 110 | +#233#205')'#220'k'#7#18#164'Cla'#24'*'#8#2#197'q'#172#213#213#213'='#205#193 111 | +#13#0'@'#189#149#149#149#234'~'#28'ke'#172'U'#185'\'#174#134#142'sNq'#28'+'#8 112 | +#2#133'a'#168'$I8j'#13#0#176'/'#165'RIq'#20#201#24#163' '#237't'#188#247'[' 113 | +#134#215#172#181'J'#146'D'#27#27#27't:'#0#128#182#197'q'#172'8Id'#140#145'1' 114 | +#230'a'#232'8'#231#228#156'K'#231#213#169'u>'#132#14#0#160']'#206'9'#165's' 115 | +#182#25'c'#228#156'S(Ia'#24#214#14'"H'#15#30#232#239#239'W'#177'X'#164'j'#0 116 | +#128#182#4'A '#179'9'#172#230#229#149#207#231#21'R'#22#0'@7UG'#205#170'#g' 117 | +#150'r'#0#0'z'#133#208#1#0't'#179#205#169'~'#217#236'x'#24'^'#3#0't9w'#24'^' 118 | +#3#0#244',p'#30#162#211#1#0#244#166#211'1t:'#0#128#30#170#133'Nz'#242'N'#189 119 | +#217#217'Y*'#4#0'h['#16#4#181#171#222'8'#231#232't'#0#0#221#151#238#219'!t'#0 120 | +#0']'#13#155'4p8d'#26#0#208#221#208#145#148'$I'#245#18'k'#198#210#233#0#0#186 121 | +#218#234#212#186#28#246#233#0#0#186#156'9['#207#211'!t'#0#0#132#14#0#224#217 122 | +'c'#235#207#207'I'#143'2H'#147'irr'#146#10#1#0#218#11#24'k'#149#201'd'#232't' 123 | +#0#0#189#177#178#178'B'#232#0#0'z'#163#175#175#143#208#1#0't'#159#247'^'#185 124 | +'\'#142#208#1#0#244#198#202#202'J'#237#218#158#198#24'B'#7#0#208#189'N'''#12 125 | +'C:'#29#0'@o'#228#243'yB'#7#0#208#27#197'bqk'#232#24'c'#228#156'S'#28#199#181 126 | +'1'#183#244#231'l6K'#197#0#0'm1'#198#168'P('#236#220#233#212#159#24#10#0'@' 127 | +#167#217#250#176'!p'#0#0']'#13#157#198#192'!|'#0#0#221'R;'#150'-'#157#235#128 128 | +#192#1#0'tBc3'#227'}C'#167'C'#151#3#0#232'&'#219#152'H'#245#223'7'#158#212#3 129 | +#0#192#190'C'#135#253'9'#0#128'Nk'#150''''#161'd$Y9W'#205' k'#141#172#13'%Y' 130 | ,#173#175#151#168#26#0#160'mI'#146'l'#239't'#182'w9F'#242'V'#162#233#1#0#236 131 | +#195#174#215'^'#171#5#15'Cl'#0#128'.'#176#141']'#142#247#190#218#224#24'q'#25 132 | +#28#0#192#190'4'#238#215#217'r'#200'4'#231#233#0#0#186#26':'#245#157#14#231 133 | +#234#0#0':)'#142#227#157'C'#7#0#128'N'#178#214'n'#15#157#250'6'#136#3#9#0#0 134 | +#157#178'm'#18'7c'#140#172#181#181'N'#199#24'#c'#173#140#140#214#214'W'#169 135 | +#24#0#160'm;'#158#167#3#0'@'#167'5='#144#0#0#128'^ t'#0#0#221'lu'#182#252#200 136 | +'e'#164#1#0#221#203#28'5'#204#167'CI'#0#0#221'kt'#216#167#3#0'xL'#8#29#0'@' 137 | +#239':'#29#231#156#156's'#213#243's'#140#169#253#145#243'N'#213#185'v'#0#0 138 | +#216';c'#140#130' '#160#211#1#0'<'#30#132#14#0#128#208#1#0'<'#221#210']6'#132 139 | +#14#0#160'g'#210#249#218#8#29#0'@O'#17':'#0#240#140':>u'#130#208#1#0'|'#131 140 | +';'#157#250#29'='#245#147#184#25'c'#212#223#215'O'#133#0#224')u'#247#139#219 141 | +#143#181#219#241#222'K'#13#7#19#208#233#0#0#186#153'<'#132#14#0'|'#147#186 142 | +#157#199#217#233'p'#193'O'#0'@O'#131#135#208#1#0#244#172#211'I'#231#210#241 143 | +#206#16':'#0#128#222'!t'#0#0'O@'#232'x)'#176#25'*'#4#0#232'\'#232'8W'#29'g' 144 | +#243#206'H'#222'J'#222#202'{#'#231#188#214'7'#214#169#16#0#160'mI'#146'l'#13 145 | +#157#250#201#219#30#170#254'.'#147#205'R1'#0'@'#219#10#133#194#214#208#169 146 | +#197#204'f'#248'4'#187#20'5'#0#0#237'h'#233#144'ir'#7#0#176'_'#198#24'U*'#149 147 | +#173#161#211#188#195#217#28'^'#11'B'#170#6#0#232#24#219#152'J'#12#175#1#0':%' 148 | +#8#130#157'C'#231'a'#248'P('#0#192#254#165'3'#134#238#26':'#181#224'!|'#0#0 149 | +#251#176#235#129#4#233'5r'#156#243#156#167#3#0#216'w'#224'Xk['#235't'#0#0#232 150 | +'4B'#7#0'@'#232#0#0#8#29#0#0#246#164'~^'#29'B'#7#0#208'3\r'#0#0#208#221#160#9 151 | +'C'#25'#'#5#161#165#211#1#0#244#180#211'q'#146#169'_T'#253'*Ou'#0#0#251#146 152 | +'^Z'#173'z'#14#168#219#189#211#137#227'2'#21#3#0't'#12#195'k'#0#128#174'u9' 153 | +#134#208#1#0#208#233#0#0#8#29#0#0#8#29#0#0#161#3#0#192#142#161'S?Euz'#28#181 154 | +#247'^'#198'H'#153'L'#142#10#1#0#218#183#153'1'#233'B'#167#3#0#232']'#167'C' 155 | +#9#0#0#132#14#0#224#169'f'#140#145#140'!t'#0#0't:'#0#0'B'#7#0#0'B'#7#0#240 156 | +#148#217'6sh'#253'9;'#0#0#180#203'{/m'#158#251'Y]'#232't'#0#0'=D'#232#0#0#8 157 | +#29#0#0#161#3#0'@K89'#20#0'@'#167#3#0' t'#0#0#232'l'#232'<<~z'#251#18'Ee*'#4 158 | +#0#160#211#1#0#16':'#0#0#16':'#0#0'B'#7#0'@'#232#0#0#176'?'#166#225#196'PB'#7 159 | +#0'@'#167#3#0'x6'#133#148#0#0#208#13'I'#146#200'm9'#255#147'N'#7#0#208'C'#132 160 | +#14#0#160'+'#140'12'#132#14#0#128'N'#7#0'@'#232#0#0'@'#232#0#0#8#29#0#0'Z'#14 161 | +#29#239#189#164#244#242#5#134#10#1#0#218'R??'#155's'#142'N'#7#0#240#152';'#29 162 | +#0#0#8#29#0#192'S'#133#171'L'#3#0#232't'#0#0#132#14#0#0#132#14#0#224#25#9#157 163 | +'t'#199'O'#245'|'#29'O'#133#0#0'm'#171#159'K'#199';C'#167#3#0'x'#140#157#14#0 164 | +#0#132#14#0#128#208#1#0#128#208#1#0'p'#188#247'"r'#0#0#157#12#156'Tm' 219 | +#159'N'#227'T'#213#0#0't'#170#195#217'v'#25#156#198''#0#0#160#211#161#19#26 220 | +'#Yk'#21#4#129#130' t'#0#0#29#15#157'Th'#140#221#22':'#214'Z'#25'cT'#169'T' 221 | +#168#24#0#160'c'#225#19#166'!'#147'.'#146#148'fR'#20#17':'#0#128#206'u:'#214 222 | +#185'D'#222'{'#245#245#245#201'Z'#171'J'#165#162'r'#165#162' '#224#188'Q'#0 223 | +'@'#251#156's'#15'O'#197'ICG'#170';'#170'`sX'#141'}:'#0#128'n'#176#198#152 224 | +#218#254#156#250'a6k'#173'2'#153#28#21#2#0't6t'#234#15'$H'#15'&'#0#0#160'k' 225 | +#161#147'.'#181#225'5c'#148#205'd'#168#16#0#160's'#161#147'~'#179#229#4#30'U' 226 | +#175'P'#176#182#190'F'#133#0#0#157#15#157#250#224#145'$yiv'#246'K*'#4#0#232 227 | +'N'#167#147#242#242#242'J'#168#14#0#160#179#161#227#189#147#181#146's'#177 228 | +#140#241#202'd'#2'e2'#129'$'#167#177#177'1*'#4#0'hK'#253#252'l'#219':'#29#0#0 229 | +'z'#208#233'<'#156#202#160#254'H6'#14#155#6#0't'#178#227#169'u:'#245'W$'#168 230 | +#191#6#27#0#0#157#8#157#166#243#233'4'#158#175#147#225'<'#29#0'@'#135#2#231 231 | +#145#161#3#0#192'~C'#167#158#221'-'#149#0#0#232'Z'#167#195#148#213#0#128'n' 232 | +#10#211#131#6#242#249#188#172#181#202#229'r*'#20#10'2'#198'('#138'"*'#4#0'h' 233 | +#155#247'^a'#24#202#24'#'#239'='#231#233#0#0#186#27':'#245#167#230#16':'#0 234 | +#128#174#134'N'#253#247#132#14#0#160'g'#157'NHI'#0#0#221#12#29#231#28#195'k' 235 | +#0#128#222'w:'#132#14#0#160#235#161#147'bx'#13#0#208#147#240#217#210#233'lll' 236 | +'('#155#205'*'#8#2'%I"'#239#189'fgg'#169#20#0#160'-Q'#148'('#138#18#149#203 237 | +#145#226#216#201#218#160#249#240#26'W$'#0#0't'#178#195'I'#217#250#153#221#26 238 | +#255'qrr'#146#138#1#0#246#21':'#15#23')'#220#250#139#173#19#186'e'#179'Y*'#6 239 | +#0#232'X'#183#19#166#191'p'#206#213#142#165#174'?'#166#26#0#128#253'v:'#233 240 | +#247#161'sNI'#146#212#22#0#0#186#209#233'x'#239#171#195'ki'#151#227#156#147 241 | +#164#218#247#149'J'#133'j'#1#0#246#29'8'#169#218'>'#157#198#208#1#0#160#211 242 | +#193'c'#141'1J'#146'D'#229'rYI'#146'('#12'C'#21#10#5#229#243'y'#221#185's' 243 | +#135'j'#1#0#218'r'#224#192#1#133'aX'#155'S'#231#192#129#3#178#214'Ze2'#25#5 244 | +'A'#160'8'#142#21'E'#145#146'$'#145'1'#134'C'#166#1#0'm'#203#231#243#10#195 245 | +'P'#206'9'#197'q\'#237't$)'#151#203')'#12#195#218'L'#161#249'|^'#253#253#253 246 | +#26#30#30#166'j'#0#128#182#28':tH'#249'|^'#222'{'#197'q,k'#173'l'#16#4#202'f' 247 | +#179#202'd2'#181#225#181#131#7#15'jllL'#153'L'#134#170#1#0#218'2::'#170'l6[;' 248 | +'l:'#8'lu'#159#142#181'V'#249'|'#190'v'#205#181#254#254'~'#141#141#141#201'Z' 249 | +'.B'#13#0#216#187#191#251#187''#165#145#145#145'Z'#142#132'a'#168'L&+k'#173 250 | +'5A'#16'hhhH'#222'{'#173#175#175#203'9'#167#145#145#17#13#14#14'R9'#0#192#158 251 | +#188#252#242'?'#209#248#248#184#14#30'' 252 | +#159#215#234#234#170'J'#165#146#198#198#198#244#252#243#207#235#226#197#139 253 | +'T'#16#0#208#178#241#241'qMMM'#233#224#193#131#138#162'H'#198#24#245#245#245 254 | +')'#151#203#201#198'q,'#231#156#6#7#7'M.'#151'S'#20'E'#138#227'XG'#142#28#209 255 | +#201#147''''#233'v'#0#0'-;'#254'%'#29'=zT'#163#163#163#26#24#24#168'u:'#185 256 | +'\N'#153'LF6'#159#207#135'aX'#157#203#173#191#191'_'#198#24'mll(I'#18#189#242 257 | +#202'+'#26#27#27#211#185's'#231'466F5'#1#0#143#232'rF'#245#173'o'#157#211#169 258 | ,'S'''#245#245#215'_'#201#185'X'#7#14#12'hhhP'#214#202'XI'#202'f'#179'F'#170 259 | +#158#200#147#203#229#180#188#188#172#187'w'#239#234#196#137#19'z'#243#205'75' 260 | +'99'#201#132'n'#0#128']]'#188'xQg'#207#158#213#137#19''''#20#134#161#138#197 261 | +#162#10#133#130#6#6#6'j'#179#22'XI'#153#244#18#5#195#195#195#26#31#31'W__' 262 | +#159'fggU'#169'T'#244#242#203'/'#235#210#165'K'#186'p'#225#2#21#5#0#236'hbbB' 263 | +#175#188#242#138'&'''''#181#190#190#174#7#15#30#232#192#129#3#26#30#30'V.' 264 | +#151#147'T'#157#218' '#217#156#200'-'#235#156'3'#199#143#31#247'I'#146'hqqQ' 265 | +#250#211#159't'#250#244'i'#189#254#250#235'2'#198#168'R'#169#232#250#245#235 266 | +'T'#22#0'P366'#166#169#169')'#253#240#135'?'#212#217#179'g'#149'$'#137#230 267 | +#230#230't'#232#208'!'#29':tH'#133'BA'#214'Z'#147'v:Q'#250#31#173#181'6'#155 268 | +#205#154#163'G'#143#234#204#153'3'#154#159#159#215#189'{'#247#148#207#231#245 269 | +#221#239'~Wo'#190#249'&'#29#15#0'`'#139#139#23'/'#234'''?'#249#137#222'z'#235 270 | +'-y'#239'u'#247#238']'#197'q'#172#139#23'/jxxX'#233'q'#3'i'#167'#I'#214'{_1' 271 | +#198#4#198#24#27#199#177'N'#159'>'#173#251#247#239'kffF'#15#30'<'#208#216#216 272 | +#152'~'#250#211#159'j||\ccc'#250#205'o~C'#165#1#224#27#236'['#223#250#150'^z' 273 | +#233'%'#189#246#218'kz'#245#213'WU,'#22'u'#243#230'MYk'#245#226#139'/'#234 274 | +#248#241#227'&I'#18#31#4#129#169#133#206#230#254#28'''I'#222#251#196#24#19 275 | +#134'a'#152#139#162#168'|'#233#210'%y'#239'533'#163#217#217'Y'#29'>|X'#151'.' 276 | +']R__'#159#142#28'9'#162#233#233'i}'#240#193#7'T'#30#0#190'A&''''522'#162#239 277 | +'}'#239'{'#250#206'w'#190#163#137#137#9'-,,hffF}}}z'#241#197#23'u'#254#252'y' 278 | +'I'#210#230#238#155#26'S?'#207#129'1F'#222'{'#25'c'#2'I'#25#231'\iii'#201'_' 279 | +#189'zUW'#174'\'#209#194#194#130'^{'#237'5'#29''#210#221#187'w'#21#4#129'N'#159'>'#173 287 | +#11#23'.hddD'#249'|^'#166'j'#219'm=2t$'#201'9'#231'K'#165#146#22#22#22'4==' 288 | +#173';w'#238#168'X,*'#8#2'MNNjjjJ'#149'JE333'#186'~'#253#186'>'#250#232'#MOO' 289 | +#235#242#229#203#188'Z'#0#240#20'z'#249#229#151'599'#169#211#167'O'#215'Bgpp' 290 | +'Pa'#24'jeeEW'#175'^U.'#151#211#225#195#135'599'#169#147'''OjddDA'#16#24#231 291 | +#156'O'#143'Vk)t'#26#210#201'J2I'#146#196#214'Z'#147'$'#137#255#234#171#175 292 | +'t'#243#230'M'#221#184'qC'#203#203#203#202'f'#179#154#152#152#208's'#207'=' 293 | +#167#129#129#1'I'#210#210#210#146#238#222#189#171#153#153#25#221#189'{Wsss*' 294 | +#22#139'Z^^Q'#177#248'@Q'#20#233#179#207'n'#242#202#2'@'#143#157':uJ'#249'|^' 295 | +#217'lV'#249'|^'#133'BA'#217'lVSSS:s'#230#140#14#28'8'#160#163'G'#143'jdd' 296 | +#164'v'#244#217#202#202#138'fgg'#245#245#215'_kmmMCCC:y'#242#164'N'#156'8' 297 | +#161#163'G'#143'*'#151#203#153'4?vkfZ'#234't'#164#135's\'#167#129#20'E'#145 298 | +''#240#224#129#166#167#167'u'#251#246'm'#21#139'Ey'#239'500'#160'C'#135#14 299 | +'ixxX'#131#131#131'*'#20#10'2'#198#168'T*i}}]'#165'RIq'#236#228#156'S'#146'$' 300 | +'J'#146'D'#206'UNo?]'#210#169#22#234'_'#31#140#233#207#222';y'#239#182'<' 301 | +#206#157#30'{'#227't'#13#245#183'S'#251#173#214#165'Y'#251#184's'#13'MK'#183 302 | +#215#236#241'4{\'#222'''{z'#140#233#255'M'#231#182#216#254#189#145'w'#219'k' 303 | +#144#254'M'#253#207#173'N{'#209'j'#29#31'''o'#188#164#14#190#222'^'#218'|;v' 304 | +#236#253#179#151#247#227#163'o'#211'K'#198'o~'#230'Z'#238#143'fe'#20't'#244 305 | +#249'x'#185'm'#143#175#217#243#171'_'#135#236#246'w'#198'T'#151'N'#10#195#140 306 | +'L'#245#226'.['#214'_'#173'|'#158'wz'#13#27'?_'#245#159#189'zA'#16'l'#249'|' 307 | +#239#212'D'#212'?'#239#244#243#27#4#129'r'#185#156#10#133#130#250#250#250'T(' 308 | +#20#20#199#177'666d'#173'U'#20'EZ]]U'#177'XT'#177'XT'#169'TR'#24#134'*'#20#10 309 | +':r'#228#136'.^'#188#168#129#129#1#5'A`6o3'#144#148#147#228#188#247#165'}' 310 | +#135#206'no'#152'J'#165#226#151#150#150'477'#167#185#185'9---'#169'R'#169#212 311 | +#158'T__'#159#6#7#7'588'#168#254#254'~Y'#27'n{'#129#26#23'I'#138#227'x['#216 312 | +'5'#6'O'#245#171#223'e'#197#236#31#249'\vz'#177':'#250#225#241#213#165#213 313 | +#149#198'N+'#143#173'o>'#183#167#21'['#253'sm|'#19'{'#239'%o'#228#189#221'5t' 314 | +#210#165#211'+'#203'g*t$'#25'o;z{'#223#212#208'q>'#169#173',w[W'#236'V'#215 315 | +'mGO'#153#206#190''''#195'0'#163#234#250#182#249#134'c'#186#180#186#158'i' 316 | +#237#179#175#29'?'#155#205#238#163'R)'#203#185'DA'#16#200'Z['#219#232#143#162 317 | +'H'#149'JEq'#28'+I'#146'ZsP'#169'TT'#169'Tj'#19'{'#14#12#12'hddD'#227#227#227 318 | +':|'#248#176#250#250#250'L'#221#253#251' '#8#130#218'K'#246#136#231#24#182'S' 319 | +#228#250#149'X'#28#199'>'#237'`'#188#247#202#229'r:p'#224#128'*'#149#138'J' 320 | +#165#146#150#150#150't'#231#206#29#133'a'#184#25':'#3'J'#18'''k'#173#194'0' 321 | +#172'-ib'#183#246#161'i|1'#182'v:'#205'^'#148'f/RZ'#248't+)]'#188#247'J'#146 322 | ,#164#163'+'#13#201#212#182#134'v'#253#144'm'#206'%'#222#236'C'#211#248'= 0) then Msg.Result := Msg.Result or DLGC_WANTTAB; 79 | end; 80 | 81 | procedure TScrollingControl.WMHScroll(var Msg: TWMScroll); 82 | begin 83 | HScroll(Msg); 84 | end; 85 | 86 | procedure TScrollingControl.WMVScroll(var Msg: TWMScroll); 87 | begin 88 | VScroll(Msg); 89 | end; 90 | 91 | procedure ZeroMemory(Destination: Pointer; Length: Cardinal); 92 | begin 93 | FillChar(Destination^, Length, 0); 94 | end; 95 | 96 | procedure TScrollingControl.SetVScrollPos(NewPos: Integer); 97 | begin 98 | FVScrollInfo.nPos := Max(0, Min(fVScrollInfo.nMax - fVScrollInfo.nPage, NewPos)); 99 | SetScrollInfo(Handle, SB_VERT, fVScrollInfo, True); 100 | Invalidate; 101 | end; 102 | 103 | 104 | procedure TScrollingControl.VScroll(var Msg: TWMScroll); 105 | var si: TScrollInfo; 106 | var newPos: Longint; 107 | begin 108 | if CanShowV then begin 109 | {$IFDEF LCLqt} 110 | newpos := Msg.Pos; 111 | {$ELSE} 112 | ZeroMemory(@si, sizeof(si)); 113 | si.cbSize := sizeof(si); 114 | si.fMask := SIF_TRACKPOS; //MSDN against 65k limit 115 | {$IFDEF LCLGtk2} 116 | newpos := Msg.Pos; 117 | {$ELSE} 118 | if GetScrollInfo(Handle, SB_VERT, si) then newPos := si.nTrackPos else newpos := Msg.Pos; 119 | {$ENDIF} 120 | {$ENDIF} 121 | case Msg.ScrollCode of 122 | SB_THUMBPOSITION, 123 | SB_THUMBTRACK: 124 | begin 125 | SetVScrollPos(NewPos); 126 | end; 127 | SB_LINEDOWN: SetVScrollPos(FVScrollInfo.nPos + fSmallStep); 128 | SB_PAGEDOWN: SetVScrollPos(FVScrollInfo.nPos + fLargeStep); 129 | SB_LINEUP: SetVScrollPos(FVScrollInfo.nPos - fSmallStep); 130 | SB_PAGEUP: SetVScrollPos(FVScrollInfo.nPos - fLargeStep); 131 | SB_TOP: SetVScrollPos(0); 132 | SB_BOTTOM: SetVScrollPos(FVScrollInfo.nMax); 133 | end; 134 | end; 135 | end; 136 | 137 | 138 | procedure TScrollingControl.SetHScrollPos(NewPos: Integer); 139 | begin 140 | fHScrollInfo.nPos := Max(0, Min(fHScrollInfo.nMax - fHScrollInfo.nPage, NewPos)); 141 | SetScrollInfo(Handle, SB_HORZ, fHScrollInfo, True); 142 | Invalidate; 143 | end; 144 | 145 | 146 | procedure TScrollingControl.HScroll(var Msg: TWMScroll); 147 | var si: TScrollInfo; 148 | var newPos: Longint; 149 | begin 150 | {$IFDEF LCLqt} 151 | newpos := Msg.Pos; 152 | {$ELSE} 153 | ZeroMemory(@si, sizeof(si)); 154 | si.cbSize := sizeof(si); 155 | si.fMask := SIF_TRACKPOS; //MSDN against 65k limit 156 | {$IFDEF LCLGtk2} 157 | newpos := Msg.Pos; 158 | {$ELSE} 159 | if GetScrollInfo(Handle, SB_HORZ, si) then newPos := si.nTrackPos else newpos := Msg.Pos; 160 | {$ENDIF} 161 | {$ENDIF} 162 | case Msg.ScrollCode of 163 | SB_THUMBPOSITION, 164 | SB_THUMBTRACK: 165 | begin 166 | SetHScrollPos(NewPos); 167 | end; 168 | SB_LINEDOWN: SetHScrollPos(FHScrollInfo.nPos + fSmallStep); 169 | SB_PAGEDOWN: SetHScrollPos(FHScrollInfo.nPos + fLargeStep); 170 | SB_LINEUP: SetHScrollPos(FHScrollInfo.nPos - fSmallStep); 171 | SB_PAGEUP: SetHScrollPos(FHScrollInfo.nPos - fLargeStep); 172 | SB_LEFT: SetHScrollPos(0); 173 | SB_RIGHT: SetVScrollPos(FHScrollInfo.nMax); 174 | end; 175 | end; 176 | 177 | 178 | procedure TScrollingControl.SetScrollBars(const AValue: TScrollStyle); 179 | begin 180 | DoSetScrollBars(AValue, False); 181 | end; 182 | 183 | procedure TScrollingControl.DoSetScrollBars(const AValue: TScrollStyle; Force: Boolean); 184 | begin 185 | if (FScrollBars <> AValue) or Force then 186 | begin 187 | case AValue of 188 | ssBoth: begin 189 | ShowScrollBar(Handle, SB_HORZ, True); 190 | ShowScrollBar(Handle, SB_VERT, True); 191 | end; 192 | 193 | ssNone: begin 194 | ShowScrollBar(Handle, SB_HORZ, False); 195 | ShowScrollBar(Handle, SB_VERT, False); 196 | end; 197 | 198 | ssVertical: begin 199 | ShowScrollBar(Handle, SB_HORZ, False); 200 | ShowScrollBar(Handle, SB_VERT, True); 201 | end; 202 | 203 | ssHorizontal: begin 204 | ShowScrollBar(Handle, SB_HORZ, True); 205 | ShowScrollBar(Handle, SB_VERT, False); 206 | end; 207 | 208 | ssAutoBoth: begin 209 | ShowScrollBar(Handle, SB_HORZ, CanShowH); 210 | ShowScrollBar(Handle, SB_VERT, CanShowV); 211 | end; 212 | 213 | ssAutoHorizontal: begin 214 | ShowScrollBar(Handle, SB_HORZ, CanShowH); 215 | ShowScrollBar(Handle, SB_VERT, False); 216 | end; 217 | 218 | ssAutoVertical: begin 219 | ShowScrollBar(Handle, SB_HORZ, False); 220 | ShowScrollBar(Handle, SB_VERT, CanShowV); 221 | end; 222 | end; 223 | FScrollBars := AValue; 224 | UpdateHScrollInfo; 225 | UpdateVScrollInfo; 226 | end; 227 | end; 228 | 229 | procedure TScrollingControl.SetVScrollPosition(const AValue: integer); 230 | begin 231 | fVScrollInfo.nPos := AValue; 232 | UpdateVScrollInfo; 233 | end; 234 | 235 | procedure TScrollingControl.SetCanShowH(const AValue: boolean); 236 | begin 237 | if HandleAllocated then 238 | if (AValue <> fCanShowH) and (fScrollBars in [ssAutoBoth, ssAutoHorizontal]) then 239 | begin 240 | fCanShowH := AValue; 241 | DoSetScrollBars(fScrollbars); 242 | end; 243 | fCanShowH := AValue; 244 | end; 245 | 246 | function TScrollingControl.GetVScrollPosition: integer; 247 | begin 248 | Result := VScrollInfo.nPos; 249 | end; 250 | 251 | function TScrollingControl.GetHScrollPosition: integer; 252 | begin 253 | Result := HScrollInfo.nPos; 254 | end; 255 | 256 | procedure TScrollingControl.SetCanShowV(const AValue: boolean); 257 | begin 258 | if HandleAllocated then 259 | if (AValue <> fCanShowV) and (fScrollBars in [ssAutoBoth, ssAutoVertical]) then 260 | begin 261 | fCanShowV := AValue; 262 | DoSetScrollBars(fScrollbars); 263 | end; 264 | fCanShowV := AValue; 265 | end; 266 | 267 | procedure TScrollingControl.SetHScrollPosition(const AValue: integer); 268 | begin 269 | fHScrollInfo.nPos := AValue; 270 | UpdateHScrollInfo; 271 | end; 272 | 273 | 274 | procedure TScrollingControl.CreateParams(var Params: TCreateParams); 275 | const 276 | ScrollBar: array[TScrollStyle] of DWORD = (0, WS_HSCROLL, WS_VSCROLL, 277 | WS_HSCROLL or WS_VSCROLL, WS_HSCROLL, WS_VSCROLL, WS_HSCROLL or WS_VSCROLL); 278 | BorderStyles: array[TBorderStyle] of DWORD = (0, WS_BORDER); 279 | ClassStylesOff = CS_VREDRAW or CS_HREDRAW; 280 | begin 281 | inherited CreateParams(Params); 282 | with Params do begin 283 | {$IFOPT R+}{$DEFINE RangeCheckOn}{$R-}{$ENDIF} 284 | WindowClass.Style := WindowClass.Style and not Cardinal(ClassStylesOff); 285 | Style := Style or ScrollBar[FScrollBars] or BorderStyles[bsSingle] or WS_CLIPCHILDREN; 286 | {$IFDEF RangeCheckOn}{$R+}{$ENDIF} 287 | if true (*NewStyleControls and Ctl3D {and (BorderStyle = bsSingle)} *) then begin 288 | Style := Style and not Cardinal(WS_BORDER); 289 | ExStyle := ExStyle or WS_EX_CLIENTEDGE; 290 | end; 291 | end; 292 | end; 293 | 294 | 295 | procedure TScrollingControl.CreateWnd; 296 | begin 297 | inherited CreateWnd; 298 | // if not (csLoading in componentstate) then 299 | begin 300 | DoSetScrollBars(fScrollBars); 301 | UpdateHScrollInfo; 302 | UpdateVScrollInfo; 303 | end; 304 | end; 305 | 306 | constructor TScrollingControl.Create(AOwner: TComponent); 307 | begin 308 | inherited Create(AOwner); 309 | fScrollBars := ssAutoBoth; 310 | fVScrollInfo.fMask := SIF_ALL or SIF_DISABLENOSCROLL and not SIF_TRACKPOS; 311 | fVScrollInfo.nMax := 1000; 312 | fVScrollInfo.nMin := 0; 313 | fVScrollInfo.nPage := 100; 314 | fVScrollInfo.nPos := 0; 315 | fHScrollInfo := FVScrollInfo; 316 | fLargeStep := 50; 317 | fSmallStep := 12; 318 | end; 319 | 320 | destructor TScrollingControl.Destroy; 321 | begin 322 | inherited Destroy; 323 | end; 324 | 325 | procedure TScrollingControl.UpdateHScrollInfo; 326 | begin 327 | if (fScrollBars in [ssBoth, ssHorizontal]) or ((fScrollBars in [ssAutoBoth, ssAutoHorizontal]) and CanShowH) then 328 | begin 329 | SetHScrollPos(HScrollInfo.nPos); 330 | end; 331 | end; 332 | 333 | procedure TScrollingControl.UpdateVScrollInfo; 334 | begin 335 | if (fScrollBars in [ssBoth, ssVertical]) or ((fScrollBars in [ssAutoBoth, ssAutoVertical]) and CanShowV) then 336 | begin 337 | SetVScrollPos(VScrollInfo.nPos); 338 | end; 339 | 340 | end; 341 | 342 | 343 | end. 344 | -------------------------------------------------------------------------------- /threadedimageloader.pas: -------------------------------------------------------------------------------- 1 | unit threadedimageLoader; 2 | 3 | //22.6.2010 Theo 4 | 5 | {$MODE objfpc}{$H+} 6 | 7 | interface 8 | 9 | uses 10 | Classes, SysUtils, contnrs, types, syncobjs, Forms, Graphics, fileutil, FPimage; 11 | 12 | type 13 | 14 | EThreadedImageLoaderError = class(Exception); 15 | TLoadState = (lsEmpty, lsLoading, lsLoaded, lsError); 16 | 17 | { TThreadedImage } 18 | TLoaderThread = class; 19 | 20 | TThreadedImage = class 21 | private 22 | FOnThreadDone: TNotifyEvent; 23 | FOnThreadStart: TNotifyEvent; 24 | FArea: TRect; 25 | FBitmap: TBitmap; 26 | FHeight: integer; 27 | FImage: TFPMemoryImage; 28 | FOnLoaded: TNotifyEvent; 29 | FOnLoadURL: TNotifyEvent; 30 | FURL: UTF8String; 31 | FLoadState: TLoadState; 32 | FThread: TLoaderThread; 33 | FRect: TRect; 34 | FWidth: integer; 35 | FMultiThreaded: Boolean; 36 | function GetImage: TFPMemoryImage; 37 | function GetRect: TRect; 38 | procedure ThreadTerm(Sender: TObject); 39 | property OnThreadDone: TNotifyEvent read FOnThreadDone write FOnThreadDone; 40 | property OnThreadStart: TNotifyEvent read FOnThreadStart write FOnThreadStart; 41 | 42 | public 43 | constructor Create; overload; 44 | constructor Create(URL: UTF8String); overload; 45 | destructor Destroy; override; 46 | function Load(Reload: Boolean = False): Boolean; 47 | procedure FreeImage; 48 | property Image: TFPMemoryImage read GetImage; 49 | property Bitmap: TBitmap read FBitmap write FBitmap; 50 | property LoadState: TLoadState read FLoadState write FLoadState; 51 | property URL: UTF8String read FURL write FURL; 52 | property Left: integer read FRect.Left write FRect.Left; 53 | property Top: integer read FRect.Top write FRect.Top; 54 | property Width: integer read FWidth write FWidth; 55 | property Height: integer read FHeight write FHeight; 56 | property Rect: TRect read GetRect; 57 | property Area: TRect read fArea write fArea; 58 | published 59 | property OnLoaded: TNotifyEvent read FOnLoaded write FOnLoaded; 60 | property OnLoadURL: TNotifyEvent read FOnLoadURL write FOnLoadURL; 61 | end; 62 | 63 | { TLoaderThread } 64 | 65 | TLoaderThread = class(TThread) 66 | private 67 | fRef: TThreadedImage; 68 | protected 69 | procedure Execute; override; 70 | end; 71 | 72 | { TImageLoaderManager } 73 | 74 | TImageLoaderManager = class 75 | private 76 | FActiveIndex: integer; 77 | FFreeInvisibleImage: Boolean; 78 | fList: TObjectList; 79 | FMultiThreaded: boolean; 80 | FQueue: TList; 81 | FOnLoaded: TNotifyEvent; 82 | FOnLoadURL: TNotifyEvent; 83 | FReload: Boolean; 84 | FMaxThreads: integer; 85 | FThreadsFree: integer; 86 | procedure NextInQueue; 87 | procedure ThreadDone(Sender: TObject); 88 | procedure ThreadStart(Sender: TObject); 89 | function GetActiveItem: TThreadedImage; 90 | procedure SetActiveIndex(const AValue: integer); 91 | public 92 | constructor Create; 93 | destructor Destroy; override; 94 | function AddImage(URL: UTF8String): TThreadedImage; 95 | procedure LoadAll; 96 | procedure LoadRect(ARect: TRect); 97 | procedure StartQueue; 98 | function ItemIndexFromPoint(Point: TPoint): integer; 99 | function ItemFromPoint(Point: TPoint): TThreadedImage; 100 | procedure Clear; 101 | procedure FreeImages; 102 | function CountItems: integer; 103 | function ThreadsIdle:boolean; 104 | property List: TObjectList read fList write fList; 105 | property Reload: Boolean read FReload write FReload; 106 | property FreeInvisibleImage: Boolean read FFreeInvisibleImage write FFreeInvisibleImage; 107 | procedure Sort(stpye: byte); 108 | function ItemFromIndex(AValue: integer): TThreadedImage; 109 | property ActiveIndex: integer read FActiveIndex write SetActiveIndex; 110 | property ActiveItem: TThreadedImage read GetActiveItem; 111 | 112 | published 113 | property OnLoaded: TNotifyEvent read FOnLoaded write FOnLoaded; 114 | property OnLoadURL: TNotifyEvent read FOnLoadURL write FOnLoadURL; 115 | property MultiThreaded: boolean read FMultiThreaded write FMultiThreaded; 116 | end; 117 | 118 | var CSImg: TCriticalSection; 119 | 120 | implementation 121 | 122 | uses Math, LazUTF8; 123 | 124 | var CS: TCriticalSection; 125 | 126 | 127 | { TThreadedImage } 128 | 129 | procedure TThreadedImage.ThreadTerm(Sender: TObject); 130 | var aW, aH: integer; 131 | begin 132 | FLoadState := lsEmpty; 133 | if FImage <> nil then 134 | begin 135 | aW := fImage.Width; 136 | aH := fImage.Height; 137 | if (aW > 0) and (aH > 0) then 138 | begin 139 | if fBitmap = nil then fBitmap := TBitmap.Create; 140 | try 141 | try 142 | CSImg.Acquire; 143 | fBitmap.Assign(fImage); 144 | fBitmap.Transparent:=false; 145 | FLoadState := lsError; 146 | FreeAndNil(fImage); 147 | except 148 | if fMultiThreaded then if Assigned(fOnThreadDone) then OnThreadDone(Self); 149 | end; 150 | finally 151 | CSImg.Release; 152 | end; 153 | FLoadState := lsLoaded; 154 | if fMultiThreaded then if Assigned(fOnLoaded) then OnLoaded(Self); 155 | end; 156 | end; 157 | if fMultiThreaded then if Assigned(fOnThreadDone) then OnThreadDone(Self); 158 | end; 159 | 160 | function TThreadedImage.GetRect: TRect; 161 | begin 162 | fRect.Right := fRect.Left + fWidth; 163 | fRect.Bottom := fRect.Top + fHeight; 164 | Result := fRect; 165 | end; 166 | 167 | 168 | function TThreadedImage.GetImage: TFPMemoryImage; 169 | begin 170 | Result := FImage; 171 | end; 172 | 173 | constructor TThreadedImage.Create; 174 | begin 175 | FLoadState := lsEmpty; 176 | fMultiThreaded := False; 177 | FBitmap := nil; 178 | Fimage := nil; 179 | end; 180 | 181 | constructor TThreadedImage.Create(URL: UTF8String); 182 | begin 183 | fURL := URL; 184 | Create; 185 | end; 186 | 187 | destructor TThreadedImage.Destroy; 188 | begin 189 | fBitmap.free; 190 | inherited Destroy; 191 | end; 192 | 193 | function TThreadedImage.Load(Reload: Boolean): Boolean; 194 | begin 195 | Result := True; 196 | if URL = '' then begin Result := False; exit; end; 197 | 198 | if (fLoadState = lsEmpty) or Reload then 199 | begin 200 | fLoadState := lsLoading; 201 | if Fimage = nil then 202 | begin 203 | FImage := TFPMemoryImage.Create(0, 0); 204 | FImage.UsePalette := false; 205 | end; 206 | 207 | if not fMultiThreaded then 208 | begin 209 | if Assigned(fOnLoadURL) then OnLoadURL(Self) else Image.LoadFromFile(UTF8ToSys(URL)); 210 | ThreadTerm(self); 211 | end else 212 | begin 213 | fThread := TLoaderThread.Create(true); 214 | if Assigned(fOnThreadStart) then OnThreadStart(Self); 215 | fThread.fRef := Self; 216 | fThread.FreeOnTerminate := true; 217 | fThread.OnTerminate := @ThreadTerm; 218 | fThread.Resume; 219 | end; 220 | end else Result := false; 221 | end; 222 | 223 | procedure TThreadedImage.FreeImage; 224 | begin 225 | fLoadState := lsEmpty; 226 | FreeAndNil(fBitmap); 227 | end; 228 | 229 | 230 | { TLoaderThread } 231 | 232 | 233 | procedure TLoaderThread.Execute; 234 | begin 235 | if Assigned(fRef.OnLoadURL) then fRef.OnLoadURL(fRef) else 236 | begin 237 | fRef.Image.LoadFromFile(UTF8ToSys(fRef.URL)); 238 | end; 239 | end; 240 | 241 | 242 | { TImageLoaderManager } 243 | 244 | 245 | function TImageLoaderManager.GetActiveItem: TThreadedImage; 246 | begin 247 | Result := ItemFromIndex(fActiveIndex); 248 | end; 249 | 250 | procedure TImageLoaderManager.SetActiveIndex(const AValue: integer); 251 | begin 252 | if (AValue > -1) and (AValue < fList.Count) then FActiveIndex := AValue; 253 | end; 254 | 255 | constructor TImageLoaderManager.Create; 256 | begin 257 | fMultiThreaded := False; 258 | FList := TObjectList.Create; 259 | FQueue := TList.Create; 260 | FReload := false; 261 | FFreeInvisibleImage := false; 262 | FMaxThreads := 8; 263 | FThreadsFree := FMaxThreads; 264 | end; 265 | 266 | destructor TImageLoaderManager.Destroy; 267 | begin 268 | FQueue.free; 269 | FList.free; 270 | inherited Destroy; 271 | end; 272 | 273 | function TImageLoaderManager.AddImage(URL: UTF8String): TThreadedImage; 274 | begin 275 | Result := TThreadedImage.Create(URL); 276 | Result.FMultiThreaded := FMultiThreaded; 277 | if Assigned(FOnLoadURL) then Result.OnLoadURL := FOnLoadURL; 278 | if Assigned(FOnLoaded) then Result.OnLoaded := FOnLoaded; 279 | Result.OnThreadDone := @ThreadDone; 280 | Result.OnThreadStart := @ThreadStart; 281 | FList.Add(Result); 282 | end; 283 | 284 | procedure TImageLoaderManager.LoadAll; 285 | var i: integer; 286 | begin 287 | if not FMultiThreaded then 288 | for i := 0 to fList.Count - 1 do TThreadedImage(fList[i]).Load(FReload) else 289 | begin 290 | for i := 0 to fList.Count - 1 do 291 | if fQueue.IndexOf(TThreadedImage(fList[i])) < 0 then fQueue.Add(TThreadedImage(fList[i])); 292 | StartQueue; 293 | end; 294 | end; 295 | 296 | procedure TImageLoaderManager.LoadRect(ARect: TRect); 297 | var i: integer; 298 | Dum: TRect; 299 | begin 300 | FQueue.Clear; 301 | 302 | if not FMultiThreaded then 303 | begin 304 | for i := 0 to fList.Count - 1 do 305 | if IntersectRect(Dum, ARect, TThreadedImage(fList[i]).Rect) then 306 | TThreadedImage(fList[i]).Load(FReload) else if FFreeInvisibleImage then 307 | TThreadedImage(fList[i]).FreeImage; 308 | end else 309 | begin 310 | for i := 0 to fList.Count - 1 do 311 | begin 312 | if IntersectRect(Dum, ARect, TThreadedImage(fList[i]).Rect) then 313 | begin 314 | if fQueue.IndexOf(TThreadedImage(fList[i])) < 0 then fQueue.Add(TThreadedImage(fList[i])) 315 | end else if FFreeInvisibleImage then TThreadedImage(fList[i]).FreeImage; 316 | end; 317 | StartQueue; 318 | end; 319 | end; 320 | 321 | procedure TImageLoaderManager.StartQueue; 322 | begin 323 | NextInQueue; 324 | end; 325 | 326 | procedure TImageLoaderManager.NextInQueue; 327 | var i: integer; 328 | begin 329 | if (fQueue.Count > 0) and (FThreadsFree > 0) then 330 | begin 331 | i := Min(fQueue.Count - 1, fThreadsFree); 332 | while i > -1 do 333 | begin 334 | if not TThreadedImage(fQueue[i]).Load(fReload) then 335 | begin 336 | fQueue.Delete(i); 337 | if fQueue.Count > i then inc(i); 338 | end; 339 | dec(i); 340 | end; 341 | end; 342 | end; 343 | 344 | 345 | procedure TImageLoaderManager.ThreadDone(Sender: TObject); 346 | var idx: integer; 347 | begin 348 | Inc(FThreadsFree); 349 | idx := fQueue.IndexOf(Sender); 350 | if idx > -1 then fQueue.Delete(idx); 351 | NextInQueue; 352 | end; 353 | 354 | procedure TImageLoaderManager.ThreadStart(Sender: TObject); 355 | begin 356 | Dec(FThreadsFree); 357 | end; 358 | 359 | 360 | function TImageLoaderManager.ItemIndexFromPoint(Point: TPoint): integer; 361 | var i: integer; 362 | aRect: TRect; 363 | begin 364 | Result := -1; 365 | for i := 0 to fList.Count - 1 do 366 | if TThreadedImage(fList[i]).LoadState = lsLoaded then 367 | begin 368 | aRect := TThreadedImage(fList[i]).Rect; 369 | OffsetRect(aRect, TThreadedImage(fList[i]).Area.Left, TThreadedImage(fList[i]).Area.Top); 370 | if PtInRect(aRect, Point) then 371 | begin 372 | Result := i; 373 | break; 374 | end; 375 | end; 376 | end; 377 | 378 | function TImageLoaderManager.ItemFromPoint(Point: TPoint): TThreadedImage; 379 | begin 380 | Result := ItemFromIndex(ItemIndexFromPoint(Point)); 381 | end; 382 | 383 | 384 | procedure TImageLoaderManager.Clear; 385 | begin 386 | FList.Clear; 387 | end; 388 | 389 | procedure TImageLoaderManager.FreeImages; 390 | var i: integer; 391 | begin 392 | try 393 | CSImg.Acquire; 394 | for i := 0 to fList.Count - 1 do TThreadedImage(fList[i]).FreeImage; 395 | finally 396 | CSImg.Release; 397 | end; 398 | end; 399 | 400 | function TImageLoaderManager.CountItems: integer; 401 | begin 402 | CS.Acquire; 403 | try 404 | Result := fList.Count; 405 | finally 406 | CS.Release; 407 | end; 408 | end; 409 | 410 | function TImageLoaderManager.ThreadsIdle: boolean; 411 | begin 412 | Result:=fThreadsFree=fMaxThreads; 413 | end; 414 | 415 | function sComp(Item1, Item2: Pointer): Integer; 416 | begin 417 | Result := CompareStr(TThreadedImage(Item1).URL, TThreadedImage(Item2).URL); 418 | end; 419 | 420 | procedure TImageLoaderManager.Sort(stpye: byte); 421 | begin 422 | fList.Sort(@sComp); 423 | end; 424 | 425 | function TImageLoaderManager.ItemFromIndex(AValue: integer): TThreadedImage; 426 | begin 427 | if (AValue > -1) and (AValue < fList.Count) then Result := TThreadedImage(fList[AValue]) else 428 | Result := nil; 429 | end; 430 | 431 | initialization 432 | 433 | CS := TCriticalSection.Create; 434 | CSImg := TCriticalSection.Create; 435 | 436 | finalization 437 | 438 | CSImg.free; 439 | CS.Free; 440 | 441 | 442 | end. 443 | -------------------------------------------------------------------------------- /thumbcontrol.pas: -------------------------------------------------------------------------------- 1 | unit thumbcontrol; 2 | 3 | //22.6.2010 Theo 4 | //Git push 30.1.2013 5 | 6 | {$MODE objfpc}{$H+} 7 | 8 | interface 9 | 10 | uses 11 | Classes, SysUtils, Controls, scrollingcontrol, ThreadedImageLoader, 12 | Graphics, fpImage, FPReadJPEGthumb, fpthumbresize, LResources, 13 | FileUtil, Dialogs, GraphType, LCLType, LCLIntf, Types; 14 | 15 | 16 | type 17 | TLayoutStyle = (LsAuto, LsAutoSize, LsHorizFixed, LsVertFixed, LsHorizAutoSize, LsVertAutoSize, LsGrid); 18 | TInternalLayoutStyle = (IlsHorz, IlsVert, IlsGrid); 19 | 20 | TSelectItemEvent = procedure(Sender: TObject; Item: TThreadedImage) of object; 21 | TLoadFileEvent = procedure(Sender: TObject; URL: string; out Stream: TStream) of object; 22 | 23 | { TThumbControl } 24 | 25 | TThumbControl = class(TScrollingControl) 26 | private 27 | FArrangeStyle: TLayoutStyle; 28 | FIls: TInternalLayoutStyle; 29 | fContentWidth: integer; 30 | fContentHeight: integer; 31 | FDirectory: UTF8String; 32 | fMngr: TImageLoaderManager; 33 | FOnLoadFile: TLoadFileEvent; 34 | FShowPictureFrame: Boolean; 35 | FShowCaptions: Boolean; 36 | fAutoSort: boolean; 37 | fThumbWidth: integer; 38 | fThumbHeight: integer; 39 | FURLList: TStringList; 40 | fUserThumbWidth: integer; 41 | fUserThumbHeight: integer; 42 | fFrame: TBitmap; 43 | fThumbDist: integer; //Distance between thumbnails 44 | fPictureFrameBorder: integer; //One Border of blacke picture frame 45 | fTextExtraHeight: integer; 46 | fLeftOffset: integer; //first frame left offset 47 | fTopOffset: integer; 48 | fOnSelectItem: TSelectItemEvent; 49 | fWindowCreated: Boolean; 50 | fGridThumbsPerLine: integer; 51 | function GetFreeInvisibleImages: boolean; 52 | function GetMultiThreaded: boolean; 53 | function GetURLList: UTF8String; 54 | procedure Init; 55 | procedure SetArrangeStyle(const AValue: TLayoutStyle); 56 | procedure SetAutoSort(AValue: boolean); 57 | procedure SetDirectory(const AValue: UTF8String); 58 | procedure SetFreeInvisibleImages(const AValue: boolean); 59 | procedure SetMultiThreaded(const AValue: boolean); 60 | procedure SetShowPictureFrame(const AValue: Boolean); 61 | procedure SetShowCaptions(const AValue: Boolean); 62 | procedure SetThumbDistance(const AValue: integer); 63 | procedure SetThumbHeight(const AValue: integer); 64 | procedure SetThumbWidth(const AValue: integer); 65 | procedure AsyncFocus(Data: PtrInt); 66 | procedure SetURLList(const AValue: UTF8String); 67 | protected 68 | class function GetControlClassDefaultSize: TSize; override; 69 | procedure BoundsChanged; override; 70 | procedure Paint; override; 71 | procedure ImgLoadURL(Sender: TObject); 72 | procedure ImgLoaded(Sender: TObject); 73 | procedure Search; 74 | procedure FileFoundEvent(FileIterator: TFileIterator); 75 | procedure CreateWnd; override; 76 | procedure Click; override; 77 | procedure DoSelectItem; virtual; 78 | procedure KeyDown(var Key: Word; Shift: TShiftState); override; 79 | procedure KeyUp(var Key: Word; Shift: TShiftState); override; 80 | procedure UpdateDims; 81 | procedure Arrange; 82 | procedure DoAutoAdjustLayout(const AMode: TLayoutAdjustmentPolicy; 83 | const AXProportion, AYProportion: Double); override; 84 | public 85 | constructor Create(AOwner: TComponent); override; 86 | destructor Destroy; override; 87 | function GetDefaultColor(const DefaultColorType: TDefaultColorType): TColor; override; 88 | {:Use this function when you need the item from control coordinates (Mouse etc.)} 89 | function ItemFromPoint(APoint: TPoint): TThreadedImage; 90 | procedure ScrollIntoView; 91 | procedure LoadSelectedBitmap(ABitmap:TBitmap); 92 | property URLList: UTF8String read GetURLList write SetURLList; 93 | property ImageLoaderManager: TImageLoaderManager read fMngr; 94 | published 95 | property Directory: UTF8String read FDirectory write SetDirectory stored True nodefault; 96 | property ThumbWidth: integer read fUserThumbWidth write SetThumbWidth; 97 | property ThumbHeight: integer read fUserThumbHeight write SetThumbHeight; 98 | property ThumbDistance: integer read fThumbDist write SetThumbDistance; 99 | {:If you set MultiThreaded to true, the images will be loaded in the "background" not blocking the application. 100 | Warning: The debugger GDB may not like this setting. Be careful in OnLoadFile in this mode} 101 | property MultiThreaded: boolean read GetMultiThreaded write SetMultiThreaded; 102 | {:Show/Hide the filename captions.} 103 | property ShowCaptions: Boolean read FShowCaptions write SetShowCaptions; 104 | {:Show/Hide picture Frame} 105 | property ShowPictureFrame: Boolean read FShowPictureFrame write SetShowPictureFrame; 106 | {:Different modes, basically horizontal, vertical and grid plus autosize and auto layout modes, depending on the size of the control} 107 | property Layout: TLayoutStyle read FArrangeStyle write SetArrangeStyle; 108 | {:Do not keep in memory the bitmaps that are currently invisble. (Slower but less resource hungry).} 109 | property FreeInvisibleImages: boolean read GetFreeInvisibleImages write SetFreeInvisibleImages; 110 | {:Event triggered when a thumbnail is clicked or selected using the enter key.} 111 | property OnSelectItem: TSelectItemEvent read fOnSelectItem write fOnSelectItem; 112 | {:Event when image stream data is required. Useful for loading data via http, ftp etc. 113 | Warning: if MultiThreaded=true, this happens in a separate thread context.} 114 | property AutoSort : boolean read fAutoSort write SetAutoSort; 115 | {:Sort URL by name} 116 | property OnLoadFile: TLoadFileEvent read FOnLoadFile write FOnLoadFile; 117 | property ScrollBars; 118 | property Align; 119 | property Anchors; 120 | property AutoSize; 121 | property BidiMode; 122 | property BorderSpacing; 123 | property ChildSizing; 124 | property ClientHeight; 125 | property ClientWidth; 126 | property Color; 127 | property Constraints; 128 | property DockSite; 129 | property DragCursor; 130 | property DragKind; 131 | property DragMode; 132 | property Enabled; 133 | property Font; 134 | property ParentBidiMode; 135 | property ParentColor; 136 | property ParentFont; 137 | property ParentShowHint; 138 | property PopupMenu; 139 | property ShowHint; 140 | property TabOrder; 141 | property TabStop; 142 | property Visible; 143 | property OnChangeBounds; 144 | property OnClick; 145 | property OnContextPopup; 146 | property OnDblClick; 147 | property OnDragDrop; 148 | property OnDockDrop; 149 | property OnDockOver; 150 | property OnDragOver; 151 | property OnEndDock; 152 | property OnEndDrag; 153 | property OnEnter; 154 | property OnExit; 155 | property OnGetSiteInfo; 156 | property OnKeyDown; 157 | property OnKeyPress; 158 | property OnKeyUp; 159 | property OnMouseDown; 160 | property OnMouseEnter; 161 | property OnMouseLeave; 162 | property OnMouseMove; 163 | property OnMouseUp; 164 | property OnResize; 165 | property OnStartDock; 166 | property OnStartDrag; 167 | property OnUnDock; 168 | property OnUTF8KeyPress; 169 | 170 | 171 | end; 172 | 173 | var frame: TPortableNetworkGraphic; 174 | 175 | const StockBorderWidth = 15; 176 | StockTextExtraHeight = 8; 177 | 178 | procedure Register; 179 | 180 | implementation 181 | 182 | uses Forms, fontfinder, 183 | fpreadgif,FPReadPSD,FPReadPCX,FPReadTGA, LazFileUtils, LazUTF8; //just register them 184 | 185 | function ShortenString(AValue: string; Width: integer; ACanvas: TCanvas): string; 186 | var len, slen: integer; 187 | NewLen: integer; 188 | begin 189 | len := ACanvas.TextWidth(AValue); 190 | if len > width then 191 | begin 192 | NewLen := ((Length(AValue) * width) div len) - 1; 193 | slen := Length(AValue); 194 | // Result:=Copy(AValue,1,NewLen); //End crop 195 | Result := Copy(AValue, 1, (NewLen) div 2) + '..' + Copy(AValue, slen - ((NewLen) div 2), slen); 196 | end else Result := AValue; 197 | end; 198 | 199 | 200 | { TThumbControl } 201 | 202 | procedure TThumbControl.SetDirectory(const AValue: UTF8String); 203 | begin 204 | if GetMultiThreaded and (not fMngr.ThreadsIdle) then 205 | Repeat 206 | Application.ProcessMessages; 207 | until fMngr.ThreadsIdle; 208 | 209 | if AValue = '' then fDirectory := 'none' else fDirectory := AValue; 210 | if (fDirectory <> 'none') and (fDirectory <> '') then 211 | if DirectoryExistsUTF8(AValue) then 212 | begin 213 | if (csLoading in ComponentState) then exit; 214 | Init; 215 | Invalidate; 216 | end; 217 | end; 218 | 219 | 220 | procedure TThumbControl.Init; 221 | begin 222 | if not (csDesigning in ComponentState) then 223 | begin 224 | fMngr.Clear; 225 | Search; 226 | if fAutoSort then fMngr.Sort(0); 227 | Arrange; 228 | end else 229 | begin 230 | fMngr.Clear; 231 | fMngr.AddImage(''); 232 | fMngr.AddImage(''); 233 | fMngr.AddImage(''); 234 | Arrange; 235 | end; 236 | end; 237 | 238 | 239 | 240 | procedure TThumbControl.SetFreeInvisibleImages(const AValue: boolean); 241 | begin 242 | fMngr.FreeInvisibleImage := AValue; 243 | end; 244 | 245 | 246 | procedure TThumbControl.SetURLList(const AValue: UTF8String); 247 | var i: integer; 248 | begin 249 | fMngr.Clear; 250 | FURLList.Text := AValue; 251 | for i := 0 to FURLList.Count - 1 do fMngr.AddImage(FURLList[i]); 252 | if fAutoSort then fMngr.Sort(0); 253 | Arrange; 254 | end; 255 | 256 | 257 | function TThumbControl.GetMultiThreaded: boolean; 258 | begin 259 | if Assigned(fMngr) then Result := fMngr.MultiThreaded; 260 | end; 261 | 262 | function TThumbControl.GetFreeInvisibleImages: boolean; 263 | begin 264 | Result := fMngr.FreeInvisibleImage; 265 | end; 266 | 267 | function TThumbControl.GetURLList: UTF8String; 268 | begin 269 | Result := FURLList.Text; 270 | end; 271 | 272 | procedure TThumbControl.SetArrangeStyle(const AValue: TLayoutStyle); 273 | begin 274 | if FArrangeStyle <> AValue then 275 | begin 276 | FArrangeStyle := AValue; 277 | if not (csLoading in ComponentState) then 278 | begin 279 | Arrange; 280 | Invalidate; 281 | end; 282 | end; 283 | end; 284 | 285 | procedure TThumbControl.SetAutoSort(AValue: boolean); 286 | begin 287 | if fAutoSort=AValue then Exit; 288 | fAutoSort:=AValue; 289 | fMngr.Sort(0); 290 | end; 291 | 292 | procedure TThumbControl.SetMultiThreaded(const AValue: boolean); 293 | begin 294 | if Assigned(fMngr) then fMngr.MultiThreaded := AValue; 295 | end; 296 | 297 | procedure TThumbControl.SetShowPictureFrame(const AValue: Boolean); 298 | begin 299 | FShowPictureFrame := AValue; 300 | if FShowPictureFrame then 301 | begin 302 | fPictureFrameBorder := Scale96ToFont(StockBorderWidth); 303 | if FShowCaptions then fTextExtraHeight := 0; 304 | end else 305 | begin 306 | fPictureFrameBorder := 0; 307 | if FShowCaptions then fTextExtraHeight := StockTextExtraHeight; 308 | end; 309 | if not (csLoading in ComponentState) then 310 | begin 311 | Arrange; 312 | Invalidate; 313 | end; 314 | end; 315 | 316 | procedure TThumbControl.SetShowCaptions(const AValue: Boolean); 317 | begin 318 | FShowCaptions := AValue; 319 | if FShowCaptions and (not FShowPictureFrame) then fTextExtraHeight := StockTextExtraHeight else fTextExtraHeight := 0; 320 | if not (csLoading in ComponentState) then 321 | begin 322 | Arrange; 323 | Invalidate; 324 | end; 325 | end; 326 | 327 | procedure TThumbControl.SetThumbDistance(const AValue: integer); 328 | begin 329 | if fThumbDist <> AValue then 330 | begin 331 | fThumbDist := AValue; 332 | if not (csLoading in ComponentState) then 333 | begin 334 | Arrange; 335 | Invalidate; 336 | end; 337 | end; 338 | end; 339 | 340 | procedure TThumbControl.SetThumbHeight(const AValue: integer); 341 | begin 342 | if fThumbHeight <> AValue then 343 | begin 344 | fThumbHeight := AValue; 345 | fUserThumbHeight := AValue; 346 | if not (csLoading in ComponentState) then 347 | begin 348 | Arrange; 349 | Invalidate; 350 | end; 351 | end; 352 | end; 353 | 354 | procedure TThumbControl.SetThumbWidth(const AValue: integer); 355 | begin 356 | if fThumbWidth <> AValue then 357 | begin 358 | fThumbWidth := AValue; 359 | fUserThumbWidth := AValue; 360 | SmallStep := fThumbWidth; 361 | LargeStep := fThumbWidth * 4; 362 | if not (csLoading in ComponentState) then 363 | begin 364 | Arrange; 365 | Invalidate; 366 | end; 367 | end; 368 | end; 369 | 370 | 371 | procedure TThumbControl.CreateWnd; 372 | begin 373 | inherited CreateWnd; 374 | fWindowCreated := true; 375 | Init; 376 | end; 377 | 378 | 379 | procedure TThumbControl.Click; 380 | var Idx: Integer; 381 | pt: TPoint; 382 | begin 383 | pt := ScreenToClient(Mouse.CursorPos); 384 | Idx := fMngr.ItemIndexFromPoint(Point(pt.X + HScrollPosition, pt.Y + VScrollPosition)); 385 | inherited; 386 | if Idx > -1 then 387 | begin 388 | fMngr.ActiveIndex := Idx; 389 | DoSelectItem; 390 | Invalidate; 391 | end; 392 | SetFocus; 393 | end; 394 | 395 | procedure TThumbControl.DoSelectItem; 396 | begin 397 | if Assigned(fOnSelectItem) then OnSelectItem(Self, fMngr.ActiveItem); 398 | end; 399 | 400 | procedure TThumbControl.AsyncFocus(Data: PtrInt); 401 | begin 402 | SetFocus; 403 | end; 404 | 405 | procedure TThumbControl.KeyDown(var Key: Word; Shift: TShiftState); 406 | begin 407 | inherited KeyDown(Key, Shift); 408 | case key of 409 | VK_LEFT: begin fMngr.ActiveIndex := fMngr.ActiveIndex - 1; ScrollIntoView; end; 410 | VK_RIGHT: begin fMngr.ActiveIndex := fMngr.ActiveIndex + 1; ScrollIntoView; end; 411 | 412 | VK_UP: if FIls = IlsGrid then 413 | begin 414 | fMngr.ActiveIndex := fMngr.ActiveIndex - fGridThumbsPerLine; ScrollIntoView; 415 | end else 416 | begin fMngr.ActiveIndex := fMngr.ActiveIndex - 1; 417 | ScrollIntoView; 418 | end; 419 | 420 | VK_DOWN: if FIls = IlsGrid then 421 | begin 422 | fMngr.ActiveIndex := fMngr.ActiveIndex + fGridThumbsPerLine; ScrollIntoView; 423 | end else 424 | begin fMngr.ActiveIndex := fMngr.ActiveIndex + 1; 425 | ScrollIntoView; 426 | end; 427 | VK_RETURN: DoSelectItem; 428 | VK_PRIOR: if (FIls = IlsVert) or (FIls = IlsGrid) then 429 | VScrollPosition := VScrollPosition - ClientHeight else HScrollPosition := HScrollPosition - ClientWidth; 430 | VK_NEXT: if (FIls = IlsVert) or (FIls = IlsGrid) then 431 | VScrollPosition := VScrollPosition + ClientHeight else HScrollPosition := HScrollPosition + ClientWidth; 432 | end; 433 | Invalidate; 434 | Application.QueueAsyncCall(@AsyncFocus, 0); 435 | end; 436 | 437 | procedure TThumbControl.KeyUp(var Key: Word; Shift: TShiftState); 438 | begin 439 | inherited KeyUp(Key, Shift); 440 | SetFocus; 441 | end; 442 | 443 | procedure TThumbControl.ScrollIntoView; 444 | var itm: TThreadedImage; 445 | Dum, ARect: TRect; 446 | begin 447 | itm := fMngr.ActiveItem; 448 | if itm <> nil then 449 | begin 450 | ARect := ClientRect; 451 | OffsetRect(ARect, HScrollPosition, VScrollPosition); 452 | 453 | if IntersectRect(Dum, ARect, itm.Rect) then exit; 454 | 455 | HScrollPosition := 0; 456 | VScrollPosition := 0; 457 | 458 | if (FIls = IlsHorz) then 459 | if Abs(Arect.Left - Itm.Rect.Left) > (Arect.Right - Itm.Rect.Right) then 460 | HScrollPosition := itm.Rect.Right - ClientWidth + fPictureFrameBorder + fThumbDist else 461 | HScrollPosition := itm.Rect.Left - ClientWidth - fPictureFrameBorder - fThumbDist + ClientWidth; 462 | 463 | if (FIls = IlsVert) or (FIls = IlsGrid) then 464 | if Abs(Arect.Top - Itm.Rect.Top) > (Arect.Bottom - Itm.Rect.Bottom) then 465 | VScrollPosition := itm.Rect.Bottom - ClientHeight + fPictureFrameBorder + fThumbDist else 466 | VScrollPosition := itm.Rect.Top - ClientHeight - fPictureFrameBorder - fThumbDist + ClientHeight; 467 | UpdateDims; 468 | end; 469 | end; 470 | 471 | 472 | 473 | procedure TThumbControl.BoundsChanged; 474 | begin 475 | inherited BoundsChanged; 476 | if fWindowCreated and not ((csLoading in ComponentState)) and Visible then 477 | begin 478 | Arrange; 479 | UpdateDims; 480 | ScrollIntoView; 481 | end; 482 | end; 483 | 484 | 485 | procedure TThumbControl.Paint; 486 | var i, tlen: integer; 487 | aRect, BorderRect, Dum: TRect; 488 | UrlStr: string; 489 | Clipped: boolean; 490 | Cim: TThreadedImage; 491 | begin 492 | begin 493 | if Canvas.Clipping {$ifdef LCLQt} and false {$endif} then 494 | begin 495 | ARect := Canvas.ClipRect; 496 | Clipped := not EqualRect(ARect, ClientRect); 497 | end else 498 | begin 499 | ARect := ClientRect; 500 | Clipped := false; 501 | end; 502 | 503 | if Color = clDefault then 504 | Canvas.Brush.Color := GetDefaultColor(dctBrush) 505 | else 506 | Canvas.Brush.Color := Color; 507 | Canvas.FillRect(ARect); 508 | OffsetRect(aRect, HScrollPosition, VScrollPosition); 509 | if not clipped then fMngr.LoadRect(ARect); 510 | 511 | Canvas.Brush.color := $F1F1F1; 512 | 513 | for i := 0 to fmngr.List.Count - 1 do 514 | begin 515 | Cim := TThreadedImage(fmngr.List[i]); 516 | BorderRect := Cim.Rect; 517 | if IntersectRect(Dum, BorderRect, Arect) then 518 | begin 519 | OffSetRect(BorderRect, -HScrollPosition, -VScrollPosition); 520 | if fShowPictureFrame then 521 | Canvas.Draw(BorderRect.Left - fPictureFrameBorder, BorderRect.Top - fPictureFrameBorder, fFrame) else 522 | begin 523 | InflateRect(BorderRect, 1, 1); 524 | Canvas.Brush.Style := bsClear; 525 | Canvas.Pen.Color := clLtGray; 526 | Canvas.Rectangle(BorderRect); 527 | Canvas.Brush.Style := bsSolid; 528 | end; 529 | 530 | if Cim.LoadState = lsLoaded then 531 | begin 532 | Canvas.Draw(Cim.Left + Cim.Area.Left - HScrollPosition, 533 | Cim.Top + Cim.Area.Top - VScrollPosition, 534 | Cim.Bitmap); 535 | if i = fMngr.ActiveIndex then 536 | begin 537 | BorderRect := Cim.Area; 538 | OffSetRect(BorderRect, -HScrollPosition + Cim.Rect.Left, 539 | -VScrollPosition + Cim.Rect.Top); 540 | InflateRect(BorderRect, 1, 1); 541 | Canvas.Brush.Style := bsClear; 542 | Canvas.Pen.Color := $448FA2; 543 | Canvas.Pen.Width := 2; 544 | Canvas.Rectangle(BorderRect); 545 | Canvas.Pen.Width := 1; 546 | Canvas.Brush.Style := bsSolid; 547 | end; 548 | end; 549 | 550 | if fShowCaptions then 551 | begin 552 | if Cim.URL = '' then 553 | UrlStr := ShortenString('Undefined', Cim.Width, Canvas) else 554 | UrlStr := ShortenString(ExtractFileName(Cim.URL), 555 | Cim.Width, Canvas); 556 | tlen := (Cim.Width - Canvas.TextWidth(UrlStr)) div 2; 557 | if not FShowPictureFrame then 558 | if i = fMngr.ActiveIndex then Canvas.Font.color := clGray else Canvas.Font.color := ClBlack else 559 | begin 560 | Canvas.Brush.Style := bsSolid; 561 | Canvas.Brush.Color := clBlack; 562 | Canvas.FillRect(Cim.Left - HScrollPosition + tlen - 1, 563 | Cim.Height + Cim.Top - VScrollPosition + 1, 564 | Cim.Left - HScrollPosition + Scale96ToFont(2) + tlen + Canvas.TextWidth(UrlStr), 565 | Cim.Height + Cim.Top - VScrollPosition + Scale96ToFont(10)); 566 | if i = fMngr.ActiveIndex then Canvas.Font.color := clWhite else Canvas.Font.color := $448FA2; 567 | end; 568 | Canvas.Brush.Style := bsClear; 569 | Canvas.TextOut( 570 | Cim.Left - HScrollPosition + 1 + tlen, 571 | Cim.Height + Cim.Top - VScrollPosition - 1, 572 | UrlStr); 573 | Canvas.Brush.Style := bsSolid; 574 | end; 575 | end; 576 | end; 577 | end; 578 | inherited Paint; 579 | end; 580 | 581 | function GetFPReaderMask: string; 582 | var i, j: integer; 583 | sl: TStringList; 584 | begin 585 | Result := ''; 586 | sl := TStringList.Create; 587 | sl.Delimiter := ';'; 588 | for i := 0 to ImageHandlers.Count - 1 do 589 | begin 590 | sl.DelimitedText := ImageHandlers.Extensions[ImageHandlers.TypeNames[i]]; 591 | for j := 0 to sl.Count - 1 do Result := Result + '*.' + sl[j] + ';'; 592 | end; 593 | sl.free; 594 | end; 595 | 596 | procedure TThumbControl.Search; 597 | var fi: TFileSearcher; 598 | begin 599 | fi := TFileSearcher.Create; 600 | fi.OnFileFound := @FileFoundEvent; 601 | //fi.Search(FDirectory, GraphicFileMask(TGraphic), false); 602 | try 603 | fi.Search(FDirectory, GetFPReaderMask, false); 604 | finally 605 | fi.free; 606 | end; 607 | end; 608 | 609 | procedure TThumbControl.FileFoundEvent(FileIterator: TFileIterator); 610 | begin 611 | fMngr.AddImage(FileIterator.FileName); 612 | end; 613 | 614 | 615 | procedure TThumbControl.Arrange; 616 | var i, x, y, aDim: integer; 617 | begin 618 | if FArrangeStyle = LsHorizFixed then FIls := IlsHorz else 619 | if FArrangeStyle = LsVertFixed then FIls := IlsVert else 620 | if FArrangeStyle = LsGrid then FIls := IlsGrid; 621 | if (FArrangeStyle = LsAuto) or (FArrangeStyle = LsAutoSize) then 622 | begin 623 | if width > height then FIls := IlsHorz else FIls := IlsVert; 624 | if (width > 2 * fUserThumbWidth + 4 * fPictureFrameBorder) and 625 | (Height > 2 * fUserThumbHeight + 4 * fPictureFrameBorder) then FIls := IlsGrid; 626 | end; 627 | 628 | if (FArrangeStyle = LsHorizFixed) or (FArrangeStyle = LsVertFixed) or 629 | (FArrangeStyle = LsGrid) or (FArrangeStyle = LsAuto) or (FIls = IlsGrid) then 630 | begin 631 | if (fUserThumbWidth <> fThumbWidth) or (fUserThumbHeight <> fThumbHeight) then 632 | begin 633 | fThumbHeight := fUserThumbHeight; 634 | fThumbWidth := fUserThumbWidth; 635 | fMngr.FreeImages; 636 | Invalidate; 637 | end; 638 | end; 639 | 640 | if (FArrangeStyle = LsHorizAutoSize) or ((FArrangeStyle = LsAutoSize) and (FIls = IlsHorz)) then 641 | begin 642 | aDim := fThumbHeight; 643 | fThumbHeight := ClientHeight - fPictureFrameBorder * 2 - fTextExtraHeight - 2 * fTopOffset - Scale96ToFont(20); 644 | fThumbWidth := Round(fThumbHeight / fUserThumbHeight * fUserThumbWidth); 645 | FIls := IlsHorz; 646 | if ADim <> fThumbHeight then 647 | begin 648 | fMngr.FreeImages; 649 | Invalidate; 650 | end; 651 | end; 652 | 653 | if (FArrangeStyle = LsVertAutoSize) or ((FArrangeStyle = LsAutoSize) and (FIls = IlsVert)) then 654 | begin 655 | aDim := fThumbWidth; 656 | fThumbWidth := ClientWidth - fPictureFrameBorder * 2 - 2 * fLeftOffset - Scale96ToFont(20); 657 | fThumbHeight := Round(fThumbWidth / fUserThumbWidth * fUserThumbHeight); 658 | FIls := IlsVert; 659 | if ADim <> fThumbWidth then 660 | begin 661 | fMngr.FreeImages; 662 | Invalidate; 663 | end; 664 | end; 665 | 666 | if FShowPictureFrame then 667 | begin 668 | fFrame.SetSize(fThumbWidth + fPictureFrameBorder * 2, fThumbHeight + fPictureFrameBorder * 2); 669 | fFrame.Canvas.Brush.FPColor := TColorToFPColor(clWhite); 670 | fFrame.Canvas.FillRect(0, 0, fFrame.Width, fFrame.Height); 671 | fFrame.Canvas.StretchDraw(Rect(0, 0, fFrame.Width, fFrame.Height), frame); 672 | end; 673 | 674 | if FIls = IlsHorz then 675 | begin 676 | for i := 0 to fMngr.List.Count - 1 do 677 | begin 678 | TThreadedImage(fMngr.List[i]).Width := fThumbWidth; 679 | TThreadedImage(fMngr.List[i]).Height := fThumbHeight; 680 | TThreadedImage(fMngr.List[i]).Left := i * (fThumbWidth + fThumbDist + 681 | fPictureFrameBorder * 2) + fLeftOffset + fPictureFrameBorder; 682 | TThreadedImage(fMngr.List[i]).Top := fTopOffset + fPictureFrameBorder; 683 | end; 684 | fContentWidth := fMngr.List.Count * (fThumbWidth + fThumbDist + fPictureFrameBorder * 2) + fLeftOffset; 685 | fContentHeight := fThumbHeight + fPictureFrameBorder * 2 + fTopOffset; 686 | end; 687 | 688 | if FIls = IlsVert then 689 | begin 690 | for i := 0 to fMngr.List.Count - 1 do 691 | begin 692 | TThreadedImage(fMngr.List[i]).Width := fThumbWidth; 693 | TThreadedImage(fMngr.List[i]).Height := fThumbHeight; 694 | TThreadedImage(fMngr.List[i]).Left := fLeftOffset + fPictureFrameBorder; 695 | TThreadedImage(fMngr.List[i]).Top := i * (fThumbHeight + fThumbDist + 696 | fTextExtraHeight + fPictureFrameBorder * 2) + fTopOffset + fPictureFrameBorder; 697 | end; 698 | fContentHeight := (fMngr.List.Count) * (fThumbHeight + fTextExtraHeight + fThumbDist + 699 | fPictureFrameBorder * 2) + fTopOffset; 700 | fContentWidth := fThumbWidth + fPictureFrameBorder * 2 + fLeftOffset; 701 | end; 702 | 703 | if FIls = IlsGrid then 704 | begin 705 | y := 0; 706 | x := 0; 707 | fGridThumbsPerLine := ClientWidth div (fThumbWidth + fThumbDist + fPictureFrameBorder * 2); 708 | for i := 0 to fMngr.List.Count - 1 do 709 | begin 710 | if (i > 0) then 711 | if (i mod fGridThumbsPerLine = 0) then 712 | begin 713 | inc(y, (fThumbHeight + fThumbDist + fTextExtraHeight + fPictureFrameBorder * 2)); 714 | x := 0; 715 | end 716 | else inc(x); 717 | TThreadedImage(fMngr.List[i]).Width := fThumbWidth; 718 | TThreadedImage(fMngr.List[i]).Height := fThumbHeight; 719 | TThreadedImage(fMngr.List[i]).Left := x * (fThumbWidth + fThumbDist + fPictureFrameBorder * 2) + 720 | fLeftOffset + fPictureFrameBorder; 721 | TThreadedImage(fMngr.List[i]).Top := y + fTopOffset + fPictureFrameBorder; 722 | end; 723 | fContentHeight := (fMngr.List.Count div fGridThumbsPerLine + 1) * (fThumbHeight + 724 | fTextExtraHeight + fThumbDist + fPictureFrameBorder * 2) + fTopOffset; 725 | fContentWidth := ClientWidth; 726 | end; 727 | 728 | 729 | if fContentWidth <= ClientWidth then HScrollPosition := 0; 730 | if fContentHeight <= ClientHeight then VScrollPosition := 0; 731 | UpdateDims; 732 | end; 733 | 734 | 735 | constructor TThumbControl.Create(AOwner: TComponent); 736 | var ff: TFontFinder; 737 | begin 738 | inherited Create(AOwner); 739 | 740 | with GetControlClassDefaultSize do SetInitialBounds(0, 0, CX, CY); 741 | 742 | FURLList := TStringList.create; 743 | 744 | ff := TFontFinder.Create; 745 | Font.Name := ff.FindAFontFromDelimitedString('Trebuchet MS,Schumacher Clean'); 746 | Font.size := 7; 747 | ff.free; 748 | 749 | fWindowCreated := false; 750 | DoubleBuffered := true; 751 | fThumbWidth := 80; 752 | fThumbHeight := 80; 753 | fUserThumbWidth := fThumbHeight; 754 | fUserThumbHeight := fThumbHeight; 755 | 756 | fContentWidth := GetControlClassDefaultSize.cx; 757 | fContentHeight := GetControlClassDefaultSize.cy; 758 | 759 | fThumbDist := 10; 760 | 761 | fLeftOffset := fThumbDist; 762 | fTopOffset := fThumbDist; 763 | FShowCaptions := true; 764 | fTextExtraHeight := 0; 765 | FShowPictureFrame := true; 766 | fPictureFrameBorder := StockBorderWidth; 767 | 768 | fMngr := TImageLoaderManager.Create; 769 | fMngr.OnLoadURL := @ImgLoadURL; 770 | fMngr.OnLoaded := @ImgLoaded; 771 | fAutoSort:=true; 772 | 773 | SmallStep := fThumbWidth; 774 | LargeStep := fThumbWidth * 4; 775 | 776 | fFrame := TBitmap.Create; 777 | fFrame.PixelFormat := pf32Bit; 778 | 779 | fDirectory := GetUserDir; 780 | end; 781 | 782 | destructor TThumbControl.Destroy; 783 | begin 784 | FURLList.Free; 785 | fMngr.free; 786 | fFrame.free; 787 | inherited Destroy; 788 | end; 789 | 790 | procedure TThumbControl.DoAutoAdjustLayout(const AMode: TLayoutAdjustmentPolicy; 791 | const AXProportion, AYProportion: Double); 792 | begin 793 | inherited; 794 | if AMode in [lapAutoAdjustWithoutHorizontalScrolling, lapAutoAdjustForDPI] then 795 | begin 796 | FUserThumbWidth := round(FUserThumbWidth * AXProportion); 797 | FUserThumbHeight := round(FUserThumbHeight * AYProportion); 798 | FThumbDist := round(FThumbDist * AXProportion); 799 | fTextExtraHeight := round(FTextExtraHeight * AYProportion); 800 | fLeftOffset := round(fLeftOffset * AXProportion); 801 | fTopOffset := round(fTopOffset * AYProportion); 802 | // FPictureFrameBorder := round(FPictureFrameBorder * AXProportion); 803 | Arrange; 804 | end; 805 | end; 806 | 807 | function TThumbControl.GetDefaultColor(const DefaultColorType: TDefaultColorType): TColor; 808 | begin 809 | if DefaultColorType = dctBrush then 810 | Result := clWindow 811 | else 812 | Result := clWindowText; 813 | end; 814 | 815 | procedure TThumbControl.UpdateDims; 816 | begin 817 | if (VScrollInfo.nMax <> fContentHeight) or (VScrollInfo.nPage <> ClientHeight) then 818 | begin 819 | fVScrollInfo.nPage := ClientHeight; 820 | fVScrollInfo.nMax := fContentHeight; 821 | CanShowV := VScrollInfo.nMax > VScrollInfo.nPage; 822 | UpdateVScrollInfo; 823 | end; 824 | if (HScrollInfo.nMax <> fContentWidth) or (HScrollInfo.nPage <> ClientWidth) then 825 | begin 826 | fHScrollInfo.nPage := ClientWidth; 827 | fHScrollInfo.nMax := fContentWidth; 828 | CanShowH := HScrollInfo.nMax > HScrollInfo.nPage; 829 | UpdateHScrollInfo; 830 | end; 831 | end; 832 | 833 | function TThumbControl.ItemFromPoint(APoint: TPoint): TThreadedImage; 834 | begin 835 | Result := fMngr.ItemFromPoint(Point(APoint.X + HScrollPosition, APoint.Y + VScrollPosition)); 836 | end; 837 | 838 | procedure TThumbControl.LoadSelectedBitmap(ABitmap:TBitmap); 839 | var fi:TFPMemoryImage; 840 | itm:TThreadedImage; 841 | begin 842 | itm:=fMngr.ActiveItem; 843 | if itm=nil then exit; 844 | fi:=TFPMemoryImage.create(0,0); 845 | fi.UsePalette:=false; 846 | try 847 | fi.LoadFromFile(UTF8ToSys(itm.URL)); 848 | ABitmap.Assign(fi); 849 | finally 850 | fi.free; 851 | end; 852 | end; 853 | 854 | 855 | procedure TThumbControl.ImgLoadURL(Sender: TObject); 856 | var Ext, Fn: string; 857 | Img, IRes: TFPMemoryImage; 858 | rdjpegthumb: TFPReaderJPEG; 859 | area: TRect; 860 | Strm: TStream; 861 | begin 862 | Strm := nil; 863 | TThreadedImage(Sender).LoadState := lsError; 864 | Fn := TThreadedImage(Sender).URL; 865 | Ext := LowerCase(ExtractFileExt(LowerCase(Fn))); 866 | if (Ext = '.jpg') or (Ext = '.jpeg') then 867 | begin 868 | Img := TFPMemoryImage.Create(0, 0); 869 | Img.UsePalette := false; 870 | rdjpegthumb := TFPReaderJPEG.Create; 871 | rdjpegthumb.MinHeight := fThumbHeight; 872 | rdjpegthumb.MinWidth := fThumbWidth; 873 | try 874 | if Assigned(FOnLoadFile) then OnLoadFile(Sender, Fn, Strm); 875 | if Strm <> nil then 876 | begin 877 | Img.LoadFromStream(Strm, rdjpegthumb); 878 | Strm.free; 879 | end else Img.LoadFromFile(UTF8ToSys(Fn), rdjpegthumb); 880 | IRes := ThumbResize(Img, fThumbWidth, fThumbHeight, area); 881 | try 882 | CSImg.Acquire; 883 | if TThreadedImage(Sender).Image <> nil 884 | then 885 | begin 886 | TThreadedImage(Sender).Image.Assign(IRes); 887 | TThreadedImage(Sender).Area := Area; 888 | end; 889 | finally 890 | CSImg.Release; 891 | end; 892 | finally 893 | IRes.free; 894 | rdjpegthumb.free; 895 | Img.free; 896 | end; 897 | end else 898 | begin 899 | Img := TFPMemoryImage.Create(0, 0); 900 | Img.UsePalette := false; 901 | try 902 | if Assigned(FOnLoadFile) then OnLoadFile(Sender, Fn, Strm); 903 | if Strm <> nil then 904 | begin 905 | Img.LoadFromStream(Strm); 906 | Strm.free; 907 | end else Img.LoadFromFile(UTF8ToSys(Fn)); 908 | IRes := ThumbResize(Img, fThumbWidth, fThumbHeight, area); 909 | try 910 | CSImg.Acquire; 911 | if TThreadedImage(Sender).Image <> nil then 912 | begin 913 | TThreadedImage(Sender).Image.Assign(IRes); 914 | TThreadedImage(Sender).Area := Area; 915 | end; 916 | finally 917 | CSImg.Release; 918 | end; 919 | finally 920 | IRes.free; 921 | Img.free; 922 | end; 923 | end; 924 | TThreadedImage(Sender).LoadState := lsLoading; 925 | end; 926 | 927 | 928 | procedure TThumbControl.ImgLoaded(Sender: TObject); 929 | var aRect: TRect; 930 | begin 931 | aRect := TThreadedImage(Sender).Rect; 932 | OffSetRect(aRect, -HScrollPosition, -VScrollPosition); 933 | InflateRect(ARect, 2, 2); 934 | InvalidateRect(Handle, @aRect, false); 935 | end; 936 | 937 | class function TThumbControl.GetControlClassDefaultSize: TSize; 938 | begin 939 | Result.CX := 260; 940 | Result.CY := 140; 941 | end; 942 | 943 | 944 | procedure Register; 945 | begin 946 | RegisterComponents('Misc', [TThumbControl]); 947 | end; 948 | 949 | initialization 950 | {$I thumbctrl.lrs} 951 | {$I images.lrs} 952 | frame := TPortableNetworkGraphic.create; 953 | frame.LoadFromLazarusResource('framecropab'); 954 | //frame.saveToFile('framecropab.png'); 955 | 956 | finalization 957 | frame.free; 958 | 959 | end. 960 | -------------------------------------------------------------------------------- /thumbctrl.lpk: -------------------------------------------------------------------------------- 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 | 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 | -------------------------------------------------------------------------------- /thumbctrl.lrs: -------------------------------------------------------------------------------- 1 | LazarusResources.Add('TThumbControl','PNG',[ 2 | #137'PNG'#13#10#26#10#0#0#0#13'IHDR'#0#0#0#24#0#0#0#24#8#3#0#0#0#215#169#205 3 | +#202#0#0#0#1'sRGB'#0#174#206#28#233#0#0#0'6PLTE'#0'!'#0#25#21#17'=8)'#232#24 4 | +':QQRY]f=t)opq0'#184'C?'#174#203'6'#191'P'#184#182'a'#205'U'#159#207#168#208 5 | +#208#141#237#216#138#188#226#248#241#239'nd'#134#252''#0#0#0#1'tRNS'#0'@' 6 | +#230#216'f'#0#0#0#1'bKGD'#0#136#5#29'H'#0#0#0#9'pHYs'#0#0#11#19#0#0#11#19#1#0 7 | +#154#156#24#0#0#0'nIDAT('#207#189#142'A'#14#128' '#12#4#17#10#5'D)'#255#255 8 | +#172' '#237#193#160#145#139#206'i'#147'9'#236'('#245#11#8#29#148#1#192#130#26 9 | +'{F'#25#249'"'#182#130#24'#'#153':'#138#157#18'D'#136')yc'#234#18#145#26#254 10 | +#20#149'5'#4#17#174#131'2'#28'<'#229#234#169#220#27'a'#163#228#246#186'RD' 11 | +#212#162#158#203#221#196#31#192#149#131#208'C'#238#194'b'#200'}'#19#159's'#0 12 | +#27#200#11#136#244#22#193#173#0#0#0#0'IEND'#174'B`'#130 13 | ]); 14 | -------------------------------------------------------------------------------- /thumbctrl.pas: -------------------------------------------------------------------------------- 1 | { This file was automatically created by Lazarus. Do not edit! 2 | This source is only used to compile and install the package. 3 | } 4 | 5 | unit thumbctrl; 6 | 7 | interface 8 | 9 | uses 10 | FPReadJPEGthumb, fpthumbresize, scrollingcontrol, threadedimageLoader, 11 | thumbcontrol, LazarusPackageIntf; 12 | 13 | implementation 14 | 15 | procedure Register; 16 | begin 17 | RegisterUnit('thumbcontrol', @thumbcontrol.Register); 18 | end; 19 | 20 | initialization 21 | RegisterPackage('thumbctrl', @Register); 22 | end. 23 | --------------------------------------------------------------------------------