mirror of
http://gitlab.expertsoft.com.ua/git/expertcad
synced 2026-01-11 22:45:39 +02:00
392 lines
12 KiB
ObjectPascal
392 lines
12 KiB
ObjectPascal
unit FillForm;
|
|
|
|
interface
|
|
|
|
uses
|
|
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
|
|
Dialogs, ExtCtrls, Buttons, ComCtrls, StdCtrls, Grids,PCTypesUtils,DrawObjects;
|
|
|
|
type
|
|
TfrmFill = class(TForm)
|
|
Button1: TButton;
|
|
Button2: TButton;
|
|
Button3: TButton;
|
|
PageControl1: TPageControl;
|
|
TabSheet1: TTabSheet;
|
|
TabSheet2: TTabSheet;
|
|
TabSheet3: TTabSheet;
|
|
Panel1: TPanel;
|
|
SpeedButton2: TSpeedButton;
|
|
SpeedButton1: TSpeedButton;
|
|
bColor: TShape;
|
|
fColor: TShape;
|
|
Bevel1: TBevel;
|
|
Bevel2: TBevel;
|
|
Bevel3: TBevel;
|
|
Bevel4: TBevel;
|
|
CheckBox1: TCheckBox;
|
|
HatchGrid: TStringGrid;
|
|
GradGrid: TStringGrid;
|
|
TextureGrid: TStringGrid;
|
|
Label1: TLabel;
|
|
Edit1: TEdit;
|
|
rbTSmall: TRadioButton;
|
|
rbTNormal: TRadioButton;
|
|
rbTBig: TRadioButton;
|
|
Label2: TLabel;
|
|
cldlg: TColorDialog;
|
|
bColorG: TShape;
|
|
procedure TextureGridDrawCell(Sender: TObject; ACol, ARow: Integer;
|
|
Rect: TRect; State: TGridDrawState);
|
|
procedure GradGridDrawCell(Sender: TObject; ACol, ARow: Integer;
|
|
Rect: TRect; State: TGridDrawState);
|
|
procedure SpeedButton2Click(Sender: TObject);
|
|
procedure SpeedButton1Click(Sender: TObject);
|
|
procedure GradGridSelectCell(Sender: TObject; ACol, ARow: Integer;
|
|
var CanSelect: Boolean);
|
|
procedure TextureGridSelectCell(Sender: TObject; ACol, ARow: Integer;
|
|
var CanSelect: Boolean);
|
|
procedure HatchGridSelectCell(Sender: TObject; ACol, ARow: Integer;
|
|
var CanSelect: Boolean);
|
|
Procedure CreateHatchMetafiles;
|
|
procedure HatchGridDrawCell(Sender: TObject; ACol, ARow: Integer;
|
|
Rect: TRect; State: TGridDrawState);
|
|
procedure FormCreate(Sender: TObject);
|
|
procedure Button3Click(Sender: TObject);
|
|
procedure Button1Click(Sender: TObject);
|
|
procedure Button2Click(Sender: TObject);
|
|
procedure CheckBox1Click(Sender: TObject);
|
|
procedure PageControl1Change(Sender: TObject);
|
|
private
|
|
{ Private declarations }
|
|
PCad: TObject;
|
|
Procedure Apply;
|
|
public
|
|
{ Public declarations }
|
|
SelFigure : TFigure;
|
|
FillType: TFillType;
|
|
HatchStyle: THatchStyle;
|
|
GradStyle: TGradStyle;
|
|
TextureStyle: TTextureStyle;
|
|
FillSize: Double;
|
|
TextureSize: Integer;
|
|
BackColor : TColor;
|
|
ForeColor : TColor;
|
|
Procedure SetControl(CadControl:TObject);
|
|
Procedure Sync;
|
|
end;
|
|
|
|
var
|
|
frmFill: TfrmFill;
|
|
HatchWmf: Array [1..1000] of TMetafile;
|
|
OnApply : TNotifyEvent;
|
|
|
|
implementation
|
|
|
|
uses PCDrawing;
|
|
|
|
{$R *.dfm}
|
|
|
|
procedure TfrmFill.TextureGridDrawCell(Sender: TObject; ACol,
|
|
ARow: Integer; Rect: TRect; State: TGridDrawState);
|
|
var index: Integer;
|
|
xBmp: TBitmap;
|
|
begin
|
|
TextureGrid.Canvas.Brush.Style := bsSolid;
|
|
TextureGrid.Canvas.Brush.Color := clWhite;
|
|
TextureGrid.Canvas.FillRect(Rect);
|
|
index := (arow*6)+acol+1;
|
|
if index <= ord(txtMediumWood) then begin
|
|
xbmp := GetTextureBitmap(index);
|
|
TextureGrid.Canvas.CopyRect(Classes.Rect(rect.left+2,rect.top+2,rect.Right-2,rect.Bottom-2),
|
|
xBmp.Canvas,Classes.Rect(2,2,46,46));
|
|
if gdSelected in State then begin
|
|
TextureGrid.Canvas.Brush.Style := bsClear;
|
|
TextureGrid.Canvas.Pen.Color := clRed;
|
|
TextureGrid.Canvas.Pen.Width := 3;
|
|
TextureGrid.Canvas.Rectangle(Classes.Rect(rect.left+1,rect.top+1,rect.Right-1,rect.Bottom-1));
|
|
end;
|
|
xBmp.Free;
|
|
end;
|
|
end;
|
|
|
|
procedure TfrmFill.GradGridDrawCell(Sender: TObject; ACol, ARow: Integer;
|
|
Rect: TRect; State: TGridDrawState);
|
|
var index: Integer;
|
|
xBmp: TBitmap;
|
|
begin
|
|
GradGrid.Canvas.Brush.Style := bsSolid;
|
|
GradGrid.Canvas.Brush.Color := clWhite;
|
|
GradGrid.Canvas.FillRect(Rect);
|
|
index := (arow*6)+acol+1;
|
|
xBmp := nil;
|
|
if index <= ord(gsMirrored) then begin
|
|
MakeGradBitmap(bColorG.Brush.Color,fColor.Brush.Color,TGradStyle(index),xBmp);
|
|
GradGrid.Canvas.StretchDraw(Classes.Rect(rect.left+2,rect.top+2,rect.Right-2,rect.Bottom-2),xBmp);
|
|
if gdSelected in State then begin
|
|
GradGrid.Canvas.Brush.Style := bsClear;
|
|
GradGrid.Canvas.Pen.Color := clRed;
|
|
GradGrid.Canvas.Pen.Width := 3;
|
|
GradGrid.Canvas.Rectangle(Classes.Rect(rect.left+1,rect.top+1,rect.Right-1,rect.Bottom-1));
|
|
end;
|
|
xBmp.Free;
|
|
end;
|
|
end;
|
|
|
|
procedure TfrmFill.SpeedButton2Click(Sender: TObject);
|
|
begin
|
|
clDlg.Color := bColor.Brush.Color;
|
|
if clDlg.Execute then begin
|
|
if PageControl1.TabIndex = 0 then begin
|
|
bColor.Brush.Color := clDlg.Color;
|
|
end else begin
|
|
bColorG.Brush.Color := clDlg.Color;
|
|
end;
|
|
HatchGrid.Refresh;
|
|
GradGrid.Refresh;
|
|
Apply;
|
|
end;
|
|
end;
|
|
|
|
procedure TfrmFill.SpeedButton1Click(Sender: TObject);
|
|
begin
|
|
clDlg.Color := fColor.Brush.Color;
|
|
if clDlg.Execute then begin
|
|
fColor.Brush.Color := clDlg.Color;
|
|
HatchGrid.Refresh;
|
|
GradGrid.Refresh;
|
|
Apply;
|
|
end;
|
|
|
|
end;
|
|
|
|
procedure TfrmFill.GradGridSelectCell(Sender: TObject; ACol, ARow: Integer;
|
|
var CanSelect: Boolean);
|
|
begin
|
|
if (acol = 5) and (arow = 3) then begin
|
|
CanSelect := False;
|
|
end else begin
|
|
canSelect := True;
|
|
end;
|
|
end;
|
|
|
|
procedure TfrmFill.TextureGridSelectCell(Sender: TObject; ACol,
|
|
ARow: Integer; var CanSelect: Boolean);
|
|
var index: Integer;
|
|
begin
|
|
index := (arow*6)+acol+1;
|
|
if index > 24 then begin
|
|
CanSelect := False;
|
|
end else CanSelect := True;
|
|
end;
|
|
|
|
procedure TfrmFill.HatchGridSelectCell(Sender: TObject; ACol,
|
|
ARow: Integer; var CanSelect: Boolean);
|
|
var index: Integer;
|
|
begin
|
|
index := (arow*6)+acol+1;
|
|
if index > 11 then begin
|
|
CanSelect := False;
|
|
end else CanSelect := True;
|
|
end;
|
|
|
|
procedure TfrmFill.CreateHatchMetafiles;
|
|
var i: Integer;
|
|
figure: TRectangle;
|
|
begin
|
|
for i := 1 to 11 do begin
|
|
figure := TRectangle.create(0,0,12,12,2,ord(psSolid),clBlack,ord(bsClear),clBlack,0,PCTypesUtils.mydsNormal,TComponent(PCad));
|
|
figure.Brs := ord(bsExHatch);
|
|
figure.ExHatchStyle := THatchStyle(i);
|
|
figure.ResetRegion;
|
|
HatchWmf[i] := TPCdrawing(PCad).FigureAsWmf(figure.Handle,false);
|
|
figure.Free;
|
|
//HatchWmf[i].SaveToFile('c:\hatch'+inttostr(i)+'.wmf');
|
|
end;
|
|
end;
|
|
|
|
procedure TfrmFill.SetControl(CadControl: TObject);
|
|
begin
|
|
if PCad <> CadControl then begin
|
|
PCad := CadControl;
|
|
if CadControl <> nil then CreateHatchMetafiles;
|
|
end;
|
|
end;
|
|
|
|
procedure TfrmFill.HatchGridDrawCell(Sender: TObject; ACol, ARow: Integer;
|
|
Rect: TRect; State: TGridDrawState);
|
|
var index: Integer;
|
|
begin
|
|
HatchGrid.Canvas.Brush.Style := bsSolid;
|
|
HatchGrid.Canvas.Brush.Color := clWhite;
|
|
HatchGrid.Canvas.FillRect(Rect);
|
|
index := (arow*6)+acol+1;
|
|
if index <= 11 then begin
|
|
|
|
HatchGrid.Canvas.StretchDraw(Classes.Rect(rect.left+2,rect.top+2,rect.Right-2,rect.Bottom-2),HatchWmf[index]);
|
|
if gdSelected in State then begin
|
|
HatchGrid.Canvas.Brush.Style := bsClear;
|
|
HatchGrid.Canvas.Pen.Color := clRed;
|
|
HatchGrid.Canvas.Pen.Width := 3;
|
|
HatchGrid.Canvas.Rectangle(Classes.Rect(rect.left+1,rect.top+1,rect.Right-1,rect.Bottom-1));
|
|
end;
|
|
end;
|
|
|
|
end;
|
|
|
|
procedure TfrmFill.FormCreate(Sender: TObject);
|
|
begin
|
|
OnApply := nil;
|
|
end;
|
|
|
|
procedure TfrmFill.Button3Click(Sender: TObject);
|
|
begin
|
|
Apply;
|
|
end;
|
|
|
|
procedure TfrmFill.Apply;
|
|
var index: Integer;
|
|
begin
|
|
if PageControl1.TabIndex = 0 then begin
|
|
FillType := fsHatch;
|
|
index := HatchGrid.Row*6+HatchGrid.Col+1;
|
|
if index < 1 then index := 1;
|
|
HatchStyle := THatchStyle(index);
|
|
FillSize := MakeFloat(Edit1.Text,2);
|
|
BackColor := bColor.Brush.Color;
|
|
if CheckBox1.Checked then BackColor := clNone;
|
|
end else if PageControl1.TabIndex = 1 then begin
|
|
FillType := fsGradient;
|
|
index := GradGrid.Row*6+GradGrid.Col+1;
|
|
if index < 1 then index := 1;
|
|
GradStyle := TGradStyle(index);
|
|
BackColor := bColorG.Brush.Color;
|
|
end else if PageControl1.TabIndex = 2 then begin
|
|
FillType := fsTexture;
|
|
index := TextureGrid.Row*6+TextureGrid.Col+1;
|
|
if index < 1 then index := 1;
|
|
TextureStyle := TTextureStyle(index);
|
|
if rbTSmall.Checked then TextureSize := 1
|
|
else if rbTNormal.Checked then TextureSize := 2
|
|
else if rbTBig.Checked then TextureSize := 3;
|
|
end;
|
|
ForeColor := fColor.Brush.Color;
|
|
|
|
|
|
if assigned(OnApply) then OnApply(Self);
|
|
end;
|
|
|
|
procedure TfrmFill.Button1Click(Sender: TObject);
|
|
begin
|
|
Apply;
|
|
Self.Close;
|
|
end;
|
|
|
|
procedure TfrmFill.Button2Click(Sender: TObject);
|
|
begin
|
|
Self.Close;
|
|
end;
|
|
|
|
procedure TfrmFill.Sync;
|
|
var index,aCol,aRow: Integer;
|
|
begin
|
|
FillType := GetFillType(SelFigure.brs);
|
|
if SelFigure.brs = bsExHatch then
|
|
HatchStyle := SelFigure.ExHatchStyle
|
|
else
|
|
HatchStyle := GetHatchStyle(SelFigure.brs);
|
|
|
|
if SelFigure.brs = bsExGrad then
|
|
GradStyle := SelFigure.ExGradStyle
|
|
else
|
|
GradStyle := GetGradStyle(SelFigure.brs);
|
|
|
|
if SelFigure.brs = bsExTexture then
|
|
TextureStyle := SelFigure.ExTextureStyle
|
|
else
|
|
TextureStyle := GetTextureStyle(SelFigure.brs);
|
|
|
|
FillSize := SelFigure.ExHatchStepSize;
|
|
TextureSize := SelFigure.ExTextureSize;
|
|
BackColor := SelFigure.ExFillBackColor;
|
|
ForeColor := SelFigure.Brc;
|
|
|
|
if FillType = fsHatch then begin
|
|
PageControl1.TabIndex := 0;
|
|
index := ord(HatchStyle)-1;
|
|
aRow := Trunc(index / 6);
|
|
aCol := index - (aRow*6);
|
|
HatchGrid.Col := aCol;
|
|
HatchGrid.Row := aRow;
|
|
Edit1.Text := FloatToStr(FillSize);
|
|
BColor.Brush.Color := BackColor;
|
|
if BackColor = clNone then
|
|
BColorG.Brush.Color := clWhite
|
|
else
|
|
BColorG.Brush.Color := BackColor;
|
|
end else if FillType = fsGradient then begin
|
|
PageControl1.TabIndex := 1;
|
|
index := ord(GradStyle)-1;
|
|
aRow := Trunc(index / 6);
|
|
aCol := index - (aRow*6);
|
|
GradGrid.Col := aCol;
|
|
GradGrid.Row := aRow;
|
|
if BackColor = clNone then
|
|
BColorG.Brush.Color := clWhite
|
|
else
|
|
BColorG.Brush.Color := BackColor;
|
|
BColor.Brush.Color := BackColor;
|
|
end else if FillType = fsTexture then begin
|
|
PageControl1.TabIndex := 2;
|
|
index := ord(TextureStyle)-1;
|
|
aRow := Trunc(index / 6);
|
|
aCol := index - (aRow*6);
|
|
TextureGrid.Col := aCol;
|
|
TextureGrid.Row := aRow;
|
|
rbTSmall.Checked := (TextureSize <= 1);
|
|
rbTNormal.Checked := (TextureSize = 2);
|
|
rbTBig.Checked := (TextureSize >= 3);
|
|
BColor.Brush.Color := BackColor;
|
|
if BackColor = clNone then
|
|
BColorG.Brush.Color := clWhite
|
|
else
|
|
BColorG.Brush.Color := BackColor;
|
|
end else begin
|
|
PageControl1.TabIndex := 0;
|
|
HatchGrid.Col := 0;
|
|
HatchGrid.Row := 0;
|
|
BColor.Brush.Color := BackColor;
|
|
if BackColor = clNone then
|
|
BColorG.Brush.Color := clWhite
|
|
else
|
|
BColorG.Brush.Color := BackColor;
|
|
end;
|
|
Panel1.Visible := (PageControl1.TabIndex <> 2);
|
|
bColor.Visible := (PageControl1.TabIndex = 0);
|
|
bColorG.Visible := (PageControl1.TabIndex = 1);
|
|
CheckBox1.Visible := (PageControl1.TabIndex = 0);
|
|
FColor.Brush.Color := ForeColor;
|
|
CheckBox1.Checked := (BackColor = clNone);
|
|
if CheckBox1.Checked then bColor.Brush.Style := bsClear else bColor.Brush.Style := bsSolid;
|
|
end;
|
|
|
|
procedure TfrmFill.CheckBox1Click(Sender: TObject);
|
|
begin
|
|
if CheckBox1.Checked then backColor := clNone else backColor := clWhite;
|
|
bColor.Brush.Color := BackColor;
|
|
if CheckBox1.Checked then bColor.Brush.Style := bsClear else bColor.Brush.Style := bsSolid;
|
|
end;
|
|
|
|
procedure TfrmFill.PageControl1Change(Sender: TObject);
|
|
begin
|
|
CheckBox1.Visible := (PageControl1.TabIndex = 0);
|
|
if pagecontrol1.TabIndex > 0 then begin
|
|
bColor.Brush.Style := bsSolid;
|
|
end;
|
|
Panel1.Visible := (PageControl1.TabIndex <> 2);
|
|
bColor.Visible := (PageControl1.TabIndex = 0);
|
|
bColorG.Visible := (PageControl1.TabIndex = 1);
|
|
end;
|
|
|
|
end.
|