1286 lines
36 KiB
ObjectPascal
1286 lines
36 KiB
ObjectPascal
{
|
|
Version 11.9
|
|
Copyright (c) 2008-2018 by HtmlViewer Team
|
|
|
|
Permission is hereby granted, free of charge, to any person obtaining a copy of
|
|
this software and associated documentation files (the "Software"), to deal in
|
|
the Software without restriction, including without limitation the rights to
|
|
use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies
|
|
of the Software, and to permit persons to whom the Software is furnished to do
|
|
so, subject to the following conditions:
|
|
|
|
The above copyright notice and this permission notice shall be included in all
|
|
copies or substantial portions of the Software.
|
|
|
|
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
|
|
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
|
|
FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR
|
|
COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER
|
|
IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
|
|
CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
|
|
|
|
Note that the source modules HTMLGIF1.PAS and DITHERUNIT.PAS
|
|
are covered by separate copyright notices located in those modules.
|
|
}
|
|
|
|
unit frxHTMLGlobals;
|
|
|
|
{$I frxHTMLCons.inc}
|
|
|
|
interface
|
|
|
|
uses
|
|
{$ifdef HasSystemUITypes}
|
|
System.UITypes,
|
|
{$endif}
|
|
{$ifdef UseVCLStyles}
|
|
Vcl.Themes,
|
|
{$endif}
|
|
{$ifdef MSWINDOWS}
|
|
Windows,
|
|
{$endif}
|
|
Classes, SysUtils, Graphics,
|
|
{$ifdef LCL}
|
|
LclIntf, LclType, LCLVersion, Types, Messages,
|
|
StdCtrls, Buttons, Forms, Base64, Dialogs, Process,
|
|
frxHTMLMisc,
|
|
{$else}
|
|
Consts, StrUtils, ShellAPI,
|
|
Buttons,
|
|
Messages,
|
|
{$ifdef Compiler18_Plus}
|
|
WideStrings,
|
|
{$else}
|
|
frxWideStringsEarlyDelphi,
|
|
{$endif}
|
|
{$endif}
|
|
Clipbrd,
|
|
Math;
|
|
|
|
const
|
|
{$ifndef LCL}
|
|
lcl_fullversion = Integer(0);
|
|
fpc_fullversion = Integer(0);
|
|
{$endif}
|
|
{$ifndef MSWindows}
|
|
//Charsets defined in unit Windows:
|
|
ANSI_CHARSET = 0;
|
|
DEFAULT_CHARSET = 1;
|
|
SYMBOL_CHARSET = 2;
|
|
SHIFTJIS_CHARSET = 128;
|
|
HANGEUL_CHARSET = 129;
|
|
//JOHAB_CHARSET = 130;
|
|
GB2312_CHARSET = 134;
|
|
CHINESEBIG5_CHARSET = 136;
|
|
GREEK_CHARSET = 161;
|
|
TURKISH_CHARSET = 162;
|
|
//VIETNAMESE_CHARSET = 163;
|
|
HEBREW_CHARSET = 177;
|
|
ARABIC_CHARSET = 178;
|
|
RUSSIAN_CHARSET = 204;
|
|
THAI_CHARSET = 222;
|
|
EASTEUROPE_CHARSET = 238;
|
|
OEM_CHARSET = 255;
|
|
{$endif MSWindows}
|
|
// more charset constants
|
|
UNKNOWN_CHARSET = -1;
|
|
|
|
// some more codepage constants
|
|
CP_UNKNOWN = -1;
|
|
CP_UTF16LE = 1200;
|
|
CP_UTF16BE = 1201;
|
|
CP_ISO2022JP = 50220;
|
|
|
|
|
|
type
|
|
{$IFNDEF DOTNET}
|
|
{$IFNDEF FPC}
|
|
{$ifndef PtrInt_defined}
|
|
{$define PtrInt_defined}
|
|
//needed so that in FreePascal, we can use pointers of different sizes
|
|
{$IFDEF WIN32}
|
|
PtrInt = LongInt;
|
|
PtrUInt = LongWord;
|
|
{$ENDIF}
|
|
{$IFDEF WIN64}
|
|
PtrInt = Int64;
|
|
PtrUInt = Int64;
|
|
{$ENDIF}
|
|
//NOTE: The code below asumes a 32bit Linux architecture (such as target i386-linux)
|
|
{$IFDEF KYLIX}
|
|
PtrInt = LongInt;
|
|
PtrUInt = LongWord;
|
|
{$ENDIF}
|
|
{$ENDIF}
|
|
{$ENDIF}
|
|
{$ENDIF}
|
|
|
|
{$ifdef FPC}
|
|
{$else}
|
|
{$ifdef Compiler18_Plus}
|
|
{$else}
|
|
TWideStringList = class(frxWideStringsEarlyDelphi.TWideStringList);
|
|
{$endif}
|
|
{$endif}
|
|
|
|
{$ifdef UNICODE}
|
|
ThtChar = Char;
|
|
ThtString = string;
|
|
ThtStrings = TStrings;
|
|
ThtStringList = TStringList;
|
|
PhtChar = PChar;
|
|
{$else}
|
|
ThtChar = WideChar;
|
|
PhtChar = PWideChar;
|
|
{$if fpc_fullversion < 30000}
|
|
UnicodeString = WideString;
|
|
ThtString = WideString;
|
|
ThtStrings = TWideStrings;
|
|
ThtStringList = TWideStringList;
|
|
{$else}
|
|
ThtString = UnicodeString;
|
|
ThtStrings = TUnicodeStrings;
|
|
ThtStringList = TUnicodeStringList;
|
|
{$ifend}
|
|
{$endif}
|
|
|
|
ThtCharArray = array of ThtChar;
|
|
ThtStringArray = array of ThtString;
|
|
ThtIntegerArray = array of Integer;
|
|
|
|
TfrxHtGraphic = class(TGraphic)
|
|
{$ifdef LCL}
|
|
private
|
|
FTransparent: Boolean;
|
|
protected
|
|
function GetTransparent: Boolean; override;
|
|
procedure SetTransparent(Value: Boolean); override;
|
|
{$endif}
|
|
end;
|
|
|
|
const
|
|
EofChar = ThtChar(#0);
|
|
TabChar = ThtChar(#9);
|
|
LfChar = ThtChar(#10);
|
|
FfChar = ThtChar(#12);
|
|
CrChar = ThtChar(#13);
|
|
SpcChar = ThtChar(' ');
|
|
DotChar = ThtChar('.');
|
|
LessChar = ThtChar('<');
|
|
MinusChar = ThtChar('-');
|
|
GreaterChar = ThtChar('>');
|
|
PercentChar = ThtChar('%');
|
|
AmperChar = ThtChar('&');
|
|
StarChar = ThtChar('*');
|
|
CrLf = ThtString(#13#10);
|
|
CrLfTab = ThtString(#13#10#9);
|
|
NullRect: TRect = (Left: 0; Top: 0; Right: 0; Bottom: 0);
|
|
|
|
{$ifdef MSWindows}
|
|
FontSerif = ThtString('Times New Roman');
|
|
FontMono = ThtString('Courier New');
|
|
FontSans = ThtString('Arial');
|
|
FontHelvet = ThtString('Arial');
|
|
FontCursive = ThtString('Lucida Handwriting');
|
|
{$endif MSWindows}
|
|
{$ifdef Linux}
|
|
FontSerif = ThtString('Serif');
|
|
FontMono = ThtString('Monospace');
|
|
FontSans = ThtString('Sans');
|
|
FontHelvet = ThtString('Sans');
|
|
FontCursive = ThtString('Sans');
|
|
{$endif Linux}
|
|
{$ifdef Darwin}
|
|
FontSerif = ThtString('Times');
|
|
FontMono = ThtString('Courier');
|
|
FontSans = ThtString('Helvetica');
|
|
FontHelvet = ThtString('Helvetica');
|
|
FontCursive = ThtString('Apple Chancery');
|
|
{$endif Darwin}
|
|
|
|
{$ifdef LCL}
|
|
const
|
|
HWND_MESSAGE = HWND(-3);
|
|
|
|
//ANSI_CHARSET = 0; // ANSI charset (Windows-1252)
|
|
//DEFAULT_CHARSET = 1;
|
|
//SYMBOL_CHARSET = 2;
|
|
MAC_CHARSET = 77;
|
|
//SHIFTJIS_CHARSET = 128; // Shift JIS charset (Windows-932)
|
|
//HANGEUL_CHARSET = 129; // Hangeul charset (Windows-949)
|
|
JOHAB_CHARSET = 130; // Johab charset (Windows-1361)
|
|
//GB2312_CHARSET = 134; // GB2312 charset (Windows-936)
|
|
//CHINESEBIG5_CHARSET = 136; // Chinese Big5 charset (Windows-950)
|
|
//GREEK_CHARSET = 161; // Greek charset (Windows-1253)
|
|
//TURKISH_CHARSET = 162; // Turkish charset (Windows-1254)
|
|
VIETNAMESE_CHARSET = 163; // Vietnamese charset (Windows-1258)
|
|
//HEBREW_CHARSET = 177; // Hebrew charset (Windows-1255)
|
|
//ARABIC_CHARSET = 178; // Arabic charset (Windows-1256)
|
|
//BALTIC_CHARSET = 186; // Baltic charset (Windows-1257)
|
|
//RUSSIAN_CHARSET = 204; // Cyrillic charset (Windows-1251)
|
|
//THAI_CHARSET = 222; // Thai charset (Windows-874)
|
|
//EASTEUROPE_CHARSET = 238; // Eastern european charset (Windows-1250)
|
|
//OEM_CHARSET = 255;
|
|
|
|
const
|
|
{ Global Memory Flags }
|
|
|
|
GMEM_FIXED = 0;
|
|
{$EXTERNALSYM GMEM_FIXED}
|
|
GMEM_MOVEABLE = 2;
|
|
{$EXTERNALSYM GMEM_MOVEABLE}
|
|
GMEM_NOCOMPACT = $10;
|
|
{$EXTERNALSYM GMEM_NOCOMPACT}
|
|
GMEM_NODISCARD = $20;
|
|
{$EXTERNALSYM GMEM_NODISCARD}
|
|
GMEM_ZEROINIT = $40;
|
|
{$EXTERNALSYM GMEM_ZEROINIT}
|
|
GMEM_MODIFY = $80;
|
|
{$EXTERNALSYM GMEM_MODIFY}
|
|
GMEM_DISCARDABLE = $100;
|
|
{$EXTERNALSYM GMEM_DISCARDABLE}
|
|
GMEM_NOT_BANKED = $1000;
|
|
{$EXTERNALSYM GMEM_NOT_BANKED}
|
|
GMEM_SHARE = $2000;
|
|
{$EXTERNALSYM GMEM_SHARE}
|
|
GMEM_DDESHARE = $2000;
|
|
{$EXTERNALSYM GMEM_DDESHARE}
|
|
GMEM_NOTIFY = $4000;
|
|
{$EXTERNALSYM GMEM_NOTIFY}
|
|
GMEM_LOWER = GMEM_NOT_BANKED;
|
|
{$EXTERNALSYM GMEM_LOWER}
|
|
GMEM_VALID_FLAGS = 32626;
|
|
{$EXTERNALSYM GMEM_VALID_FLAGS}
|
|
GMEM_INVALID_HANDLE = $8000;
|
|
{$EXTERNALSYM GMEM_INVALID_HANDLE}
|
|
|
|
GHND = GMEM_MOVEABLE or GMEM_ZEROINIT;
|
|
{$EXTERNALSYM GHND}
|
|
GPTR = GMEM_FIXED or GMEM_ZEROINIT;
|
|
{$EXTERNALSYM GPTR}
|
|
|
|
// device caps
|
|
{$EXTERNALSYM SHADEBLENDCAPS}
|
|
SHADEBLENDCAPS = 45;
|
|
{$EXTERNALSYM SB_CONST_ALPHA}
|
|
SB_CONST_ALPHA = 1;
|
|
|
|
{
|
|
const
|
|
HeapAllocFlags = GMEM_MOVEABLE;
|
|
|
|
type
|
|
// missing in unit Graphics
|
|
TProgressStage = (
|
|
psStarting,
|
|
psRunning,
|
|
psEnding
|
|
);
|
|
}
|
|
|
|
procedure DecodeStream(Input, Output: TStream);
|
|
|
|
function PromptForFileName(var AFileName: string; const AFilter: string = '';
|
|
const ADefaultExt: string = ''; const ATitle: string = '';
|
|
const AInitialDir: string = ''; SaveDialog: Boolean = False): Boolean;
|
|
|
|
{$else}
|
|
|
|
// Open a document with the default application associated with it in the system
|
|
function OpenDocument(const APath: ThtString): Boolean;
|
|
|
|
{$endif}
|
|
|
|
function StartProcess(const ApplicationName, Params: string; ShowWindow: Word = SW_SHOW): Boolean;
|
|
|
|
{$ifndef Compiler17_Plus}
|
|
type
|
|
TBytes = array of byte;
|
|
{$endif}
|
|
|
|
var
|
|
ColorBits: Byte;
|
|
ThePalette: HPalette; {the rainbow palette for 256 colors}
|
|
PalRelative: integer;
|
|
|
|
const
|
|
{DarkerColors and LighterColors need to be in the interface section for inlining to work.}
|
|
DarkerColors: array [0..255] of Byte = (
|
|
0, 1, 1, 2, 3, 3, 4, 4, 5, 6, 6, 7, 8, 8, 9, 9,
|
|
10, 11, 11, 12, 13, 13, 14, 14, 15, 16, 16, 17, 18, 18, 19, 19,
|
|
20, 21, 21, 22, 23, 23, 24, 24, 25, 26, 26, 27, 28, 28, 29, 29,
|
|
30, 31, 31, 32, 33, 33, 34, 35, 35, 36, 36, 37, 38, 38, 39, 40,
|
|
40, 41, 41, 42, 43, 43, 44, 45, 45, 46, 46, 47, 48, 48, 49, 50,
|
|
50, 51, 51, 52, 53, 53, 54, 55, 55, 56, 56, 57, 58, 58, 59, 60,
|
|
60, 61, 61, 62, 63, 63, 64, 65, 65, 66, 67, 67, 68, 68, 69, 70,
|
|
70, 71, 72, 72, 73, 73, 74, 75, 75, 76, 77, 77, 78, 78, 79, 80,
|
|
80, 81, 82, 82, 83, 83, 84, 85, 85, 86, 87, 87, 88, 88, 89, 90,
|
|
90, 91, 92, 92, 93, 93, 94, 95, 95, 96, 97, 97, 98, 99, 99, 100,
|
|
100, 101, 102, 102, 103, 104, 104, 105, 105, 106, 107, 107, 108, 109, 109, 110,
|
|
110, 111, 112, 112, 113, 114, 114, 115, 115, 116, 117, 117, 118, 119, 119, 120,
|
|
120, 121, 122, 122, 123, 124, 124, 125, 125, 126, 127, 127, 128, 129, 129, 130,
|
|
131, 131, 132, 132, 133, 134, 134, 135, 136, 136, 137, 137, 138, 139, 139, 140,
|
|
141, 141, 142, 142, 143, 144, 144, 145, 146, 146, 147, 147, 148, 149, 149, 150,
|
|
151, 151, 152, 152, 153, 154, 154, 155, 156, 156, 157, 157, 158, 159, 159, 160
|
|
);
|
|
LighterColors: array [0..255] of Byte = (
|
|
128, 128, 129, 129, 130, 130, 131, 131, 132, 132, 133, 133, 134, 134, 135, 135,
|
|
136, 136, 137, 137, 138, 138, 139, 139, 140, 140, 141, 141, 142, 142, 143, 143,
|
|
144, 144, 145, 145, 146, 146, 147, 147, 148, 148, 149, 149, 150, 150, 151, 151,
|
|
152, 152, 153, 153, 154, 154, 155, 155, 156, 156, 157, 157, 158, 158, 159, 159,
|
|
160, 160, 161, 161, 162, 162, 163, 163, 164, 164, 165, 165, 166, 166, 167, 167,
|
|
168, 168, 169, 169, 170, 170, 171, 171, 172, 172, 173, 173, 174, 174, 175, 175,
|
|
176, 176, 177, 177, 178, 178, 179, 179, 180, 180, 181, 181, 182, 182, 183, 183,
|
|
184, 184, 185, 185, 186, 186, 187, 187, 188, 188, 189, 189, 190, 190, 191, 191,
|
|
192, 192, 193, 193, 194, 194, 195, 195, 196, 196, 197, 197, 198, 198, 199, 199,
|
|
200, 200, 201, 201, 202, 202, 203, 203, 204, 204, 205, 205, 206, 206, 207, 207,
|
|
208, 208, 209, 209, 210, 210, 211, 211, 212, 212, 213, 213, 214, 214, 215, 215,
|
|
216, 216, 217, 217, 218, 218, 219, 219, 220, 220, 221, 221, 222, 222, 223, 223,
|
|
224, 224, 225, 225, 226, 226, 227, 227, 228, 228, 229, 229, 230, 230, 231, 231,
|
|
232, 232, 233, 233, 234, 234, 235, 235, 236, 236, 237, 237, 238, 238, 239, 239,
|
|
240, 240, 241, 241, 242, 242, 243, 243, 244, 244, 245, 245, 246, 246, 247, 247,
|
|
248, 248, 249, 249, 250, 250, 251, 251, 252, 252, 253, 253, 254, 254, 255, 255
|
|
);
|
|
|
|
{$if not declared(CopyPalette)}
|
|
{$define CopyPaletteMissing}
|
|
function CopyPalette(Palette: HPALETTE): HPALETTE;
|
|
{$ifend}
|
|
|
|
function TransparentStretchBlt(DstDC: HDC; DstX, DstY, DstW, DstH: Integer;
|
|
SrcDC: HDC; SrcX, SrcY, SrcW, SrcH: Integer; MaskDC: HDC; MaskX,
|
|
MaskY: Integer): Boolean;
|
|
|
|
function htString(const Str: String): ThtString;
|
|
function htStringToString(const Str: ThtString): String;
|
|
|
|
procedure htAppendChr(var Dest: ThtString; C: ThtChar); {$ifdef UseInline} inline; {$endif}
|
|
procedure htAppendStr(var Dest: ThtString; const S: ThtString); {$ifdef UseInline} inline; {$endif}
|
|
procedure htSetString(var Dest: ThtString; Chr: PhtChar; Len: Integer); {$ifdef UseInline} inline; {$endif}
|
|
function htCompareStr(const S1, S2: ThtString): Integer; {$ifdef UseInline} inline; {$endif}
|
|
function htCompareText(const S1, S2: ThtString): Integer; {$ifdef UseInline} inline; {$endif}
|
|
function htSameText(const S1, S2: ThtString): Boolean; {$ifdef UseInline} inline; {$endif}
|
|
function htLowerCase(const Str: ThtString): ThtString; {$ifdef UseInline} inline; {$endif}
|
|
function htTrim(const Str: ThtString): ThtString; {$ifdef UseInline} inline; {$endif}
|
|
function htUpperCase(const Str: ThtString): ThtString; {$ifdef UseInline} inline; {$endif}
|
|
// htPos(SubStr, S, Offst): find substring in S starting at Offset: (formerly known as PosX)
|
|
function htPos(const SubStr, S: ThtString; Offset: Integer = 1): Integer;
|
|
|
|
function IsAlpha(Ch: ThtChar): Boolean; {$ifdef UseInline} inline; {$endif}
|
|
function IsDigit(Ch: ThtChar): Boolean; {$ifdef UseInline} inline; {$endif}
|
|
function RemoveQuotes(const S: ThtString): ThtString;
|
|
|
|
function htStringArrayToStr(const StrArray: ThtStringArray; Separator: ThtChar): ThtString;
|
|
function htSameStringArray(const A1, A2: ThtStringArray): Boolean;
|
|
procedure htSortStringArray(A: ThtStringArray);
|
|
|
|
//{$ifdef UnitConstsMissing}
|
|
//const
|
|
// SOutOfResources = 'Out of system resources';
|
|
// SInvalidBitmap = 'Bitmap image is not valid';
|
|
// SScanLine = 'Scan line index out of range';
|
|
//{$endif}
|
|
|
|
function PtrSub(P1, P2: Pointer): Integer; {$ifdef UseInline} inline; {$endif}
|
|
function PtrAdd(P1: Pointer; Offset: Integer): Pointer; {$ifdef UseInline} inline; {$endif}
|
|
procedure PtrInc(var P1; Offset: Integer); {$ifdef UseInline} inline; {$endif}
|
|
|
|
// BG, 17.04.2013: Color of Darker() and Lighter() must be RGB or palette values. Themed or system colors are not supported!
|
|
function Darker(Color : TColor): TColor; {$ifdef UseInline} inline; {$endif}
|
|
function Lighter(Color : TColor): TColor; {$ifdef UseInline} inline; {$endif}
|
|
|
|
//code movements from HTMLSubs
|
|
function FindSpaces(PStart : PWideChar; const ACount : Integer) : Integer; {$ifdef UseInline} inline; {$endif}
|
|
procedure InitFullBg(var FullBG : Graphics.TBitmap; const W, H: Integer; const AIsCopy : Boolean); {$ifdef UseInline} inline; {$endif}
|
|
procedure Circle(ACanvas : TCanvas; const X, Y, Rad: Integer); {$ifdef UseInline} inline; {$endif}
|
|
|
|
//alpha blend determination for Printers only
|
|
function CanPrintAlpha(ADC : HDC) : Boolean; {$ifdef UseInline} inline; {$endif}
|
|
|
|
procedure GetTSize(DC: HDC; P : PWideChar; N : Integer; out VSize : TSize); {$ifdef UseInline} inline; {$endif}
|
|
|
|
function ThemedColor(const AColor : TColor): TColor; {$ifdef UseInline} inline; {$endif} //overload;
|
|
|
|
function TextEndsWith(const SubStr, S : ThtString) : Boolean; {$ifdef UseInline} inline; {$endif}
|
|
function TextStartsWith(const SubStr, S : ThtString) : Boolean; {$ifdef UseInline} inline; {$endif}
|
|
|
|
procedure CopyToClipBoardAsHtml(const Str: UTF8String);
|
|
procedure CopyToClipBoardAsText(const Str: ThtString);
|
|
|
|
type
|
|
TQuickHtFragment = class
|
|
private
|
|
FText: ThtString;
|
|
FCount: Integer;
|
|
function GetText: ThtString;
|
|
public
|
|
constructor Create;
|
|
procedure AddChr(C: ThtChar);
|
|
procedure AddStr(const S: ThtString);
|
|
|
|
property Text: ThtString read GetText;
|
|
end;
|
|
|
|
|
|
implementation
|
|
|
|
{$ifdef UseVCLStyles}
|
|
uses
|
|
Vcl.Controls;
|
|
{$endif}
|
|
|
|
|
|
function ThemedColor(const AColor : TColor): TColor;
|
|
{$ifdef UseInline} inline; {$endif}
|
|
begin
|
|
{$ifdef UseVCLStyles}
|
|
if TStyleManager.IsCustomStyleActive then begin
|
|
Result := StyleServices.GetSystemColor(AColor);
|
|
end else begin
|
|
Result := AColor;
|
|
end;
|
|
Result := ColorToRGB(Result);
|
|
{$else}
|
|
Result := ColorToRGB(AColor);
|
|
{$endif}
|
|
end;
|
|
|
|
procedure GetTSize(DC: HDC; P : PWideChar; N : Integer; out VSize : TSize);
|
|
{$ifdef UseInline} inline; {$endif}
|
|
var
|
|
Dummy: Integer;
|
|
begin
|
|
VSize.cx := 0;
|
|
VSize.cy := 0;
|
|
GetTextExtentExPointW(DC, P, N, 0, @Dummy, nil, VSize)
|
|
end;
|
|
|
|
function CanPrintAlpha(ADC : HDC) : Boolean; {$ifdef UseInline} inline; {$endif}
|
|
begin
|
|
Result := GetDeviceCaps(ADC,SHADEBLENDCAPS) and SB_CONST_ALPHA > 0;
|
|
end;
|
|
|
|
function Darker(Color : TColor): TColor; {$ifdef UseInline} inline; {$endif}
|
|
{find a somewhat darker color for shading purposes}
|
|
var
|
|
Red, Green, Blue: Byte;
|
|
begin
|
|
Result := ColorToRGB(Color);
|
|
Red := DarkerColors[Byte(Result )];
|
|
Green := DarkerColors[Byte(Result shr 8)];
|
|
Blue := DarkerColors[Byte(Result shr 16)];
|
|
Result := RGB(Red, Green, Blue);
|
|
end;
|
|
|
|
function Lighter(Color : TColor) : TColor; {$ifdef UseInline} inline; {$endif}
|
|
{find a somewhat lighter color for shading purposes}
|
|
var
|
|
Red, Green, Blue: Byte;
|
|
begin
|
|
Result := ColorToRGB(Color);
|
|
Red := LighterColors[Byte(Result )];
|
|
Green := LighterColors[Byte(Result shr 8)];
|
|
Blue := LighterColors[Byte(Result shr 16)];
|
|
Result := RGB(Red, Green, Blue);
|
|
end;
|
|
|
|
function FindSpaces(PStart : PWideChar; const ACount : Integer) : Integer;
|
|
{$ifdef UseInline} inline; {$endif}
|
|
var
|
|
I: Integer;
|
|
begin
|
|
Result := 0;
|
|
for I := 0 to ACount - 2 do {-2 so as not to count end spaces}
|
|
if ((PStart + I)^ = ' ') or ((PStart + I)^ = #160) then
|
|
Inc(Result);
|
|
end;
|
|
|
|
procedure InitFullBg(var FullBG : Graphics.TBitmap; const W, H: Integer; const AIsCopy : Boolean);
|
|
{$ifdef UseInline} inline; {$endif}
|
|
begin
|
|
if not Assigned(FullBG) then
|
|
begin
|
|
FullBG := Graphics.TBitmap.Create;
|
|
if AIsCopy then
|
|
begin
|
|
FullBG.HandleType := bmDIB;
|
|
if ColorBits <= 8 then
|
|
FullBG.Palette := CopyPalette(ThePalette);
|
|
end;
|
|
end;
|
|
FullBG.Width := Max(W,2);
|
|
FullBG.Height := Max(H,2);
|
|
end;
|
|
|
|
procedure Circle(ACanvas : TCanvas; const X, Y, Rad: Integer);
|
|
{$ifdef UseInline} inline; {$endif}
|
|
begin
|
|
ACanvas.Ellipse(X, Y - Rad, X + Rad, Y);
|
|
end;
|
|
|
|
//-- BG ------------------------------------------------------------------------
|
|
function PtrSub(P1, P2: Pointer): Integer;
|
|
{$ifdef UseInline} inline; {$endif}
|
|
begin
|
|
{$ifdef FPC}
|
|
Result := P1 - P2;
|
|
{$else}
|
|
Result := PAnsiChar(P1) - PAnsiChar(P2);
|
|
{$endif}
|
|
end;
|
|
|
|
//-- BG ------------------------------------------------------------------------
|
|
function PtrAdd(P1: Pointer; Offset: Integer): Pointer;
|
|
{$ifdef UseInline} inline; {$endif}
|
|
begin
|
|
{$ifdef FPC}
|
|
Result := P1 + Offset;
|
|
{$else}
|
|
Result := PAnsiChar(P1) + Offset;
|
|
{$endif}
|
|
end;
|
|
|
|
//-- BG ------------------------------------------------------------------------
|
|
procedure PtrInc(var P1; Offset: Integer);
|
|
{$ifdef UseInline} inline; {$endif}
|
|
begin
|
|
{$ifdef FPC}
|
|
Inc(PAnsiChar(P1), Offset);
|
|
{$else}
|
|
Inc(PAnsiChar(P1), Offset);
|
|
{$endif}
|
|
end;
|
|
|
|
procedure CalcPalette(DC: HDC);
|
|
{$ifdef UseInline} inline; {$endif}
|
|
{calculate a rainbow palette, one with equally spaced colors}
|
|
const
|
|
Values: array[0..5] of integer = (55, 115, 165, 205, 235, 255);
|
|
var
|
|
LP: ^TLogPalette;
|
|
I, J, K, Sub: integer;
|
|
begin
|
|
GetMem(LP, Sizeof(TLogPalette) + 256 * Sizeof(TPaletteEntry));
|
|
try
|
|
with LP^ do
|
|
begin
|
|
palVersion := $300;
|
|
palNumEntries := 256;
|
|
GetSystemPaletteEntries(DC, 0, 256, palPalEntry);
|
|
Sub := 10; {start at entry 10}
|
|
for I := 0 to 5 do
|
|
for J := 0 to 5 do
|
|
for K := 0 to 5 do
|
|
if not ((I = 5) and (J = 5) and (K = 5)) then {skip the white}
|
|
with palPalEntry[Sub] do
|
|
begin
|
|
peBlue := Values[I];
|
|
peGreen := Values[J];
|
|
peRed := Values[K];
|
|
peFlags := 0;
|
|
Inc(Sub);
|
|
end;
|
|
for I := 1 to 24 do
|
|
if not (I in [7, 15, 21]) then {these would be duplicates}
|
|
with palPalEntry[Sub] do
|
|
begin
|
|
peBlue := 130 + 5 * I;
|
|
peGreen := 130 + 5 * I;
|
|
peRed := 130 + 5 * I;
|
|
peFlags := 0;
|
|
Inc(Sub);
|
|
end;
|
|
Sub := 245;
|
|
with palPalEntry[Sub] do
|
|
begin
|
|
peBlue := 254;
|
|
peGreen := 255;
|
|
peRed := 255;
|
|
peFlags := 0;
|
|
end;
|
|
ThePalette := CreatePalette(LP^);
|
|
end;
|
|
finally
|
|
FreeMem(LP, Sizeof(TLogPalette) + 256 * Sizeof(TPaletteEntry));
|
|
end;
|
|
end;
|
|
|
|
{$ifdef CopyPaletteMissing}
|
|
// -----------
|
|
// CopyPalette
|
|
// -----------
|
|
// Copies a HPALETTE.
|
|
//
|
|
// Copied from D3 graphics.pas. This is declared private in some old versions
|
|
// of Delphi 2 and is missing in Lazarus Component Library (LCL), so we have
|
|
// to implement it here to support those versions.
|
|
//
|
|
// Parameters:
|
|
// Palette The palette to copy.
|
|
//
|
|
// Returns:
|
|
// The handle to a new palette.
|
|
//
|
|
function CopyPalette(Palette: HPALETTE): HPALETTE;
|
|
{$ifdef UseInline} inline; {$endif}
|
|
var
|
|
PaletteSize: Integer;
|
|
LogPal: TMaxLogPalette;
|
|
begin
|
|
Result := 0;
|
|
if Palette = 0 then Exit;
|
|
PaletteSize := 0;
|
|
if GetObject(Palette, SizeOf(PaletteSize), @PaletteSize) = 0 then Exit;
|
|
if PaletteSize = 0 then Exit;
|
|
with LogPal do
|
|
begin
|
|
palVersion := $0300;
|
|
palNumEntries := PaletteSize;
|
|
GetPaletteEntries(Palette, 0, PaletteSize, palPalEntry);
|
|
end;
|
|
Result := CreatePalette(PLogPalette(@LogPal)^);
|
|
end;
|
|
{$endif CopyPaletteMissing}
|
|
|
|
const
|
|
SOutOfResources = 'Out of system resources';
|
|
var
|
|
SystemPalette16: HPalette; // 16 color palette that maps to the system palette
|
|
|
|
procedure OutOfResources;
|
|
begin
|
|
raise EOutOfResources.Create(SOutOfResources);
|
|
end;
|
|
|
|
procedure GDIError;
|
|
{$ifndef LCL}
|
|
var
|
|
ErrorCode: Integer;
|
|
Buf: array [Byte] of Char;
|
|
begin
|
|
ErrorCode := GetLastError;
|
|
if (ErrorCode <> 0) and (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, nil,
|
|
ErrorCode, LOCALE_USER_DEFAULT, Buf, sizeof(Buf), nil) <> 0) then
|
|
raise EOutOfResources.Create(Buf)
|
|
else
|
|
{$else}
|
|
begin
|
|
{$endif}
|
|
OutOfResources;
|
|
end;
|
|
|
|
function GDICheck(Value: PtrUInt): PtrUInt;
|
|
begin
|
|
if Value = 0 then GDIError;
|
|
Result := Value;
|
|
end;
|
|
|
|
function TransparentStretchBlt(DstDC: HDC; DstX, DstY, DstW, DstH: Integer;
|
|
SrcDC: HDC; SrcX, SrcY, SrcW, SrcH: Integer; MaskDC: HDC; MaskX,
|
|
MaskY: Integer): Boolean;
|
|
const
|
|
ROP_DstCopy = $00AA0029;
|
|
var
|
|
MemDC: HDC;
|
|
MemBmp: HBITMAP;
|
|
SaveObj: HGDIOBJ;
|
|
crText, crBack: TColorRef;
|
|
SavePal: HPALETTE;
|
|
begin
|
|
Result := True;
|
|
{$ifdef MSWindows}
|
|
if (Win32Platform = VER_PLATFORM_WIN32_NT) and (SrcW = DstW) and (SrcH = DstH) then
|
|
begin
|
|
MemBmp := GDICheck(CreateCompatibleBitmap(SrcDC, 1, 1));
|
|
MemBmp := SelectObject(MaskDC, MemBmp);
|
|
try
|
|
MaskBlt(
|
|
DstDC, DstX, DstY, DstW, DstH,
|
|
SrcDC, SrcX, SrcY,
|
|
MemBmp, MaskX, MaskY,
|
|
MakeRop4(ROP_DstCopy, SrcCopy));
|
|
finally
|
|
MemBmp := SelectObject(MaskDC, MemBmp);
|
|
DeleteObject(MemBmp);
|
|
end;
|
|
Exit;
|
|
end;
|
|
{$endif}
|
|
MemDC := GDICheck(CreateCompatibleDC(DstDC));
|
|
try
|
|
MemBmp := GDICheck(CreateCompatibleBitmap(SrcDC, SrcW, SrcH));
|
|
SaveObj := SelectObject(MemDC, MemBmp);
|
|
SavePal := SelectPalette(SrcDC, SystemPalette16, False);
|
|
try
|
|
SelectPalette(SrcDC, SavePal, False);
|
|
if SavePal <> 0 then
|
|
SavePal := SelectPalette(MemDC, SavePal, True)
|
|
else
|
|
SavePal := SelectPalette(MemDC, SystemPalette16, True);
|
|
RealizePalette(MemDC);
|
|
|
|
{ Mask out the transparent colored pixels of the source }
|
|
BitBlt(MemDC, 0, 0, SrcW, SrcH, MaskDC, MaskX, MaskY, SrcCopy);
|
|
BitBlt(MemDC, 0, 0, SrcW, SrcH, SrcDC, SrcX, SrcY, SrcErase);
|
|
|
|
{ Punch out a black hole in the background where the source image will go}
|
|
crText := SetTextColor(DstDC, $0);
|
|
crBack := SetBkColor(DstDC, $FFFFFF);
|
|
StretchBlt(DstDC, DstX, DstY, DstW, DstH, MaskDC, MaskX, MaskY, SrcW, SrcH, SrcAnd);
|
|
SetTextColor(DstDC, crText);
|
|
SetBkColor(DstDC, crBack);
|
|
|
|
StretchBlt(DstDC, DstX, DstY, DstW, DstH, MemDC, 0, 0, SrcW, SrcH, SrcInvert);
|
|
finally
|
|
SelectPalette(MemDC, SavePal, False);
|
|
SelectObject(MemDC, SaveObj);
|
|
DeleteObject(MemBmp);
|
|
end;
|
|
finally
|
|
DeleteDC(MemDC);
|
|
end;
|
|
end;
|
|
|
|
//-- BG ---------------------------------------------------------- 19.09.2018 --
|
|
function htString(const Str: String): ThtString;
|
|
begin
|
|
{$ifdef LCL}
|
|
Result := UTF8Decode(Str);
|
|
{$else}
|
|
Result := Str;
|
|
{$endif}
|
|
end;
|
|
|
|
function htStringToString(const Str: ThtString): String;
|
|
begin
|
|
{$ifdef LCL}
|
|
Result := UTF8Encode(Str);
|
|
{$else}
|
|
Result := Str;
|
|
{$endif}
|
|
end;
|
|
|
|
//-- BG ---------------------------------------------------------- 27.03.2011 --
|
|
procedure htAppendChr(var Dest: ThtString; C: ThtChar);
|
|
{$ifdef UseInline} inline; {$endif}
|
|
begin
|
|
SetLength(Dest, Length(Dest) + 1);
|
|
Dest[Length(Dest)] := C;
|
|
end;
|
|
|
|
//-- BG ---------------------------------------------------------- 27.03.2011 --
|
|
procedure htAppendStr(var Dest: ThtString; const S: ThtString);
|
|
{$ifdef UseInline} inline; {$endif}
|
|
var
|
|
L, N: Integer;
|
|
begin
|
|
L := Length(S);
|
|
if L > 0 then
|
|
begin
|
|
N := Length(Dest);
|
|
SetLength(Dest, N + L);
|
|
Move(S[1], Dest[N + 1], L * sizeof(ThtChar));
|
|
end;
|
|
end;
|
|
|
|
//-- BG ---------------------------------------------------------- 20.03.2011 --
|
|
function htCompareStr(const S1, S2: ThtString): Integer;
|
|
{$ifdef UseInline} inline; {$endif}
|
|
begin
|
|
{$ifdef UNICODE}
|
|
Result := CompareStr(S1, S2);
|
|
{$else}
|
|
Result := WideCompareStr(S1, S2);
|
|
{$endif}
|
|
end;
|
|
|
|
//-- BG ---------------------------------------------------------- 10.12.2010 --
|
|
function htCompareText(const S1, S2: ThtString): Integer;
|
|
{$ifdef UseInline} inline; {$endif}
|
|
begin
|
|
{$ifdef UNICODE}
|
|
Result := CompareText(S1, S2);
|
|
{$else}
|
|
Result := WideCompareText(S1, S2);
|
|
{$endif}
|
|
end;
|
|
|
|
//-- BG ---------------------------------------------------------- 10.10.2016 --
|
|
function htSameText(const S1, S2: ThtString): Boolean;
|
|
{$ifdef UseInline} inline; {$endif}
|
|
begin
|
|
Result := htCompareText(S1, S2) = 0;
|
|
end;
|
|
|
|
//-- BG ---------------------------------------------------------- 22.10.2016 --
|
|
function htStringArrayToStr(const StrArray: ThtStringArray; Separator: ThtChar): ThtString;
|
|
var
|
|
I: Integer;
|
|
begin
|
|
SetLength(Result, 0);
|
|
for I := Low(StrArray) to high(StrArray) do
|
|
begin
|
|
if Length(Result) > 0 then
|
|
htAppendChr(Result, Separator);
|
|
htAppendStr(Result, StrArray[I]);
|
|
end;
|
|
end;
|
|
|
|
//-- BG ---------------------------------------------------------- 20.03.2011 --
|
|
function htSameStringArray(const A1, A2: ThtStringArray): Boolean;
|
|
var
|
|
I, N: Integer;
|
|
begin
|
|
N := Length(A1);
|
|
Result := N = Length(A2);
|
|
if Result then
|
|
for I := 0 To N - 1 do
|
|
if htCompareStr(A1[I], A2[I]) <> 0 then
|
|
begin
|
|
Result := False;
|
|
break;
|
|
end;
|
|
end;
|
|
|
|
//-- BG ---------------------------------------------------------- 20.03.2011 --
|
|
procedure htSortStringArray(A: ThtStringArray);
|
|
|
|
procedure QuickSort(L, R: Integer);
|
|
var
|
|
I, J: Integer;
|
|
P, T: ThtString;
|
|
begin
|
|
repeat
|
|
I := L;
|
|
J := R;
|
|
P := A[(L + R) shr 1];
|
|
repeat
|
|
while htCompareStr(A[I], P) < 0 do
|
|
Inc(I);
|
|
while htCompareStr(A[J], P) > 0 do
|
|
Dec(J);
|
|
if I <= J then
|
|
begin
|
|
T := A[I];
|
|
A[I] := A[J];
|
|
A[J] := T;
|
|
Inc(I);
|
|
Dec(J);
|
|
end;
|
|
until I > J;
|
|
if L < J then
|
|
QuickSort(L, J);
|
|
L := I;
|
|
until I >= R;
|
|
end;
|
|
|
|
begin
|
|
if length(A) > 1 then
|
|
QuickSort(Low(A), High(A));
|
|
end;
|
|
|
|
//-- BG ---------------------------------------------------------- 28.01.2011 --
|
|
function htLowerCase(const Str: ThtString): ThtString;
|
|
{$ifdef UseInline} inline; {$endif}
|
|
begin
|
|
{$ifdef UNICODE}
|
|
// LowerCase() converts 7bit chars only while AnsiLowerCase() converts UnicodeStrings correctly.
|
|
// Actually it does the same as we do in the $else part except for Linux.
|
|
Result := AnsiLowerCase(Str);
|
|
{$else}
|
|
Result := WideLowerCase(Str);
|
|
{$endif}
|
|
end;
|
|
|
|
//-- BG ---------------------------------------------------------- 27.03.2011 --
|
|
procedure htSetString(var Dest: ThtString; Chr: PhtChar; Len: Integer);
|
|
{$ifdef UseInline} inline; {$endif}
|
|
begin
|
|
{$ifdef UNICODE}
|
|
SetString(Dest, Chr, Len);
|
|
{$else}
|
|
SetLength(Dest, Len);
|
|
Move(Chr^, Dest[1], Len * sizeof(ThtChar));
|
|
{$endif}
|
|
end;
|
|
|
|
//-- BG ---------------------------------------------------------- 09.08.2011 --
|
|
function htTrim(const Str: ThtString): ThtString;
|
|
{$ifdef UseInline} inline; {$endif}
|
|
begin
|
|
Result := Trim(Str);
|
|
end;
|
|
|
|
//-- BG ---------------------------------------------------------- 28.01.2011 --
|
|
function htUpperCase(const Str: ThtString): ThtString;
|
|
{$ifdef UseInline} inline; {$endif}
|
|
begin
|
|
{$ifdef UNICODE}
|
|
// UpperCase() converts 7bit chars only while AnsiUpperCase() converts UnicodeStrings correctly.
|
|
// Actually it does the same as we do in the $else part except for Linux.
|
|
Result := AnsiUpperCase(Str);
|
|
{$else}
|
|
Result := WideUpperCase(Str);
|
|
{$endif}
|
|
end;
|
|
|
|
//-- BG ---------------------------------------------------------- 21.08.2011 --
|
|
function IsAlpha(Ch: ThtChar): Boolean; {$ifdef UseInline} inline; {$endif}
|
|
begin
|
|
case Ch of
|
|
'a'..'z', 'A'..'Z':
|
|
Result := True;
|
|
else
|
|
Result := False;
|
|
end;
|
|
end;
|
|
|
|
//-- BG ---------------------------------------------------------- 21.08.2011 --
|
|
function IsDigit(Ch: ThtChar): Boolean; {$ifdef UseInline} inline; {$endif}
|
|
begin
|
|
case Ch of
|
|
'0'..'9':
|
|
Result := True;
|
|
else
|
|
Result := False;
|
|
end;
|
|
end;
|
|
|
|
{----------------RemoveQuotes}
|
|
|
|
function RemoveQuotes(const S: ThtString): ThtString;
|
|
{$ifdef UseInline} inline; {$endif}
|
|
{if ThtString is a quoted ThtString, remove the quotes (either ' or ")}
|
|
begin
|
|
Result := S;
|
|
if Length(Result) >= 2 then
|
|
begin
|
|
case Result[1] of
|
|
'"', '''':
|
|
if Result[Length(Result)] = Result[1] then
|
|
Result := Copy(Result, 2, Length(Result) - 2);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function htPos(const SubStr, S: ThtString; Offset: Integer = 1): Integer;
|
|
{$ifdef UseInline} inline; {$endif}
|
|
{find substring in S starting at Offset}
|
|
var
|
|
S1: ThtString;
|
|
I: Integer;
|
|
begin
|
|
if Offset <= 1 then
|
|
Result := Pos(SubStr, S)
|
|
else
|
|
begin
|
|
S1 := Copy(S, Offset, Length(S) - Offset + 1);
|
|
I := Pos(SubStr, S1);
|
|
if I > 0 then
|
|
Result := I + Offset - 1
|
|
else
|
|
Result := 0;
|
|
end;
|
|
end;
|
|
|
|
function TextStartsWith(const SubStr, S : ThtString) : Boolean;
|
|
{$ifdef UseInline} inline; {$endif}
|
|
begin
|
|
Result := Copy(S,1,Length(SubStr)) = SubStr;
|
|
end;
|
|
|
|
function TextEndsWith(const SubStr, S : ThtString) : Boolean;
|
|
{$ifdef UseInline} inline; {$endif}
|
|
var l : Integer;
|
|
begin
|
|
l := Length(SubStr);
|
|
Result := Copy(S,Length(S)-l+1,l) = SubStr;
|
|
end;
|
|
|
|
{$ifdef LCL}
|
|
|
|
procedure DecodeStream(Input, Output: TStream);
|
|
const
|
|
BufferSize = 999;
|
|
var
|
|
Decoder: TBase64DecodingStream;
|
|
Buffer: array[1..BufferSize] of Byte;
|
|
Count: LongInt;
|
|
I, J: Integer;
|
|
begin
|
|
I := 0;
|
|
J := 0;
|
|
Decoder := TBase64DecodingStream.Create(Input, bdmMIME);
|
|
try
|
|
Decoder.Reset;
|
|
repeat
|
|
Count := Decoder.Read(Buffer[1], BufferSize);
|
|
Output.Write(Buffer[1], Count);
|
|
Inc(I);
|
|
Inc(J, Count);
|
|
until Count < BufferSize;
|
|
finally
|
|
Decoder.Free;
|
|
end;
|
|
end;
|
|
|
|
function PromptForFileName(var AFileName: string; const AFilter: string = '';
|
|
const ADefaultExt: string = ''; const ATitle: string = '';
|
|
const AInitialDir: string = ''; SaveDialog: Boolean = False): Boolean;
|
|
var
|
|
Dialog: TOpenDialog;
|
|
begin
|
|
if SaveDialog then
|
|
begin
|
|
Dialog := TSaveDialog.Create(nil);
|
|
Dialog.Options := Dialog.Options + [ofOverwritePrompt];
|
|
end
|
|
else
|
|
Dialog := TOpenDialog.Create(nil);
|
|
with Dialog do
|
|
try
|
|
Title := ATitle;
|
|
if Length(Title) = 0 then
|
|
if SaveDialog then
|
|
Title := 'Select Filename'
|
|
else
|
|
Title := 'Select File';
|
|
Filter := AFilter;
|
|
if Length(Filter) = 0 then
|
|
Filter := 'Any File (*.*)|*.*';
|
|
DefaultExt := ADefaultExt;
|
|
InitialDir := AInitialDir;
|
|
FileName := AFileName;
|
|
Result := Execute;
|
|
if Result then
|
|
AFileName := FileName;
|
|
finally
|
|
Free;
|
|
end;
|
|
end;
|
|
|
|
{$else}
|
|
|
|
// Open a document with the default application associated with it in the system
|
|
function OpenDocument(const APath: ThtString): Boolean;
|
|
begin
|
|
Result := ShellExecuteW(0, nil, PWideChar(APath), nil, nil, SW_SHOWNORMAL) > 32;
|
|
end;
|
|
|
|
{$endif LCL}
|
|
|
|
function StartProcess(const ApplicationName, Params: string; ShowWindow: Word): Boolean;
|
|
{$ifdef LCL}
|
|
var
|
|
Process: TProcess;
|
|
I: Integer;
|
|
begin
|
|
// uses TProcess although Lazarus documentation prefers RunCommand
|
|
// as RunCommand does not start an asynchronous process.
|
|
Process := TProcess.Create(nil);
|
|
try
|
|
Process.Executable := ApplicationName;
|
|
Process.Parameters.Add(Params);
|
|
Process.InheritHandles := False;
|
|
Process.ShowWindow := swoShow;
|
|
|
|
// Copy default environment variables
|
|
// including DISPLAY variable for GUI application to work
|
|
for I := 1 to GetEnvironmentVariableCount do
|
|
Process.Environment.Add(GetEnvironmentString(I));
|
|
|
|
Process.Execute;
|
|
Result := True;
|
|
finally
|
|
Process.Free;
|
|
end;
|
|
end;
|
|
{$else}
|
|
var
|
|
si: TStartupInfo;
|
|
pi: TProcessInformation;
|
|
CommandLine: string;
|
|
begin
|
|
FillMemory(@si, SizeOf(si), 0);
|
|
FillMemory(@pi, SizeOf(pi), 0);
|
|
si.cb := SizeOf(si);
|
|
si.dwFlags := STARTF_USESHOWWINDOW;
|
|
si.wShowWindow := ShowWindow;
|
|
CommandLine := ApplicationName;
|
|
if Pos(' ', CommandLine) > 0 then
|
|
CommandLine := '"' + CommandLine + '"';
|
|
if Length(Params) > 0 then
|
|
CommandLine := CommandLine + ' ' + Params;
|
|
UniqueString(CommandLine);
|
|
Result := CreateProcess(PChar(ApplicationName), PChar(CommandLine), nil, nil, False, 0, nil, nil, si, pi);
|
|
CloseHandle(pi.hProcess);
|
|
CloseHandle(pi.hThread);
|
|
end;
|
|
{$endif}
|
|
|
|
//-- BG ---------------------------------------------------------- 26.09.2016 --
|
|
procedure CopyToClipBoardAsHtml(const Str: UTF8String);
|
|
// Put SOURCE on the clipboard, using FORMAT as the clipboard format
|
|
const
|
|
HtmlClipboardFormat = 'HTML Format';
|
|
var
|
|
CF_HTML: UINT;
|
|
Len: Integer;
|
|
{$ifdef LCL}
|
|
Str1: UTF8String;
|
|
{$else}
|
|
Mem: HGLOBAL;
|
|
Buf: PAnsiChar;
|
|
{$endif}
|
|
begin
|
|
CF_HTML := RegisterClipboardFormat(HtmlClipboardFormat); {not sure this is necessary}
|
|
Len := Length(Str);
|
|
{$ifdef LCL}
|
|
Str1 := Str;
|
|
Clipboard.AddFormat(CF_HTML, Str1[1], Len);
|
|
{$else}
|
|
Mem := GlobalAlloc(GMEM_DDESHARE + GMEM_MOVEABLE, Len + 1);
|
|
try
|
|
Buf := GlobalLock(Mem);
|
|
try
|
|
Move(Str[1], Buf[0], Len);
|
|
Buf[Len] := #0;
|
|
SetClipboardData(CF_HTML, Mem);
|
|
finally
|
|
GlobalUnlock(Mem);
|
|
end;
|
|
except
|
|
GlobalFree(Mem);
|
|
end;
|
|
{$endif}
|
|
end;
|
|
|
|
//-- BG ---------------------------------------------------------- 26.09.2016 --
|
|
procedure CopyToClipboardAsText(const Str: ThtString);
|
|
{$ifdef LCL}
|
|
var
|
|
Utf8: Utf8String;
|
|
begin
|
|
Utf8 := Utf8Encode(Str);
|
|
Clipboard.AsText := Utf8;
|
|
end;
|
|
{$else}
|
|
var
|
|
Len: Integer;
|
|
Mem: HGLOBAL;
|
|
Wuf: PWideChar;
|
|
begin
|
|
Len := Length(Str);
|
|
Mem := GlobalAlloc(GMEM_DDESHARE + GMEM_MOVEABLE, (Len + 1) * SizeOf(WideChar));
|
|
try
|
|
Wuf := GlobalLock(Mem);
|
|
try
|
|
Move(Str[1], Wuf[0], Len * SizeOf(WideChar));
|
|
Wuf[Len] := #0;
|
|
// BG, 28.06.2012: use API method. The vcl clipboard does not support multiple formats.
|
|
SetClipboardData(CF_UNICODETEXT, Mem);
|
|
finally
|
|
GlobalUnlock(Mem);
|
|
end;
|
|
except
|
|
GlobalFree(Mem);
|
|
end;
|
|
end;
|
|
{$endif}
|
|
|
|
{ TfrxHtGraphic }
|
|
|
|
{$ifdef LCL}
|
|
//-- BG ---------------------------------------------------------- 10.10.2016 --
|
|
function TfrxHtGraphic.GetTransparent: Boolean;
|
|
begin
|
|
Result := FTransparent;
|
|
end;
|
|
|
|
//-- BG ---------------------------------------------------------- 10.10.2016 --
|
|
procedure TfrxHtGraphic.SetTransparent(Value: Boolean);
|
|
begin
|
|
if FTransparent <> Value then
|
|
begin
|
|
FTransparent := Value;
|
|
Changed(Self);
|
|
end;
|
|
end;
|
|
{$endif}
|
|
|
|
{ initialization }
|
|
|
|
var
|
|
DC: HDC;
|
|
|
|
{ TQuickHtFragment }
|
|
const
|
|
FragmentStartSize = 1024;
|
|
|
|
procedure TQuickHtFragment.AddChr(C: ThtChar);
|
|
begin
|
|
if FCount = Length(FText) then
|
|
SetLength(FText, Length(FText) * 2);
|
|
Inc(FCount);
|
|
FText[FCount] := C;
|
|
end;
|
|
|
|
procedure TQuickHtFragment.AddStr(const S: ThtString);
|
|
var
|
|
i: Integer;
|
|
begin
|
|
for i := 1 to Length(S) do
|
|
AddChr(S[i]);
|
|
end;
|
|
|
|
constructor TQuickHtFragment.Create;
|
|
begin
|
|
SetLength(FText, FragmentStartSize);
|
|
FCount := 0;
|
|
end;
|
|
|
|
function TQuickHtFragment.GetText: ThtString;
|
|
begin
|
|
Result := FText;
|
|
SetLength(Result, FCount);
|
|
end;
|
|
|
|
initialization
|
|
DC := GetDC(0);
|
|
try
|
|
ColorBits := GetDeviceCaps(DC, BitsPixel) * GetDeviceCaps(DC, Planes);
|
|
|
|
if ColorBits <= 4 then
|
|
ColorBits := 4
|
|
else if ColorBits <= 8 then
|
|
ColorBits := 8
|
|
else
|
|
ColorBits := 24;
|
|
|
|
ThePalette := 0;
|
|
if ColorBits = 8 then
|
|
CalcPalette(DC);
|
|
if ColorBits <= 8 then {use Palette Relative bit only when Palettes used}
|
|
PalRelative := $2000000
|
|
else
|
|
PalRelative := 0;
|
|
finally
|
|
ReleaseDC(0, DC);
|
|
end;
|
|
|
|
{$ifdef TransparentStretchBltMissing}
|
|
// Note: This doesn't return the same palette as the Delphi 3 system palette
|
|
// since the true system palette contains 20 entries and the Delphi 3 system
|
|
// palette only contains 16.
|
|
// For our purpose this doesn't matter since we do not care about the actual
|
|
// colors (or their number) in the palette.
|
|
// Stock objects doesn't have to be deleted.
|
|
SystemPalette16 := GetStockObject(DEFAULT_PALETTE);
|
|
{$endif}
|
|
|
|
finalization
|
|
if ThePalette <> 0 then
|
|
DeleteObject(ThePalette);
|
|
end.
|
|
|