paweld/lazarus-ccr
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
c9d65fa82e
lazarus-ccr/components/orpheus/ovcmisc.pas

1116 lines
33 KiB
ObjectPascal
Raw Blame History

{*********************************************************}
{* OVCMISC.PAS 4.06 *}
{*********************************************************}
{* ***** BEGIN LICENSE BLOCK ***** *}
{* Version: MPL 1.1 *}
{* *}
{* 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/ *}
{* *}
{* Software distributed under the License is distributed on an "AS IS" basis, *}
{* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License *}
{* for the specific language governing rights and limitations under the *}
{* License. *}
{* *}
{* The Original Code is TurboPower Orpheus *}
{* *}
{* The Initial Developer of the Original Code is TurboPower Software *}
{* *}
{* Portions created by TurboPower Software Inc. are Copyright (C) 1995-2002 *}
{* TurboPower Software Inc. All Rights Reserved. *}
{* *}
{* Contributor(s): *}
{* *}
{* ***** END LICENSE BLOCK ***** *}
(*Changes)
10/20/01- Hdc changed to TOvcHdc for BCB Compatibility
10/20/01- HWnd changed to TOvcHWnd for BCB Compatibility
*)
{$I OVC.INC}
{$B-} {Complete Boolean Evaluation}
{$I+} {Input/Output-Checking}
{$P+} {Open Parameters}
{$T-} {Typed @ Operator}
{.W-} {Windows Stack Frame}
{$X+} {Extended Syntax}
unit ovcmisc;
{-Miscellaneous functions and procedures}
interface
uses
{$IFNDEF LCL} Windows, Messages, {$ELSE} LclIntf, LMessages, LclType, MyMisc, {$ENDIF}
Buttons, Classes, Controls, ExtCtrls, Forms, Graphics,
SysUtils, {$IFNDEF LCL} Consts, {$ELSE} LclStrConsts, {$ENDIF} OvcData;
{ Hdc needs to be an Integer for BCB compatibility }
{$IFDEF CBuilder}
type
TOvcHdc = Integer;
TOvcHWND = Cardinal;
{$ELSE}
type
TOvcHdc = HDC;
TOvcHWND = HWND;
{$ENDIF}
{$IFNDEF LCL}
function LoadBaseBitmap(lpBitmapName : PAnsiChar) : HBITMAP;
{-load and return the handle to bitmap resource}
function LoadBaseCursor(lpCursorName : PAnsiChar) : HCURSOR;
{-load and return the handle to cursor resource}
{$ENDIF}
function CompStruct(const S1, S2; Size : Cardinal) : Integer;
{-compare two fixed size structures}
function DefaultEpoch : Integer;
{-return the current century}
function DrawButtonFrame(Canvas : TCanvas; const Client : TRect;
IsDown, IsFlat : Boolean; Style : TButtonStyle) : TRect;
{-produce a button similar to DrawFrameControl}
procedure FixRealPrim(P : PAnsiChar; DC : AnsiChar);
{-get a PChar string representing a real ready for Val()}
function GetDisplayString(Canvas : TCanvas; const S : string;
MinChars, MaxWidth : Integer) : string;
{-given a string, a minimum number of chars to display, and a max width,
find the string that can be displayed in that width - add ellipsis to
the end if necessary and possible}
function GetLeftButton: Byte;
{-return the mapped left button}
{ - HWnd changed to TOvcHWnd for BCB Compatibility }
function GetNextDlgItem(Ctrl : TOvcHWnd{hWnd}) : hWnd;
{-get handle of next control in the same form}
procedure GetRGB(Clr : TColor; var IR, IG, IB : Byte);
{-return component parts of the rgb value}
function GetShiftFlags : Byte;
{-get current shift flags, the high order bit is set if the key is down}
function CreateRotatedFont(F : TFont; Angle : Integer) : hFont;
{-create a rotated font based on the font object F}
function GetTopTextMargin(Font : TFont; BorderStyle : TBorderStyle;
Height : Integer; Ctl3D : Boolean) : Integer;
{-return the pixel top margin size}
function ExtractWord(N : Integer; const S : string; WordDelims : TCharSet) : string;
{-return the Nth word from S}
function IsForegroundTask : Boolean;
{-returns true if this task is currently in the foreground}
function TrimLeft(const S : string) : string;
{-return a string with leading white space removed}
function TrimRight(const S : string) : string;
{-return a string with trailing white space removed}
function QuotedStr(const S : string) : string;
{-return a quoted string string with internal quotes escaped}
function WordCount(const S : string; const WordDelims : TCharSet) : Integer;
{-return the word count given a set of word delimiters}
function WordPosition(const N : Integer; const S : string; const WordDelims : TCharSet) : Integer;
{-return start position of N'th word in S}
function PtrDiff(const P1, P2) : Word;
{-return the difference between P1 and P2}
procedure PtrInc(var P; Delta : Word);
{-increase P by Delta}
procedure PtrDec(var P; Delta : Word);
{-decrease P by Delta}
procedure FixTextBuffer(InBuf, OutBuf : PChar; OutSize : Integer);
{-replace orphan linefeeds with cr/lf pairs}
{ - Hdc changed to TOvcHdc for BCB Compatibility }
procedure TransStretchBlt(DstDC: TOvcHdc{HDC}; DstX, DstY, DstW, DstH: Integer;
SrcDC: TOvcHdc{HDC}; SrcX, SrcY, SrcW, SrcH: Integer;
MaskDC: TOvcHdc{HDC};
MaskX, MaskY : Integer);
function MaxL(A, B : LongInt) : LongInt;
function MinL(A, B : LongInt) : LongInt;
function MinI(X, Y : Integer) : Integer;
{-return the minimum of two integers}
function MaxI(X, Y : Integer) : Integer;
{-return the maximum of two integers}
{function GenerateComponentName(PF : TCustomForm; const Root : string) : string;}
function GenerateComponentName(PF : TWinControl; const Root : string) : string;
{-return a component name unique for this form}
function PartialCompare(const S1, S2 : string) : Boolean;
{-compare minimum length of S1 and S2 strings}
function PathEllipsis(const S : string; MaxWidth : Integer) : string;
function CreateDisabledBitmap(FOriginal : TBitmap; OutlineColor : TColor) : TBitmap;
procedure CopyParentImage(Control : TControl; Dest : TCanvas);
procedure DrawTransparentBitmap(Dest : TCanvas; X, Y, W, H : Integer;
Rect : TRect; Bitmap : TBitmap; TransparentColor : TColor);
function WidthOf(const R : TRect) : Integer;
{returnd R.Right - R.Left}
function HeightOf(const R : TRect) : Integer;
{returnd R.Bottom - R.Top}
procedure DebugOutput(const S : string);
{use OutputDebugString()}
implementation
uses
OvcBase, OvcStr;
{$IFNDEF LCL}
function LoadBaseBitmap(lpBitmapName : PAnsiChar) : HBITMAP;
begin
Result := LoadBitmap(FindClassHInstance(TOvcCustomControlEx), lpBitmapName);
end;
function LoadBaseCursor(lpCursorName : PAnsiChar) : HCURSOR;
begin
Result := LoadCursor(FindClassHInstance(TOvcCustomControlEx), lpCursorName);
end;
{$ENDIF}
{$IFDEF NoAsm}
function CompStruct(const S1, S2; Size : Cardinal) : Integer;
// Since CompStruct currently only used elsewhere to determine if
// two structures are different, just use CompareMem and don't
// worry about whether "greater than" or "less than".
begin
if CompareMem(@S1, @S2, Size) then {Structures identical?}
Result := 0
else {Structures not identical, so just return as though S1 > S2}
Result := 1;
end;
{$ELSE}
function CompStruct(const S1, S2; Size : Cardinal) : Integer; register;
{-compare two fixed size structures}
asm
push esi
push edi
mov esi, eax {pointer to S1}
mov edi, edx {pointer to S2}
xor eax, eax {eax holds temporary result (Equal)}
or ecx, ecx {size is already in ecx}
jz @@CSDone {make sure size isn't zero}
cld {go forward}
repe cmpsb {compare until no match or ecx = 0}
je @@CSDone {if equal, result is already in eax}
inc eax {prepare for greater}
ja @@CSDone {S1 greater? return +1}
mov eax, -1 {else S1 less, return -1}
@@CSDone:
pop edi
pop esi
end;
{$ENDIF}
procedure FixRealPrim(P : PAnsiChar; DC : AnsiChar);
{-Get a string representing a real ready for Val()}
var
DotPos : Cardinal;
EPos : Cardinal;
Len : Word;
Found : Boolean;
EFound : Boolean;
begin
TrimAllSpacesPChar(P);
Len := StrLen(P);
if Len > 0 then begin
if P[Len-1] = DC then begin
Dec(Len);
P[Len] := #0;
TrimAllSpacesPChar(P);
end;
{Val doesn't accept alternate decimal point chars}
Found := StrChPos(P, DC, DotPos);
{replace with '.'}
if Found and (DotPos > 0) then
P[DotPos] := '.'
else
Found := StrChPos(P, pmDecimalPt, DotPos);
if Found then begin
{check for 'nnnn.'}
if LongInt(DotPos) = Len-1 then begin
P[Len] := '0';
Inc(Len);
P[Len] := #0;
end;
{check for '.nnnn'}
if DotPos = 0 then begin
StrChInsertPrim(P, '0', 0);
Inc(Len);
Inc(DotPos);
end;
{check for '-.nnnn'}
if (Len > 1) and (P^ = '-') and (DotPos = 1) then begin
StrChInsertPrim(P, '0', 1);
Inc(DotPos);
end;
end;
{fix up numbers with exponents}
EFound := StrChPos(P, 'E', EPos);
if EFound and (EPos > 0) then begin
if not Found then begin
StrChInsertPrim(P, '.', EPos);
DotPos := EPos;
Inc(EPos);
end;
if EPos-DotPos < 12 then
StrStInsertPrim(P, '00000', EPos);
end;
{remove blanks before and after '.' }
if Found then begin
while (DotPos > 0) and (P[DotPos-1] = ' ') do begin
StrStDeletePrim(P, DotPos-1, 1);
Dec(DotPos);
end;
while P[DotPos+1] = ' ' do
StrStDeletePrim(P, DotPos+1, 1);
end;
end else begin
{empty string = '0'}
P[0] := '0';
P[1] := #0;
end;
end;
function GetLeftButton: Byte;
const
RLButton : array[Boolean] of Word = (VK_LBUTTON, VK_RBUTTON);
begin
Result := RLButton[GetSystemMetrics(SM_SWAPBUTTON) <> 0];
end;
{ - HWnd changed to TOvcHWnd for BCB Compatibility }
function GetNextDlgItem(Ctrl : TOvcHWnd{hWnd}) : hWnd;
{-Get handle of next control in the same form}
begin
{asking for previous returns next}
Result := GetNextWindow(Ctrl, GW_HWNDPREV);
if Result = 0 then begin
{asking for last returns first}
Result := GetWindow(Ctrl, GW_HWNDLAST);
if Result = 0 then
Result := Ctrl;
end;
end;
procedure GetRGB(Clr : TColor; var IR, IG, IB : Byte);
begin
if (Clr < 0) then begin
Clr := Clr + MaxLongInt + 1;
Clr := GetSysColor(Clr);
end;
IR := GetRValue(Clr);
IG := GetGValue(Clr);
IB := GetBValue(Clr);
end;
function GetShiftFlags : Byte;
{-get current shift flags, the high order bit is set if the key is down}
begin
Result := (Ord(GetKeyState(VK_CONTROL) < 0) * ss_Ctrl) +
(Ord(GetKeyState(VK_SHIFT ) < 0) * ss_Shift) +
(Ord(GetKeyState(VK_ALT ) < 0) * ss_Alt);
end;
function CreateRotatedFont(F : TFont; Angle : Integer) : hFont;
{-create a rotated font based on the font object F}
var
LF : TLogFont;
begin
FillChar(LF, SizeOf(LF), #0);
with LF do begin
lfHeight := F.Height;
lfWidth := 0;
lfEscapement := Angle*10;
lfOrientation := 0;
if fsBold in F.Style then
lfWeight := FW_BOLD
else
lfWeight := FW_NORMAL;
lfItalic := Byte(fsItalic in F.Style);
lfUnderline := Byte(fsUnderline in F.Style);
lfStrikeOut := Byte(fsStrikeOut in F.Style);
lfCharSet := DEFAULT_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;
function GetTopTextMargin(Font : TFont; BorderStyle : TBorderStyle;
Height : Integer; Ctl3D : Boolean) : Integer;
{-return the pixel top margin size}
var
I : Integer;
DC : hDC;
Metrics : TTextMetric;
SaveFont : hFont;
SysMetrics : TTextMetric;
begin
DC := GetDC(0);
try
GetTextMetrics(DC, SysMetrics);
SaveFont := SelectObject(DC, Font.Handle);
GetTextMetrics(DC, Metrics);
SelectObject(DC, SaveFont);
finally
ReleaseDC(0, DC);
end;
I := SysMetrics.tmHeight;
if I > Metrics.tmHeight then
I := Metrics.tmHeight;
if NewStyleControls then begin
if BorderStyle = bsNone then begin
Result := 0;
if I >= Height-2 then
Result := (Height-I-2) div 2 - Ord(Odd(Height-I));
end else if Ctl3D then begin
Result := 1;
if I >= Height-4 then
Result := (Height-I-4) div 2 - 1;
end else begin
Result := 1;
if I >= Height-4 then
Result := (Height-I-4) div 2 - Ord(Odd(Height-I));
end;
end else begin
Result := (Height-Metrics.tmHeight-1) div 2;
if I > Height-2 then begin
Dec(Result, 2);
if BorderStyle = bsNone then
Inc(Result, 1);
end;
end;
end;
function PtrDiff(const P1, P2) : Word;
{-return the difference between P1 and P2}
begin
{P1 and P2 are assumed to point within the same buffer}
Result := PAnsiChar(P1) - PAnsiChar(P2);
end;
procedure PtrInc(var P; Delta : Word);
{-increase P by Delta}
begin
Inc(PAnsiChar(P), Delta);
end;
procedure PtrDec(var P; Delta : Word);
{-increase P by Delta}
begin
Dec(PAnsiChar(P), Delta);
end;
{$IFDEF NoAsm}
function MinI(X, Y : Integer) : Integer;
begin
if X < Y then
Result := X
else
Result := Y;
end;
function MaxI(X, Y : Integer) : Integer;
begin
if X >= Y then
Result := X
else
Result := Y;
end;
{$ELSE}
function MinI(X, Y : Integer) : Integer;
asm
cmp eax, edx
jle @@Exit
mov eax, edx
@@Exit:
end;
function MaxI(X, Y : Integer) : Integer;
asm
cmp eax, edx
jge @@Exit
mov eax, edx
@@Exit:
end;
{$ENDIF}
function MaxL(A, B : LongInt) : LongInt;
begin
if (A < B) then
Result := B
else
Result := A;
end;
function MinL(A, B : LongInt) : LongInt;
begin
if (A < B) then
Result := A
else
Result := B;
end;
function TrimLeft(const S : string) : string;
var
I, L : Integer;
begin
L := Length(S);
I := 1;
while (I <= L) and (S[I] <= ' ') do
Inc(I);
Result := Copy(S, I, Length(S)-I+1);
end;
function TrimRight(const S : string) : string;
var
I : Integer;
begin
I := Length(S);
while (I > 0) and (S[I] <= ' ') do
Dec(I);
Result := Copy(S, 1, I);
end;
function QuotedStr(const S: string): string;
var
I : Integer;
begin
Result := S;
for I := Length(Result) downto 1 do
if Result[I] = '''' then Insert('''', Result, I);
Result := '''' + Result + '''';
end;
function WordCount(const S : string; const WordDelims : TCharSet) : Integer;
var
SLen, I : Integer;
begin
Result := 0;
I := 1;
SLen := Length(S);
while I <= SLen do begin
while (I <= SLen) and (S[I] in WordDelims) do
Inc(I);
if I <= SLen then
Inc(Result);
while (I <= SLen) and not(S[I] in WordDelims) do
Inc(I);
end;
end;
function ExtractWord(N : Integer; const S : string; WordDelims : TCharSet) : string;
var
I : Word;
Len : Integer;
begin
Len := 0;
I := WordPosition(N, S, WordDelims);
if I <> 0 then
{ find the end of the current word }
while (I <= Length(S)) and not(S[I] in WordDelims) do begin
{ add the I'th character to result }
Inc(Len);
SetLength(Result, Len);
Result[Len] := S[I];
Inc(I);
end;
SetLength(Result, Len);
end;
function WordPosition(const N : Integer; const S : string; const WordDelims : TCharSet) : Integer;
var
Count, I : Integer;
begin
Count := 0;
I := 1;
Result := 0;
while (I <= Length(S)) and (Count <> N) do begin
{skip over delimiters}
while (I <= Length(S)) and (S[I] in WordDelims) do
Inc(I);
{if we're not beyond end of S, we're at the start of a word}
if I <= Length(S) then
Inc(Count);
{if not finished, find the end of the current word}
if Count <> N then
while (I <= Length(S)) and not (S[I] in WordDelims) do
Inc(I)
else
Result := I;
end;
end;
function DrawButtonFrame(Canvas : TCanvas; const Client : TRect;
IsDown, IsFlat : Boolean; Style : TButtonStyle) : TRect;
var
NewStyle : Boolean;
begin
Result := Client;
NewStyle := (Style = bsNew) or (NewStyleControls and (Style = bsAutoDetect));
if IsDown then begin
if NewStyle then begin
Frame3D(Canvas, Result, clWindowFrame, clBtnHighlight, 1);
if not IsFlat then
Frame3D(Canvas, Result, clBtnShadow, clBtnFace, 1);
end else begin
if IsFlat then
Frame3D(Canvas, Result, clWindowFrame, clBtnHighlight, 1)
else begin
Frame3D(Canvas, Result, clWindowFrame, clWindowFrame, 1);
Canvas.Pen.Color := clBtnShadow;
Canvas.PolyLine([Point(Result.Left, Result.Bottom - 1),
Point(Result.Left, Result.Top), Point(Result.Right, Result.Top)]);
end;
end;
end else begin
if NewStyle then begin
if IsFlat then
Frame3D(Canvas, Result, clBtnHighlight, clBtnShadow, 1)
else begin
Frame3D(Canvas, Result, clBtnHighlight, clWindowFrame, 1);
Frame3D(Canvas, Result, clBtnFace, clBtnShadow, 1);
end;
end else begin
if IsFlat then
Frame3D(Canvas, Result, clBtnHighlight, clWindowFrame, 1)
else begin
Frame3D(Canvas, Result, clWindowFrame, clWindowFrame, 1);
Frame3D(Canvas, Result, clBtnHighlight, clBtnShadow, 1);
end;
end;
end;
InflateRect(Result, -1, -1);
end;
function GetDisplayString(Canvas : TCanvas; const S : string;
MinChars, MaxWidth : Integer) : string;
var
iDots, EllipsisWidth, Extent, Len, Width : Integer;
ShowEllipsis : Boolean;
begin
{be sure that the Canvas Font is set before entering this routine}
EllipsisWidth := Canvas.TextWidth('...');
Len := Length(S);
Result := S;
Extent := Canvas.TextWidth(Result);
ShowEllipsis := False;
Width := MaxWidth;
while (Extent > Width) do begin
ShowEllipsis := True;
Width := MaxWidth - EllipsisWidth;
if Len > MinChars then begin
Delete(Result, Len, 1);
dec(Len);
end else
break;
Extent := Canvas.TextWidth(Result);
end;
if ShowEllipsis then begin
Result := Result + '...';
inc(Len, 3);
Extent := Canvas.TextWidth(Result);
iDots := 3;
while (iDots > 0) and (Extent > MaxWidth) do begin
Delete(Result, Len, 1);
Dec(Len);
Extent := Canvas.TextWidth(Result);
Dec(iDots);
end;
end;
end;
type
PCheckTaskInfo = ^TCheckTaskInfo;
TCheckTaskInfo = packed record
FocusWnd: HWnd;
Found: Boolean;
end;
{ - HWnd changed to TOvcHWnd for BCB Compatibility }
function CheckTaskWindow(Window: TOvcHWnd{HWnd};
Data: Longint): WordBool; stdcall;
begin
Result := True;
if PCheckTaskInfo(Data)^.FocusWnd = Window then begin
Result := False;
PCheckTaskInfo(Data)^.Found := True;
end;
end;
function IsForegroundTask : Boolean;
var
Info : TCheckTaskInfo;
begin
Info.FocusWnd := GetActiveWindow;
Info.Found := False;
{$IFNDEF DARWIN}
EnumThreadWindows(GetCurrentThreadID, @CheckTaskWindow, Longint(@Info));
{$ELSE}
EnumThreadWindows(LongWord(GetCurrentThreadID), @CheckTaskWindow, Longint(@Info));
{$ENDIF}
Result := Info.Found;
end;
procedure FixTextBuffer(InBuf, OutBuf : PChar; OutSize : Integer);
var
I, P : Integer;
begin
P := 0;
for I := 0 to StrLen(InBuf) do begin
if (InBuf[I] = #10) and ((I = 0) or (InBuf[I-1] <> #13)) then begin
OutBuf[P] := #13;
Inc(P);
end;
OutBuf[P] := InBuf[I];
{is outbuf full?}
if P = OutSize-1 then begin
{if so, terminate and exit}
OutBuf[OutSize] := #0;
Break;
end;
Inc(P);
end;
end;
{ - Hdc changed to TOvcHdc for BCB Compatibility }
procedure TransStretchBlt(DstDC: TOvcHdc{HDC}; DstX, DstY, DstW, DstH: Integer;
SrcDC: TOvcHdc{HDC}; SrcX, SrcY, SrcW, SrcH: Integer;
MaskDC: TOvcHdc{HDC};
MaskX, MaskY : Integer);
var
MemDC : HDC;
MemBmp : HBITMAP;
Save : THandle;
crText, crBack : TColorRef;
SystemPalette16, SavePal : HPALETTE;
begin
SavePal := 0;
MemDC := CreateCompatibleDC(0);
try
MemBmp := CreateCompatibleBitmap(SrcDC, SrcW, SrcH);
Save := SelectObject(MemDC, MemBmp);
SystemPalette16 := GetStockObject(DEFAULT_PALETTE);
SavePal := SelectPalette(SrcDC, SystemPalette16, False);
SelectPalette(SrcDC, SavePal, False);
if SavePal <> 0 then
SavePal := SelectPalette(MemDC, SavePal, True)
else
SavePal := SelectPalette(MemDC, SystemPalette16, True);
RealizePalette(MemDC);
StretchBlt(MemDC, 0, 0, SrcW, SrcH, MaskDC, MaskX, MaskY,
SrcW, SrcH, SrcCopy);
StretchBlt(MemDC, 0, 0, SrcW, SrcH, SrcDC, SrcX, SrcY, SrcW, SrcH,
SrcErase);
crText := SetTextColor(DstDC, $0);
crBack := SetBkColor(DstDC, $FFFFFF);
StretchBlt(DstDC, DstX, DstY, DstW, DstH, MaskDC, MaskX, MaskY,
SrcW, SrcH, SrcAnd);
StretchBlt(DstDC, DstX, DstY, DstW, DstH, MemDC, 0, 0,
SrcW, SrcH, SrcInvert);
SetTextColor(DstDC, crText);
SetBkColor(DstDC, crBack);
if Save <> 0 then
SelectObject(MemDC, Save);
DeleteObject(MemBmp);
finally
if SavePal <> 0 then
SelectPalette(MemDC, SavePal, False);
DeleteDC(MemDC);
end;
end;
function DefaultEpoch : Integer;
var
ThisYear : Word;
ThisMonth : Word;
ThisDay : Word;
begin
DecodeDate(SysUtils.Date, ThisYear, ThisMonth, ThisDay);
Result := (ThisYear div 100) * 100;
end;
{function GenerateComponentName(PF : TCustomForm; const Root : string) : string;}
function GenerateComponentName(PF : TWinControl; const Root : string) : string;
var
I : Integer;
begin
if not IsValidIdent(Root) then
raise EComponentError.CreateFmt('''''%s'''' is not a valid component name',
[Root]);
I := 0;
repeat
Inc(I);
Result := Root + IntToStr(I);
until (PF.FindComponent(Result) = nil);
end;
function PartialCompare(const S1, S2 : string) : Boolean;
var
L : Integer;
begin
{and empty string matches nothing}
Result := False;
L := MinI(Length(S1), Length(S2));
if L > 0 then
Result := AnsiUpperCase(Copy(S1, 1, L)) = AnsiUpperCase(Copy(S2, 1, L));
end;
function PathEllipsis(const S : string; MaxWidth : Integer) : string;
{ PathEllipsis function. Trims a path down to the }
{ specified number of pixels. For example, }
{ 'd:\program files\my stuff\some long document.txt' }
{ becomes 'd:\...\some long...' or a variation thereof }
{ depending on the value of MaxWidth. }
var
R : TRect;
BM : TBitmap;
NCM : TNonClientMetrics;
begin
if MaxWidth = 0 then begin
Result := S;
Exit;
end;
NCM.cbSize := SizeOf(NCM);
SystemParametersInfo(
SPI_GETNONCLIENTMETRICS, NCM.cbSize, @NCM, 0);
BM := TBitmap.Create;
try
BM.Canvas.Font.Handle := CreateFontIndirect(NCM.lfMenuFont);
if BM.Canvas.TextWidth(S) < MaxWidth then begin
Result := S;
Exit;
end;
Result := ExtractFilePath(S);
Delete(Result, Length(Result), 1);
while BM.Canvas.TextWidth(Result + '\...\' + ExtractFileName(S)) > MaxWidth do begin
{ Start trimming the path, working backwards }
Result := ExtractFilePath(Result);
Delete(Result, Length(Result), 1);
{ Only drive letter left so break out of loop. }
if Length(Result) = 2 then
Break;
end;
{ Add the filename back onto the modified path. }
Result := Result + '\...\' + ExtractFileName(S);
{ Still too long? }
if BM.Canvas.TextWidth(Result) > MaxWidth then begin
R := Rect(0, 0, MaxWidth, 0);
DrawText(BM.Canvas.Handle, PChar(Result), -1,
R, DT_SINGLELINE or DT_END_ELLIPSIS or DT_MODIFYSTRING or DT_CALCRECT);
end;
finally
BM.Free;
end;
end;
function CreateDisabledBitmap(FOriginal : TBitmap; OutlineColor : TColor) : TBitmap;
{-create TBitmap object with disabled glyph}
const
ROP_DSPDxax = $00E20746;
var
MonoBmp : TBitmap;
IRect : TRect;
begin
IRect := Rect(0, 0, FOriginal.Width, FOriginal.Height);
Result := TBitmap.Create;
try
Result.Width := FOriginal.Width;
Result.Height := FOriginal.Height;
MonoBmp := TBitmap.Create;
try
with MonoBmp do begin
Assign(FOriginal);
HandleType := bmDDB;
Canvas.Brush.Color := OutlineColor;
if Monochrome then begin
Canvas.Font.Color := clWhite;
Monochrome := False;
Canvas.Brush.Color := clWhite;
end;
Monochrome := True;
end;
with Result.Canvas do begin
Brush.Color := clBtnFace;
FillRect(IRect);
Brush.Color := clBtnHighlight;
SetTextColor(Handle, clBlack);
SetBkColor(Handle, clWhite);
BitBlt(Handle, 1, 1, WidthOf(IRect), HeightOf(IRect),
MonoBmp.Canvas.Handle, 0, 0, ROP_DSPDxax);
Brush.Color := clBtnShadow;
SetTextColor(Handle, clBlack);
SetBkColor(Handle, clWhite);
BitBlt(Handle, 0, 0, WidthOf(IRect), HeightOf(IRect),
MonoBmp.Canvas.Handle, 0, 0, ROP_DSPDxax);
end;
finally
MonoBmp.Free;
end;
except
Result.Free;
raise;
end;
end;
type
TParentControl = class(TWinControl);
procedure CopyParentImage(Control : TControl; Dest : TCanvas);
var
I : Integer;
Count : Integer;
X, Y : Integer;
OldDC : Integer;
DC : hDC;
R : TRect;
SelfR : TRect;
CtlR : TRect;
begin
if Control.Parent = nil then
Exit;
Count := Control.Parent.ControlCount;
DC := Dest.Handle;
SelfR := Bounds(Control.Left, Control.Top, Control.Width, Control.Height);
X := -Control.Left; Y := -Control.Top;
{copy parent control image}
OldDC := SaveDC(DC);
SetViewportOrgEx(DC, X, Y, nil);
IntersectClipRect(DC, 0, 0, Control.Parent.ClientWidth, Control.Parent.ClientHeight);
TParentControl(Control.Parent).PaintWindow(DC);
RestoreDC(DC, OldDC);
{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 Bool(IntersectRect(R, SelfR, CtlR)) and Visible then begin
OldDC := SaveDC(DC);
SetViewportOrgEx(DC, Left + X, Top + Y, nil);
IntersectClipRect(DC, 0, 0, Width, Height);
Perform(WM_PAINT, DC, 0);
RestoreDC(DC, OldDC);
end;
end;
end;
end;
end;
{ - Hdc changed to TOvcHdc for BCB Compatibility }
procedure DrawTransparentBitmapPrim(DC : TOvcHdc{HDC}; Bitmap : HBitmap;
xStart, yStart, Width, Height : Integer; Rect : TRect;
TransparentColor : TColorRef);
{-draw transparent bitmap}
var
{$IFNDEF LCL}
BM : Windows.TBitmap;
{$ELSE}
BM : LclType.tagBITMAP;
{$ENDIF}
cColor : TColorRef;
bmAndBack : hBitmap;
bmAndObject : hBitmap;
bmAndMem : hBitmap;
bmSave : hBitmap;
bmBackOld : hBitmap;
bmObjectOld : hBitmap;
bmMemOld : hBitmap;
bmSaveOld : hBitmap;
hdcMem : hDC;
hdcBack : hDC;
hdcObject : hDC;
hdcTemp : hDC;
hdcSave : hDC;
ptSize : TPoint;
ptRealSize : TPoint;
ptBitSize : TPoint;
ptOrigin : TPoint;
begin
hdcTemp := CreateCompatibleDC(DC);
SelectObject(hdcTemp, Bitmap);
GetObject(Bitmap, SizeOf(BM), @BM);
ptRealSize.x := MinL(Rect.Right - Rect.Left, BM.bmWidth - Rect.Left);
ptRealSize.y := MinL(Rect.Bottom - Rect.Top, BM.bmHeight - Rect.Top);
DPtoLP(hdcTemp, ptRealSize, 1);
ptOrigin.x := Rect.Left;
ptOrigin.y := Rect.Top;
{convert from device to logical points}
DPtoLP(hdcTemp, ptOrigin, 1);
{get width of bitmap}
ptBitSize.x := BM.bmWidth;
{get height of bitmap}
ptBitSize.y := BM.bmHeight;
DPtoLP(hdcTemp, ptBitSize, 1);
if (ptRealSize.x = 0) or (ptRealSize.y = 0) then begin
ptSize := ptBitSize;
ptRealSize := ptSize;
end else
ptSize := ptRealSize;
if (Width = 0) or (Height = 0) then begin
Width := ptSize.x;
Height := ptSize.y;
end;
{create DCs to hold temporary data}
hdcBack := CreateCompatibleDC(DC);
hdcObject := CreateCompatibleDC(DC);
hdcMem := CreateCompatibleDC(DC);
hdcSave := CreateCompatibleDC(DC);
{create a bitmap for each DC}
{monochrome DC}
bmAndBack := CreateBitmap(ptSize.x, ptSize.y, 1, 1, nil);
bmAndObject := CreateBitmap(ptSize.x, ptSize.y, 1, 1, nil);
bmAndMem := CreateCompatibleBitmap(DC, MaxL(ptSize.x, Width), MaxL(ptSize.y, Height));
bmSave := CreateCompatibleBitmap(DC, ptBitSize.x, ptBitSize.y);
{select a bitmap object to store pixel data}
bmBackOld := SelectObject(hdcBack, bmAndBack);
bmObjectOld := SelectObject(hdcObject, bmAndObject);
bmMemOld := SelectObject(hdcMem, bmAndMem);
bmSaveOld := SelectObject(hdcSave, bmSave);
SetMapMode(hdcTemp, GetMapMode(DC));
{save the bitmap sent here, it will be overwritten}
BitBlt(hdcSave, 0, 0, ptBitSize.x, ptBitSize.y, hdcTemp, 0, 0, SRCCOPY);
{set the background color of the source DC to the color,}
{contained in the parts of the bitmap that should be transparent}
cColor := SetBkColor(hdcTemp, TransparentColor);
{create the object mask for the bitmap by performing a BitBlt()}
{from the source bitmap to a monochrome bitmap}
BitBlt(hdcObject, 0, 0, ptSize.x, ptSize.y, hdcTemp, ptOrigin.x, ptOrigin.y, SRCCOPY);
{set the background color of the source DC back to the original color}
SetBkColor(hdcTemp, cColor);
{create the inverse of the object mask}
BitBlt(hdcBack, 0, 0, ptSize.x, ptSize.y, hdcObject, 0, 0, NOTSRCCOPY);
{copy the background of the main DC to the destination}
BitBlt(hdcMem, 0, 0, Width, Height, DC, xStart, yStart, SRCCOPY);
{mask out the places where the bitmap will be placed}
StretchBlt(hdcMem, 0, 0, Width, Height, hdcObject, 0, 0, ptSize.x, ptSize.y, SRCAND);
{mask out the transparent colored pixels on the bitmap}
BitBlt(hdcTemp, ptOrigin.x, ptOrigin.y, ptSize.x, ptSize.y, hdcBack, 0, 0, SRCAND);
{XOR the bitmap with the background on the destination DC}
StretchBlt(hdcMem, 0, 0, Width, Height, hdcTemp, ptOrigin.x, ptOrigin.y, ptSize.x, ptSize.y, SRCPAINT);
{copy the destination to the screen}
BitBlt(DC, xStart, yStart, MaxL(ptRealSize.x, Width), MaxL(ptRealSize.y, Height), hdcMem, 0, 0, SRCCOPY);
{place the original bitmap back into the bitmap sent}
BitBlt(hdcTemp, 0, 0, ptBitSize.x, ptBitSize.y, hdcSave, 0, 0, SRCCOPY);
{delete the memory bitmaps}
DeleteObject(SelectObject(hdcBack, bmBackOld));
DeleteObject(SelectObject(hdcObject, bmObjectOld));
DeleteObject(SelectObject(hdcMem, bmMemOld));
DeleteObject(SelectObject(hdcSave, bmSaveOld));
{delete the memory DCs}
DeleteDC(hdcMem);
DeleteDC(hdcBack);
DeleteDC(hdcObject);
DeleteDC(hdcSave);
DeleteDC(hdcTemp);
end;
procedure DrawTransparentBitmap(Dest : TCanvas; X, Y, W, H : Integer;
Rect : TRect; Bitmap : TBitmap; TransparentColor : TColor);
var
MemImage : TBitmap;
R : TRect;
begin
MemImage := TBitmap.Create;
try
R := Bounds(0, 0, Bitmap.Width, Bitmap.Height);
if TransparentColor = clNone then begin
if (WidthOf(Rect) <> 0) and (HeightOf(Rect) <> 0) then
R := Rect;
MemImage.Width := WidthOf(R);
MemImage.Height := HeightOf(R);
MemImage.Canvas.CopyRect(Bounds(0, 0, MemImage.Width, MemImage.Height),
Bitmap.Canvas, R);
if (W = 0) or (H = 0) then
Dest.Draw(X, Y, MemImage)
else
Dest.StretchDraw(Bounds(X, Y, W, H), MemImage);
end else begin
MemImage.Width := WidthOf(R);
MemImage.Height := HeightOf(R);
MemImage.Canvas.CopyRect(R, Bitmap.Canvas, R);
if TransparentColor = clDefault then
TransparentColor := MemImage.Canvas.Pixels[0, MemImage.Height - 1];
DrawTransparentBitmapPrim(Dest.Handle, MemImage.Handle, X, Y, W, H,
Rect, ColorToRGB(TransparentColor and not $02000000));
end;
finally
MemImage.Free;
end;
end;
function WidthOf(const R : TRect) : Integer;
begin
Result := R.Right - R.Left;
end;
function HeightOf(const R : TRect) : Integer;
begin
Result := R.Bottom - R.Top;
end;
procedure DebugOutput(const S : string);
begin
OutputDebugString(PChar(S));
OutputDebugString(#13#10);
end;
end.
Reference in New Issue View Git Blame Copy Permalink