2178 lines
65 KiB
ObjectPascal
2178 lines
65 KiB
ObjectPascal
{-----------------------------------------------------------------------------
|
||
The contents of this file are subject to the Mozilla Public License
|
||
Version 1.1 (the "License"); you may not use this file except in compliance
|
||
with the License. You may obtain a copy of the License at
|
||
http://www.mozilla.org/MPL/MPL-1.1.html
|
||
|
||
Software distributed under the License is distributed on an "AS IS" basis,
|
||
WITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for
|
||
the specific language governing rights and limitations under the License.
|
||
|
||
The Original Code is: JvgUtils.PAS, released on 2003-01-15.
|
||
|
||
The Initial Developer of the Original Code is Andrey V. Chudin, [chudin att yandex dott ru]
|
||
Portions created by Andrey V. Chudin are Copyright (C) 2003 Andrey V. Chudin.
|
||
All Rights Reserved.
|
||
|
||
Contributor(s):
|
||
Michael Beck [mbeck att bigfoot dott com].
|
||
Burov Dmitry, translation of russian text.
|
||
|
||
You may retrieve the latest version of this file at the Project JEDI's JVCL home page,
|
||
located at http://jvcl.sourceforge.net
|
||
|
||
Known Issues:
|
||
-----------------------------------------------------------------------------}
|
||
// $Id: JvgUtils.pas 10612 2006-05-19 19:04:09Z jfudickar $
|
||
|
||
unit JvgUtils;
|
||
|
||
{$I jvcl.inc}
|
||
|
||
interface
|
||
|
||
uses
|
||
{$IFDEF USEJVCL}
|
||
{$IFDEF UNITVERSIONING}
|
||
JclUnitVersioning,
|
||
{$ENDIF UNITVERSIONING}
|
||
{$ENDIF USEJVCL}
|
||
Windows, Messages, Graphics, ExtCtrls,
|
||
SysUtils, Classes, Controls, Forms, MMSystem,
|
||
JvgTypes, JvgCommClasses, Jvg3DColors;
|
||
|
||
type
|
||
TJvgPublicWinControl = class(TWinControl)
|
||
public
|
||
procedure PaintWindow(DC: HDC); override;
|
||
procedure RecreateWnd;
|
||
property Font;
|
||
property OnEnter;
|
||
property OnExit;
|
||
property Color;
|
||
end;
|
||
|
||
function IsEven(I: Integer): Boolean;
|
||
function InchesToPixels(DC: HDC; Value: Single; IsHorizontal: Boolean): Integer;
|
||
function CentimetersToPixels(DC: HDC; Value: Single; IsHorizontal: Boolean): Integer;
|
||
|
||
procedure SwapInt(var I1, I2: Integer);
|
||
function Spaces(Count: Integer): string;
|
||
function DupStr(const Str: string; Count: Integer): string;
|
||
function DupChar(C: Char; Count: Integer): string;
|
||
procedure Msg(const AMsg: string);
|
||
function RectW(R: TRect): Integer;
|
||
function RectH(R: TRect): Integer;
|
||
function IncColor(AColor: Longint; AOffset: Byte): Longint;
|
||
function DecColor(AColor: Longint; AOffset: Byte): Longint;
|
||
function IsItAFilledBitmap(Bmp: TBitmap): Boolean;
|
||
procedure DrawTextInRectWithAlign(DC: HDC; R: TRect; const Text: string;
|
||
HAlign: TglHorAlign; VAlign: TglVertAlign;
|
||
Style: TglTextStyle; Fnt: TFont; Flags: UINT);
|
||
|
||
procedure DrawTextInRect(DC: HDC; R: TRect; const Text: string;
|
||
Style: TglTextStyle; Fnt: TFont; Flags: UINT);
|
||
|
||
procedure ExtTextOutExt(DC: HDC; X, Y: Integer; R: TRect; const Text: string;
|
||
Style: TglTextStyle; ADelineated, ASupress3D: Boolean;
|
||
FontColor, DelinColor, HighlightColor, ShadowColor: TColor;
|
||
Illumination: TJvgIllumination; Gradient: TJvgGradient; Font: TFont);
|
||
|
||
procedure DrawBox(DC: HDC; var R: TRect; Style: TglBoxStyle;
|
||
BackgrColor: Longint; ATransparent: Boolean);
|
||
|
||
function DrawBoxEx(DC: HDC; ARect: TRect; Borders: TglSides;
|
||
BevelInner, BevelOuter: TPanelBevel; Bold: Boolean; BackgrColor: Longint;
|
||
ATransparent: Boolean): TRect;
|
||
|
||
procedure GradientBox(DC: HDC; R: TRect; Gradient: TJvgGradient;
|
||
PenStyle, PenWidth: Integer);
|
||
|
||
procedure ChangeBitmapColor(Bitmap: TBitmap; FromColor, ToColor: TColor);
|
||
|
||
procedure DrawBitmapExt(DC: HDC; { DC - background & result}
|
||
SourceBitmap: TBitmap; R: TRect;
|
||
X, Y: Integer; //...X,Y _in_ rect!
|
||
BitmapOption: TglWallpaperOption; DrawState: TglDrawState;
|
||
ATransparent: Boolean; TransparentColor: TColor; DisabledMaskColor: TColor);
|
||
|
||
procedure CreateBitmapExt(DC: HDC; { DC - background & result}
|
||
SourceBitmap: TBitmap; R: TRect;
|
||
X, Y: Integer; //...X,Y _in_ rect!
|
||
BitmapOption: TglWallpaperOption; DrawState: TglDrawState;
|
||
ATransparent: Boolean; TransparentColor: TColor; DisabledMaskColor: TColor);
|
||
|
||
procedure BringParentWindowToTop(Wnd: TWinControl);
|
||
function GetParentForm(Control: TControl): TForm;
|
||
procedure GetWindowImageFrom(Control: TWinControl; X, Y: Integer; ADrawSelf, ADrawChildWindows: Boolean; DC: HDC);
|
||
procedure GetWindowImage(Control: TWinControl; ADrawSelf, ADrawChildWindows: Boolean; DC: HDC);
|
||
procedure GetParentImageRect(Control: TControl; Rect: TRect; DC: HDC);
|
||
function CreateRotatedFont(F: TFont; Escapement: Integer): HFONT;
|
||
function FindMainWindow(const AWndClass, AWndTitle: string): THandle;
|
||
procedure CalcShadowAndHighlightColors(BaseColor: TColor; Colors: TJvgLabelColors);
|
||
|
||
function CalcMathString(AExpression: string): Single;
|
||
|
||
function IIF(AExpression: Boolean; IfTrue, IfFalse: Variant): Variant; overload;
|
||
function IIF(AExpression: Boolean; const IfTrue, IfFalse: string): string; overload;
|
||
|
||
function GetTransparentColor(Bitmap: TBitmap; AutoTrColor: TglAutoTransparentColor): TColor;
|
||
procedure TypeStringOnKeyboard(const S: string);
|
||
//function NextStringGridCell( Grid: TStringGrid ): Boolean;
|
||
procedure DrawTextExtAligned(Canvas: TCanvas; const Text: string; R: TRect; Alignment: TglAlignment; WordWrap: Boolean);
|
||
procedure LoadComponentFromTextFile(Component: TComponent; const FileName: string);
|
||
procedure SaveComponentToTextFile(Component: TComponent; const FileName: string);
|
||
function ComponentToString(Component: TComponent): string;
|
||
procedure StringToComponent(Component: TComponent; const Value: string);
|
||
function PlayWaveResource(const ResName: string): Boolean;
|
||
function UserName: string;
|
||
function ComputerName: string;
|
||
function CreateIniFileName: string;
|
||
function ExpandString(const Str: string; Len: Integer): string;
|
||
function Transliterate(const Str: string; RusToLat: Boolean): string;
|
||
function IsSmallFonts: Boolean;
|
||
function SystemColorDepth: Integer;
|
||
function GetFileType(const FileName: string): TglFileType;
|
||
function FindControlAtPt(Control: TWinControl; Pt: TPoint; MinClass: TClass): TControl;
|
||
function StrPosExt(const Str1, Str2: PChar; Str2Len: DWORD): PChar; assembler;
|
||
|
||
{$IFDEF glDEBUG}
|
||
function DeleteObject(P1: HGDIOBJ): BOOL; stdcall;
|
||
{$ENDIF glDEBUG}
|
||
|
||
{$IFNDEF USEJVCL}
|
||
function DrawText(Canvas: TCanvas; Text: PAnsiChar; Len: Integer;
|
||
var R: TRect; WinFlags: Integer): Integer; overload;
|
||
function DrawText(Canvas: TCanvas; const Text: string; Len: Integer; var R: TRect;
|
||
WinFlags: Integer): Integer; overload;
|
||
function PtInRectExclusive(R: TRect; Pt: TPoint): Boolean;
|
||
function CanvasMaxTextHeight(Canvas: TCanvas): Integer;
|
||
{$ENDIF !USEJVCL}
|
||
|
||
{$IFDEF USEJVCL}
|
||
{$IFDEF UNITVERSIONING}
|
||
const
|
||
UnitVersioning: TUnitVersionInfo = (
|
||
RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/tags/JVCL3_32/run/JvgUtils.pas $';
|
||
Revision: '$Revision: 10612 $';
|
||
Date: '$Date: 2006-05-19 21:04:09 +0200 (ven., 19 mai 2006) $';
|
||
LogPath: 'JVCL\run'
|
||
);
|
||
{$ENDIF UNITVERSIONING}
|
||
{$ENDIF USEJVCL}
|
||
|
||
implementation
|
||
|
||
uses
|
||
JvJCLUtils,
|
||
{$IFDEF USEJVCL}
|
||
ShlObj, Math,
|
||
JvResources, JvConsts,
|
||
{$ELSE}
|
||
ShlObj, Math,
|
||
{$ENDIF USEJVCL}
|
||
JvVCL5Utils;
|
||
|
||
{$IFNDEF USEJVCL}
|
||
|
||
resourcestring
|
||
RsERightBracketsNotFound = 'Right brackets not found';
|
||
RsERightBracketHavntALeftOnePosd = 'Right bracket havn''t a left one. Pos: %d';
|
||
RsEDivideBy = 'Divide by 0';
|
||
RsEDuplicateSignsAtPos = 'Duplicate signs at Pos: %d';
|
||
RsEExpressionStringIsEmpty = 'Expression string is empty.';
|
||
{$IFDEF glDEBUG}
|
||
RsEObjectMemoryLeak = 'object memory leak';
|
||
{$ENDIF glDEBUG}
|
||
|
||
const
|
||
ROP_DSPDxax = $00E20746;
|
||
|
||
{$ENDIF !USEJVCL}
|
||
|
||
{ debug func }
|
||
{$IFDEF glDEBUG}
|
||
function DeleteObject(P1: HGDIOBJ): BOOL; stdcall;
|
||
begin
|
||
Result := Windows.DeleteObject(P1);
|
||
if not Result then
|
||
raise Exception.CreateRes(@RsEObjectMemoryLeak);
|
||
end;
|
||
{$ENDIF glDEBUG}
|
||
|
||
procedure TJvgPublicWinControl.PaintWindow(DC: HDC);
|
||
begin
|
||
inherited PaintWindow(DC);
|
||
end;
|
||
|
||
procedure TJvgPublicWinControl.RecreateWnd;
|
||
begin
|
||
inherited RecreateWnd;
|
||
end;
|
||
|
||
function IsEven(I: Integer): Boolean;
|
||
begin
|
||
Result := not Odd(I);
|
||
end;
|
||
|
||
procedure SwapInt(var I1, I2: Integer);
|
||
var
|
||
Tmp: Integer;
|
||
begin
|
||
Tmp := I1;
|
||
I1 := I2;
|
||
I2 := Tmp;
|
||
end;
|
||
|
||
function Spaces(Count: Integer): string;
|
||
var
|
||
I: Integer;
|
||
begin
|
||
Result := '';
|
||
for I := 1 to Count do
|
||
Result := Result + ' ';
|
||
end;
|
||
|
||
function DupChar(C: Char; Count: Integer): string;
|
||
var
|
||
I: Integer;
|
||
begin
|
||
Result := '';
|
||
for I := 1 to Count do
|
||
Result := Result + C;
|
||
end;
|
||
|
||
function DupStr(const Str: string; Count: Integer): string;
|
||
var
|
||
I: Integer;
|
||
begin
|
||
Result := '';
|
||
for I := 1 to Count do
|
||
Result := Result + Str;
|
||
end;
|
||
|
||
{ Modal window with (i) icon and single OK button }
|
||
|
||
procedure Msg(const AMsg: string);
|
||
begin
|
||
MessageBox(GetForegroundWindow, PChar(AMsg), '',
|
||
MB_APPLMODAL or MB_ICONINFORMATION or MB_OK);
|
||
end;
|
||
|
||
{ Checks if point is inside rect. Rect's borders are not part of rect }
|
||
{ // (andreas) make Delphi 5 compiler happy
|
||
function IsPointInRect(P: TPoint; R: TRect): Boolean;
|
||
begin
|
||
Result := PtInRect(R, P);
|
||
// Result := (P.X > R.Left) and (P.X < R.Right) and (P.Y > R.Top) and (P.Y < R.Bottom);
|
||
end;
|
||
}
|
||
|
||
{ Rect's width }
|
||
|
||
function RectW(R: TRect): Integer;
|
||
begin
|
||
Result := R.Right - R.Left;
|
||
end;
|
||
|
||
{ Rect's height }
|
||
|
||
function RectH(R: TRect): Integer;
|
||
begin
|
||
Result := R.Bottom - R.Top;
|
||
end;
|
||
|
||
{ Increases components of the colour with given offset }
|
||
|
||
function IncColor(AColor: Longint; AOffset: Byte): Longint;
|
||
var
|
||
R, G, B: Byte;
|
||
begin
|
||
if AColor < 0 then
|
||
AColor := GetSysColor(AColor and $FF);
|
||
R := Min(255, GetRValue(AColor) + AOffset);
|
||
G := Min(255, GetGValue(AColor) + AOffset);
|
||
B := Min(255, GetBValue(AColor) + AOffset);
|
||
Result := RGB(R, G, B);
|
||
end;
|
||
|
||
{ Decreases components of the colour with given offset }
|
||
|
||
function DecColor(AColor: Longint; AOffset: Byte): Longint;
|
||
var
|
||
R, G, B: Byte;
|
||
begin
|
||
if AColor < 0 then
|
||
AColor := GetSysColor(AColor and $FF);
|
||
R := Max(0, GetRValue(AColor) - AOffset);
|
||
G := Max(0, GetGValue(AColor) - AOffset);
|
||
B := Max(0, GetBValue(AColor) - AOffset);
|
||
Result := RGB(R, G, B);
|
||
end;
|
||
|
||
function InchesToPixels(DC: HDC; Value: Single; IsHorizontal: Boolean): Integer;
|
||
const
|
||
LogPixels: array [Boolean] of Integer = (LOGPIXELSY, LOGPIXELSX);
|
||
begin
|
||
Result := Round(Value * GetDeviceCaps(DC, LogPixels[IsHorizontal]));// * 1.541 / 10);
|
||
end;
|
||
|
||
function CentimetersToPixels(DC: HDC; Value: Single; IsHorizontal: Boolean): Integer;
|
||
const
|
||
LogPixels: array [Boolean] of Integer = (LOGPIXELSY, LOGPIXELSX);
|
||
begin
|
||
Result := Round(Value * GetDeviceCaps(DC, LogPixels[IsHorizontal])/2.54);// * 1.541 / 2.54 / 10);
|
||
end;
|
||
|
||
{ Checks wheter bitmap object is created and is having size }
|
||
|
||
function IsItAFilledBitmap(Bmp: TBitmap): Boolean;
|
||
begin
|
||
with Bmp do
|
||
Result := Assigned(Bmp) and (Width <> 0) and (Height <> 0);
|
||
end;
|
||
|
||
|
||
{
|
||
Renders text wth alignment, given style and given font
|
||
|
||
DC - Handle of canvas
|
||
HAlign, VAlign - Alingment horizontal and vertical
|
||
Style - Style (embossed, with shadow, etc)
|
||
Flags - Extra parameters for Windows.DrawText
|
||
}
|
||
|
||
procedure DrawTextInRectWithAlign(DC: HDC; R: TRect; const Text: string;
|
||
HAlign: TglHorAlign; VAlign: TglVertAlign;
|
||
Style: TglTextStyle; Fnt: TFont; Flags: UINT);
|
||
begin
|
||
case HAlign of
|
||
fhaLeft:
|
||
Flags := Flags or DT_LEFT;
|
||
fhaCenter:
|
||
Flags := Flags or DT_CENTER;
|
||
fhaRight:
|
||
Flags := Flags or DT_RIGHT;
|
||
end;
|
||
case VAlign of
|
||
fvaTop:
|
||
Flags := Flags or DT_TOP;
|
||
fvaCenter:
|
||
Flags := Flags or DT_VCENTER;
|
||
fvaBottom:
|
||
Flags := Flags or DT_BOTTOM;
|
||
end;
|
||
|
||
DrawTextInRect(DC, R, Text, Style, Fnt, Flags);
|
||
end;
|
||
|
||
|
||
{
|
||
Renders text with alignment, given style and given font
|
||
|
||
DC - Handle of canvas
|
||
Style - Style (embossed, with shadow, etc)
|
||
Flags - Extra parameters for Windows.DrawText
|
||
}
|
||
|
||
procedure DrawTextInRect(DC: HDC; R: TRect; const Text: string; Style: TglTextStyle;
|
||
Fnt: TFont; Flags: UINT);
|
||
var
|
||
OldBkMode: Integer;
|
||
OldFont: Windows.HFONT;
|
||
FontColor: TColor;
|
||
ShadowColor, HighlightColor: TColor;
|
||
begin
|
||
if not Assigned(Fnt) then
|
||
Exit;
|
||
if Flags = 0 then
|
||
Flags := DT_LEFT or DT_VCENTER or DT_SINGLELINE;
|
||
OldBkMode := SetBkMode(DC, Ord(Transparent));
|
||
FontColor := Fnt.Color;
|
||
|
||
ShadowColor := clBtnShadow;
|
||
HighlightColor := clBtnHighlight;
|
||
|
||
OldFont := SelectObject(DC, Fnt.Handle);
|
||
case Style of
|
||
fstRaised:
|
||
begin
|
||
SetTextColor(DC, ColorToRGB(HighlightColor));
|
||
OffsetRect(R, -1, -1);
|
||
Windows.DrawText(DC, PChar(Text), Length(Text), R, Flags);
|
||
SetTextColor(DC, ColorToRGB(ShadowColor));
|
||
OffsetRect(R, 2, 2);
|
||
Windows.DrawText(DC, PChar(Text), Length(Text), R, Flags);
|
||
SetTextColor(DC, ColorToRGB(FontColor));
|
||
OffsetRect(R, -1, -1);
|
||
Windows.DrawText(DC, PChar(Text), Length(Text), R, Flags);
|
||
end;
|
||
fstRecessed:
|
||
begin
|
||
SetTextColor(DC, ColorToRGB(ShadowColor));
|
||
OffsetRect(R, -1, -1);
|
||
Windows.DrawText(DC, PChar(Text), Length(Text), R, Flags);
|
||
SetTextColor(DC, ColorToRGB(HighlightColor));
|
||
OffsetRect(R, 2, 2);
|
||
Windows.DrawText(DC, PChar(Text), Length(Text), R, Flags);
|
||
SetTextColor(DC, ColorToRGB(FontColor));
|
||
OffsetRect(R, -1, -1);
|
||
Windows.DrawText(DC, PChar(Text), Length(Text), R, Flags);
|
||
end;
|
||
fstPushed:
|
||
begin
|
||
SetTextColor(DC, ColorToRGB(HighlightColor));
|
||
Windows.DrawText(DC, PChar(Text), Length(Text), R, Flags);
|
||
SetTextColor(DC, ColorToRGB(ShadowColor));
|
||
OffsetRect(R, -1, -1);
|
||
Windows.DrawText(DC, PChar(Text), Length(Text), R, Flags);
|
||
end;
|
||
fstShadow:
|
||
begin
|
||
SetTextColor(DC, ColorToRGB(ShadowColor));
|
||
OffsetRect(R, 2, 2);
|
||
Windows.DrawText(DC, PChar(Text), Length(Text), R, Flags);
|
||
SetTextColor(DC, ColorToRGB(FontColor));
|
||
OffsetRect(R, -2, -2);
|
||
Windows.DrawText(DC, PChar(Text), Length(Text), R, Flags);
|
||
end;
|
||
else
|
||
begin
|
||
SetTextColor(DC, ColorToRGB(FontColor));
|
||
Windows.DrawText(DC, PChar(Text), Length(Text), R, Flags);
|
||
end;
|
||
end;
|
||
SelectObject(DC, OldFont);
|
||
SetBkMode(DC, OldBkMode);
|
||
end;
|
||
|
||
{
|
||
Renders text wth given style, countouring option and given colours fo 3D effects
|
||
|
||
DC - Handle of canvas
|
||
Style - Style (embossed, with shadow, etc)
|
||
ADelineated - Contour of color of DelinColor
|
||
FontColor, DelinColor, HighlightColor, ShadowColor -
|
||
Colors of font and 3D effects
|
||
Illumination - Not used
|
||
Gradient - Gradient for filling letters of text
|
||
}
|
||
|
||
procedure ExtTextOutExt(DC: HDC; X, Y: Integer; R: TRect; const Text: string;
|
||
Style: TglTextStyle; ADelineated, ASupress3D: Boolean;
|
||
FontColor, DelinColor, HighlightColor, ShadowColor: TColor;
|
||
Illumination: TJvgIllumination; Gradient: TJvgGradient; Font: TFont);
|
||
var
|
||
OldBkMode, X1, Y1, I, ShadowDepth: Integer;
|
||
OldFont: Windows.HFONT;
|
||
|
||
procedure DrawMain(ADelineated: Boolean; S: Integer);
|
||
begin
|
||
if ADelineated then
|
||
begin
|
||
if not ASupress3D then
|
||
begin
|
||
SetTextColor(DC, ColorToRGB(DelinColor));
|
||
ExtTextOut(DC, X + S, Y + S, ETO_CLIPPED, @R, PChar(Text), Length(Text), nil);
|
||
ExtTextOut(DC, X + 2 + S, Y + 2 + S, ETO_CLIPPED, @R, PChar(Text), Length(Text), nil);
|
||
ExtTextOut(DC, X + S, Y + S + 2, ETO_CLIPPED, @R, PChar(Text), Length(Text), nil);
|
||
ExtTextOut(DC, X + S + 2, Y + S, ETO_CLIPPED, @R, PChar(Text), Length(Text), nil);
|
||
end;
|
||
SetTextColor(DC, ColorToRGB(FontColor));
|
||
if Assigned(Gradient) then
|
||
Gradient.TextOut(DC, Text, R, X + S + 1, Y + S + 1)
|
||
else
|
||
ExtTextOut(DC, X + S + 1, Y + S + 1, ETO_CLIPPED, @R, PChar(Text), Length(Text), nil);
|
||
end
|
||
else
|
||
begin
|
||
SetTextColor(DC, ColorToRGB(FontColor));
|
||
if Assigned(Gradient) then
|
||
Gradient.TextOut(DC, Text, R, X + S, Y + S)
|
||
else
|
||
ExtTextOut(DC, X + S, Y + S, ETO_CLIPPED, @R, PChar(Text), Length(Text), nil);
|
||
end;
|
||
end;
|
||
begin
|
||
if not Assigned(Font) then
|
||
Exit;
|
||
OldFont := SelectObject(DC, Font.Handle);
|
||
OldBkMode := SetBkMode(DC, TRANSPARENT);
|
||
|
||
if ADelineated then
|
||
begin
|
||
X1 := 4;
|
||
Y1 := 4;
|
||
end
|
||
else
|
||
begin
|
||
X1 := 2;
|
||
Y1 := 2;
|
||
end;
|
||
if Style = fstNone then
|
||
begin
|
||
X1 := X1 div 2 - 1;
|
||
Y1 := Y1 div 2 - 1;
|
||
end;
|
||
if Style = fstShadow then
|
||
begin
|
||
X1 := X1 div 2 - 1;
|
||
Y1 := Y1 div 2 - 1;
|
||
end;
|
||
if Assigned(Illumination) then
|
||
ShadowDepth := Illumination.ShadowDepth
|
||
else
|
||
ShadowDepth := 2;
|
||
case Style of
|
||
fstRaised:
|
||
begin
|
||
if not ASupress3D then
|
||
begin
|
||
SetTextColor(DC, ColorToRGB(HighlightColor));
|
||
ExtTextOut(DC, X, Y, ETO_CLIPPED, @R, PChar(Text), Length(Text), nil);
|
||
SetTextColor(DC, ColorToRGB(ShadowColor));
|
||
ExtTextOut(DC, X + X1, Y + Y1, ETO_CLIPPED, @R, PChar(Text), Length(Text), nil);
|
||
end;
|
||
DrawMain(ADelineated, 1);
|
||
end;
|
||
fstRecessed:
|
||
begin
|
||
if not ASupress3D then
|
||
begin
|
||
SetTextColor(DC, ColorToRGB(ShadowColor));
|
||
ExtTextOut(DC, X, Y, ETO_CLIPPED, @R, PChar(Text), Length(Text), nil);
|
||
SetTextColor(DC, ColorToRGB(HighlightColor));
|
||
ExtTextOut(DC, X + X1, Y + Y1, ETO_CLIPPED, @R, PChar(Text), Length(Text), nil);
|
||
end;
|
||
DrawMain(ADelineated, 1);
|
||
end;
|
||
fstPushed:
|
||
begin
|
||
SetTextColor(DC, ColorToRGB(HighlightColor));
|
||
ExtTextOut(DC, X + 1, Y + 1, ETO_CLIPPED, @R, PChar(Text), Length(Text), nil);
|
||
SetTextColor(DC, ColorToRGB(ShadowColor));
|
||
ExtTextOut(DC, X, Y, ETO_CLIPPED, @R, PChar(Text), Length(Text), nil);
|
||
end;
|
||
fstShadow:
|
||
begin
|
||
if not ASupress3D then
|
||
begin
|
||
SetTextColor(DC, ColorToRGB(ShadowColor));
|
||
ExtTextOut(DC, X + X1 + ShadowDepth, Y + Y1 + ShadowDepth, ETO_CLIPPED, @R, PChar(Text), Length(Text), nil);
|
||
end;
|
||
DrawMain(ADelineated, 0);
|
||
end;
|
||
fstVolumetric:
|
||
begin
|
||
if not ASupress3D then
|
||
begin
|
||
SetTextColor(DC, ColorToRGB(ShadowColor));
|
||
for I := 1 to ShadowDepth do
|
||
ExtTextOut(DC, X + I, Y + I, ETO_CLIPPED, @R, PChar(Text), Length(Text), nil);
|
||
end;
|
||
DrawMain(ADelineated, 0);
|
||
end;
|
||
else
|
||
DrawMain(ADelineated, 0);
|
||
// SetTextColor( DC , ColorToRGB(FontColor) );
|
||
// ExtTextOut( DC, X, Y, ETO_CLIPPED, @R, PChar(Text), Length(Text), nil);
|
||
end;
|
||
SelectObject(DC, OldFont);
|
||
SetBkMode(DC, OldBkMode);
|
||
end;
|
||
|
||
{
|
||
Draws rect with given 3D style
|
||
|
||
DC - Handle of canvas
|
||
Style - Style (fbsFlat, fbsCtl3D, fbsStatusControl, fbsRecessed, fbsRaised, fbsRaisedFrame, fbsRecessedFrame)
|
||
BackgrColor - Background Color if FTransparen is False
|
||
}
|
||
|
||
|
||
procedure DrawBox(DC: HDC; var R: TRect; Style: TglBoxStyle;
|
||
BackgrColor: Longint; ATransparent: Boolean);
|
||
const
|
||
FBorderWidth = 1;
|
||
begin
|
||
|
||
case Style of
|
||
fbsFlat:
|
||
begin
|
||
end;
|
||
fbsCtl3D:
|
||
begin
|
||
R.Top := R.Top + 2;
|
||
R.Left := R.Left + 2;
|
||
R.Right := R.Right - 2;
|
||
R.Bottom := R.Bottom - 1;
|
||
// Frame3D(Canvas, R,clBtnShadow,clBtnHighlight,1);
|
||
end;
|
||
// fbsStatusControl:
|
||
fbsRaised:
|
||
begin
|
||
InflateRect(R, -2, -2);
|
||
DrawEdge(DC, R, BDR_RAISEDOUTER, BF_BOTTOMRIGHT); // black
|
||
Dec(R.Bottom);
|
||
Dec(R.Right);
|
||
DrawEdge(DC, R, BDR_RAISEDINNER, BF_TOPLEFT); // btnhilite
|
||
Inc(R.Top);
|
||
Inc(R.Left);
|
||
DrawEdge(DC, R, BDR_RAISEDINNER, BF_BOTTOMRIGHT or BF_MIDDLE); // btnshadow
|
||
end;
|
||
fbsRecessed:
|
||
begin
|
||
R.Bottom := R.Bottom - 1;
|
||
DrawEdge(DC, R, BDR_SUNKENINNER, BF_TOPLEFT); // black
|
||
DrawEdge(DC, R, BDR_SUNKENOUTER, BF_BOTTOMRIGHT); // btnhilite
|
||
Dec(R.Bottom);
|
||
Dec(R.Right);
|
||
Inc(R.Top);
|
||
Inc(R.Left);
|
||
DrawEdge(DC, R, BDR_SUNKENOUTER, BF_TOPLEFT or BF_MIDDLE); // btnshadow
|
||
Inc(R.Top);
|
||
Inc(R.Left);
|
||
end;
|
||
fbsRaisedFrame:
|
||
begin
|
||
DrawEdge(DC, R, BDR_RAISEDOUTER, BF_BOTTOMRIGHT); // black
|
||
Dec(R.Bottom);
|
||
Dec(R.Right);
|
||
DrawEdge(DC, R, BDR_RAISEDINNER, BF_TOPLEFT); // btnhilite
|
||
Inc(R.Top);
|
||
Inc(R.Left);
|
||
DrawEdge(DC, R, BDR_RAISEDINNER, BF_BOTTOMRIGHT or BF_MIDDLE); // btnshadow
|
||
|
||
InflateRect(R, -FBorderWidth, -FBorderWidth);
|
||
|
||
DrawEdge(DC, R, BDR_SUNKENINNER, BF_TOPLEFT); // black
|
||
DrawEdge(DC, R, BDR_SUNKENOUTER, BF_BOTTOMRIGHT); // btnhilite
|
||
Dec(R.Bottom);
|
||
Dec(R.Right);
|
||
Inc(R.Top);
|
||
Inc(R.Left);
|
||
DrawEdge(DC, R, BDR_SUNKENOUTER, BF_TOPLEFT or BF_MIDDLE); // btnshadow
|
||
Inc(R.Top);
|
||
Inc(R.Left);
|
||
end;
|
||
fbsRecessedFrame:
|
||
begin
|
||
DrawEdge(DC, R, BDR_SUNKENINNER, BF_TOPLEFT); // black
|
||
DrawEdge(DC, R, BDR_SUNKENOUTER, BF_BOTTOMRIGHT); // btnhilite
|
||
Dec(R.Bottom);
|
||
Dec(R.Right);
|
||
Inc(R.Top);
|
||
Inc(R.Left);
|
||
DrawEdge(DC, R, BDR_SUNKENOUTER, BF_TOPLEFT or BF_MIDDLE); // btnshadow
|
||
Inc(R.Top);
|
||
Inc(R.Left);
|
||
|
||
InflateRect(R, -FBorderWidth, -FBorderWidth);
|
||
|
||
DrawEdge(DC, R, BDR_RAISEDOUTER, BF_BOTTOMRIGHT); // black
|
||
Dec(R.Bottom);
|
||
Dec(R.Right);
|
||
DrawEdge(DC, R, BDR_RAISEDINNER, BF_TOPLEFT); // btnhilite
|
||
Inc(R.Top);
|
||
Inc(R.Left);
|
||
DrawEdge(DC, R, BDR_RAISEDINNER, BF_BOTTOMRIGHT or BF_MIDDLE); // btnshadow
|
||
end;
|
||
end;
|
||
end;
|
||
|
||
{
|
||
Draws rect with given 3D style and specifing borders
|
||
|
||
DC - Handle of canvas
|
||
Borders - Borders for drawing
|
||
BevelInner, BevelOuter - Borders' styles
|
||
Bold - Bold border(frame)
|
||
BackgrColor - Background Color if ATransparent is False
|
||
}
|
||
|
||
function DrawBoxEx(DC: HDC; ARect: TRect; Borders: TglSides;
|
||
BevelInner, BevelOuter: TPanelBevel; Bold: Boolean; BackgrColor: Longint;
|
||
ATransparent: Boolean): TRect;
|
||
var
|
||
I: Word;
|
||
BPen, LPen, SPen, OldPen: HPEN;
|
||
HBackgrBrush, HOldBrush: HBRUSH;
|
||
R, R1: TRect;
|
||
BColor, HColor, SColor: Longint;
|
||
LogOldPen: TLOGPEN;
|
||
PenWidth: UINT;
|
||
|
||
procedure SetDefColors;
|
||
begin
|
||
BColor := GetSysColor(COLOR_3DDKSHADOW);
|
||
HColor := GetSysColor(COLOR_3DHILIGHT);
|
||
SColor := GetSysColor(COLOR_3DSHADOW);
|
||
end;
|
||
|
||
procedure DrawBevel(Bevel: TPanelBevel);
|
||
begin
|
||
if fsdLeft in Borders then
|
||
begin
|
||
case Bevel of
|
||
bvRaised:
|
||
begin
|
||
SelectObject(DC, LPen);
|
||
MoveToEx(DC, R.Left, R.Top, nil);
|
||
LineTo(DC, R.Left, R.Bottom + 1);
|
||
Inc(R1.Left);
|
||
//.if Bold then Inc(R1.Left);
|
||
end;
|
||
bvLowered:
|
||
if Bold then
|
||
begin
|
||
SelectObject(DC, BPen);
|
||
MoveToEx(DC, R.Left, R.Top, nil);
|
||
LineTo(DC, R.Left, R.Bottom);
|
||
Inc(R1.Left);
|
||
SelectObject(DC, SPen);
|
||
if fsdBottom in Borders then
|
||
I := 0
|
||
else
|
||
I := 1;
|
||
MoveToEx(DC, R.Left + 1, R.Top + 1, nil);
|
||
LineTo(DC, R.Left + 1, R.Bottom + I);
|
||
//SetPixel(DC, R.Left, R.Bottom-1, SColor);
|
||
Inc(R1.Left);
|
||
end
|
||
else
|
||
begin
|
||
SelectObject(DC, SPen);
|
||
MoveToEx(DC, R.Left, R.Top, nil);
|
||
LineTo(DC, R.Left, R.Bottom);
|
||
Inc(R1.Left);
|
||
end;
|
||
bvSpace:
|
||
begin
|
||
SelectObject(DC, SPen);
|
||
MoveToEx(DC, R.Left, R.Top, nil);
|
||
LineTo(DC, R.Left, R.Bottom);
|
||
Inc(R1.Left);
|
||
end;
|
||
end;
|
||
end;
|
||
if fsdTop in Borders then
|
||
begin
|
||
case Bevel of
|
||
bvRaised:
|
||
begin
|
||
SelectObject(DC, LPen);
|
||
MoveToEx(DC, R.Left, R.Top, nil);
|
||
LineTo(DC, R.Right, R.Top);
|
||
Inc(R1.Top);
|
||
//.if Bold then Inc(R1.Top);
|
||
end;
|
||
bvLowered:
|
||
if Bold then
|
||
begin
|
||
SelectObject(DC, BPen);
|
||
MoveToEx(DC, R.Left, R.Top, nil);
|
||
LineTo(DC, R.Right, R.Top);
|
||
Inc(R1.Top);
|
||
SelectObject(DC, SPen);
|
||
MoveToEx(DC, R.Left + 1, R.Top + 1, nil);
|
||
LineTo(DC, R.Right, R.Top + 1);
|
||
//SetPixel(DC, R.Right-1, R.Top+1, SColor);
|
||
Inc(R1.Top);
|
||
end
|
||
else
|
||
begin
|
||
SelectObject(DC, SPen);
|
||
MoveToEx(DC, R.Left, R.Top, nil);
|
||
LineTo(DC, R.Right, R.Top);
|
||
Inc(R1.Top);
|
||
end;
|
||
bvSpace:
|
||
begin
|
||
SelectObject(DC, SPen);
|
||
MoveToEx(DC, R.Left, R.Top, nil);
|
||
LineTo(DC, R.Right, R.Top);
|
||
Inc(R1.Top);
|
||
end;
|
||
end;
|
||
end;
|
||
if fsdRight in Borders then
|
||
begin
|
||
case Bevel of
|
||
bvRaised:
|
||
if Bold then
|
||
begin
|
||
SelectObject(DC, BPen);
|
||
MoveToEx(DC, R.Right, R.Top, nil);
|
||
LineTo(DC, R.Right, R.Bottom + 1);
|
||
Dec(R1.Right);
|
||
SelectObject(DC, SPen);
|
||
MoveToEx(DC, R.Right - 1, R.Top + 1, nil);
|
||
LineTo(DC, R.Right - 1, R.Bottom + 1);
|
||
//SetPixel(DC, R.Right-1, R.Bottom-1, SColor);
|
||
Dec(R1.Right);
|
||
end
|
||
else
|
||
begin
|
||
SelectObject(DC, SPen);
|
||
MoveToEx(DC, R.Right, R.Top, nil);
|
||
LineTo(DC, R.Right, R.Bottom + 1);
|
||
Dec(R1.Right);
|
||
end;
|
||
bvLowered:
|
||
begin
|
||
SelectObject(DC, LPen);
|
||
MoveToEx(DC, R.Right, R.Top, nil);
|
||
LineTo(DC, R.Right, R.Bottom);
|
||
Dec(R1.Right);
|
||
//. if Bold then Dec(R1.Right);
|
||
end;
|
||
bvSpace:
|
||
begin
|
||
SelectObject(DC, SPen);
|
||
MoveToEx(DC, R.Right, R.Top, nil);
|
||
LineTo(DC, R.Right, R.Bottom);
|
||
Dec(R1.Right);
|
||
end;
|
||
end;
|
||
end;
|
||
if fsdBottom in Borders then
|
||
begin
|
||
case Bevel of
|
||
bvRaised:
|
||
if Bold then
|
||
begin
|
||
SelectObject(DC, BPen);
|
||
if fsdLeft in Borders then
|
||
I := 1
|
||
else
|
||
I := 0;
|
||
MoveToEx(DC, R.Left {+1}, R.Bottom, nil);
|
||
LineTo(DC, R.Right, R.Bottom);
|
||
Dec(R1.Bottom);
|
||
SelectObject(DC, SPen);
|
||
MoveToEx(DC, R.Left + I {+I}, R.Bottom - 1, nil);
|
||
LineTo(DC, R.Right, R.Bottom - 1);
|
||
//SetPixel(DC, R.Right-1+I, R.Bottom-1, SColor);
|
||
Dec(R1.Bottom);
|
||
end
|
||
else
|
||
begin
|
||
SelectObject(DC, SPen);
|
||
MoveToEx(DC, R.Left, R.Bottom, nil);
|
||
LineTo(DC, R.Right, R.Bottom);
|
||
Dec(R1.Bottom);
|
||
end;
|
||
bvLowered:
|
||
begin
|
||
SelectObject(DC, LPen);
|
||
// if Borders.Left then I:=1 else I:=0;
|
||
MoveToEx(DC, R.Left, R.Bottom {-1}, nil);
|
||
LineTo(DC, R.Right + 1, R.Bottom {-1});
|
||
Dec(R1.Bottom);
|
||
//. if Bold then Dec(R1.Bottom);
|
||
//Dec(R1.Bottom);
|
||
end;
|
||
bvSpace:
|
||
begin
|
||
SelectObject(DC, SPen);
|
||
MoveToEx(DC, R.Left, R.Bottom {-1}, nil);
|
||
LineTo(DC, R.Right + 1, R.Bottom {-1});
|
||
Dec(R1.Bottom);
|
||
end;
|
||
end;
|
||
end;
|
||
end;
|
||
|
||
begin
|
||
try
|
||
if Assigned(glGlobalData.lp3DColors) then
|
||
with TJvg3DColors(glGlobalData.lp3DColors) do
|
||
begin
|
||
BColor := ColorToRGB(DkShadow);
|
||
HColor := ColorToRGB(Highlight);
|
||
SColor := ColorToRGB(Shadow);
|
||
end
|
||
else
|
||
SetDefColors;
|
||
except
|
||
end;
|
||
|
||
LPen := CreatePen(PS_SOLID, 1, HColor);
|
||
OldPen := SelectObject(DC, LPen);
|
||
DeleteObject(SelectObject(DC, OldPen));
|
||
|
||
FillChar(LogOldPen, SizeOf(LogOldPen), 0);
|
||
GetObject(OldPen, SizeOf(LogOldPen), @LogOldPen);
|
||
if LogOldPen.lopnWidth.X = 0 then
|
||
PenWidth := 1
|
||
else
|
||
PenWidth := LogOldPen.lopnWidth.X;
|
||
BPen := CreatePen(LogOldPen.lopnStyle, PenWidth, BColor);
|
||
LPen := CreatePen(LogOldPen.lopnStyle, PenWidth, HColor);
|
||
SPen := CreatePen(LogOldPen.lopnStyle, PenWidth, SColor);
|
||
SelectObject(DC, LPen);
|
||
R1 := ARect;
|
||
R := ARect;
|
||
if BevelOuter <> bvNone then
|
||
DrawBevel(BevelOuter);
|
||
R := R1;
|
||
// if (BevelOuter = bvRaised)and(BevelInner = bvLowered)and Bold then
|
||
// begin Dec(R.Top); Dec(R.Left); end;
|
||
|
||
if BevelInner <> bvNone then
|
||
DrawBevel(BevelInner);
|
||
|
||
SelectObject(DC, OldPen);
|
||
DeleteObject(BPen);
|
||
DeleteObject(LPen);
|
||
DeleteObject(SPen);
|
||
|
||
if not ATransparent then
|
||
begin
|
||
HBackgrBrush := CreateSolidBrush(ColorToRGB(BackgrColor));
|
||
HOldBrush := SelectObject(DC, HBackgrBrush);
|
||
R := R1; {Dec(R.Top);Dec(R.Left);}
|
||
Inc(R.Right);
|
||
Inc(R.Bottom);
|
||
FillRect(DC, R, HBackgrBrush);
|
||
DeleteObject(SelectObject(DC, HOldBrush));
|
||
end;
|
||
|
||
Result := R1;
|
||
end;
|
||
|
||
{ Draws TJvgGradient gradient }
|
||
|
||
procedure GradientBox(DC: HDC; R: TRect; Gradient: TJvgGradient; PenStyle, PenWidth: Integer);
|
||
begin
|
||
Gradient.Draw(DC, R, PenStyle, PenWidth);
|
||
end;
|
||
|
||
{ Replaces bitmap's color }
|
||
|
||
procedure ChangeBitmapColor(Bitmap: TBitmap; FromColor, ToColor: TColor);
|
||
var
|
||
IWidth, IHeight: Integer;
|
||
DRect, SRect: TRect;
|
||
MonoBMP, OldBMP: HBITMAP;
|
||
MonoDC: HDC;
|
||
begin
|
||
if (Bitmap.Width or Bitmap.Height) = 0 then
|
||
Exit;
|
||
IWidth := Bitmap.Width;
|
||
IHeight := Bitmap.Height;
|
||
DRect := Rect(0, 0, IWidth, IHeight);
|
||
SRect := DRect;
|
||
|
||
MonoDC := CreateCompatibleDC(Bitmap.Canvas.Handle);
|
||
MonoBMP := CreateBitmap(IWidth, IHeight, 1, 1, nil);
|
||
OldBMP := SelectObject(MonoDC, MonoBMP);
|
||
|
||
try
|
||
with Bitmap.Canvas do { Convert FromColor to ToColor }
|
||
begin
|
||
Bitmap.Canvas.Brush.Color := FromColor;
|
||
{copy Bitmap to MonoBMP}
|
||
BitBlt(MonoDC, 0, 0, IWidth, IHeight, Handle, 0, 0, cmSrcCopy);
|
||
Brush.Color := ToColor;
|
||
SetTextColor(Handle, clBlack);
|
||
SetBkColor(Handle, clWhite);
|
||
BitBlt(Handle, 0, 0, IWidth, IHeight, MonoDC, 0, 0, ROP_DSPDxax);
|
||
end;
|
||
finally
|
||
DeleteObject(SelectObject(MonoDC, OldBMP));
|
||
DeleteDC(MonoDC);
|
||
end;
|
||
end;
|
||
|
||
{ Paints bitmap. Transparent, disabled, multiplied, etc }
|
||
|
||
procedure DrawBitmapExt(DC: HDC; { DC - background & result}
|
||
SourceBitmap: TBitmap; R: TRect;
|
||
X, Y: Integer; //...X,Y _in_ rect!
|
||
BitmapOption: TglWallpaperOption; DrawState: TglDrawState;
|
||
ATransparent: Boolean; TransparentColor: TColor; DisabledMaskColor: TColor);
|
||
begin
|
||
CreateBitmapExt(DC, SourceBitmap, R, X, Y, BitmapOption,
|
||
DrawState, ATransparent, TransparentColor, DisabledMaskColor);
|
||
end;
|
||
|
||
//..DrawBitmap algorithm borrow from Delphi2 VCL Sources
|
||
{ create bimap based on SourceBitmap and write new bitmap to DC }
|
||
|
||
procedure CreateBitmapExt(DC: HDC; {target DC}
|
||
SourceBitmap: TBitmap; R: TRect;
|
||
X, Y: Integer; //...X,Y _in_ rect!
|
||
BitmapOption: TglWallpaperOption; DrawState: TglDrawState;
|
||
ATransparent: Boolean; TransparentColor: TColor; DisabledMaskColor: TColor);
|
||
const
|
||
ROP_DSPDxax = $00E20746;
|
||
var
|
||
X1, Y1, H, W: Integer;
|
||
D, D1: Double;
|
||
TmpImage, MonoBMP: TBitmap;
|
||
IWidth, IHeight: Integer;
|
||
IRect, ORect: TRect;
|
||
// DestDC: HDC;
|
||
BmpInfo: Windows.TBitmap;
|
||
PtSize, PtOrg: TPoint;
|
||
MemDC, ImageDC: HDC;
|
||
OldBMP, OldMonoBMP, OldScreenImageBMP, OldMemBMP: HBITMAP;
|
||
HMonoBMP, ScreenImageBMP, MemBMP: HBITMAP;
|
||
MonoDC, ScreenImageDC: HDC;
|
||
OldBkColor: COLORREF;
|
||
SavedIHeight: Integer;
|
||
|
||
procedure BitBltWorks;
|
||
begin
|
||
if ATransparent then
|
||
begin
|
||
{ create copy of drawing image }
|
||
BitBlt(MemDC, 0, 0, IWidth, IHeight, ImageDC, 0, 0, SRCCOPY);
|
||
if DrawState = fdsDisabled then
|
||
TransparentColor := clBtnFace;
|
||
OldBkColor := SetBkColor(MemDC, ColorToRGB(TransparentColor));
|
||
{ create monohrome mask: TransparentColor -> white, other color -> black }
|
||
BitBlt(MonoDC, 0, 0, IWidth, IHeight, MemDC, 0, 0, SRCCOPY);
|
||
SetBkColor(MemDC, OldBkColor);
|
||
{create copy of screen image}
|
||
BitBlt(ScreenImageDC, 0, 0, IWidth, IHeight, DC, X1, Y1, SRCCOPY);
|
||
{ put monochrome mask }
|
||
BitBlt(ScreenImageDC, 0, 0, IWidth, IHeight, MonoDC, 0, 0, SRCAND);
|
||
BitBlt(MonoDC, 0, 0, IWidth, IHeight, MonoDC, 0, 0, NOTSRCCOPY);
|
||
{ put inverse monochrome mask }
|
||
BitBlt(MemDC, 0, 0, IWidth, IHeight, MonoDC, 0, 0, SRCAND);
|
||
{ merge Screen screen image(MemDC) and Screen image(ScreenImageDC) }
|
||
BitBlt(MemDC, 0, 0, IWidth, IHeight, ScreenImageDC, 0, 0, SRCPAINT);
|
||
{ to screen }
|
||
// DSTINVERT MERGEPAINT
|
||
BitBlt(DC, X1, Y1, IWidth, IHeight, MemDC, 0, 0, SRCCOPY);
|
||
end
|
||
else
|
||
BitBlt(DC, X1, Y1, IWidth, IHeight, ImageDC, 0, 0, SRCCOPY);
|
||
end;
|
||
|
||
begin
|
||
if (SourceBitmap.Width = 0) or (SourceBitmap.Height = 0) then
|
||
Exit;
|
||
|
||
X := X + R.Left;
|
||
Y := Y + R.Top;
|
||
X1 := X;
|
||
Y1 := Y;
|
||
OldBMP := 0;
|
||
OldMemBMP := 0;
|
||
OldMonoBMP := 0;
|
||
OldScreenImageBMP := 0;
|
||
MemDC := 0;
|
||
ImageDC := 0;
|
||
// MonoBMP := 0;
|
||
// ScreenImageBMP := 0;
|
||
// MemBMP := 0;
|
||
MonoDC := 0;
|
||
ScreenImageDC := 0;
|
||
|
||
IWidth := SourceBitmap.Width; //Min( SourceBitmap.Width, R.Right-R.Left );
|
||
IHeight := SourceBitmap.Height; //Min( SourceBitmap.Height, R.Bottom-R.Top );
|
||
TmpImage := TBitmap.Create;
|
||
try
|
||
TmpImage.Width := IWidth;
|
||
TmpImage.Height := IHeight;
|
||
IRect := Rect(0, 0, IWidth, IHeight);
|
||
ORect := Rect(0, 0, IWidth, IHeight);
|
||
|
||
TmpImage.Canvas.Brush.Color := TransparentColor;
|
||
TmpImage.Canvas.FillRect(Rect(0, 0, IWidth, IHeight));
|
||
|
||
case DrawState of
|
||
fdsDefault:
|
||
BitBlt(TmpImage.Canvas.Handle, 0, 0, IWidth, IHeight,
|
||
SourceBitmap.Canvas.Handle, 0, 0, SRCCOPY);
|
||
fdsDelicate:
|
||
begin
|
||
with TmpImage.Canvas do
|
||
BitBlt(Handle, 0, 0, IWidth, IHeight,
|
||
SourceBitmap.Canvas.Handle, 0, 0, SRCCOPY);
|
||
{ Convert white to clBtnHighlight }
|
||
ChangeBitmapColor(TmpImage, clWhite, clBtnHighlight);
|
||
{ Convert gray to clBtnShadow }
|
||
ChangeBitmapColor(TmpImage, clGray, clBtnShadow);
|
||
{ Convert transparent color to clBtnFace }
|
||
// ChangeBitmapColor(TmpImage,ColorToRGB(}TransparentColor),clBtnFace);
|
||
end;
|
||
fdsDisabled:
|
||
begin
|
||
if DisabledMaskColor <> 0 then
|
||
ChangeBitmapColor(TmpImage, DisabledMaskColor, clBlack);
|
||
MonoBMP := TBitmap.Create;
|
||
try { Create a disabled version }
|
||
with MonoBMP do
|
||
begin
|
||
Assign(SourceBitmap);
|
||
Canvas.Brush.Color := 0;
|
||
Width := IWidth;
|
||
if Monochrome then
|
||
begin
|
||
Canvas.Font.Color := clWhite;
|
||
Monochrome := False;
|
||
Canvas.Brush.Color := clWhite;
|
||
end;
|
||
Monochrome := True;
|
||
end;
|
||
with TmpImage.Canvas do
|
||
begin
|
||
Brush.Color := clBtnFace;
|
||
FillRect(IRect);
|
||
Brush.Color := clBtnHighlight;
|
||
SetTextColor(Handle, 0);
|
||
SetBkColor(Handle, clWhite);
|
||
BitBlt(Handle, 1, 1, IWidth, IHeight,
|
||
MonoBMP.Canvas.Handle, 0, 0, ROP_DSPDxax);
|
||
Brush.Color := clBtnShadow;
|
||
SetTextColor(Handle, 0);
|
||
SetBkColor(Handle, clWhite);
|
||
BitBlt(Handle, 0, 0, IWidth, IHeight,
|
||
MonoBMP.Canvas.Handle, 0, 0, ROP_DSPDxax);
|
||
end;
|
||
finally
|
||
MonoBMP.Free;
|
||
end;
|
||
end;
|
||
end;
|
||
|
||
with TmpImage.Canvas do
|
||
if (BitmapOption = fwoStretch) or (BitmapOption = fwoPropStretch) then
|
||
begin
|
||
MemDC := CreateCompatibleDC(DC);
|
||
MemBMP := CreateCompatibleBitmap(TmpImage.Canvas.Handle, R.Right - R.Left, R.Bottom - R.Top);
|
||
OldMemBMP := SelectObject(MemDC, MemBMP);
|
||
W := R.Right - R.Left;
|
||
H := R.Bottom - R.Top;
|
||
if BitmapOption = fwoPropStretch then
|
||
begin
|
||
D1 := W / IWidth;
|
||
D := H / IHeight;
|
||
if D > D1 then
|
||
D := D1; //...D == Min
|
||
W := Trunc(IWidth * D);
|
||
H := Trunc(IHeight * D);
|
||
end;
|
||
StretchBlt(MemDC, 0, 0, W, H, Handle, 0, 0, IWidth, IHeight, SRCCOPY);
|
||
|
||
IWidth := W;
|
||
IHeight := H;
|
||
TmpImage.Width := W;
|
||
TmpImage.Height := H;
|
||
BitBlt(Handle, 0, 0, IWidth, IHeight, MemDC, 0, 0, SRCCOPY);
|
||
|
||
DeleteObject(SelectObject(MemDC, OldMemBMP));
|
||
DeleteDC(MemDC);
|
||
end;
|
||
|
||
ImageDC := CreateCompatibleDC(DC);
|
||
|
||
if ATransparent then
|
||
begin
|
||
MemDC := CreateCompatibleDC(DC);
|
||
ScreenImageDC := CreateCompatibleDC(DC);
|
||
MonoDC := CreateCompatibleDC(DC);
|
||
|
||
HMonoBMP := CreateBitmap(IWidth, IHeight, 1, 1, nil);
|
||
ScreenImageBMP := CreateCompatibleBitmap(TmpImage.Canvas.Handle, IWidth, IHeight);
|
||
MemBMP := CreateCompatibleBitmap(TmpImage.Canvas.Handle, IWidth, IHeight);
|
||
|
||
OldMonoBMP := SelectObject(MonoDC, HMonoBMP);
|
||
OldScreenImageBMP := SelectObject(ScreenImageDC, ScreenImageBMP);
|
||
OldMemBMP := SelectObject(MemDC, MemBMP);
|
||
end;
|
||
OldBMP := SelectObject(ImageDC, TmpImage.Handle);
|
||
|
||
if OldBMP <> 0 then
|
||
begin
|
||
SetMapMode(ImageDC, GetMapMode(DC));
|
||
GetObject(TmpImage.Handle, SizeOf(Windows.TBitmap), @BmpInfo);
|
||
PtSize.X := BmpInfo.bmWidth;
|
||
PtOrg.X := 0;
|
||
PtSize.Y := BmpInfo.bmHeight;
|
||
PtOrg.Y := 0;
|
||
if ATransparent then
|
||
begin
|
||
DPtoLP(DC, PtSize, 1);
|
||
DPtoLP(MemDC, PtOrg.Y, 1);
|
||
end;
|
||
if BitmapOption = fwoTile then
|
||
begin
|
||
//SavedIWidth:=IWidth;
|
||
SavedIHeight := IHeight;
|
||
while X1 < R.Right do
|
||
begin
|
||
//IWidth:=SavedIWidth; //SavedIWidth:=IWidth;
|
||
if X1 + IWidth > R.Right then
|
||
IWidth := R.Right - X1;
|
||
while Y1 < R.Bottom do
|
||
begin
|
||
IHeight := SavedIHeight; // SavedIHeight:=IHeight;
|
||
if Y1 + IHeight > R.Bottom then
|
||
IHeight := R.Bottom - Y1;
|
||
BitBltWorks;
|
||
Inc(Y1, IHeight);
|
||
end;
|
||
Inc(X1, IWidth);
|
||
Y1 := Y;
|
||
end;
|
||
end
|
||
else
|
||
BitBltWorks;
|
||
end;
|
||
finally
|
||
DeleteObject(SelectObject(ImageDC, OldBMP));
|
||
DeleteDC(ImageDC);
|
||
if ATransparent then
|
||
begin
|
||
DeleteObject(SelectObject(MonoDC, OldMonoBMP));
|
||
DeleteObject(SelectObject(ScreenImageDC, OldScreenImageBMP));
|
||
DeleteObject(SelectObject(MemDC, OldMemBMP));
|
||
DeleteDC(MonoDC);
|
||
DeleteDC(ScreenImageDC);
|
||
DeleteDC(MemDC);
|
||
end;
|
||
TmpImage.Free;
|
||
end;
|
||
|
||
end;
|
||
|
||
{ Brings parent window to front }
|
||
|
||
procedure BringParentWindowToTop(Wnd: TWinControl);
|
||
begin
|
||
if Wnd is TForm then
|
||
BringWindowToTop(Wnd.Handle)
|
||
else
|
||
if Wnd.Parent is TWinControl then
|
||
BringParentWindowToTop(Wnd.Parent);
|
||
end;
|
||
|
||
{ Gives parent window of TForm class }
|
||
|
||
function GetParentForm(Control: TControl): TForm;
|
||
begin
|
||
if Control is TForm then
|
||
Result := TForm(Control)
|
||
else
|
||
if Control.Parent is TWinControl then
|
||
Result := GetParentForm(Control.Parent)
|
||
else
|
||
Result := nil;
|
||
end;
|
||
|
||
|
||
{ Paints TWinControl with all its content onto DC with offset(shift) X,Y
|
||
...from rxLib... :( very sorry }
|
||
|
||
procedure GetWindowImageFrom(Control: TWinControl; X, Y: Integer; ADrawSelf, ADrawChildWindows: Boolean; DC: HDC);
|
||
var
|
||
I, Count, SaveIndex: Integer;
|
||
begin
|
||
if Control = nil then
|
||
Exit;
|
||
Count := Control.ControlCount;
|
||
|
||
{ Copy self image }
|
||
if ADrawSelf then
|
||
begin
|
||
SaveIndex := SaveDC(DC);
|
||
SetViewportOrgEx(DC, X, Y, nil);
|
||
TJvgPublicWinControl(Control).PaintWindow(DC);
|
||
RestoreDC(DC, SaveIndex);
|
||
end;
|
||
{ Copy images of graphic controls }
|
||
for I := 0 to Count - 1 do
|
||
begin
|
||
if Control.Controls[I] <> nil then
|
||
begin
|
||
if Control.Controls[I] = Control then
|
||
Break;
|
||
if (Control.Controls[I] is TWinControl) and ADrawChildWindows then
|
||
GetWindowImageFrom(TWinControl(Control.Controls[I]),
|
||
TWinControl(Control.Controls[I]).Left,
|
||
TWinControl(Control.Controls[I]).Top,
|
||
True {ADrawSelf}, ADrawChildWindows, DC)
|
||
else
|
||
with Control.Controls[I] do
|
||
if Visible then
|
||
begin
|
||
SaveIndex := SaveDC(DC);
|
||
SetViewportOrgEx(DC, Left + X, Top + Y, nil);
|
||
Perform(WM_PAINT, Longint(DC), 0);
|
||
RestoreDC(DC, SaveIndex);
|
||
end;
|
||
end;
|
||
end;
|
||
end;
|
||
|
||
{ Paints(renders) TWinControl with all its content onto DC with offset (0,0) }
|
||
|
||
procedure GetWindowImage(Control: TWinControl; ADrawSelf, ADrawChildWindows: Boolean; DC: HDC);
|
||
begin
|
||
GetWindowImageFrom(Control, 0, 0, ADrawSelf, ADrawChildWindows, DC);
|
||
end;
|
||
|
||
{ Paints parent TWinControl with all its contents onto DC with limit of Rect }
|
||
|
||
procedure GetParentImageRect(Control: TControl; Rect: TRect; DC: HDC);
|
||
var
|
||
I, Count, X, Y, SaveIndex: Integer;
|
||
R, SelfR, CtlR: TRect;
|
||
begin
|
||
if Control.Parent = nil then
|
||
Exit;
|
||
Count := Control.Parent.ControlCount;
|
||
SelfR := Bounds(Control.Left, Control.Top, Control.Width, Control.Height);
|
||
// OffsetRect( Rect, Control.Left, Control.Top );
|
||
IntersectRect(SelfR, SelfR, Rect);
|
||
|
||
X := -Rect.Left;
|
||
Y := -Rect.Top;
|
||
{ Copy parent control image }
|
||
SaveIndex := SaveDC(DC);
|
||
SetViewportOrgEx(DC, X, Y, nil);
|
||
IntersectClipRect(DC, 0, 0, Rect.Right, Rect.Bottom);
|
||
TJvgPublicWinControl(Control.Parent).PaintWindow(DC);
|
||
RestoreDC(DC, SaveIndex);
|
||
{ Copy images of graphic controls }
|
||
for I := 0 to Count - 1 do
|
||
begin
|
||
if (Control.Parent.Controls[I] <> nil) and
|
||
not (Control.Parent.Controls[I] is TWinControl) then
|
||
begin
|
||
if Control.Parent.Controls[I] = Control then
|
||
Break;
|
||
with Control.Parent.Controls[I] do
|
||
begin
|
||
CtlR := Bounds(Left, Top, Width, Height);
|
||
if IntersectRect(R, SelfR, CtlR) and Visible then
|
||
begin
|
||
SaveIndex := SaveDC(DC);
|
||
SetViewportOrgEx(DC, Left + X, Top + Y, nil);
|
||
IntersectClipRect(DC, 0, 0, Width, Height);
|
||
Perform(WM_PAINT, Longint(DC), 0);
|
||
RestoreDC(DC, SaveIndex);
|
||
end;
|
||
end;
|
||
end;
|
||
end;
|
||
end;
|
||
|
||
{-create a rotated font based on the font object F}
|
||
|
||
function CreateRotatedFont(F: TFont; Escapement: Integer): HFONT;
|
||
var
|
||
LF: TLogFont;
|
||
begin
|
||
FillChar(LF, SizeOf(LF), #0);
|
||
with LF do
|
||
begin
|
||
lfHeight := F.Height;
|
||
// lfWidth := 8;//FHeight div 4;
|
||
lfEscapement := Escapement;
|
||
lfOrientation := 0;
|
||
if fsBold in F.Style then
|
||
lfWeight := FW_BOLD
|
||
else
|
||
lfWeight := FW_NORMAL;
|
||
// if FFontWeight <> fwDONTCARE then lfWeight:=uFontWeight;
|
||
lfItalic := Ord(fsItalic in F.Style);
|
||
lfUnderline := Ord(fsUnderline in F.Style);
|
||
lfStrikeOut := Ord(fsStrikeOut in F.Style);
|
||
lfCharSet := F.CHARSET;
|
||
StrPCopy(lfFaceName, F.Name);
|
||
lfQuality := DEFAULT_QUALITY;
|
||
{everything else as default}
|
||
lfOutPrecision := OUT_DEFAULT_PRECIS;
|
||
lfClipPrecision := CLIP_DEFAULT_PRECIS;
|
||
case F.Pitch of
|
||
fpVariable:
|
||
lfPitchAndFamily := VARIABLE_PITCH;
|
||
fpFixed:
|
||
lfPitchAndFamily := FIXED_PITCH;
|
||
else
|
||
lfPitchAndFamily := DEFAULT_PITCH;
|
||
end;
|
||
end;
|
||
Result := CreateFontIndirect(LF);
|
||
end;
|
||
|
||
{ Returns main window of application }
|
||
|
||
function FindMainWindow(const AWndClass, AWndTitle: string): THandle;
|
||
begin
|
||
Result := 0;
|
||
if (AWndClass <> '') or (AWndTitle <> '') then
|
||
Result := FindWindow(PChar(AWndClass), PChar(AWndTitle));
|
||
end;
|
||
|
||
{ Calculates colors of shadow and lighted border for given base color. }
|
||
|
||
procedure CalcShadowAndHighlightColors(BaseColor: TColor; Colors: TJvgLabelColors);
|
||
var
|
||
R, G, B: Byte;
|
||
begin
|
||
with Colors do
|
||
begin
|
||
if (BaseColor and $80000000) <> 0 then
|
||
BaseColor := GetSysColor(BaseColor and $FF);
|
||
B := (BaseColor and $00FF0000) shr 16;
|
||
G := (BaseColor and $0000FF00) shr 8;
|
||
R := BaseColor and $000000FF;
|
||
if AutoShadow then
|
||
begin
|
||
{if R<G then limit:=R else limit:=G; if B<limit then limit:=B;//...Min
|
||
if limit<FColorShadowShift then FColorShadowShift:=limit;
|
||
FShadow := RGB(R-FColorShadowShift,G-FColorShadowShift,B-FColorShadowShift);}
|
||
Shadow := RGB(Max(R - ColorShadowShift, 0), Max(G - ColorShadowShift, 0), Max(B - ColorShadowShift, 0));
|
||
end;
|
||
if AutoHighlight then
|
||
begin
|
||
{if R>G then limit:=R else limit:=G; if B>limit then limit:=B;//...Max
|
||
if (255-limit)<FColorHighlightShift then FColorHighlightShift:=255-limit;
|
||
FHighlight := RGB(R+FColorHighlightShift,G+FColorHighlightShift,B+FColorHighlightShift);}
|
||
Highlight := RGB(Min(R + ColorHighlightShift, 255), Min(G + ColorHighlightShift, 255), Min(B +
|
||
ColorHighlightShift, 255));
|
||
end;
|
||
end;
|
||
end;
|
||
|
||
{ Calculates arithmetic expression, given in string }
|
||
|
||
function CalcMathString(AExpression: string): Single;
|
||
var
|
||
ExpressionPtr, ExpressionLength, BracketsCount: Integer;
|
||
CalcResult: Boolean;
|
||
CurrChar: Char;
|
||
|
||
function Expression: Single; forward;
|
||
|
||
procedure NextChar;
|
||
begin
|
||
Inc(ExpressionPtr);
|
||
if ExpressionPtr <= ExpressionLength then
|
||
CurrChar := AExpression[ExpressionPtr]
|
||
else
|
||
CurrChar := #0;
|
||
if CurrChar = ' ' then
|
||
NextChar;
|
||
if CurrChar = #0 then
|
||
Exit;
|
||
if not (CurrChar in ['0'..'9', ',', '.', '-', '+', '/', '*', '(', ')']) then
|
||
NextChar;
|
||
end;
|
||
|
||
function DigitsToValue: Single;
|
||
var
|
||
PointDepth: Integer;
|
||
Point: Boolean;
|
||
begin
|
||
Result := 0;
|
||
Point := False;
|
||
PointDepth := 0;
|
||
while CurrChar = ' ' do
|
||
NextChar;
|
||
|
||
if (CurrChar >= '0') and (CurrChar <= '9') then
|
||
begin
|
||
while (CurrChar >= '0') and (CurrChar <= '9') do
|
||
begin
|
||
Result := Result * 10 + Ord(CurrChar) - Ord('0');
|
||
NextChar;
|
||
if Point then
|
||
Inc(PointDepth);
|
||
if (CurrChar = '.') or (CurrChar = ',') then
|
||
begin
|
||
NextChar;
|
||
Point := True;
|
||
end;
|
||
end;
|
||
if PointDepth <> 0 then
|
||
Result := Result / (10.0 * PointDepth);
|
||
end
|
||
else
|
||
begin
|
||
case CurrChar of
|
||
'-':
|
||
begin
|
||
NextChar;
|
||
Result := -1.0 * Result;
|
||
end;
|
||
'(':
|
||
begin
|
||
Inc(BracketsCount);
|
||
NextChar;
|
||
Result := Expression;
|
||
while CurrChar = ' ' do
|
||
NextChar;
|
||
if CurrChar <> ')' then
|
||
begin
|
||
raise Exception.CreateRes(@RsERightBracketsNotFound);
|
||
CalcResult := False;
|
||
Result := 0;
|
||
end
|
||
else
|
||
NextChar;
|
||
end;
|
||
// '.': Point := True;
|
||
// ',': Point := True;
|
||
end;
|
||
end;
|
||
if CurrChar = ')' then
|
||
begin
|
||
Dec(BracketsCount);
|
||
if BracketsCount < 0 then
|
||
raise Exception.CreateResFmt(@RsERightBracketHavntALeftOnePosd, [ExpressionPtr - 1]);
|
||
end;
|
||
end;
|
||
|
||
function TestForMulDiv: Single;
|
||
var
|
||
Denominator: Single;
|
||
begin
|
||
Result := DigitsToValue; // . . .test For digits, signs And brackets
|
||
while True do
|
||
begin
|
||
case CurrChar of
|
||
// Case "-": NextChar
|
||
'*':
|
||
begin
|
||
NextChar;
|
||
Result := Result * DigitsToValue;
|
||
end;
|
||
'/':
|
||
begin
|
||
NextChar;
|
||
Denominator := DigitsToValue;
|
||
if Denominator <> 0 then
|
||
Result := Result / Denominator
|
||
else
|
||
begin
|
||
CalcResult := False;
|
||
raise Exception.CreateRes(@RsEDivideBy);
|
||
end;
|
||
end;
|
||
else
|
||
Break;
|
||
end;
|
||
end;
|
||
end;
|
||
|
||
function Expression: Single;
|
||
begin
|
||
Result := TestForMulDiv; //...test for '*' and '/'
|
||
while True do
|
||
case CurrChar of //...TestFor_AddSub
|
||
' ':
|
||
NextChar;
|
||
'+':
|
||
begin
|
||
NextChar;
|
||
if CurrChar in ['+', '-', '/', '*'] then
|
||
raise Exception.CreateResFmt(@RsEDuplicateSignsAtPos , [ExpressionPtr - 1]);
|
||
Result := Result + TestForMulDiv;
|
||
end;
|
||
'-':
|
||
begin
|
||
NextChar;
|
||
if CurrChar in ['+', '-', '/', '*'] then
|
||
raise Exception.CreateResFmt(@RsEDuplicateSignsAtPos, [ExpressionPtr - 1]);
|
||
Result := Result - TestForMulDiv;
|
||
end;
|
||
else
|
||
Break;
|
||
end;
|
||
end;
|
||
|
||
begin
|
||
ExpressionPtr := 0;
|
||
BracketsCount := 0;
|
||
AExpression := Trim(AExpression);
|
||
|
||
ExpressionLength := Length(AExpression);
|
||
if ExpressionLength = 0 then
|
||
raise Exception.CreateRes(@RsEExpressionStringIsEmpty);
|
||
CalcResult := True;
|
||
NextChar;
|
||
Result := Expression;
|
||
end;
|
||
|
||
{ Ternary operator: X ? Y : Z }
|
||
|
||
function IIF(AExpression: Boolean; IfTrue, IfFalse: Variant): Variant; overload;
|
||
begin
|
||
if AExpression then
|
||
Result := IfTrue
|
||
else
|
||
Result := IfFalse;
|
||
end;
|
||
|
||
function IIF(AExpression: Boolean; const IfTrue, IfFalse: string): string; overload;
|
||
begin
|
||
if AExpression then
|
||
Result := IfTrue
|
||
else
|
||
Result := IfFalse;
|
||
end;
|
||
|
||
{ Returns colour of Leftmost/Rightmost Top/Bottom pixel of bitmap }
|
||
|
||
function GetTransparentColor(Bitmap: TBitmap; AutoTrColor: TglAutoTransparentColor): TColor;
|
||
var
|
||
X, Y: Integer;
|
||
begin
|
||
if (AutoTrColor = ftcUser) or not IsItAFilledBitmap(Bitmap) then
|
||
Result := 0
|
||
else
|
||
begin
|
||
case AutoTrColor of
|
||
ftcLeftTopPixel:
|
||
begin
|
||
X := 0;
|
||
Y := 0;
|
||
end;
|
||
ftcLeftBottomPixel:
|
||
begin
|
||
X := 0;
|
||
Y := Bitmap.Height - 1;
|
||
end;
|
||
ftcRightTopPixel:
|
||
begin
|
||
X := Bitmap.Width - 1;
|
||
Y := 0;
|
||
end;
|
||
else {ftcRightBottomPixel}
|
||
begin
|
||
X := Bitmap.Width - 1;
|
||
Y := Bitmap.Height - 1;
|
||
end;
|
||
end;
|
||
Result := GetPixel(Bitmap.Canvas.Handle, X, Y);
|
||
end;
|
||
end;
|
||
|
||
procedure TypeStringOnKeyboard(const S: string);
|
||
var
|
||
I: Integer;
|
||
VK: Byte;
|
||
begin
|
||
for I := 1 to Length(S) do
|
||
begin
|
||
if Ord(S[I]) > 32 then
|
||
VK := Ord(S[I]) - 32
|
||
else
|
||
VK := Ord(S[I]);
|
||
keybd_event(VK, 0, 0, 0);
|
||
keybd_event(VK, 0, KEYEVENTF_KEYUP, 0);
|
||
end;
|
||
end;
|
||
|
||
{function NextStringGridCell( Grid: TStringGrid ): Boolean;
|
||
var
|
||
R: TRect;
|
||
I: Integer;
|
||
begin
|
||
with Grid do
|
||
begin
|
||
if Cols[Selection.Left][Selection.Top]='' then
|
||
begin Result := True; Exit; end;
|
||
Result := not ((Grid.Selection.Top = RowCount-1)and(Grid.Selection.Left =
|
||
if Result then
|
||
if Selection.Top = RowCount-1 then
|
||
begin
|
||
Perform( wM_KEYDOWN, VK_TAB, 1);
|
||
for I:=1 to RowCount-FixedRows-1 do Perform( wM_KEYDOWN, VK_UP, 1);
|
||
end
|
||
else
|
||
begin Perform( wM_KEYDOWN, VK_DOWN, 1); end;
|
||
// Grid.SetFocus;
|
||
Grid.EditorMode:=False;
|
||
Grid.EditorMode:=True;
|
||
end;
|
||
end;
|
||
}
|
||
|
||
procedure DrawTextExtAligned(Canvas: TCanvas; const Text: string; R: TRect; Alignment: TglAlignment; WordWrap: Boolean);
|
||
const
|
||
Alignments: array [TglAlignment] of Word = (DT_LEFT, DT_RIGHT, DT_CENTER, 0);
|
||
WordWraps: array [Boolean] of Word = (0, DT_WORDBREAK);
|
||
var
|
||
DrawPos, Pos1, Pos2, LineWidth, LineNo, LexemCount, TextHeight: Integer;
|
||
Width: Integer;
|
||
Lexem: string;
|
||
Size: TSize;
|
||
Stop, BroadwiseLine: Boolean;
|
||
|
||
function GetNextLexem(var Pos1, Pos2: Integer; TrimLeft: Boolean): string;
|
||
var
|
||
Pos: Integer;
|
||
begin
|
||
Pos := Pos1;
|
||
if Text[Pos] = ' ' then
|
||
repeat
|
||
Inc(Pos);
|
||
until (Pos > Length(Text)) or (Text[Pos] <> ' ');
|
||
Pos2 := Pos;
|
||
if TrimLeft and (LineNo > 0) then
|
||
Pos1 := Pos;
|
||
repeat
|
||
Inc(Pos2);
|
||
until (Pos2 > Length(Text)) or (Text[Pos2] = ' ');
|
||
|
||
Result := Copy(Text, Pos1, Pos2 - Pos1);
|
||
end;
|
||
|
||
procedure DrawLine(AdditSpace: Cardinal);
|
||
var
|
||
I, DrawPos1, DrawPos2: Integer;
|
||
Lexem: string;
|
||
Size: TSize;
|
||
X, X1: Single;
|
||
begin
|
||
DrawPos1 := DrawPos;
|
||
DrawPos2 := DrawPos;
|
||
X := 0;
|
||
X1 := 0;
|
||
LineWidth := 0;
|
||
for I := 1 to LexemCount do
|
||
begin
|
||
Lexem := GetNextLexem(DrawPos1, DrawPos2, I = 1);
|
||
// if LexemCount=1 then Lexem:=Lexem+' ';
|
||
GetTextExtentPoint32(Canvas.Handle, PChar(Lexem), Length(Lexem), Size);
|
||
Inc(LineWidth, Trunc(X));
|
||
X := X + Size.cx;
|
||
if (Trunc(X) > Width) and (LexemCount > 1) then
|
||
Exit;
|
||
|
||
if (LexemCount > 1) and BroadwiseLine then
|
||
X := X + AdditSpace / (LexemCount - 1);
|
||
TextOut(Canvas.Handle, R.Left + Trunc(X1), R.Top + LineNo * TextHeight, PChar(Lexem), Length(Lexem));
|
||
X1 := X;
|
||
DrawPos1 := DrawPos2;
|
||
end;
|
||
end;
|
||
|
||
begin
|
||
if Text = '' then
|
||
Exit;
|
||
if Alignment <> ftaBroadwise then
|
||
begin
|
||
Windows.DrawText(Canvas.Handle, PChar(Text), Length(Text), R,
|
||
DT_EXPANDTABS or WordWraps[WordWrap] or Alignments[Alignment]);
|
||
Exit;
|
||
end;
|
||
Width := R.Right - R.Left; {Height := R.Bottom - R.Top;}
|
||
LineWidth := 0;
|
||
LineNo := 0;
|
||
DrawPos := 1;
|
||
Pos1 := 1;
|
||
Pos2 := 1;
|
||
LexemCount := 0;
|
||
TextHeight := 0;
|
||
Stop := False;
|
||
BroadwiseLine := True;
|
||
repeat
|
||
Lexem := GetNextLexem(Pos1, Pos2, LexemCount = 0);
|
||
// if LexemCount=0 then Lexem:=Lexem+' ';
|
||
GetTextExtentPoint32(Canvas.Handle, PChar(Lexem), Length(Lexem), Size);
|
||
Inc(LineWidth, Size.cx);
|
||
Inc(LexemCount);
|
||
if TextHeight < Size.cy then
|
||
TextHeight := Size.cy;
|
||
if (LineWidth > Width) or (Pos2 >= Length(Text)) then
|
||
begin
|
||
if LineWidth > Width then
|
||
begin
|
||
if LexemCount = 1 then
|
||
Pos1 := Pos2;
|
||
if LexemCount > 1 then
|
||
Dec(LexemCount);
|
||
DrawLine(Width - (LineWidth - Size.cx));
|
||
DrawPos := Pos1;
|
||
Inc(LineNo);
|
||
LexemCount := 0;
|
||
LineWidth := 0;
|
||
Stop := Pos1 > Length(Text);
|
||
end
|
||
else
|
||
begin
|
||
BroadwiseLine := False; //ftoBroadwiseLastLine;
|
||
DrawLine(Width - LineWidth);
|
||
Inc(LineNo);
|
||
Stop := True;
|
||
end;
|
||
end
|
||
else
|
||
Pos1 := Pos2;
|
||
until Stop;
|
||
// if FAutoSize then Height := Max( 12, LineNo*TextHeight );
|
||
end;
|
||
|
||
{ Deserialization: loading component from text file }
|
||
|
||
procedure LoadComponentFromTextFile(Component: TComponent; const FileName: string);
|
||
var
|
||
MemStream: TMemoryStream;
|
||
FileStream: TFileStream;
|
||
begin
|
||
MemStream := TMemoryStream.Create;
|
||
FileStream := TFileStream.Create(FileName, fmOpenRead);
|
||
try
|
||
ObjectTextToBinary(FileStream, MemStream);
|
||
MemStream.Position := 0;
|
||
MemStream.ReadComponent(Component);
|
||
finally
|
||
MemStream.Free;
|
||
FileStream.Free;
|
||
end;
|
||
end;
|
||
|
||
{ Serializing component to string }
|
||
|
||
function ComponentToString(Component: TComponent): string;
|
||
var
|
||
MemStream: TMemoryStream;
|
||
StringStream: TStringStream;
|
||
begin
|
||
StringStream := TStringStream.Create(' ');
|
||
MemStream := TMemoryStream.Create;
|
||
try
|
||
MemStream.WriteComponent(Component);
|
||
MemStream.Position := 0;
|
||
ObjectBinaryToText(MemStream, StringStream);
|
||
StringStream.Position := 0;
|
||
Result := StringStream.DataString;
|
||
finally
|
||
MemStream.Free;
|
||
StringStream.Free;
|
||
end;
|
||
end;
|
||
|
||
{ Serialization: writing component to text file }
|
||
|
||
procedure SaveComponentToTextFile(Component: TComponent; const FileName: string);
|
||
var
|
||
MemStream: TMemoryStream;
|
||
FileStream: TFileStream;
|
||
begin
|
||
FileStream := TFileStream.Create(FileName, fmCreate or fmOpenWrite);
|
||
try
|
||
MemStream := TMemoryStream.Create;
|
||
try
|
||
MemStream.WriteComponent(Component);
|
||
MemStream.Position := 0;
|
||
ObjectBinaryToText(MemStream, FileStream);
|
||
finally
|
||
MemStream.Free;
|
||
end;
|
||
finally
|
||
FileStream.Free;
|
||
end;
|
||
end;
|
||
|
||
{ Deserializing component from string }
|
||
|
||
procedure StringToComponent(Component: TComponent; const Value: string);
|
||
var
|
||
StrStream: TStringStream;
|
||
MemStream: TMemoryStream;
|
||
begin
|
||
StrStream := TStringStream.Create(Value);
|
||
try
|
||
MemStream := TMemoryStream.Create;
|
||
try
|
||
ObjectTextToBinary(StrStream, MemStream);
|
||
|
||
MemStream.Position := 0;
|
||
MemStream.ReadComponent(Component);
|
||
// Result := BinStream.ReadComponent(nil);
|
||
finally
|
||
MemStream.Free;
|
||
end;
|
||
finally
|
||
StrStream.Free;
|
||
end;
|
||
end;
|
||
|
||
{ Plays WAV resource }
|
||
|
||
function PlayWaveResource(const ResName: string): Boolean;
|
||
var
|
||
WaveHandle: THandle;
|
||
WavePointer: Pointer;
|
||
begin
|
||
Result := False;
|
||
WaveHandle := FindResource(HInstance, PChar(ResName), RT_RCDATA);
|
||
if WaveHandle <> 0 then
|
||
begin
|
||
WaveHandle := LoadResource(HInstance, WaveHandle);
|
||
if WaveHandle <> 0 then
|
||
begin
|
||
WavePointer := LockResource(WaveHandle);
|
||
Result := sndPlaySound(WavePointer, SND_MEMORY or SND_ASYNC);
|
||
UnlockResource(WaveHandle);
|
||
FreeResource(WaveHandle);
|
||
end;
|
||
end;
|
||
end;
|
||
|
||
{ User name for current thread }
|
||
|
||
// JVCL4: Should go to JvJCLUtils.pas as "GetUserName: string"
|
||
function UserName: string;
|
||
var
|
||
Name: array [0..127] of Char;
|
||
Len: DWORD;
|
||
begin
|
||
Len := SizeOf(Name);
|
||
GetUserName(Name, Len);
|
||
Result := Name;
|
||
end;
|
||
|
||
{ PC name }
|
||
|
||
// JVCL4: Should go to JvJCLUtils.pas as "GetComputerName: string"
|
||
function ComputerName: string;
|
||
begin
|
||
Result := JvJCLUtils.GetComputerName;
|
||
end;
|
||
|
||
{ Creates ini-file with the same name to project's file - use ChangeFileExt }
|
||
|
||
function CreateIniFileName: string;
|
||
begin
|
||
Result := ParamStr(0);
|
||
SetLength(Result, Length(Result) - Length(ExtractFileExt(Result)));
|
||
Result := Result + '.ini';
|
||
end;
|
||
|
||
{ Expands string with spaces up to given Length }
|
||
|
||
function ExpandString(const Str: string; Len: Integer): string;
|
||
var
|
||
I: Integer;
|
||
begin
|
||
Result := Str;
|
||
if Length(Result) >= Len then
|
||
Exit;
|
||
SetLength(Result, Len);
|
||
|
||
for I := 1 to Length(Result) do
|
||
if I <= Length(Str) then
|
||
Result[I] := Str[I]
|
||
else
|
||
Result[I] := ' ';
|
||
end;
|
||
|
||
{ Transliterating string Rus <-> Lat }
|
||
|
||
function Transliterate(const Str: string; RusToLat: Boolean): string;
|
||
const
|
||
LAT: string = 'ABVGDEGZIIKLMNOPRSTUFHC___"Y''EUYabvgdegziiklmnoprstufhc___"y''euy+';
|
||
RUS: string = '<27><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>+';
|
||
LATRUS: array [1..52, 1..2] of Char =
|
||
(
|
||
('A', '<27>'), ('B', '<27>'), ('C', '<27>'), ('D', '<27>'), ('E', '<27>'),
|
||
('F', '<27>'), ('G', '<27>'), ('H', '<27>'), ('I', '<27>'), ('J', '<27>'),
|
||
('K', '<27>'), ('L', '<27>'), ('M', '<27>'), ('N', '<27>'), ('O', '<27>'),
|
||
('P', '<27>'), ('Q', #0), ('R', '<27>'), ('S', '<27>'), ('T', '<27>'),
|
||
('U', '<27>'), ('V', '<27>'), ('W', #0), ('X', #0), ('Y', '<27>'), ('Z', '<27>'),
|
||
('a', '<27>'), ('b', '<27>'), ('c', '<27>'), ('d', '<27>'), ('e', '<27>'),
|
||
('f', '<27>'), ('g', '<27>'), ('h', '<27>'), ('i', '<27>'), ('j', '<27>'),
|
||
('k', '<27>'), ('l', '<27>'), ('m', '<27>'), ('n', '<27>'), ('o', '<27>'),
|
||
('p', '<27>'), ('q', #0), ('r', '<27>'), ('s', '<27>'), ('t', '<27>'),
|
||
('u', '<27>'), ('v', '<27>'), ('w', #0), ('x', #0), ('y', '<27>'), ('z', '<27>')
|
||
);
|
||
|
||
TRANS_PAIRCOUNT = 14;
|
||
TRANS_PAIR: array [1..TRANS_PAIRCOUNT, Boolean] of string =
|
||
(('<27>', 'kh'), ('<27>', 'ts'), ('<27>', 'ch'), ('<27>', 'sh'), ('<27>', 'shch'), ('<27>', 'iu'), ('<27>', 'ia'),
|
||
('<27>', 'Kh'), ('<27>', 'Ts'), ('<27>', '<27>h'), ('<27>', 'Sh'), ('<27>', 'Shch'), ('<27>', 'Iu'), ('<27>', 'Ia'));
|
||
var
|
||
I, J: Integer;
|
||
begin
|
||
Result := Str;
|
||
for I := 1 to TRANS_PAIRCOUNT do
|
||
Result := StringReplace(Result, TRANS_PAIR[I, not RusToLat], TRANS_PAIR[I, RusToLat], [rfReplaceAll]);
|
||
|
||
if RusToLat then
|
||
begin
|
||
for I := 1 to Length(Result) do
|
||
if Result[I] in ['<27>'..'<27>'] then
|
||
Result[I] := LAT[Ord(Result[I]) - Ord('<27>') + 1];
|
||
end
|
||
else
|
||
for I := 1 to Length(Result) do
|
||
if Result[I] in ['A'..'z'] then
|
||
for J := 1 to 52 do
|
||
if Result[I] = LATRUS[J, 1] then
|
||
begin
|
||
Result[I] := LATRUS[J, 2];
|
||
Break;
|
||
end;
|
||
end;
|
||
|
||
{ Function returns True, if font is small }
|
||
|
||
function IsSmallFonts: Boolean;
|
||
var
|
||
DC: HDC;
|
||
begin
|
||
DC := GetDC(HWND_DESKTOP);
|
||
Result := (GetDeviceCaps(DC, LOGPIXELSX) = 96);
|
||
{ For large font it would be 120 }
|
||
ReleaseDC(HWND_DESKTOP, DC);
|
||
end;
|
||
|
||
{ Color depth in system: 8, 16 or 32 bits }
|
||
|
||
function SystemColorDepth: Integer;
|
||
var
|
||
DC: HDC;
|
||
begin
|
||
DC := GetDC(HWND_DESKTOP);
|
||
Result := GetDeviceCaps(DC, BITSPIXEL);
|
||
ReleaseDC(HWND_DESKTOP, DC);
|
||
end;
|
||
|
||
function GetFileType(const FileName: string): TglFileType;
|
||
var
|
||
Ext: string;
|
||
I: Integer;
|
||
const
|
||
Extensions: array [0..3] of string = ('.gif', '.jpeg', '.jpg', '.bmp');
|
||
Types: array [0..4] of TglFileType = (fftGif, fftJpeg, fftJpeg, fftBmp, fftUndefined);
|
||
begin
|
||
Result := fftUndefined;
|
||
Ext := ExtractFileExt(FileName);
|
||
for I := Low(Extensions) to High(Extensions) do
|
||
if SameFileName(Ext, Extensions[I]) then
|
||
begin
|
||
Result := Types[I];
|
||
Break;
|
||
end;
|
||
end;
|
||
|
||
{ Looks for upper(topmost) control at given point }
|
||
|
||
function FindControlAtPt(Control: TWinControl; Pt: TPoint; MinClass: TClass): TControl;
|
||
var
|
||
I: Integer;
|
||
begin
|
||
Result := nil;
|
||
for I := Control.ControlCount - 1 downto 0 do
|
||
if (Control.Controls[I] is MinClass) and PtInRect(Control.Controls[I].BoundsRect, Pt) then
|
||
begin
|
||
Result := Control.Controls[I];
|
||
Break;
|
||
end;
|
||
end;
|
||
|
||
{ StrPosExt - Looks for position of one string inside another with given length
|
||
Outperforms StrPos on long strings in 10-100 times (1-2 orders) }
|
||
|
||
function StrPosExt(const Str1, Str2: PChar; Str2Len: DWORD): PChar; assembler;
|
||
asm
|
||
PUSH EDI
|
||
PUSH ESI
|
||
PUSH EBX
|
||
OR EAX,EAX // Str1
|
||
JE @@2 // If Str1 is empty - get out
|
||
OR EDX,EDX // Str2
|
||
JE @@2 // If Str2 is empty - get out
|
||
MOV EBX,EAX
|
||
MOV EDI,EDX // Setting offset for SCASB - substring Str2
|
||
XOR AL,AL // Zero AL
|
||
|
||
push ECX // String length
|
||
|
||
MOV ECX,0FFFFFFFFH // to be assured it will never underflow
|
||
REPNE SCASB // Searching for end of Str2 substring
|
||
NOT ECX // Inverting ECX - getting string length +1
|
||
DEC ECX // And here is exact length
|
||
|
||
JE @@2 // length = 0? get out!
|
||
MOV ESI,ECX // Saving substring length in ESI
|
||
|
||
pop ECX
|
||
|
||
SUB ECX,ESI // ECX := Length(Str1) - Length(Str2)
|
||
JBE @@2 // Length(substring) > Length(containing string) ? get out!
|
||
MOV EDI,EBX // EDI points to the beginning od Str1
|
||
LEA EBX,[ESI-1] // EBX - length of comparision of strings
|
||
@@1: MOV ESI,EDX // ESI - offset of Str2 string
|
||
LODSB // Loading 1st byte of substring into AL
|
||
REPNE SCASB // Searching that very char in EDI string
|
||
JNE @@2 // Char not found? get out!
|
||
MOV EAX,ECX // Saving difference of lengths of strings
|
||
PUSH EDI // Saving current offset of search
|
||
MOV ECX,EBX
|
||
REPE CMPSB // per-byte comparision of strings
|
||
POP EDI
|
||
MOV ECX,EAX
|
||
JNE @@1 // If strings do not match - searching for 1st substring's char again
|
||
LEA EAX,[EDI-1]
|
||
JMP @@3
|
||
@@2: XOR EAX,EAX
|
||
@@3: POP EBX
|
||
POP ESI
|
||
POP EDI
|
||
end;
|
||
|
||
{$IFNDEF USEJVCL}
|
||
|
||
function DrawText(Canvas: TCanvas; Text: PAnsiChar; Len: Integer;
|
||
var R: TRect; WinFlags: Integer): Integer; overload;
|
||
begin
|
||
Result := Windows.DrawText(Canvas.Handle, Text, Len, R, WinFlags);
|
||
end;
|
||
|
||
function DrawText(Canvas: TCanvas; const Text: string; Len: Integer; var R: TRect;
|
||
WinFlags: Integer): Integer; overload;
|
||
begin
|
||
Result := DrawText(Canvas, PChar(Text), Len, R, WinFlags and not DT_MODIFYSTRING); // make sure the string cannot be modified
|
||
end;
|
||
|
||
function PtInRectExclusive(R: TRect; Pt: TPoint): Boolean;
|
||
begin
|
||
R.Left := R.Left + 1;
|
||
R.Top := R.Top + 1;
|
||
Result := PtInRect(R, Pt);
|
||
end;
|
||
|
||
function CanvasMaxTextHeight(Canvas: TCanvas): Integer;
|
||
var
|
||
tt: TTextMetric;
|
||
begin
|
||
// (ahuser) Qt returns different values for TextHeight('Ay') and TextHeigth(#1..#255)
|
||
{$IFDEF VisualCLX}
|
||
Canvas.Start; // if it is called outside a paint event
|
||
RequiredState(Canvas, [csHandleValid, csFontValid, csBrushValid]);
|
||
{$ENDIF VisualCLX}
|
||
GetTextMetrics(Canvas.Handle, tt);
|
||
{$IFDEF VisualCLX}
|
||
Canvas.Stop;
|
||
{$ENDIF VisualCLX}
|
||
Result := tt.tmHeight;
|
||
end;
|
||
|
||
{$ENDIF !USEJVCL}
|
||
|
||
{$IFDEF USEJVCL}
|
||
{$IFDEF UNITVERSIONING}
|
||
initialization
|
||
RegisterUnitVersion(HInstance, UnitVersioning);
|
||
|
||
finalization
|
||
UnregisterUnitVersion(HInstance);
|
||
{$ENDIF UNITVERSIONING}
|
||
{$ENDIF USEJVCL}
|
||
|
||
end.
|
||
|