Delphi/FastReport_2022_VCL
Delphi/FastReport_2022_VCL
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
master
FastReport_2022_VCL/LibD28/frxHTMLGlobals.pas

1286 lines
36 KiB
ObjectPascal
Raw Permalink Normal View History

Inicijalizacija
2024-01-01 16:13:08 +01:00
{
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.
Reference in New Issue Copy Permalink