transcanvas.pas

这部分与维生素D3

unit TransCanvas;
{
	TTransCanvas By Paul van Dinther Copyright Diprode 24-01-2000
	e-mail: [e-mail]
	Website: http://www.diprode.com

	Having strugled for a while with several methods to display a semi transparent
	area, I thought it would be usefull to encapsulate the whole thing into a
	component. TransCanvas is similar to TPaintBox and would make a great control
	to inherit from to create other semi transparent controls. TTransCanvas
	controls can quite happily be stacked on top of each other with each level
	clearly visible.

	Just set the Transparency type to ttAlpha and set the transparency percentage
	(0 to 100) and presto. The Graphic controls (be aware that windowed controls
	such as buttons are always on top of Graphic controls) behind TTransCanvas
	show through!.

	Transparency types are:

	ttnone		Is like having a transparent canvas to start with.
	ttKey			Key color transparency. to be used with TransKeyColor
	ttAlpha		Full range of transparency from 0 percent to 100
	ttRed			Red Screening. More red means more transparent.
	ttGreen   Green Screening. More red means more transparent.
	ttBlue		Blue Screening. More red means more transparent.

	Note: The last 3 types are slower to render because additional calculations
	are performed for each pixel. Still pretty fast though.

	Use ScreenBiasPercent to improve the Bluescreening effect.The result is often
	a better blue screen effect because it reduces transperency even more in
	colors that are less that 100% blue. (Try it!)
}

interface

uses
	Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
	extctrls, math;
type
	TRGB = record
	R,G,B: Word;
end;

type
	TCalcEvent = procedure (Sender: TObject; ForeColor,BackColor:TRGB; var MergeColor: TRGB; X,Y: Integer) of object;
	TPaintEvent =  procedure (Sender: TObject; Canvas: TCanvas) of object;
	TCanvasType = (ctTransparent, ctLumFilter);
	TTransFade = (tfNone,tfLeft,tfRight,tfUp,tfDown,tfLeftDown,tfRightDown,tfLeftUp,tfRightUp,tfCenter,tfPeak, tfHorizon, tfVertical, tfButton, tfRoundButton);
	TTransType = (ttNone,ttKey,ttAlpha,ttRed,ttGreen,ttBlue);
	TCustomTransCanvas = class(TGraphicControl)
	private
		FCanvasType: TCanvasType;
		FTransBiasPercent: Integer;
		FTransBias: Double;
		FScreenBias: Double;
		FScreenBiasPercent: Integer;
		FTransFade: TTransFade;
		FOnCalc: TCalcEvent;
		FUseCalcEvent: Boolean;
		FonPaint: TPaintEvent;
		FTransMinCutoff: Integer;
		FTransMaxCutoff: Integer;
		FInverse: Boolean;
		FTransType: TTransType;
		FTransPercent: Integer;
		FTransKeyColor: TColor;
		FBackground :TBitmap;
		FTransBand: Integer;
		procedure CanvasToBitmap;
		procedure SetCanvasType(Value : TCanvasType);
		procedure SetScreenBiasPercent(Value: Integer);
		procedure SetTransBiasPercent(Value: Integer);
		function bias(PValue,PBias: Double):Double;
		procedure SetTransFade(Value: TTransFade);
		procedure SetTransBand(Value: Integer);
		procedure SetTransMinCutoff(Value: Integer);
		procedure SetTransMaxCutoff(Value: Integer);
		procedure SetInverse(Value: Boolean);
		procedure SetTransType(Value: TTransType);
		procedure SetTransPercent(Value: Integer);
		procedure SetTransKeyColor(Value: TColor);
		procedure PaintTransArea;
	protected
		procedure paint; override;
		procedure DoPaint(PCanvas: TCanvas); virtual;
		function CalculateTransFade(PX,PY: Integer; PTransPercent: Integer): Integer;
		property CanvasType: TCanvasType read FCanvasType write SetCanvasType;
		property TransBiasPercent: Integer read FTransBiasPercent write SetTransBiasPercent;
		property ScreenBiasPercent: Integer read FScreenBiasPercent write SetScreenBiasPercent;
		property TransFade: TTransFade read FTransFade write SetTransFade;
		property TransBand: Integer read FTransBand write SetTransBand;
		property UseCalcEvent: Boolean read FUseCalcEvent write FUseCalcEvent;
		property OnCalc: TCalcEvent read FOnCalc write FOnCalc;
		property TransType: TTransType read FTransType write SetTransType;
		property TransPercent: Integer read FTransPercent write SetTransPercent;
		property TransMinCutoff: Integer read FTransMinCutoff write SetTransMinCutoff;
		property TransMaxCutoff: Integer read FTransMaxCutoff write SetTransMaxCutoff;
		property TransKeyColor: TColor read FTransKeyColor write SetTransKeyColor;
		property Inverse: Boolean read FInverse write SetInverse;
		property OnPaint: TPaintEvent read FOnPaint write FOnPaint;
	public
		procedure Refresh;
		constructor Create(AOwner: TComponent); override;
		destructor Destroy; override;
	end;

	{TTransCanvas}
	TTransCanvas = class(TCustomTransCanvas)
	published
		//New Properties
		property CanvasType;
		property UseCalcEvent;
		property OnCalc;
		property TransFade;
		property TransType;
		property TransPercent;
		property TransMinCutoff;
		property TransMaxCutoff;
		property TransKeyColor;
		property ScreenBiasPercent;
		property TransBiasPercent;
		property Inverse;
		property OnPaint;
		//Standard Properties
		property Align;
		property Color;
		property DragCursor;
		property DragMode;
		property Enabled;
		property Font;
		property ParentColor;
		property ParentFont;
		property ParentShowHint;
		property PopupMenu;
		property ShowHint;
		property Visible;
		property OnClick;
		property OnDblClick;
		property OnDragDrop;
		property OnDragOver;
		property OnEndDrag;
		property OnMouseDown;
		property OnMouseMove;
		property OnMouseUp;
		property OnStartDrag;
	end;

procedure Register;

implementation

procedure Register;
begin
	RegisterComponents('Diprode', [TTransCanvas]);
end;

constructor TCustomTransCanvas.Create(AOwner: TComponent);
begin
	inherited Create(AOwner);
	//Setting of the default values
	FTransType := ttNone;
	FBackground := TBitmap.Create;
	FBackground.PixelFormat := pf24Bit;
	FTransPercent := 50;
	FCanvasType := ctTransparent;
	FTransMaxCutoff := 100;
	Width := 50;
	Height := 50;
end;

destructor TCustomTransCanvas.Destroy;
begin
	FBackGround.Free;
	inherited Destroy;
end;

procedure TCustomTransCanvas.CanvasToBitmap;
var
	LPoint: Tpoint;
	HDC: Integer;
	function Min(PValue1,PValue2:Integer): Integer;
	begin
		if PValue1 <= PValue2 then Result := PValue1
		else result := PValue2;
	end;
	function Max(PValue1,PValue2:Integer): Integer;
	begin
		if PValue1 > PValue2 then Result := PValue1
		else result := PValue2;
	end;
begin
	if FBackground.Width <> width then FBackground.Width := Width;
	if FBackground.Height <> Height then FBackground.Height := Height;
	{
		Translate the Top-Left of the control to screen coordinates
		Grab the screen device, take a snapshot and copy the picture accross to FBackground
	}
	LPoint := ClientToScreen(point(Left,Top));
	HDC := GetDC(0);
	BitBlt(FBackground.Canvas.Handle,0,0,min(TPanel(parent).Width - Left,Width),min(TPanel(Parent).Height - Top,Height),HDC,LPoint.X - Left,LPoint.Y - Top, SRCCOPY);
	ReleaseDc(0,HDC);
end;

{
	This procedure calculates the resulting bitmap pixel by pixel using the
	foreground and backgound bitmaps. The calculation method depends on the TransType
	property value selected. An onCalc event exposes the calculation to the
	user and let's the user apply it's own merge calculation.
}
procedure TCustomTransCanvas.PaintTransArea;
var
	LWidth,LHeight: Integer;
	FForeground: TBitmap;
	FCombined: TBitmap;
	LLumPercent: Integer;
	LFCol,LBCol,LMCol: TRGB;
	LTransPercent: Integer;
	x,y : Integer;
	LForeScan: PByteArray;
	LBackScan: PByteArray;
	LCombinedScan: PByteArray;
	function CalcPartLum(PValue1,PValue2,Part: Integer): Integer;
	var
		LLum: Integer;
	begin
		if PValue1 = 0 then begin
			LLum := Part - 50;
			if LLum = 0 then Result := PValue2;
			if LLum > 0 then Result := trunc(PValue2 + ((256 - PValue2) * 0.02 * LLum));
			if LLum < 0 then Result := trunc(PValue2 + (PValue2 * 0.02 * LLum));
		end else Result := PValue2;
	end;
	function CalcPartValue(PValue1,PValue2,Part: Integer): Integer;
	begin
		Result := ((PValue1 * (100 - Part)) + (PValue2 * Part)) div 100;
	end;
	function Min(PValue1,PValue2:Integer): Integer;
	begin
		if PValue1 <= PValue2 then Result := PValue1
		else result := PValue2;
	end;
	function Max(PValue1,PValue2:Integer): Integer;
	begin
		if PValue1 > PValue2 then Result := PValue1
		else result := PValue2;
	end;
begin
	//Crate and Adjust bitmaps
	FForeGround := TBitmap.Create;
	FForeGround.PixelFormat := pf24Bit;
	FCombined := TBitmap.Create;
	FCombined.PixelFormat := pf24Bit;
	FForeGround.Width := Width;
	FForeGround.Height := Height;
	FCombined.Width := Width;
	FCombined.Height := Height;
	DoPaint(FForeground.Canvas);
	LHeight := min(FBackground.Height,TPanel(parent).Height - Top);
	LWidth := Min(FBackground.Width, TPanel(parent).Width  - Left);
	if FCanvasType <> ctTransparent then begin
		{
		This procedure modifies the luminosity value of the background pixel in  those
		locations were the foreground pixel is painted. The amount of Luminosity change
		is defined by the FilterFadeType, MinLum and MaxLum properties. Luminosity is
		defined as a value from 0 to 255. Background luminosity is seen as a value of 0
		and the range from that luminosity value to MinLum and MaxLum is always + and - 100
		}
		for y := 0 to LHeight - 1 do	begin
			LForeScan := FForeground.ScanLine[y];
			LBackScan := FBackground.ScanLine[y];
			LCombinedScan := FCombined.ScanLine[y];
			X := 0;
			while X < LWidth * 3 do begin
				LLumPercent := CalculateTransFade(X div 3,Y,FTransPercent);
				if FInverse then LLumPercent := 100 - LLumPercent;
				LCombinedScan[x] := CalcPartLum(LForeScan[X]+LForeScan[X+1]+LForeScan[X+2],LBackScan[X],LLumPercent);
				LCombinedScan[x+1] := CalcPartLum(LForeScan[X]+LForeScan[X+1]+LForeScan[X+2],LBackScan[X+1],LLumPercent);
				LCombinedScan[x+2] := CalcPartLum(LForeScan[X]+LForeScan[X+1]+LForeScan[X+2],LBackScan[X+2],LLumPercent);
				inc(X,3);
			end;
		end
	end	else begin
		LTransPercent := FTranspercent;
		//these two nested For loops using Y and X provide a step through for each pixel
		for y := 0 to LHeight - 1 do
		begin
			LForeScan := FForeground.ScanLine[y];
			LBackScan := FBackground.ScanLine[y];
			LCombinedScan := FCombined.ScanLine[y];
			X := 0;
			//Width * 3 because the internal bitmaps are always 24 Bit (3 Bytes per pixel)
			while X < LWidth * 3 do begin
				if (assigned(FOnCalc)) and FUseCalcEvent then begin
					//Collect the foreground color for this pixel
					LFCol.R := LForeScan[X + 2];
					LFCol.G := LForeScan[X + 1];
					LFCol.B := LForeScan[X];
					//collect the background color for this pixel
					LBCol.R := LBackScan[X + 2];
					LBCol.G := LBackScan[X + 1];
					LBCol.B := LBackScan[X];
					//Call the event handler
					FOnCalc(self,LFCol,LBCol,LMCol,X,Y);
					//Assign the merged result to the scanline pixel of the destination
					LCombinedScan[X+2] := LMCol.R;
					LCombinedScan[X+1] := LMCol.G;
					LCombinedScan[X] := LMCol.B;
				end else begin
					Case FTransType of
						ttNone:
							LTransPercent := FTransPercent;
						ttKey:
							begin
							if FForeGround.Canvas.Pixels[x div 3,y] = FTransKeyColor then LTransPercent := 100
							else LTransPercent := FTransPercent;