Related
I am trying to produce a consistent interface in high DPI and standard DPI environments. We have a selection box that with paint using something like this:
theCanvas.Brush.style := bsBDiagonal;
theCanvas.pen.style := psClear;
theCanvas.brush.color := clBlue;
Is there any way to change the width of the lines and the gaps between the lines that are drawn by bsBDiagonal because these don't take into account the DPI of the monitor. A user with a high DPI system will see very fine diagonal lines that are very close together whereas a person with a regular DPI monitor will see painting that is further apart and wider.
For example. The one on the left is what a user on a regular DPI monitor will see and the one on the right is the high DPI equivalent.
Hatch brush always works in graphic device units. I met this problem with printers in old times and made this procedure:
//Fillstep depends linearly on DPI
procedure PrintHatchPolygon(Canvas: TCanvas; Pts: array of TPoint;
FillStep: Integer);
var
ClipRgn: HRGN;
r: TRect;
i, MaxSize, OldPenColor, HatchStyle: Integer;
procedure Line(X1, Y1, X2, Y2: Integer);
begin
Canvas.MoveTo(X1, Y1);
Canvas.LineTo(X2, Y2);
end;
begin
case Canvas.Brush.Style of
bsVertical:
HatchStyle := 1;
bsHorizontal:
HatchStyle := 2;
bsFDiagonal:
HatchStyle := 4;
bsBDiagonal:
HatchStyle := 8;
bsCross:
HatchStyle := 3;
bsDiagCross:
HatchStyle := 12;
else
HatchStyle := 0;
end;
OldPenColor := Canvas.Pen.Color;
Canvas.Pen.Color := Canvas.Brush.Color;
ClipRgn := CreatePolygonRgn(Pts, High(Pts) + 1, ALTERNATE);
GetRgnBox(ClipRgn, r);
MaxSize := r.Bottom - r.Top;
if MaxSize < (r.Right - r.Left) then
MaxSize := r.Right - r.Left;
SelectClipRgn(Canvas.Handle, ClipRgn);
with r do begin
if (HatchStyle and 1) > 0 then
for i := 1 to (r.Right - r.Left) div FillStep do
Line(Left + i * FillStep, Top, Left + i * FillStep, Bottom);
if (HatchStyle and 2) > 0 then
for i := 1 to (r.Bottom - r.Top) div FillStep do
Line(Left, Top + i * FillStep, Right, Top + i * FillStep);
//to equalize step
//FillStep := 1414 * FillStep div 1000;
if (HatchStyle and 4) > 0 then
for i := 1 to 2 * MaxSize div FillStep do
Line(Left, Bottom - i * FillStep, Left + i * FillStep, Bottom);
if (HatchStyle and 8) > 0 then
for i := 1 to 2 * MaxSize div FillStep do
Line(Left, Top + i * FillStep, Left + i * FillStep, Top);
end;
SelectClipRgn(Canvas.Handle, 0);
DeleteObject(ClipRgn);
Canvas.Pen.Color := OldPenColor;
end;
procedure TForm1.Button7Click(Sender: TObject);
var
P: array [0 .. 2] of TPoint;
begin
P[0] := Point(10, 10);
P[1] := Point(100, 10);
P[2] := Point(10, 200);
Canvas.Brush.Style := bsDiagCross;
Canvas.Brush.Color := clRed;
//value 8 for usual monitor dpi (72?)
//value 60 for 600dpi printer
PrintHatchPolygon(Canvas, P, 8);
Canvas.Brush.Style := bsClear;
Canvas.Polygon(P);
end;
Another alternative is to use a custom brush. I couldn't get the custom brush option working with transparency.
procedure SetupHatchBitmapBrush(ABitmap: TBitmap; const ABrushStyle:
TBrushStyle; const AFillStep: Integer; const APenColor: TColor);
var
bitmapSize: TSize;
rect: TRect;
cntr: Integer;
maxSize: Integer;
oldPenColor: Integer;
hatchStyle: Integer;
procedure Line(bBitmap: TBitmap; bX1, bY1, bX2, bY2: Integer);
begin
bBitmap.Canvas.MoveTo(bX1, bY1);
bBitmap.Canvas.LineTo(bX2, bY2);
end;
begin
case ABrushStyle of
bsVertical: hatchStyle := 1;
bsHorizontal: hatchStyle := 2;
bsFDiagonal: hatchStyle := 4;
bsBDiagonal: hatchStyle := 8;
bsCross: hatchStyle := 3;
bsDiagCross: hatchStyle := 12;
else
hatchStyle := 0;
end;
oldPenColor := ABitmap.Canvas.Pen.Color;
try
ABitmap.Canvas.Pen.Color := APenColor;
maxSize := ABitmap.Height;
if maxSize < ABitmap.Width then
maxSize := ABitmap.Width;
if (hatchStyle and 1) > 0 then
for cntr := 1 to ABitmap.Width div AFillStep do
Line(ABitmap, cntr * AFillStep, 0, cntr * AFillStep, ABitmap.Height);
if (hatchStyle and 2) > 0 then
for cntr := 1 to ABitmap.Height div AFillStep do
Line(ABitmap, 0, cntr * AFillStep, ABitmap.Width, cntr * AFillStep);
if (hatchStyle and 4) > 0 then
for cntr := 1 to 2 * maxSize div AFillStep do
Line(ABitmap, 0, ABitmap.Height - cntr * AFillStep, cntr * AFillStep, ABitmap.Height);
if (hatchStyle and 8) > 0 then
for cntr := 1 to 2 * maxSize div AFillStep do
Line(ABitmap, 0, cntr * AFillStep, cntr * AFillStep, 0);
finally
ABitmap.Canvas.Pen.Color := oldPenColor;
end;
end;
function CreatePatternBitmap(const ABrushStyle: TBrushStyle; const APenColor,
ABackgroundColor: TColor; const AScaleFactor: Double): TBitmap;
const
DEFAULT_SIZE = 8;
var
bitmapStep: Integer;
begin
bitmapStep := Trunc(DEFAULT_SIZE * AScaleFactor);
Result := TBitmap.Create;
Result.Canvas.Brush.Color := clWhite;
Result.Canvas.Brush.Style := bsSolid;
Result.PixelFormat := pf32bit;
Result.SetSize(bitmapStep * 2, bitmapStep * 2);
SetupHatchBitmapBrush(Result, ABrushStyle, bitmapStep, APenColor);
end;
At some point we need to create the bitmap.
begin
FBitmap := CreatePatternBitmap(bsBDiagonal, clRed, clWhite, 1.5);
end;
Painting would look like this:
begin
Canvas.Brush.Color := clBlue;
Canvas.Pen.Style := psClear;
Canvas.Brush.style := bsBDiagonal;
Canvas.Brush.Bitmap := FBitmap;
Canvas.Rectangle(Rect(10, 10, 100, 100));
end;
In Firemonkey we can use a TShadowEffect to draw a nice looking shadow.
This shadow also adjusts its opacity and translucency so it displays the correct component beneath it if a control is overlapping.
Without TShadowEffect:
With TShadowEffect:
Is there a way to draw the same shadow effect in VCL forms without embedding a FMX form?
My idea was to create a TGraphicControl and place it underneath the target control. The shadow control will stick to the target control. The steps of drawing the shadow are as follow:
We create an off screen Bitmap and draw a RoundRect
Then apply Gaussian Blur convolution kernel:
see http://www.concepto.ch/delphi/uddf/pages/graphics.htm#graphics9 (unit GBlur2). (EDIT: Link is dead)
Finally we make it 32 bit alpha semi transparent gray scale. depending on the amount of darkness:
And draw it via AlphaBlend on the TGraphicControl canvas.
GBlur2.pas (Author unknown)
unit GBlur2;
interface
uses
Windows, Graphics;
type
PRGBTriple = ^TRGBTriple;
TRGBTriple = packed record
b: byte; {easier to type than rgbtBlue}
g: byte;
r: byte;
end;
PRow = ^TRow;
TRow = array[0..1000000] of TRGBTriple;
PPRows = ^TPRows;
TPRows = array[0..1000000] of PRow;
const
MaxKernelSize = 100;
type
TKernelSize = 1..MaxKernelSize;
TKernel = record
Size: TKernelSize;
Weights: array[-MaxKernelSize..MaxKernelSize] of single;
end;
{the idea is that when using a TKernel you ignore the Weights except
for Weights in the range -Size..Size.}
procedure GBlur(theBitmap: TBitmap; radius: double);
implementation
uses
SysUtils;
procedure MakeGaussianKernel(var K: TKernel; radius: double; MaxData, DataGranularity: double);
{makes K into a gaussian kernel with standard deviation = radius. For the current application
you set MaxData = 255 and DataGranularity = 1. Now the procedure sets the value of K.Size so
that when we use K we will ignore the Weights that are so small they can't possibly matter. (Small
Size is good because the execution time is going to be propertional to K.Size.)}
var
j: integer;
temp, delta: double;
KernelSize: TKernelSize;
begin
for j := Low(K.Weights) to High(K.Weights) do
begin
temp := j / radius;
K.Weights[j] := exp(-temp * temp / 2);
end;
{now divide by constant so sum(Weights) = 1:}
temp := 0;
for j := Low(K.Weights) to High(K.Weights) do
temp := temp + K.Weights[j];
for j := Low(K.Weights) to High(K.Weights) do
K.Weights[j] := K.Weights[j] / temp;
{now discard (or rather mark as ignorable by setting Size) the entries that are too small to matter.
This is important, otherwise a blur with a small radius will take as long as with a large radius...}
KernelSize := MaxKernelSize;
delta := DataGranularity / (2 * MaxData);
temp := 0;
while (temp < delta) and (KernelSize > 1) do
begin
temp := temp + 2 * K.Weights[KernelSize];
dec(KernelSize);
end;
K.Size := KernelSize;
{now just to be correct go back and jiggle again so the sum of the entries we'll be using is exactly 1}
temp := 0;
for j := -K.Size to K.Size do
temp := temp + K.Weights[j];
for j := -K.Size to K.Size do
K.Weights[j] := K.Weights[j] / temp;
end;
function TrimInt(Lower, Upper, theInteger: integer): integer;
begin
if (theInteger <= Upper) and (theInteger >= Lower) then
result := theInteger
else if theInteger > Upper then
result := Upper
else
result := Lower;
end;
function TrimReal(Lower, Upper: integer; x: double): integer;
begin
if (x < upper) and (x >= lower) then
result := trunc(x)
else if x > Upper then
result := Upper
else
result := Lower;
end;
procedure BlurRow(var theRow: array of TRGBTriple; K: TKernel; P: PRow);
var
j, n: integer;
tr, tg, tb: double; {tempRed, etc}
w: double;
begin
for j := 0 to High(theRow) do
begin
tb := 0;
tg := 0;
tr := 0;
for n := -K.Size to K.Size do
begin
w := K.Weights[n];
{the TrimInt keeps us from running off the edge of the row...}
with theRow[TrimInt(0, High(theRow), j - n)] do
begin
tb := tb + w * b;
tg := tg + w * g;
tr := tr + w * r;
end;
end;
with P[j] do
begin
b := TrimReal(0, 255, tb);
g := TrimReal(0, 255, tg);
r := TrimReal(0, 255, tr);
end;
end;
Move(P[0], theRow[0], (High(theRow) + 1) * Sizeof(TRGBTriple));
end;
procedure GBlur(theBitmap: TBitmap; radius: double);
var
Row, Col: integer;
theRows: PPRows;
K: TKernel;
ACol: PRow;
P: PRow;
begin
if (theBitmap.HandleType <> bmDIB) or (theBitmap.PixelFormat <> pf24Bit) then
raise exception.Create('GBlur only works for 24-bit bitmaps');
MakeGaussianKernel(K, radius, 255, 1);
GetMem(theRows, theBitmap.Height * SizeOf(PRow));
GetMem(ACol, theBitmap.Height * SizeOf(TRGBTriple));
{record the location of the bitmap data:}
for Row := 0 to theBitmap.Height - 1 do
theRows[Row] := theBitmap.Scanline[Row];
{blur each row:}
P := AllocMem(theBitmap.Width * SizeOf(TRGBTriple));
for Row := 0 to theBitmap.Height - 1 do
BlurRow(Slice(theRows[Row]^, theBitmap.Width), K, P);
{now blur each column}
ReAllocMem(P, theBitmap.Height * SizeOf(TRGBTriple));
for Col := 0 to theBitmap.Width - 1 do
begin
{first read the column into a TRow:}
for Row := 0 to theBitmap.Height - 1 do
ACol[Row] := theRows[Row][Col];
BlurRow(Slice(ACol^, theBitmap.Height), K, P);
{now put that row, um, column back into the data:}
for Row := 0 to theBitmap.Height - 1 do
theRows[Row][Col] := ACol[Row];
end;
FreeMem(theRows);
FreeMem(ACol);
ReAllocMem(P, 0);
end;
end.
ShadowBox.pas
unit ShadowBox;
interface
uses Messages, Windows, SysUtils, Classes, Controls, Graphics, StdCtrls;
type
TShadowBox = class(TGraphicControl)
private
FControl: TControl;
FControlWndProc: TWndMethod;
procedure SetControl(AControl: TControl);
procedure ControlWndProc(var Message: TMessage);
procedure AdjustBounds;
protected
procedure Notification(AComponent: TComponent; Operation: TOperation); override;
procedure Paint; override;
public
destructor Destroy; override;
published
property Control: TControl read FControl write SetControl;
end;
implementation
uses GBlur2;
destructor TShadowBox.Destroy;
begin
SetControl(nil);
inherited;
end;
procedure TShadowBox.SetControl(AControl: TControl);
begin
if AControl = Self then Exit;
if FControl <> AControl then
begin
if FControl <> nil then
begin
FControl.WindowProc := FControlWndProc;
FControl.RemoveFreeNotification(Self);
end;
FControl := AControl;
if FControl <> nil then
begin
FControlWndProc := FControl.WindowProc;
FControl.WindowProc := ControlWndProc;
FControl.FreeNotification(Self);
end else
FControlWndProc := nil;
if FControl <> nil then
begin
Parent := FControl.Parent;
AdjustBounds;
end;
end;
end;
procedure TShadowBox.ControlWndProc(var Message: TMessage);
begin
if Assigned(FControlWndProc) then
FControlWndProc(Message);
case Message.Msg of
CM_VISIBLECHANGED:
Visible := FControl.Visible;
WM_WINDOWPOSCHANGED:
begin
if Parent <> FControl.Parent then
Parent := FControl.Parent;
AdjustBounds;
end;
end;
end;
procedure TShadowBox.Notification(AComponent: TComponent; Operation: TOperation);
begin
inherited;
if (Operation = opRemove) and (AComponent = FControl) then
begin
FControl := nil;
FControlWndProc := nil;
end;
end;
procedure TShadowBox.AdjustBounds;
begin
if FControl <> nil then
begin
SetBounds(FControl.Left - 8, FControl.Top - 8, FControl.Width + 16, FControl.Height + 16);
if FControl is TWinControl then
BringToFront
else
SendToBack;
end;
end;
procedure PrepareBitmap32Shadow(Bitmap: TBitmap; Darkness: Byte=100);
var
I, J: Integer;
Pixels: PRGBQuad;
Color: COLORREF;
begin
for I := 0 to Bitmap.Height - 1 do
begin
Pixels := PRGBQuad(Bitmap.ScanLine[I]);
for J := 0 to Bitmap.Width - 1 do
begin
with Pixels^ do
begin
Color := RGB(rgbRed, rgbGreen, rgbBlue);
case Color of
$FFFFFF: rgbReserved := 0; // white = transparent
$000000: rgbReserved := 255; // black = opaque
else
rgbReserved := 255 - ((rgbRed + rgbGreen + rgbBlue) div 3); // intensity of semi transparent
end;
rgbRed := Darkness; rgbGreen := Darkness; rgbBlue := Darkness; // darkness
// pre-multiply the pixel with its alpha channel
rgbRed := (rgbRed * rgbReserved) div $FF;
rgbGreen := (rgbGreen * rgbReserved) div $FF;
rgbBlue := (rgbBlue * rgbReserved) div $FF;
end;
Inc(Pixels);
end;
end;
end;
{$IFDEF VER130} // D5
const
AC_SRC_ALPHA = $01;
{$ENDIF}
procedure TShadowBox.Paint;
var
Bitmap: TBitmap;
BlendFunction: TBlendFunction;
begin
Bitmap := TBitmap.Create;
try
Bitmap.PixelFormat := pf24bit;
Bitmap.Width := Width;
Bitmap.Height := Height;
Bitmap.Canvas.Pen.Color := clBlack;
Bitmap.Canvas.Brush.Color := clBlack;
Bitmap.Canvas.RoundRect(5, 5, Width - 5, Height - 5, 10, 10);
GBlur(Bitmap, 3); // Radius
Bitmap.PixelFormat := pf32bit;
Bitmap.IgnorePalette := True;
Bitmap.HandleType := bmDIB;
PrepareBitmap32Shadow(Bitmap, 150); // Darkness
BlendFunction.BlendOp := AC_SRC_OVER;
BlendFunction.BlendFlags := 0;
BlendFunction.SourceConstantAlpha := 255;
BlendFunction.AlphaFormat := AC_SRC_ALPHA;
Windows.AlphaBlend(
Canvas.Handle, // HDC hdcDest
0, // int xoriginDest
0, // int yoriginDest
Bitmap.Width, // int wDest
Bitmap.Height, // int hDest
Bitmap.Canvas.Handle, // HDC hdcSrc
0, // int xoriginSrc
0, // int yoriginSrc
Bitmap.Width, // int wSrc
Bitmap.Height, // int hSrc
BlendFunction); // BLENDFUNCTION
finally
Bitmap.Free;
end;
end;
end.
Usage:
uses ShadowBox;
...
procedure TForm1.FormCreate(Sender: TObject);
begin
with TShadowBox.Create(Self) do
Control := Edit1;
with TShadowBox.Create(Self) do
Control := Shape1;
with TShadowBox.Create(Self) do
Control := Panel1;
end;
How can I replace color on TCanvas on Delphi XE2? The following code works incredibly slow:
for y := ARect.Top to ARect.Top + ARect.Height - 1 do
for x := ARect.Left to ARect.Left + ARect.Width - 1 do
if Canvas.Pixels[x, y] = FixedColor then
Canvas.Pixels[x, y] := Canvas.Pixels[ARect.Left, ARect.Top];
Here are two function (with and without tolerance) to replace the color:
Bonus:
Code to test the functions also provided. Load your image in a TImage control, then use the MouseUp event to change the color under mouse.
procedure ReplaceColor(BMP: TBitmap; OldColor, NewColor: TColor);
VAR
x, y: Integer;
R,G,B: Byte;
R_,G_,B_: Byte;
aPixel: PRGBTriple;
begin
R:= GetRValue(OldColor);
G:= GetGValue(OldColor);
B:= GetBValue(OldColor);
R_:= GetRValue(NewColor);
G_:= GetGValue(NewColor);
B_:= GetBValue(NewColor);
BMP.PixelFormat := pf24bit;
for y := 0 to BMP.Height - 1 do
for x := 0 to BMP.Width - 1 do
begin
aPixel := BMP.ScanLine[y];
Inc(aPixel, x);
if (aPixel^.rgbtRed = R)
AND (aPixel^.rgbtGreen = G)
AND (aPixel^.rgbtBlue = B) then
begin
aPixel^.rgbtRed := R_;
aPixel^.rgbtGreen := G_;
aPixel^.rgbtBlue := B_;
end;
end;
end;
procedure ReplaceColor(BMP: TBitmap; OldColor, NewColor: TColor; ToleranceR, ToleranceG, ToleranceB: Byte);
VAR
x, y: Integer;
R,G,B: Byte;
R_,G_,B_: Byte;
aPixel: PRGBTriple;
begin
R:= GetRValue(OldColor);
G:= GetGValue(OldColor);
B:= GetBValue(OldColor);
R_:= GetRValue(NewColor);
G_:= GetGValue(NewColor);
B_:= GetBValue(NewColor);
BMP.PixelFormat := pf24bit;
for y := 0 to BMP.Height - 1 do
for x := 0 to BMP.Width - 1 do
begin
aPixel := BMP.ScanLine[y];
Inc(aPixel, x);
if (abs(aPixel^.rgbtRed - R)< ToleranceR)
AND (abs(aPixel^.rgbtGreen- G)< ToleranceG)
AND (abs(aPixel^.rgbtBlue - B)< ToleranceB) then
begin
aPixel^.rgbtRed := R_;
aPixel^.rgbtGreen := G_;
aPixel^.rgbtBlue := B_;
end;
end;
end;
procedure TfrmTester.imgOnMouseUp(Sender: TObject; Shift: TShiftState; X, Y: Integer);
VAR
PixelClr: TColor;
BMP: TBitmap;
begin
// Collect the new color, under mouse pointer
PixelClr:= imgReplaceOrig.Picture.Bitmap.Canvas.Pixels[x, y];
if PixelClr< 0 then EXIT;
Label1.Caption := 'x'+IntToStr(X)+':y='
+ IntToStr(Y)
+' r'+ IntToStr(GetRValue(Pixel))
+', g'+ IntToStr(GetGValue(Pixel))
+', b'+ IntToStr(GetBValue(Pixel));
BMP:= TBitmap.Create;
BMP.Assign(imgReplaceOrig.Picture.Bitmap);
// Replace the color
cGraphUtil.ReplaceColor(BMP, PixelClr, clBlue, 44, 44, 44);
imgReplace.Picture.Assign(BMP);
FreeAndNil(BMP);
end;
var
aBitmap: TBitmap;
x, y: Integer;
aPixel: PRGBTriple;
...
aBitmap := TBitmap.Create;
try
aBitmap.PixelFormat := pf24bit;
aBitmap.Height := ARect.Height;
aBitmap.Width := ARect.Width;
aBitmap.Canvas.CopyRect(TRect.Create(0, 0, aBitmap.Width, aBitmap.Height), Canvas, ARect);
for y := 0 to aBitmap.Height - 1 do
for x := 0 to aBitmap.Width - 1 do
begin
aPixel := aBitmap.ScanLine[y];
Inc(aPixel, x);
if (aPixel^.rgbtRed = GetRValue(FixedColor)) and (aPixel^.rgbtGreen = GetGValue(FixedColor)) and (aPixel^.rgbtBlue = GetBValue(FixedColor)) then
aPixel^ := PRGBTriple(aBitmap.ScanLine[y])^;
end;
Canvas.Draw(ARect.Left, ARect.Top, aBitmap);
finally
aBitmap.Free;
end;
I have been experimenting a lot with some glassy images, such as the one below, and I got to thinking there's gotta be a way I can put this into code, so I can color it anything I want. It doesn't need to look 100% precisely like the image below, but I'd like to write some code to draw the oval and the glass effect (gradient with some really fancy calculations). I must note clearly that I am horrible with math, and I know this requires some tricky formulas.
Sample of what I'm working on:
The border of the oval is the easy part, the gradient that goes inside the oval from top to bottom is also fairly easy - but when it comes to making the edges fade to make that glassy look along the top and sides - I have no clue how to go about doing this.
Original left edge image:
Whether someone can point me to a good tutorial for this, or if someone wants to demonstrate it, either would be really appreciated.
Here's the procedure I use to draw so far:
//B = Bitmap to draw to
//Col = Color to draw glass image
procedure TForm1.DrawOval(const Col: TColor; var B: TBitmap);
var
C: TCanvas; //Main canvas for drawing easily
R: TRect; //Base rect
R2: TRect; //Working rect
X: Integer; //Main top/bottom gradient loop
CR, CG, CB: Byte; //Base RGB color values
TR, TG, TB: Byte; //Working RGB color values
begin
if assigned(B) then begin
if B <> nil then begin
C:= B.Canvas;
R:= C.ClipRect;
C.Pen.Style:= psClear;
C.Brush.Style:= bsSolid;
C.Brush.Color:= B.TransparentColor;
C.FillRect(R);
C.Pen.Style:= psSolid;
C.Pen.Color:= clBlack;
C.Pen.Width:= 5;
C.Brush.Color:= clBlack;
R2:= R;
for X:= 1 to 6 do begin
R2.Bottom:= R2.Bottom - 1;
C.RoundRect(R2.Left, R2.Top, R2.Right, R2.Bottom,
Round(R2.Bottom / 1.5), Round(R2.Bottom / 1.5));
end;
R2.Left:= R2.Left + 1;
R2.Right:= R2.Right - 1;
C.Brush.Color:= Col;
C.Pen.Width:= 3;
C.RoundRect(R2.Left, R2.Top, R2.Right, R2.Bottom,
Round(R2.Bottom / 1.5), Round(R2.Bottom / 1.5));
C.Brush.Style:= bsSolid;
C.Pen.Style:= psClear;
R2:= R;
R2.Left:= R2.Left + 13;
R2.Right:= R2.Right - 13;
R2.Top:= 3;
R2.Bottom:= (R2.Bottom div 2) - 18;
CR:= GetRValue(Col);
CG:= GetGValue(Col);
CB:= GetBValue(Col);
for X:= 1 to 16 do begin
TR:= EnsureRange(CR + (X * 4)+25, 0, 255);
TG:= EnsureRange(CG + (X * 4)+25, 0, 255);
TB:= EnsureRange(CB + (X * 4)+25, 0, 255);
C.Brush.Color:= RGB(TR, TG, TB);
C.RoundRect(R2.Left, R2.Top, R2.Right, R2.Bottom,
Round(R2.Bottom / 1.5), Round(R2.Bottom / 1.5));
R2.Left:= R2.Left + 2;
R2.Right:= R2.Right - 2;
R2.Bottom:= R2.Bottom - 1;
end;
end;
end;
end;
Ingredients needed:
AlphaBlend for the glassy effect,
GradientFill for the top gradient ellipse,
MaskBlt to exclude non-rectangular already drawn parts when drawing,
indeed some math, pretty easy though.
It is really necessary to devide the drawing task in small steps and place them in the right order. Then this is not as impossible as it at first may seem.
In the code below, I use three temporary bitmaps to reach the end goal:
a memory bitmap on which everything is drawn to reduce flicker,
a temporary bitmap, needed for assistance,
a mask bitmap for storage of a clipping shape.
I do not like comments in code, but I expect it speaks for itself:
unit GlassLabel;
interface
uses
Classes, Controls, Windows, Graphics, Math;
const
DefTransparency = 30;
type
TPercentage = 0..100;
TGlassLabel = class(TGraphicControl)
private
FTransparency: TPercentage;
procedure SetTransparency(Value: TPercentage);
protected
procedure Paint; override;
public
constructor Create(AOwner: TComponent); override;
procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
published
property Caption;
property Color;
property Font;
property Transparency: TPercentage read FTransparency
write SetTransparency default DefTransparency;
end;
implementation
type
PTriVertex = ^TTriVertex;
TTriVertex = record
X: DWORD;
Y: DWORD;
Red: WORD;
Green: WORD;
Blue: WORD;
Alpha: WORD;
end;
TRGB = record
R: Byte;
G: Byte;
B: Byte;
end;
function GradientFill(DC: HDC; Vertex: PTriVertex; NumVertex: ULONG;
Mesh: Pointer; NumMesh, Mode: ULONG): BOOL; stdcall; overload;
external msimg32 name 'GradientFill';
function GradientFill(DC: HDC; const ARect: TRect; StartColor,
EndColor: TColor; Vertical: Boolean): Boolean; overload;
const
Modes: array[Boolean] of ULONG = (GRADIENT_FILL_RECT_H, GRADIENT_FILL_RECT_V);
var
Vertices: array[0..1] of TTriVertex;
GRect: TGradientRect;
begin
Vertices[0].X := ARect.Left;
Vertices[0].Y := ARect.Top;
Vertices[0].Red := GetRValue(ColorToRGB(StartColor)) shl 8;
Vertices[0].Green := GetGValue(ColorToRGB(StartColor)) shl 8;
Vertices[0].Blue := GetBValue(ColorToRGB(StartColor)) shl 8;
Vertices[0].Alpha := 0;
Vertices[1].X := ARect.Right;
Vertices[1].Y := ARect.Bottom;
Vertices[1].Red := GetRValue(ColorToRGB(EndColor)) shl 8;
Vertices[1].Green := GetGValue(ColorToRGB(EndColor)) shl 8;
Vertices[1].Blue := GetBValue(ColorToRGB(EndColor)) shl 8;
Vertices[1].Alpha := 0;
GRect.UpperLeft := 0;
GRect.LowerRight := 1;
Result := GradientFill(DC, #Vertices, 2, #GRect, 1, Modes[Vertical]);
end;
function GetRGB(AColor: TColor): TRGB;
begin
AColor := ColorToRGB(AColor);
Result.R := GetRValue(AColor);
Result.G := GetGValue(AColor);
Result.B := GetBValue(AColor);
end;
function MixColor(Base, MixWith: TColor; Factor: Single): TColor;
var
FBase: TRGB;
FMixWith: TRGB;
begin
if Factor <= 0 then
Result := Base
else if Factor >= 1 then
Result := MixWith
else
begin
FBase := GetRGB(Base);
FMixWith := GetRGB(MixWith);
with FBase do
begin
R := R + Round((FMixWith.R - R) * Factor);
G := G + Round((FMixWith.G - G) * Factor);
B := B + Round((FMixWith.B - B) * Factor);
Result := RGB(R, G, B);
end;
end;
end;
function ColorWhiteness(C: TColor): Single;
begin
Result := (GetRValue(C) + GetGValue(C) + GetBValue(C)) / 255 / 3;
end;
function ColorBlackness(C: TColor): Single;
begin
Result := 1 - ColorWhiteness(C);
end;
{ TGlassLabel }
constructor TGlassLabel.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
ControlStyle := [csOpaque];
FTransparency := DefTransparency;
end;
procedure TGlassLabel.Paint;
const
DSTCOPY = $00AA0029;
DrawTextFlags = DT_CENTER or DT_END_ELLIPSIS or DT_SINGLELINE or DT_VCENTER;
var
W: Integer;
H: Integer;
BorderTop: Integer;
BorderBottom: Integer;
BorderSide: Integer;
Shadow: Integer;
R0: TRect; //Bounds of control
R1: TRect; //Inside border
R2: TRect; //Top gradient
R3: TRect; //Text
R4: TRect; //Perforation
ParentDC: HDC;
Tmp: TBitmap;
Mem: TBitmap;
Msk: TBitmap;
ShadowFactor: Single;
X: Integer;
BlendFunc: TBlendFunction;
procedure PrepareBitmaps;
begin
Tmp.Width := W;
Tmp.Height := H;
Mem.Canvas.Brush.Color := Color;
Mem.Width := W;
Mem.Height := H;
Mem.Canvas.Brush.Style := bsClear;
Msk.Width := W;
Msk.Height := H;
Msk.Monochrome := True;
end;
procedure PrepareMask(R: TRect);
var
Radius: Integer;
begin
Radius := (R.Bottom - R.Top) div 2;
Msk.Canvas.Brush.Color := clBlack;
Msk.Canvas.FillRect(R0);
Msk.Canvas.Brush.Color := clWhite;
Msk.Canvas.Ellipse(R.Left, R.Top, R.Left + 2 * Radius, R.Bottom);
Msk.Canvas.Ellipse(R.Right - 2 * Radius, R.Top, R.Right, R.Bottom);
Msk.Canvas.FillRect(Rect(R.Left + Radius, R.Top, R.Right - Radius,
R.Bottom));
end;
procedure DrawTopGradientEllipse;
begin
GradientFill(Tmp.Canvas.Handle, R2, MixColor(Color, clWhite, 1.0),
MixColor(Color, clWhite, 0.2), True);
PrepareMask(R2);
MaskBlt(Mem.Canvas.Handle, 0, 0, W, H, Tmp.Canvas.Handle, 0, 0,
Msk.Handle, 0, 0, MakeROP4(SRCCOPY, DSTCOPY));
end;
procedure DrawPerforation;
begin
while R4.Right < (W - H div 2) do
begin
Mem.Canvas.Pen.Color := MixColor(Color, clBlack, 0.9);
Mem.Canvas.RoundRect(R4.Left, R4.Top, R4.Right, R4.Bottom, H div 7,
H div 7);
Mem.Canvas.Pen.Color := MixColor(Color, clBlack, 0.5);
Mem.Canvas.RoundRect(R4.Left + 1, R4.Top + 1, R4.Right - 1,
R4.Bottom - 1, H div 7 - 1, H div 7 - 1);
Mem.Canvas.Pen.Color := MixColor(Color, clWhite, 0.33);
Mem.Canvas.MoveTo(R4.Left + H div 14, R4.Top + 1);
Mem.Canvas.LineTo(R4.Right - H div 14, R4.Top + 1);
OffsetRect(R4, R4.Right - R4.Left + H div 12, 0);
end;
end;
procedure DrawCaption;
begin
Mem.Canvas.Font := Font;
ShadowFactor := 0.6 + 0.4 * (Min(1.0, ColorBlackness(Font.Color) + 0.3));
Mem.Canvas.Font.Color := MixColor(Font.Color, clBlack, ShadowFactor);
DrawText(Mem.Canvas.Handle, PChar(Caption), -1, R3, DrawTextFlags);
OffsetRect(R3, -Shadow, Shadow);
Mem.Canvas.Font.Color := Font.Color;
DrawText(Mem.Canvas.Handle, PChar(Caption), -1, R3, DrawTextFlags);
end;
procedure DrawBorderAlias;
begin
Mem.Canvas.Pen.Color := MixColor(Color, clBlack, 0.65);
X := R1.Left + (R1.Bottom - R1.Top) div 2 + 2;
Mem.Canvas.Arc(R1.Left + 1, R1.Top, R1.Left + R1.Bottom - R1.Top + 1,
R1.Bottom, X, 0, X, H);
X := R1.Right - (R1.Bottom - R1.Top) div 2 - 2;
Mem.Canvas.Arc(R1.Right - 1, R1.Top, R1.Right - R1.Bottom + R1.Top - 1,
R1.Bottom, X, H, X, 0);
end;
procedure DrawBorder;
begin
PrepareMask(R1);
Tmp.Canvas.Brush.Color := clWhite;
Tmp.Canvas.Draw(0, 0, Msk);
BitBlt(Mem.Canvas.Handle, 0, 0, W, H, Tmp.Canvas.Handle, 0, 0, SRCAND);
end;
procedure DrawCombineParent;
begin
BitBlt(Tmp.Canvas.Handle, 0, 0, W, H, ParentDC, Left, Top, SRCCOPY);
BlendFunc.BlendOp := AC_SRC_OVER;
BlendFunc.BlendFlags := 0;
BlendFunc.SourceConstantAlpha := Round(FTransparency * High(Byte) / 100);
BlendFunc.AlphaFormat := 0;
AlphaBlend(Mem.Canvas.Handle, 0, 0, W, H, Tmp.Canvas.Handle, 0, 0, W, H,
BlendFunc);
PrepareMask(R0);
MaskBlt(Mem.Canvas.Handle, 0, 0, W, H, Tmp.Canvas.Handle, 0, 0,
Msk.Handle, 0, 0, MakeROP4(DSTCOPY, SRCCOPY));
end;
begin
if HasParent and (Height > 1) then
begin
W := Width;
H := Height;
BorderTop := Max(1, H div 30);
BorderBottom := Max(2, H div 10);
BorderSide := (BorderTop + BorderBottom) div 2;
Shadow := Font.Size div 8;
R0 := ClientRect;
R1 := Rect(BorderSide, BorderTop, W - BorderSide, H - BorderBottom);
R2 := Rect(R1.Left + BorderSide + 1, R1.Top, R1.Right - BorderSide - 1,
R1.Top + H div 4);
R3 := Rect(H div 2 + 1 + Shadow, R1.Top + 1, W - H div 2 - 1,
R1.Bottom - Shadow);
R4 := Bounds(H div 2, R1.Bottom - H div 4 + 1, H div 5, H div 4 - 2);
ParentDC := GetDC(Parent.Handle);
Tmp := TBitmap.Create;
Mem := TBitmap.Create;
Msk := TBitmap.Create;
try
PrepareBitmaps;
DrawTopGradientEllipse;
DrawPerforation;
DrawCaption;
DrawBorderAlias;
DrawBorder;
DrawCombineParent;
BitBlt(Canvas.Handle, 0, 0, W, H, Mem.Canvas.Handle, 0, 0, SRCCOPY);
finally
Msk.Free;
Mem.Free;
Tmp.Free;
ReleaseDC(Parent.Handle, ParentDC);
end;
end;
end;
procedure TGlassLabel.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
begin
if AWidth < AHeight then
AWidth := AHeight;
inherited SetBounds(ALeft, ATop, AWidth, AHeight);
end;
procedure TGlassLabel.SetTransparency(Value: TPercentage);
begin
if FTransparency <> Value then
begin
FTransparency := Value;
Invalidate;
end;
end;
end.
Sample code to produce the above (place an TImage control in the background):
procedure TForm1.FormCreate(Sender: TObject);
begin
Font.Size := 16;
Font.Color := $00A5781B;
Font.Name := 'Calibri';
Font.Style := [fsBold];
with TGlassLabel.Create(Self) do
begin
SetBounds(40, 40, 550, 60);
Color := $00271907;
Caption := '395 Days, 22 Hours, 0 Minutes, 54 Seconds';
Parent := Self;
end;
with TGlassLabel.Create(Self) do
begin
SetBounds(40, 40 + 119, 550, 60);
Color := $00000097;
Caption := '0 Days, 1 Hours, 59 Minutes, 31 Seconds';
Parent := Self;
end;
end;
Tweak as you like.
First you need to draw some image. It can have gradients, transparency, etc. Then you will need to convert it to bitmap and for each pixel use GraphUtil.ColorRGBToHLS/ColorHLSToRGB functions. In your case you will need to change only hue of each pixel.
I need to get a regular snapshot from a webcam in Delphi. Speed is not a problem (once a second is fine). I have tried demo code from based on stuff from http://delphi.pjh2.de but I can't get it to work. It compiles and runs OK but the callback function never fires.
I don't have a real webcam but am running instead a simulator. The simulator works (I can see the video using Skype) but not with the test app. I don't really know where to start looking...
Can anyone be bothered to try this code? (Apologies for the voluminous post - couldn't find how or if you can attach files - a zip file is available here.)
Alternatively, any webcam demo code would be appreciated, preferably with a known good EXE as well as source.
program WebCamTest;
uses
Forms,
WebCamMainForm in 'WebCamMainForm.pas' {Form1},
yuvconverts in 'yuvconverts.pas';
{$R *.res}
begin
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.
unit WebCamMainForm;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
Dialogs, ExtCtrls, YUVConverts, StdCtrls, JPeg {, TntStdCtrls} ;
const
WM_CAP_START = WM_USER;
WM_CAP_DRIVER_CONNECT = WM_CAP_START+ 10;
WM_CAP_SET_PREVIEW = WM_CAP_START+ 50;
WM_CAP_SET_OVERLAY = WM_CAP_START+ 51;
WM_CAP_SET_PREVIEWRATE = WM_CAP_START+ 52;
WM_CAP_GRAB_FRAME_NOSTOP = WM_CAP_START+ 61;
WM_CAP_SET_CALLBACK_FRAME = WM_CAP_START+ 5;
WM_CAP_GET_VIDEOFORMAT = WM_CAP_START+ 44;
WM_CAP_DLG_VIDEOFORMAT = WM_CAP_START+ 41;
PICWIDTH= 640;
PICHEIGHT= 480;
SUBLINEHEIGHT= 18;
EXTRAHEIGHT= 400;
type
TVIDEOHDR= record
lpData: Pointer; // address of video buffer
dwBufferLength: DWord; // size, in bytes, of the Data buffer
dwBytesUsed: DWord; // see below
dwTimeCaptured: DWord; // see below
dwUser: DWord; // user-specific data
dwFlags: DWord; // see below
dwReserved1, dwReserved2, dwReserved3: DWord; // reserved; do not use
end;
TVIDEOHDRPtr= ^TVideoHDR;
DWordDim= array[1..PICWIDTH] of DWord;
TForm1 = class(TForm)
Timer1: TTimer;
Panel1: TPanel;
procedure FormDestroy(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormActivate(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
private
FCapHandle: THandle;
FCodec: TVideoCodec;
FBuf1, FBuf2: array[1..PICHEIGHT] of DWordDim;
FBitmap: TBitmap;
FJpeg: TJPegImage;
{ Private-Deklarationen }
public
{ Public-Deklarationen }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
function capCreateCaptureWindow(lpszWindowName: LPCSTR;
dwStyle: DWORD;
x, y,
nWidth,
nHeight: integer;
hwndParent: HWND;
nID: integer): HWND; stdcall;
external 'AVICAP32.DLL' name 'capCreateCaptureWindowA';
function FrameCallbackFunction(AHandle: hWnd; VIDEOHDR: TVideoHDRPtr): bool; stdcall;
var
I: integer;
begin
result:= true;
with form1 do begin
try
ConvertCodecToRGB(FCodec, VideoHDR^.lpData, #FBuf2, PICWIDTH, PICHEIGHT);
for I:= 1 to PICHEIGHT do FBuf1[I]:= FBuf2[PICHEIGHT- (I- 1)];
SetBitmapBits(FBitmap.Handle, PICWIDTH* PICHEIGHT* SizeOf(DWord), #FBuf1);
FBitmap.Canvas.Brush.Color:= clWhite;
FBitmap.Canvas.Font.Color:= clRed;
FJpeg.Assign(FBitmap);
FJpeg.CompressionQuality:= 85;
FJpeg.ProgressiveEncoding:= true;
FJpeg.SaveToFile('c:\webcam.jpg');
SendMessage(FCapHandle, WM_CAP_SET_CALLBACK_FRAME, 0, 0);
except
end;
end;
end;
//------------------------------------------------------------------------------
procedure TForm1.FormCreate(Sender: TObject);
var BitmapInfo: TBitmapInfo;
begin
Timer1.Enabled := false;
FBitmap:= TBitmap.Create;
FBitmap.Width:= PICWIDTH;
FBitmap.Height:= PICHEIGHT+ SUBLINEHEIGHT+ EXTRAHEIGHT;
FBitmap.PixelFormat:= pf32Bit;
FBitmap.Canvas.Font.Assign(Panel1.Font);
FBitmap.Canvas.Brush.Style:= bssolid;
FBitmap.Canvas.Rectangle(0, PICHEIGHT, PICWIDTH, PICHEIGHT+ SUBLINEHEIGHT);
FJpeg:= TJpegImage.Create;
FCapHandle:= capCreateCaptureWindow('Video', WS_CHILD or WS_VISIBLE, 0, 0, PICWIDTH, PICHEIGHT, Panel1.Handle, 1);
SendMessage(FCapHandle, WM_CAP_DRIVER_CONNECT, 0, 0);
SendMessage(FCapHandle, WM_CAP_SET_PREVIEWRATE, 15000, 0);
sendMessage(FCapHandle, WM_CAP_SET_OVERLAY, 1, 0);
SendMessage(FCapHandle, WM_CAP_SET_PREVIEW, 1, 0);
// SendMessage(FCapHandle, WM_CAP_DLG_VIDEOFORMAT,1,0); // -this was commented out
FillChar(BitmapInfo, SizeOf(BitmapInfo), 0);
SendMessage(FCapHandle, WM_CAP_GET_VIDEOFORMAT, SizeOf(BitmapInfo), Integer(#BitmapInfo));
FCodec:= BICompressionToVideoCodec(bitmapinfo.bmiHeader.biCompression);
if FCodec<> vcUnknown then begin
Timer1.Enabled:= true;
end;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
FBitmap.Free;
FJpeg.Free;
end;
procedure TForm1.FormActivate(Sender: TObject);
begin
if FCodec= vcUnknown then
showMessage('unknown compression');
FBitmap.Height:= PICHEIGHT+ SUBLINEHEIGHT;
end;
//------------------------------------------------------------------------------
procedure TForm1.Timer1Timer(Sender: TObject);
begin
SendMessage(FCapHandle, WM_CAP_SET_CALLBACK_FRAME, 0, integer(#FrameCallbackFunction));
SendMessage(FCapHandle, WM_CAP_GRAB_FRAME_NOSTOP, 1, 0); // ist hintergrundlauff盲hig
end;
end.
object Form1: TForm1
Left = 0
Top = 0
Caption = 'Form1'
ClientHeight = 301
ClientWidth = 562
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Tahoma'
Font.Style = []
OldCreateOrder = False
OnActivate = FormActivate
OnCreate = FormCreate
OnDestroy = FormDestroy
PixelsPerInch = 96
TextHeight = 13
object Panel1: TPanel
Left = 48
Top = 16
Width = 185
Height = 145
Caption = 'Panel1'
TabOrder = 0
end
object Timer1: TTimer
OnTimer = Timer1Timer
Left = 464
Top = 24
end
end
{**************************************************************************************************}
{ }
{ YUVConverts }
{ }
{ The contents of this file are subject to the Y Library Public License Version 1.0 (the }
{ "License"); you may not use this file except in compliance with the License. You may obtain a }
{ copy of the License at http://delphi.pjh2.de/ }
{ }
{ 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: YUVConverts.pas, part of CapDemoC.dpr. }
{ The Initial Developer of the Original Code is Peter J. Haas (libs#pjh2.de). Portions created }
{ by Peter J. Haas are Copyright (C) 2000-2005 Peter J. Haas. All Rights Reserved. }
{ }
{ Contributor(s): }
{ }
{ You may retrieve the latest version of this file at the homepage of Peter J. Haas, located at }
{ http://delphi.pjh2.de/ }
{ }
{**************************************************************************************************}
// For history see end of file
{$ALIGN ON, $BOOLEVAL OFF, $LONGSTRINGS ON, $IOCHECKS ON, $WRITEABLECONST OFF, $OVERFLOWCHECKS OFF}
{$RANGECHECKS OFF, $TYPEDADDRESS ON, $MINENUMSIZE 1}
unit yuvconverts;
interface
uses
Windows;
type
TVideoCodec = (vcUnknown, vcRGB, vcYUY2, vcUYVY, vcBTYUV, vcYVU9, vcYUV12, vcY8, vcY211);
const
BI_YUY2 = $32595559; // 'YUY2'
BI_UYVY = $59565955; // 'UYVY'
BI_BTYUV = $50313459; // 'Y41P'
BI_YVU9 = $39555659; // 'YVU9' planar
BI_YUV12 = $30323449; // 'I420' planar
BI_Y8 = $20203859; // 'Y8 '
BI_Y211 = $31313259; // 'Y211'
function BICompressionToVideoCodec(Value: DWord): TVideoCodec;
function ConvertCodecToRGB(Codec: TVideoCodec; Src, Dst: Pointer; AWidth, AHeight: Integer): Boolean;
implementation
function BICompressionToVideoCodec(Value: DWord): TVideoCodec;
begin
case Value of
BI_RGB, BI_BITFIELDS: Result := vcRGB; // no RLE
BI_YUY2: Result := vcYUY2 ;
BI_UYVY: Result := vcUYVY ;
BI_BTYUV: Result := vcBTYUV;
BI_YVU9: Result := vcYVU9;
BI_YUV12: Result := vcYUV12;
BI_Y8: Result := vcY8;
BI_Y211: Result := vcY211;
else
Result := vcUnknown;
end;
end;
const
// RGB255 ColorFAQ
fY = 298.082 / 256;
fRU = 0;
fGU = -100.291 / 256;
fBU = 516.411 / 256;
fRV = 408.583 / 256;
fGV = -208.120 / 256;
fBV = 0;
{ // RGB219 ColorFAQ too dark
fY = 256 / 256;
fRU = 0;
fGU = -86.132 / 256;
fBU = 443.506 / 256;
fRV = 350.901 / 256;
fGV = -178.738 / 256;
fBV = 0; }
{ // Earl same like RGB255
fY = 1.164;
fRU = 0;
fGU = -0.392;
fBU = 2.017;
fRV = 1.596;
fGV = -0.813;
fBV = 0;
}
// |R| |fY fRU fRV| |Y| | 16|
// |G| = |fY fGU fGV| * |U| - |128|
// |B| |fY fBU fBV| |V| |128|
type
TYUV = packed record
Y, U, V, F1: Byte;
end;
PBGR32 = ^TBGR32;
TBGR32 = packed record
B, G, R, A: Byte;
end;
function YUVtoBGRAPixel(AYUV: DWord): DWord;
var
ValueY, ValueU, ValueV: Integer;
ValueB, ValueG, ValueR: Integer;
begin
ValueY := TYUV(AYUV).Y - 16;
ValueU := TYUV(AYUV).U - 128;
ValueV := TYUV(AYUV).V - 128;
ValueB := Trunc(fY * ValueY + fBU * ValueU); // fBV = 0
if ValueB > 255 then
ValueB := 255;
if ValueB < 0 then
ValueB := 0;
ValueG := Trunc(fY * ValueY + fGU * ValueU + fGV * ValueV);
if ValueG > 255 then
ValueG := 255;
if ValueG < 0 then
ValueG := 0;
ValueR := Trunc(fY * ValueY + fRV * ValueV); // fRU = 0
if ValueR > 255 then
ValueR := 255;
if ValueR < 0 then
ValueR := 0;
with TBGR32(Result) do begin
B := ValueB;
G := ValueG;
R := ValueR;
A := 0;
end;
end;
type
TDWordRec = packed record
case Integer of
0: (B0, B1, B2, B3: Byte);
1: (W0, W1: Word);
end;
// UYVY
// YUV 4:2:2 (Y sample at every pixel, U and V sampled at every second pixel
// horizontally on each line). A macropixel contains 2 pixels in 1 DWord.
// 16 Bits per Pixel, 4 Byte Macropixel
// U0 Y0 V0 Y1
procedure UYVYtoRGB(Src, Dst: Pointer; AWidth, AHeight: Integer);
type
PUYVY = ^TUYVY;
TUYVY = packed record
U, Y0, V, Y1: Byte;
end;
var
x, y: Integer;
w: Integer;
SrcPtr: PDWord;
DstPtr: PDWord;
SrcLineSize: Integer;
DstLineSize: Integer;
YUV: DWord;
b: Byte;
begin
SrcLineSize := AWidth * 2;
DstLineSize := AWidth * 4;
// Dst is Bottom Top Bitmap
Inc(PByte(Dst), (AHeight - 1) * DstLineSize);
w := (AWidth div 2) - 1; { TODO : bei ungeraden Breiten fehlt letztes Pixel }
for y := 0 to AHeight - 1 do begin
SrcPtr := Src;
DstPtr := Dst;
for x := 0 to w do begin
YUV := SrcPtr^;
// First Pixel
b := TDWordRec(YUV).B0;
TDWordRec(YUV).B0 := TDWordRec(YUV).B1;
TDWordRec(YUV).B1 := b;
DstPtr^ := YUVtoBGRAPixel(YUV);
Inc(DstPtr);
// Second Pixel
TDWordRec(YUV).B0 := TDWordRec(YUV).B3;
DstPtr^ := YUVtoBGRAPixel(YUV);
Inc(DstPtr);
Inc(SrcPtr);
end;
Dec(PByte(Dst), DstLineSize);
Inc(PByte(Src), SrcLineSize);
end;
end;
// YUY2, YUNV, V422
// YUV 4:2:2 as for UYVY but with different component ordering within the DWord
// macropixel.
// 16 Bits per Pixel, 4 Byte Macropixel
// Y0 U0 Y1 V0
procedure YUY2toRGB(Src, Dst: Pointer; AWidth, AHeight: Integer);
var
x, y: Integer;
w: Integer;
SrcPtr: PDWord;
DstPtr: PDWord;
SrcLineSize: Integer;
DstLineSize: Integer;
YUV: DWord;
b: Byte;
begin
SrcLineSize := AWidth * 2;
DstLineSize := AWidth * 4;
// Dst is Bottom Top Bitmap
Inc(PByte(Dst), (AHeight - 1) * DstLineSize);
w := (AWidth div 2) - 1; { TODO : bei ungeraden Breiten fehlt letztes Pixel }
for y := 0 to AHeight - 1 do begin
SrcPtr := Src;
DstPtr := Dst;
for x := 0 to w do begin
YUV := SrcPtr^;
// First Pixel
b := TDWordRec(YUV).B2; // Y0 U Y1 V -> Y0 U V Y1
TDWordRec(YUV).B2 := TDWordRec(YUV).B3;
TDWordRec(YUV).B3 := b;
DstPtr^ := YUVtoBGRAPixel(YUV);
Inc(DstPtr);
// Second Pixel
TDWordRec(YUV).B0 := TDWordRec(YUV).B3;
DstPtr^ := YUVtoBGRAPixel(YUV);
Inc(DstPtr);
Inc(SrcPtr);
end;
Dec(PByte(Dst), DstLineSize);
Inc(PByte(Src), SrcLineSize);
end;
end;
// BTYUV, I42P
// YUV 4:1:1 (Y sample at every pixel, U and V sampled at every fourth pixel
// horizontally on each line). A macropixel contains 8 pixels in 3 DWords.
// 16 Bits per Pixel, 12 Byte Macropixel
// U0 Y0 V0 Y1 U4 Y2 V4 Y3 Y4 Y5 Y6 Y7
procedure BTYUVtoRGB(Src, Dst: Pointer; AWidth, AHeight: Integer);
type
PBTYUVPixel = ^TBTYUVPixel;
TBTYUVPixel = packed record
U0, Y0, V0, Y1, U4, Y2, V4, Y3, Y4, Y5, Y6, Y7: Byte;
end;
var
x, y: Integer;
w: Integer;
SrcPtr: PBTYUVPixel;
DstPtr: PDWord;
SrcLineSize: Integer;
DstLineSize: Integer;
YUV: DWord;
SrcPixel: TBTYUVPixel;
begin
SrcLineSize := ((AWidth + 7) div 8) * (3 * 4);
DstLineSize := AWidth * 4;
w := AWidth - 1;
for y := 0 to AHeight - 1 do begin
SrcPtr := Src;
DstPtr := Dst;
x := w;
while x > 0 do begin
// read macropixel
SrcPixel := SrcPtr^;
// First 4 Pixel
TYUV(YUV).U := SrcPixel.U0;
TYUV(YUV).V := SrcPixel.V0;
TYUV(YUV).Y := SrcPixel.Y0;
DstPtr^ := YUVtoBGRAPixel(YUV);
Inc(DstPtr);
Dec(x);
if x <= 0 then
Break;
TYUV(YUV).Y := SrcPixel.Y1;
DstPtr^ := YUVtoBGRAPixel(YUV);
Inc(DstPtr);
Dec(x);
if x <= 0 then
Break;
TYUV(YUV).Y := SrcPixel.Y2;
DstPtr^ := YUVtoBGRAPixel(YUV);
Inc(DstPtr);
Dec(x);
if x <= 0 then
Break;
TYUV(YUV).Y := SrcPixel.Y3;
DstPtr^ := YUVtoBGRAPixel(YUV);
Inc(DstPtr);
Dec(x);
if x <= 0 then
Break;
// Second 4 Pixel
TYUV(YUV).U := SrcPixel.U4;
TYUV(YUV).V := SrcPixel.V4;
TYUV(YUV).Y := SrcPixel.Y4;
DstPtr^ := YUVtoBGRAPixel(YUV);
Inc(DstPtr);
Dec(x);
if x <= 0 then
Break;
TYUV(YUV).Y := SrcPixel.Y5;
DstPtr^ := YUVtoBGRAPixel(YUV);
Inc(DstPtr);
Dec(x);
if x <= 0 then
Break;
TYUV(YUV).Y := SrcPixel.Y6;
DstPtr^ := YUVtoBGRAPixel(YUV);
Inc(DstPtr);
Dec(x);
if x <= 0 then
Break;
TYUV(YUV).Y := SrcPixel.Y7;
DstPtr^ := YUVtoBGRAPixel(YUV);
Inc(DstPtr);
Inc(SrcPtr);
end;
Inc(PByte(Dst), DstLineSize);
Inc(PByte(Src), SrcLineSize);
end;
end;
// YVU9
// 8 bit Y plane followed by 8 bit 4x4 subsampled V and U planes.
// 9 Bits per Pixel, planar format
procedure YVU9toRGB(Src, Dst: Pointer; AWidth, AHeight: Integer);
var
x, y, r, l: Integer;
w: Integer;
SrcYPtr: PByte;
SrcUPtr: PByte;
SrcVPtr: PByte;
DstPtr: PDWord;
SrcYLineSize: Integer;
SrcUVLineSize: Integer;
DstLineSize: Integer;
YUV: DWord;
begin
DstLineSize := AWidth * 4;
SrcYLineSize := AWidth;
SrcUVLineSize := (AWidth + 3) div 4;
// Dst is Bottom Top Bitmap
Inc(PByte(Dst), (AHeight - 1) * DstLineSize);
SrcYPtr := Src;
SrcVPtr := PByte(LongInt(SrcYPtr) + SrcYLineSize * AHeight);
SrcUPtr := PByte(LongInt(SrcVPtr) + SrcUVLineSize * ((AHeight + 3) div 4));
w := (AWidth div 4) - 1; { TODO : bei ungeraden Breiten fehlt letztes Pixel }
for y := 0 to (AHeight div 4) - 1 do begin { TODO : bei ungeraden H枚hen fehlt letzte Reihe }
for l := 0 to 3 do begin
DstPtr := Dst;
for x := 0 to w do begin
// U and V
YUV := (SrcUPtr^ shl 8) or (SrcVPtr^ shl 16);
for r := 0 to 3 do begin
YUV := (YUV and $00FFFF00) or SrcYPtr^;
DstPtr^ := YUVtoBGRAPixel(YUV);
Inc(DstPtr);
Inc(SrcYPtr);
end;
Inc(SrcUPtr);
Inc(SrcVPtr);
end;
Dec(PByte(Dst), DstLineSize);
if l < 3 then begin
Dec(SrcUPtr, SrcUVLineSize);
Dec(SrcVPtr, SrcUVLineSize);
end;
end;
end;
end;
// YUV12, I420, IYUV
// 8 bit Y plane followed by 8 bit 2x2 subsampled U and V planes.
// 12 Bits per Pixel, planar format
procedure YUV12toRGB(Src, Dst: Pointer; AWidth, AHeight: Integer); // I420, IYUV
var
x, y, l: Integer;
w: Integer;
SrcYPtr: PByte;
SrcUPtr: PByte;
SrcVPtr: PByte;
DstPtr: PDWord;
SrcYLineSize: Integer;
SrcUVLineSize: Integer;
DstLineSize: Integer;
YUV: DWord;
begin
DstLineSize := AWidth * 4;
SrcYLineSize := AWidth;
SrcUVLineSize := (AWidth + 1) div 2;
// Dst is Bottom Top Bitmap
Inc(PByte(Dst), (AHeight - 1) * DstLineSize);
SrcYPtr := Src;
SrcUPtr := PByte(LongInt(SrcYPtr) + SrcYLineSize * AHeight);
SrcVPtr := PByte(LongInt(SrcUPtr) + SrcUVLineSize * ((AHeight + 1) div 2));
w := (AWidth div 2) - 1; { TODO : bei ungeraden Breiten fehlt letztes Pixel }
for y := 0 to (AHeight div 2) - 1 do begin { TODO : bei ungeraden H枚hen fehlt letzte Reihe }
for l := 0 to 1 do begin
DstPtr := Dst;
for x := 0 to w do begin
// First Pixel
YUV := SrcYPtr^ or (SrcUPtr^ shl 8) or (SrcVPtr^ shl 16);
DstPtr^ := YUVtoBGRAPixel(YUV);
Inc(DstPtr);
Inc(SrcYPtr);
// Second Pixel
YUV := (YUV and $00FFFF00) or SrcYPtr^;
DstPtr^ := YUVtoBGRAPixel(YUV);
Inc(DstPtr);
Inc(SrcYPtr);
Inc(SrcUPtr);
Inc(SrcVPtr);
end;
Dec(PByte(Dst), DstLineSize);
if l = 0 then begin
Dec(SrcUPtr, SrcUVLineSize);
Dec(SrcVPtr, SrcUVLineSize);
end;
end;
end;
end;
// Y8, Y800
// Simple, single Y plane for monochrome images.
// 8 Bits per Pixel, planar format
procedure Y8toRGB(Src, Dst: Pointer; AWidth, AHeight: Integer);
var
x, y: Integer;
w: Integer;
SrcPtr: PByte;
DstPtr: PDWord;
SrcLineSize: Integer;
DstLineSize: Integer;
Pixel: DWord;
begin
SrcLineSize := AWidth;
DstLineSize := AWidth * 4;
// Dst is Bottom Top Bitmap
Inc(PByte(Dst), (AHeight - 1) * DstLineSize);
w := (AWidth) - 1;
for y := 0 to AHeight - 1 do begin
SrcPtr := Src;
DstPtr := Dst;
for x := 0 to w do begin
Pixel := SrcPtr^;
TDWordRec(Pixel).B1 := TDWordRec(Pixel).B0;
TDWordRec(Pixel).B2 := TDWordRec(Pixel).B0;
TDWordRec(Pixel).B3 := 0;
DstPtr^ := Pixel;
Inc(DstPtr);
Inc(SrcPtr);
end;
Dec(PByte(Dst), DstLineSize);
Inc(PByte(Src), SrcLineSize);
end;
end;
// Y211
// Packed YUV format with Y sampled at every second pixel across each line
// and U and V sampled at every fourth pixel.
// 8 Bits per Pixel, 4 Byte Macropixel
// Y0, U0, Y2, V0
procedure Y211toRGB(Src, Dst: Pointer; AWidth, AHeight: Integer);
type
PYUYV = ^TYUYV;
TYUYV = packed record
Y0, U, Y2, V: Byte;
end;
var
x, y: Integer;
w : Integer;
SrcPtr : PDWord;
DstPtr : PDWord;
SrcLineSize : Integer;
DstLineSize : Integer;
YUV: DWord;
BGR: DWord;
b: Byte;
begin
SrcLineSize := ((AWidth + 3) div 4) * 4;
DstLineSize := AWidth * 4;
// Dst is Bottom Top Bitmap
Inc(PByte(Dst), (AHeight - 1) * DstLineSize);
w := (AWidth div 4) - 1; { TODO : bei ungeraden Breiten fehlt letztes Pixel }
for y := 0 to AHeight - 1 do begin
SrcPtr := Src;
DstPtr := Dst;
for x := 0 to w do begin
// Y0 U Y2 V
YUV := SrcPtr^;
// First and second Pixel
b := TDWordRec(YUV).B2; // Y0 U Y2 V -> Y0 U V Y2
TDWordRec(YUV).B2 := TDWordRec(YUV).B3;
TDWordRec(YUV).B3 := b;
BGR := YUVtoBGRAPixel(YUV);
DstPtr^ := BGR;
Inc(DstPtr);
DstPtr^ := BGR;
Inc(DstPtr);
// third and fourth
TDWordRec(YUV).B0 := TDWordRec(YUV).B3; // Y0 U V Y2 -> Y2 U V Y2
BGR := YUVtoBGRAPixel(YUV);
DstPtr^ := BGR;
Inc(DstPtr);
DstPtr^ := BGR;
Inc(DstPtr);
Inc(SrcPtr);
end;
Dec(PByte(Dst), DstLineSize);
Inc(PByte(Src), SrcLineSize);
end;
end;
function ConvertCodecToRGB(Codec: TVideoCodec; Src, Dst: Pointer; AWidth, AHeight: Integer): Boolean;
begin
Result := True;
case Codec of
vcYUY2: YUY2toRGB (Src, Dst, AWidth, AHeight);
vcUYVY: UYVYtoRGB (Src, Dst, AWidth, AHeight);
vcBTYUV: BTYUVtoRGB(Src, Dst, AWidth, AHeight);
vcYVU9: YVU9toRGB (Src, Dst, AWidth, AHeight);
vcYUV12: YUV12toRGB(Src, Dst, AWidth, AHeight);
vcY8: Y8toRGB (Src, Dst, AWidth, AHeight);
vcY211: Y211toRGB (Src, Dst, AWidth, AHeight);
else
Result := False;
end;
end;
// History:
// 2005-02-12, Peter J. Haas
//
// 2002-02-22, Peter J. Haas
// - add YVU9, YUV12 (I420)
// - add Y211 (untested)
//
// 2001-06-14, Peter J. Haas
// - First public version
// - YUY2, UYVY, BTYUV (Y41P), Y8
end.
Some message results:
var
MsgResult : Integer ;
procedure TForm1.FormCreate(Sender: TObject);
var BitmapInfo: TBitmapInfo;
begin
Timer1.Enabled := false;
FBitmap:= TBitmap.Create;
FBitmap.Width:= PICWIDTH;
FBitmap.Height:= PICHEIGHT+ SUBLINEHEIGHT+ EXTRAHEIGHT;
FBitmap.PixelFormat:= pf32Bit;
FBitmap.Canvas.Font.Assign(Panel1.Font);
FBitmap.Canvas.Brush.Style:= bssolid;
FBitmap.Canvas.Rectangle(0, PICHEIGHT, PICWIDTH, PICHEIGHT+ SUBLINEHEIGHT);
FJpeg:= TJpegImage.Create;
FCapHandle:= capCreateCaptureWindow('Video', WS_CHILD or WS_VISIBLE, 0, 0, PICWIDTH, PICHEIGHT, Panel1.Handle, 1); // returns 2558326
MsgResult := SendMessage(FCapHandle, WM_CAP_DRIVER_CONNECT, 0, 0); // returns 0
MsgResult := SendMessage(FCapHandle, WM_CAP_SET_PREVIEWRATE, 15000, 0); // returns 1
MsgResult := sendMessage(FCapHandle, WM_CAP_SET_OVERLAY, 1, 0); // returns 0
MsgResult := SendMessage(FCapHandle, WM_CAP_SET_PREVIEW, 1, 0); // returns 0
// SendMessage(FCapHandle, WM_CAP_DLG_VIDEOFORMAT,1,0); // -this was commented out
FillChar(BitmapInfo, SizeOf(BitmapInfo), 0);
MsgResult := SendMessage(FCapHandle, WM_CAP_GET_VIDEOFORMAT, SizeOf(BitmapInfo), Integer(#BitmapInfo)); // returns 0
FCodec:= BICompressionToVideoCodec(bitmapinfo.bmiHeader.biCompression); // returns vcRGB
if FCodec<> vcUnknown then begin
Timer1.Enabled:= true;
end;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
FBitmap.Free;
FJpeg.Free;
end;
procedure TForm1.FormActivate(Sender: TObject);
begin
if FCodec= vcUnknown then
showMessage('unknown compression');
FBitmap.Height:= PICHEIGHT+ SUBLINEHEIGHT;
end;
//------------------------------------------------------------------------------
procedure TForm1.Timer1Timer(Sender: TObject);
begin
MsgResult := SendMessage(FCapHandle, WM_CAP_SET_CALLBACK_FRAME, 0, integer(#FrameCallbackFunction)); // returns 0
MsgResult := SendMessage(FCapHandle, WM_CAP_GRAB_FRAME_NOSTOP, 1, 0); // ist hintergrundlauff盲hig // returns 0
end;
Your program works for me on Win7 32bits with D2010.
What it does though is raising an exception:
---------------------------
Project WebCamTest.exe raised exception class EFCreateError with message
'Cannot create file "c:\webcam.jpg". Access is denied'.
---------------------------
which can be corrected by changing
FJpeg.SaveToFile('c:\webcam.jpg');
to
FJpeg.SaveToFile(TPath.GetTempPath + '\webcam.jpg');
And also, it does not display the whole available image, you'd have to enlarge your Panel, recenter or shrink the webcam output.
Update with some code modifications that would make it work per your comments...
// introducing the RGB array and a buffer
TVideoArray = array[1..PICHEIGHT] of array[1..PICWIDTH] of TRGBTriple;
PVideoArray = ^TVideoArray;
TForm1 = class(TForm)
[...]
FBuf24_1: TVideoArray;
[...]
function FrameCallbackFunction(AHandle: hWnd; VIDEOHDR: TVideoHDRPtr): bool; stdcall;
var
I: integer;
begin
result:= true;
with form1 do begin
try
if ConvertCodecToRGB(FCodec, VideoHDR^.lpData, #FBuf2, PICWIDTH, PICHEIGHT) then
begin
for I:= 1 to PICHEIGHT do FBuf1[I]:= FBuf2[PICHEIGHT- (I- 1)];
SetBitmapBits(FBitmap.Handle, PICWIDTH* PICHEIGHT* SizeOf(DWord), #FBuf1);
end
else
begin // assume RGB
for I:= 1 to PICHEIGHT do
FBuf24_1[I] := PVideoArray(VideoHDR^.lpData)^[PICHEIGHT-I+1];
SetBitmapBits(FBitmap.Handle, PICWIDTH* PICHEIGHT* SizeOf(RGBTriple), #FBuf24_1);
end;
[...]
If you wish to use DirectX API instead of deprecated Video For Windows (VFW) API:
http://www.delphibasics.info/home/delphibasicsprojects/directxdelphiwebcamcaptureexample
Here is a link to a larger project implementing the code detailed below:
http://www.delphibasics.info/home/delphibasicssnippets/delphiwebcamcaptureexample
Interchange lines indicated by comment notation as you wish.
program WebcamTest;
//www.delphibasics.info
//cswi
uses
Windows;
const
WM_CAP_DRIVER_CONNECT = 1034;
WM_CAP_GRAB_FRAME = 1084;
//WM_CAP_SAVEDIB = 1049;
WM_CAP_EDIT_COPY = 1054;//
WM_CAP_DRIVER_DISCONNECT = 1035;
function SendMessageA(hWnd: Integer;
Msg: Integer;
wParam: Integer;
lParam: Integer): Integer;
stdcall;
external 'user32.dll' name 'SendMessageA';
function capGetDriverDescriptionA(DrvIndex: Cardinal;
Name: PAnsiChar;
NameLen: Integer;
Description: PAnsiChar;
DescLen: Integer) : Boolean;
stdcall;
external 'avicap32.dll' name 'capGetDriverDescriptionA';
function capCreateCaptureWindowA(lpszWindowName: PAnsiChar;
dwStyle: Integer;
x : Integer;
y : Integer;
nWidth : Integer;
nHeight : Integer;
ParentWin: Integer;
nId: Integer): Integer;
stdcall;
external 'avicap32.dll' name 'capCreateCaptureWindowA';
function IntToStr(i: Integer): String;
begin
Str(i, Result);
end;
var
WebCamId : Integer;
CaptureWindow : Integer;
x : Integer;
FileName : PAnsiChar;
hData: DWORD;
pData: Pointer;
dwSize: DWORD;
szText : AnsiString;
FileHandle, BytesWritten : LongWord;
begin
WebcamId := 0;
CaptureWindow := capCreateCaptureWindowA('CaptureWindow', 0, 0, 0, 0, 0, 0, 0);
if CaptureWindow <> 0 then
begin
if SendMessageA(CaptureWindow, WM_CAP_DRIVER_CONNECT, WebCamId, 0) <> 1 then
begin
SendMessageA(CaptureWindow, WM_CAP_DRIVER_DISCONNECT, 0, 0);
end
else
begin
for x := 1 to 20 do // Take 20 photos.
begin
SendMessageA(CaptureWindow, WM_CAP_GRAB_FRAME, 0, 0);
FileName := PAnsiChar('C:\Test' + IntToStr(x) + '.bmp');
//SendMessageA(CaptureWindow, WM_CAP_SAVEDIB, 0, LongInt(FileName));
SendMessageA(CaptureWindow, WM_CAP_EDIT_COPY, 0, LongInt(FileName));//
if OpenClipBoard(0) then
begin
hData := GetClipBoardData(CF_DIB);
if hData <> 0 then
begin
pData := GlobalLock(hData);
if pData <> nil then
begin
dwSize := GlobalSize(hData);
if dwSize <> 0 then
begin
FileHandle := CreateFileA(FileName, GENERIC_WRITE, FILE_SHARE_WRITE, nil, CREATE_NEW, FILE_ATTRIBUTE_HIDDEN, 0);
WriteFile(FileHandle, pData, dwSize, BytesWritten, nil);
CloseHandle(FileHandle);
end;
GlobalUnlock(DWORD(pData));
end;
end;
CloseClipBoard;
end;
end;
end;
SendMessageA(CaptureWindow, WM_CAP_DRIVER_DISCONNECT, 0, 0);
end;
end.
I use a component called TVideoCap. It is for 3, 4, and 5 but it includes source so it is easy to update. It will do exactly what you want. Just do a search for 'TVideoCap'.