frmmain.pas

Apprehend Screen Capture Component Version 4.2 A non-visible component to capture images. Freeware w

    Result.BottomRight := ControlToBitmap(Point
      (RBLayer.Location.BottomRight));
  end;
end;

//To crop, use this result as the srcRect, and the Image.Bitmap as the
//srcBitmap in:

procedure CropBitmap(const srcRect: TRect; const srcBitmap: TBitmap32; dstBitmap:
  TBitmap32);
begin
  with srcRect do
    dstBitmap.SetSize(Right - Left, Bottom - Top);
  with dstBitmap do
    Draw(Rect(0, 0, Width, Height), srcRect, srcBitmap);
end;

procedure TFormMain.EditCrop1Execute(Sender: TObject);
var
  SrcRect: TRect;
  SrcBmp, DestBmp: TBitmap32;
begin
  // If image present...
  if Assigned(TImage32(PageControl1.ActivePage.Tag).Bitmap) then
  begin
    with RBLayer do
    begin
      DestBmp := TBitmap32.Create;
      try
        SrcBmp := TBitmap32.Create;
        try
          SrcBmp.Assign(TImage32(PageControl1.ActivePage.Tag).Bitmap);
          SrcRect := ApplyCropSettings;
          CropBitmap(SrcRect, SrcBmp, DestBmp);
          AddControls(Sender);
              // Set the caption of the tabsheet
          TabSheet.Caption := Format('Untitled%d', [PageControl1.ActivePage.PageIndex]);
              // set tabsheet glyph
          Tabsheet.ImageIndex := 6;
          TImage32(PageControl1.ActivePage.Tag).Bitmap.Assign(DestBmp);
          TImage32(PageControl1.ActivePage.Tag).Refresh;
          TImgView32(PageControl1.ActivePage.Tag).Hint := 'Height: ' + IntToStr(TImgView32(PageControl1.ActivePage.Tag).Bitmap.Height) +
            ' pixels' + '  Width: ' + IntToStr(TImgView32(PageControl1.ActivePage.Tag).Bitmap.Width) +
            ' pixels';
          StatusBar1.Panels[1].Text := 'Height: ' + IntToStr(TImage32(PageControl1.ActivePage.Tag).Bitmap.Height) +
           ' pixels' + '  Width: ' + IntToStr(TImgView32(PageControl1.ActivePage.Tag).Bitmap.Width) +
           ' pixels';
        finally SrcBmp.Free; end;
      finally DestBmp.Free; end;
    end;
  end;
end;

procedure TFormMain.SetSelection(Value: TPositionedLayer);
begin
  if Value <> FSelection then
  begin
    if RBLayer <> nil then
    begin
      RBLayer.ChildLayer := nil;
      RBLayer.LayerOptions := LOB_NO_UPDATE; // disable both LOB_GDI_OVERLAY and LOB_MOUSE_EVENTS
      pnlBitmapLayer.Visible := False;
      pnlMagn.Visible := False;
      TImage32(PageControl1.ActivePage.Tag).Invalidate;
    end;

    FSelection := Value;

    if Value <> nil then
    begin
      if RBLayer = nil then
      begin
        RBLayer := TRubberBandLayer.Create(TImage32(PageControl1.ActivePage.Tag).Layers);
        RBLayer.MinHeight := 1;
        RBLayer.MinWidth := 1;
      end
      else RBLayer.BringToFront;
      RBLayer.ChildLayer := Value;
      RBLayer.LayerOptions := LOB_VISIBLE or LOB_MOUSE_EVENTS or LOB_NO_UPDATE;
      RBLayer.OnMouseDown := RBMouseDown;

      if Value is TBitmapLayer then
        with TBitmapLayer(Value) do
        begin
          pnlBitmapLayer.Visible := True;
          LayerOpacity.Position := Bitmap.MasterAlpha;
          LayerInterpolate.Checked := Bitmap.StretchFilter = sfLinear;
        end
      else if Value.Tag = 2 then
      begin
        // tag = 2 for magnifiers
        pnlMagn.Visible := True;
      end;
    end;
  end;
end;

procedure TFormMain.LayerMouseDown(Sender: TObject; Buttons: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  if Sender <> nil then Selection := TPositionedLayer(Sender);
end;

function TFormMain.CreatePositionedLayer: TPositionedLayer;
begin
  Result := TPositionedLayer.Create(TImage32(PageControl1.ActivePage.Tag).Layers);
  Result.Location := FloatRect(0, 0, 64, 64);
  Result.Cursor := crHandPoint;
  Result.Scaled := True;
  Result.MouseEvents := True;
  Result.OnMouseDown := LayerMouseDown;
end;

function TFormMain.CreateRubberbandLayer: TRubberbandLayer;
begin
  Result := TRubberbandLayer.Create(TImage32(PageControl1.ActivePage.Tag).Layers);
  Result.Location := FloatRect(0, 0, 100, 100);
  Result.Cursor := crHandPoint;
  Result.Tag := 1;
  Selection := Result;
end;

procedure TFormMain.PaintMagnifierHandler(Sender: TObject; Buffer: TBitmap32);
var
  Magnification, Rotation: Single;
  SrcRect, DstRect: TFloatRect;
  R: TRect;
  T: TAffineTransformation;
  B: TBitmap32;
  W2, H2: Single;
  I: Integer;
begin
  if Sender is TPositionedLayer then
    with TPositionedLayer(Sender) do
    begin
      Magnification := Power(10, (MagnMagnification.Position / 50));
      Rotation := -MagnRotation.Position;
      Cursor := crHandPoint;
      DstRect := GetAdjustedLocation;
      R := Rect(DstRect);
      B := TBitmap32.Create;
      try
        with R do
        begin
          B.SetSize( Right - Left, Bottom - Top);
          W2 := 100;
          H2 := 100;
        end;

        SrcRect := DstRect;
        with SrcRect do
        begin
          Left := Left - H2;
          Right := Right + H2;
          Top := Top - W2;
          Bottom := Bottom + W2;
        end;

        T := TAffineTransformation.Create;
        try
          T.SrcRect := SrcRect;
          T.Translate(-R.Left, -R.Top);

          T.Translate(-W2, -H2);
          T.Scale(Magnification, Magnification);
          T.Rotate(0, 0, Rotation);
          T.Translate(W2, H2);

          if MagnInterpolate.Checked then
          begin
            Buffer.BeginUpdate;
            Buffer.StretchFilter := sfLinear;
            Transform(B, Buffer, T);
            Buffer.StretchFilter := sfNearest;
            Buffer.EndUpdate;
          end
          else
            Transform(B, Buffer, T);

          B.ResetAlpha;
          B.DrawMode := dmBlend;
          B.MasterAlpha := MagnOpacity.Position;
          B.DrawTo(Buffer, R);

          // draw frame
          for I := 0 to 4 do
          begin
            with R do Buffer.RaiseRectTS(Left, Top, Right, Bottom, 35 - I * 8);
            InflateRect(R, -1, -1);
          end;
        finally
          T.Free;
        end;
      finally
        B.Free;
      end;
    end;
end;

procedure TFormMain.RBMouseDown(Sender: TObject; Buttons: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  // this event handler is called after the mouse button is pressed on top
  // of the rubber band layer
  with RBLayer do
    //if ssCtrl in Shift then ResizeOptions := ResizeOptions + [rroSymmetrical]
    //else ResizeOptions := ResizeOptions - [rroSymmetrical];
end;

procedure TFormMain.MagnOpacityChange(Sender: TObject);
begin
  TImage32(PageControl1.ActivePage.Tag).Invalidate;
end;

procedure TFormMain.MagnMagnificationChange(Sender: TObject);
begin
  TImage32(PageControl1.ActivePage.Tag).Invalidate;
end;

procedure TFormMain.MagnRotationChange(Sender: TObject);
begin
  TImage32(PageControl1.ActivePage.Tag).Invalidate;
end;

procedure TFormMain.ScaleComboChange(Sender: TObject);
var
  S: string;
  I: Integer;
begin
  S := ScaleCombo.Text;
  S := StringReplace(S, '%', '', [rfReplaceAll]);
  S := StringReplace(S, ' ', '', [rfReplaceAll]);
  if S = '' then Exit;
  I := StrToIntDef(S, -1);
  if (I < 1) or (I > 2000) then I := Round(TImage32(PageControl1.ActivePage.Tag).Scale * 100)
  else TImage32(PageControl1.ActivePage.Tag).Scale := I / 100;
  ScaleCombo.Text := IntToStr(I) + '%';
  ScaleCombo.SelStart := Length(ScaleCombo.Text) - 1;
end;

procedure TFormMain.ImageInterpolateClick(Sender: TObject);
const
  STRETCH_FILTER: array[Boolean] of TStretchFilter = (sfNearest, sfLinear);
begin
  TImage32(PageControl1.ActivePage.Tag).Bitmap.StretchFilter := STRETCH_FILTER[ImageInterpolate.Checked];
end;

procedure TFormMain.LayerOpacityChange(Sender: TObject);
begin
  if Selection is TBitmapLayer then
    TBitmapLayer(Selection).Bitmap.MasterAlpha := LayerOpacity.Position;
end;

procedure TFormMain.LayerInterpolateClick(Sender: TObject);
const
  STRETCH_FILTER: array[Boolean] of TStretchFilter = (sfNearest, sfLinear);
begin
  if Selection is TBitmapLayer then
  begin
    TBitmapLayer(Selection).Bitmap.StretchFilter := STRETCH_FILTER[LayerInterpolate.Checked];
  end;
end;

procedure TFormMain.CroppedClick(Sender: TObject);
begin
  if Selection is TBitmapLayer then
    TBitmapLayer(Selection).Cropped := Cropped.Checked;
end;

procedure TFormMain.LayerRescaleClick(Sender: TObject);
var
  T: TBitmap32;
begin
  // resize the layer's bitmap to the size of the layer
  if Selection is TBitmapLayer then
    with TBitmapLayer(Selection) do
    begin
      T := TBitmap32.Create;
      T.Assign(Bitmap);
      with Rect(Location) do
        Bitmap.SetSize(Right - Left, Bottom - Top);
      T.StretchFilter := sfLinear;
      T.DrawMode := dmOpaque;
      T.DrawTo(Bitmap, Rect(0, 0, Bitmap.Width, Bitmap.Height));
      T.Free;
      LayerResetScaleClick(Self);
    end;
end;

procedure TFormMain.LayerResetScaleClick(Sender: TObject);
var
  L: TFloatRect;
begin
  // resize the layer to the size of its bitmap
  if Selection is TBitmapLayer then
    with RBLayer, TBitmapLayer(Selection).Bitmap do
    begin
      L := Location;
      L.Right := L.Left + Width;
      L.Bottom := L.Top + Height;
      Location := L;
      Changed;
    end;
end;

procedure TFormMain.SelectionDelete1Execute(Sender: TObject);
var
  ALayer: TPositionedLayer;
begin
  if Selection <> nil then
  begin
    ALayer := Selection;
    Selection := nil;
    ALayer.Free;
  end;
  if RBLayer <> nil then
    RBLayer.Free;
end;

procedure TFormMain.SelectionMagnifier1Execute(Sender: TObject);
var
  L: TPositionedLayer;
  ALayer: TPositionedLayer;
begin
  SelectionMagnifier1.Checked := not SelectionMagnifier1.Checked;
  if SelectionMagnifier1.Checked then begin
    L := CreatePositionedLayer;
    L.OnPaint := PaintMagnifierHandler;
    L.Tag := 2;
    Selection := L;
    L.Cursor := crHandPoint;
  end
  else
  begin
    if Selection <> nil then
    begin
      ALayer := Selection;
      Selection := nil;
      ALayer.Free;
    end;
  end;
end;

procedure TFormMain.SelectionRubberband1Execute(Sender: TObject);
begin
  RBLayer := CreateRubberbandLayer;
end;

procedure TFormMain.ImgViewMouseDown(Sender: TObject;
  Button: TMouseButton; Shift: TShiftState; X, Y: Integer;
  Layer: TCustomLayer);
begin
  if PageControl1.PageCount <> 0 then
  begin
    Screen.Cursor := crCross;
    if Assigned(TImage32(PageControl1.ActivePage.Tag)) then
    begin
      Filename := ExpandFilename(PageControl1.ActivePage.Caption);
      Hint := 'Height: ' + IntToStr(TImage32(PageControl1.ActivePage.Tag).Bitmap.Height) +
        ' pixels' + '  Width: ' + IntToStr(TImage32(PageControl1.ActivePage.Tag).Bitmap.Width) +
        ' pixels';
    end;
  end;
end;

procedure TFormMain.ImgViewMouseMove(Sender: TObject;
  Shift: TShiftState; X, Y: Integer; Layer: TCustomLayer);
begin
  StatusBar1.Panels[2].Text := '(' + IntToStr(X) + ',' + IntToStr(Y) + ')';
end;

procedure TFormMain.ImgViewMouseUp(Sender: TObject;
  Button: TMouseButton; Shift: TShiftState; X, Y: Integer;
  Layer: TCustomLayer);
begin
  if PageControl1.PageCount <> 0 then
  begin
    Screen.Cursor := crDefault;
    bLeftDown := false;
    StatusBar1.Panels[2].Text := '';
  end;
end;

procedure TFormMain.ImgViewDblClick(Sender: TObject);
begin
  if PageControl1.PageCount <> 0 then
  begin
    try
      FullScreen := TFullScreen.Create(Self);
      Screen.Cursor := crDefault;
      // copy image to fullscreen image}
      FullScreen.Image32.Bitmap.Assign(TImage32(PageControl1.ActivePage.Tag).Bitmap);
      FullScreen.ScrollBox1.HorzScrollBar.Range := TImage32(PageControl1.ActivePage.Tag).Bitmap.Width;
      FullScreen.ScrollBox1.VertScrollBar.Range := TImage32(PageControl1.ActivePage.Tag).Bitmap.Height;
      // show the image fullscreen}
      FullScreen.Showmodal;
      Screen.Cursor := crDefault;
    except
      FullScreen.Free;
    end;
  end;
end;

procedure TFormMain.ScaleBarChange(Sender: TObject);
var
  NewScale: Single;
begin
  NewScale := Power(10, ScaleBar.Position / 100);
  ScaleBar.Repaint; // update the scale bar before the image is repainted
  TImage32(PageControl1.ActivePage.Tag).Scale := NewScale;
end;

end.