Create a watermark

Problem/Question/Abstract:

How to create a watermark

Answer:

Solve 1:

How it works: On a hidden image, sized to suit the final text, print text in black. Then by using the Pixels[] property, interrogate the hidden image. Where a pixel is black, adjust the red/green/blue settings of a corresponding pixel in the photograph. The following procedure MakeWatermark will do just that, placing the text where you want it.

{ ... }
type
  wmType = (wmTopLeft, wmTopCentre, wmTopRight, wmCentreLeft, wmCentre, wmCentreRight,
    wmBottomLeft, wmBottomCentre, wmBottomRight, wmRndXRndY, wmSetXRndY,
    wmRndXSetY, wmSetXSetY);

function Limit256(I: integer): integer;
begin
  if I < 0 then
    I := 0;
  if > 255 then
    I := 255;
  Limit256 := I;
end;

function ColourAdjust(Z, R, G, B: integer): integer;
var
  B1, G1, R1: integer;
begin
  {shl 1 = Multiply by 2}{TColor}
  R1 := Limit256((Z and $000000FF) + R);
  G1 := Limit256(((Z and $0000FF00) shr 8) + G);
  B1 := Limit256(((Z and $00FF0000) shr 16) + B);
  ColourAdjust := (B1 shl 16) + (G1 shl 8) + R1;
end;

procedure TForm1.MakeWatermark(const wmMode: wmType; var vImage: TImage;
  const Txt, FntName: string; FntStyle: TFontStyles; FntSize, X, Y, AdjRed, AdjGrn,
    AdjBlu: integer);
var
  I, J, IH, IW, TH, TW, Z: integer;
  TmpImg: TImage;
begin
  TmpImg := TImage.Create(Form1);
  TmpImg.Picture := nil;
  with TmpImg do
  begin
    Canvas.Pen.Color := clWhite;
    Canvas.Pen.Style := psSolid;
    Canvas.Font.Name := FntName;
    Canvas.Font.Color := clBlack;
    Canvas.Font.Style := FntStyle;
    if FntSize > 0 then
    begin
      Canvas.Font.Size := FntSize;
      TW := Canvas.TextWidth(Txt);
      TH := Canvas.TextHeight(Txt);
    end
    else
    begin
      TW := vImage.Width;
      TH := vImage.Height;
      I := 7;
      repeat
        inc(I);
        Canvas.Font.Size := I;
      until
        (Canvas.TextWidth(Txt) > TW) or (Canvas.TextHeight(Txt) > TH);
      dec(I);
      Canvas.Font.Size := I;
      TW := Canvas.TextWidth(Txt);
      TH := Canvas.TextHeight(Txt);
    end;
  end;
  TmpImg.Width := TW;
  TmpImg.Picture.Bitmap.Width := TW;
  TmpImg.Height := TH;
  TmpImg.Picture.Bitmap.Height := TH;
  TmpImg.Repaint;
  TmpImg.Canvas.TextOut(0, 0, Txt);
  TmpImg.Refresh;
  if TmpImg.Canvas.Pixels[0, 0] < 0 then
    ShowMessage('TmpImg pixel error.');
  if vImage.Picture.Bitmap.Canvas.Pixels[0, 0] < 0 then
    ShowMessage('vImage pixel error.');
  IW := vImage.Picture.Width;
  IH := vImage.Picture.Height;
  case wmMode of
    wmTopLeft:
      begin
        X := 0;
        Y := 0;
      end;
    wmTopCentre:
      begin
        X := IW div 2 - TW div 2;
        Y := 0;
      end;
    wmTopRight:
      begin
        X := IW - TW;
        Y := 0;
      end;
    wmCentreLeft:
      begin
        X := 0;
        Y := IH div 2 - TH div 2;
      end;
    wmCentre:
      begin
        X := IW div 2 - TW div 2;
        Y := IH div 2 - TH div 2;
      end;
    wmCentreRight:
      begin
        X := IW - TW;
        Y := IH div 2 - TH div 2;
      end;
    wmBottomLeft:
      begin
        X := 0;
        Y := IH - TH;
      end;
    wmBottomCentre:
      begin
        X := IW div 2 - TW div 2;
        Y := IH - TH;
      end;
    wmBottomRight:
      begin
        X := IW - TW;
        Y := IH - TH;
      end;
    wmRndXRndY:
      begin
        X := Random(IW - TW);
        Y := Random(IH - TH);
      end;
    wmSetXRndY:
      begin
        {X passed}
        Y := Random(IH - TH);
      end;
    wmRndXSetY:
      begin
        X := Random(IW - TW);
        {Y passed}
      end;
    wmSetXSetY:
      begin
        {X passed}
        {Y passed}
        DoNothing;
      end;
  end;
  for I := 0 to TW do
    for J := 0 to TH do
      if TmpImg.Canvas.Pixels[I, J] = clBlack then
      begin
        Z := vImage.Picture.Bitmap.Canvas.Pixels[I + X, J + Y];
        Z := ColourAdjust(Z, AdjRed, AdjGrn, AdjBlu);
        vImage.Picture.Bitmap.Canvas.Pixels[I + X, J + Y] := Z;
      end;
  TmpImg.Free;
end;

Call MakeWatermark with the following parameters:

watermark type eg wmTopLeft places the watermark in the top left of the image;
Image to be watermarked;
Text to be shown;
Name of the font to use;
style of the font eg [fsBold,fsItalic];
size of the text, use -1 for maximum size;
X and Y co-ordinates (used only in  wmSetXRndY, wmRndXSetY and wmSetXSetY, X being only used where type contains "SetX";
adjustments for Red, Green, and Blue, negative = darken.

If the image you wish to watermark objects to reading the pixels then an error message will be given and the procedure exited.


Solve 2:

If you sport a company (or other) logo, you might want to display it on your program's GUI, but unobtrusively and matching the user's color preferences. This can be done by displaying it as a "watermark" with colors only slightly different from the background color. All you have to do is to add a Timage with a 2- or 3-color bitmap. One color (usually the one at the lower left corner of the bitmap) becomes the transparent color (be sure to set Image.Transparent := True), the other one or two are changed at runtime to the watermark colors:

procedure TAboutBox.FormCreate(Sender: TObject);
var
  clWatermd: TColor;
  clWaterml: TColor;
begin
  {Set watermark colors slightly off parent}
  clWatermd := ColorToRGB(Panel1.Color) - $101010;
  clWaterml := ColorToRGB(Panel1.Color) + $080808;
  with Image2 do
  begin
    {Modify moon color to watermark color}
    Canvas.Brush.Color := clWaterml;
    Canvas.FloodFill(20, 20, clSilver, fsSurface);
    Canvas.FloodFill(51, 42, clSilver, fsSurface);
    {Modify wolf color to watermark color}
    Canvas.Brush.Color := clWatermd;
    Canvas.FloodFill(60, 60, clBlack, fsSurface);
  end;
end;

In the example above, clSilver in the original bitmap is displayed slightly brighter than the background, clBlack slightly darker. The point coordinates lie somewhere within the colored areas, separate areas must all be separately handled. On 256 color displays, the watermark colors may be 'slightly' off the desired effect, so use is only recommended on higher color resolutions.