[Retboon]

Помогите сократить программный код

Код:

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, Buttons, ExtCtrls, ComCtrls, XPMan;

type
TForm1 = class(TForm)
Panel1: TPanel;
BtnRectangle: TBitBtn;
BtnEllipse: TBitBtn;
BtnRoundRect: TBitBtn;
Panel2: TPanel;
editRed: TEdit;
editGreen: TEdit;
editBlue: TEdit;
RedUpDown: TUpDown;
GreenUpDown: TUpDown;
Label1: TLabel;
Label2: TLabel;
Label3: TLabel;
sbRedScroll: TScrollBar;
sbGreenScroll: TScrollBar;
sbBlueScroll: TScrollBar;
shShape: TShape;
StatusBar1: TStatusBar;
blueUpDown: TUpDown;
XPManifest1: TXPManifest;
procedure FormCreate(Sender: TObject);
procedure FGK(n: TObject);
procedure sbScrollChange(Sender: TObject);
procedure BtnClick(Sender: TObject);
procedure editChange(Sender: TObject);
private
RedColor,GreenColor,BlueColor: TColor;
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;
implementation

{$R *.dfm}

procedure TForm1.FormCreate(Sender: TObject);
begin
RedColor:=127;
redUpDown.Position:=RedColor;
sbRedScroll.Position:=RedColor;
editRed.Text:=IntToStr(RedColor);

GreenColor:=127;
greenUpDown.Position:=GreenColor;
sbGreenScroll.Position:=GreenColor;
editGreen.Text:=IntToStr(GreenColor );

BlueColor:=127;
blueUpDown.Position:=BlueColor;
sbBlueScroll.Position:=BlueColor;
editBlue.Text:=IntToStr(BlueColor);

shShape.Brush.Color:=RGB(RedColor,G reenColor,BlueColor);
end;

procedure TForm1.BtnClick(Sender: TObject);
begin
case (sender as TBitBtn).tag of
0: shShape.Shape:=stRectangle;
1: shShape.Shape:=stEllipse;
2: shShape.Shape:=stRoundRect;
end;
end;

procedure TForm1.editChange(Sender: TObject);
var
S: String;
begin
if (sender as TEdit).Name='editred' then
begin
S:=(sender as TEdit).Text;
while Pos(' ',S)>0 do Delete(S,Pos(' ',S),1);
if S='' then Exit;
RedColor:=StrToInt(S);
if RedColor<0 then RedColor:=0;
if RedColor>255 then RedColor:=255;
sbRedScroll.Position:=RedColor;
RedUpDown.Position:=RedColor;
shShape.Brush.Color:=RGB(RedColor,G reenColor,BlueColor);
end;
if (sender as TEdit).Name='editgreen' then
begin
S:=editGreen.Text;
while Pos(' ',S)>0 do Delete(S,Pos(' ',S),1);
if S='' then Exit;
greenColor:=StrToInt(S);
if GreenColor<0 then GreenColor:=0;
if GreenColor>255 then GreenColor:=255;
sbGreenScroll.Position:=GreenColor;
GreenUpDown.Position:=GreenColor;
shShape.Brush.Color:=RGB(RedColor,G reenColor,BlueColor);
end;
if (sender as TEdit).Name='editblue' then
begin
S:=editBlue.Text;
while Pos(' ',S)>0 do Delete(S,Pos(' ',S),1);
if S='' then Exit;
blueColor:=StrToInt(S);
if BlueColor<0 then BlueColor:=0;
if BlueColor>255 then BlueColor:=255;
sbBlueScroll.Position:=BlueColor;
BlueUpDown.Position:=BlueColor;
shShape.Brush.Color:=RGB(RedColor,G reenColor,BlueColor);
end;
end;

procedure TForm1.sbScrollChange(Sender: TObject);
begin
if (sender as TScrollBar).Name='sbRedScroll' then
begin
RedColor:=sbRedScroll.Position;
RedUpDown.Position:=RedColor;
editRed.Text:=IntToStr(RedColor);
shShape.Brush.Color:=RGB(RedColor,G reenColor,BlueColor);
FGK(sender);
end;
if (sender as TScrollBar).Name='sbGreenScroll' then
begin
GreenColor:=sbGreenScroll.Position;
GreenUpDown.Position:=GreenColor;
editGreen.Text:=IntToStr(GreenColor );
shShape.Brush.Color:=RGB(RedColor,G reenColor,BlueColor);
FGK(sender)
end;
if (sender as TScrollBar).Name='sbBlueScroll' then
begin
BlueColor:=sbBlueScroll.Position;
BlueUpDown.Position:=BlueColor;
editBlue.Text:=IntToStr(BlueColor);
shShape.Brush.Color:=RGB(RedColor,G reenColor,BlueColor);
FGK(sender)
end;

end;

procedure TForm1.FGK(n: TObject);
begin
case (n as TScrollBar).Position of
1..50: StatusBar1.Panels[(n as TScrollBar).tag].Text:= 'Насыщенние цвета отсутсвует'; 
51..100: StatusBar1.Panels[(n as TScrollBar).tag].Text:= 'Слабо насыщенный';
101..150: StatusBar1.Panels[(n as TScrollBar).tag].Text:= 'Слабо насыщенный';
151..200: StatusBar1.Panels[(n as TScrollBar).tag].Text:= 'Сильно насыщенный';
201..255: StatusBar1.Panels[(n as TScrollBar).tag].Text:= 'Насыщеннеее максимальное';
end;
end;

end.

Админ: Пользуемся тегами при оформлении кода!

[lmikle]

Ну, только вот разве так:

Код:

unit Unit1;
 
interface
 
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, Buttons, ExtCtrls, ComCtrls, XPMan;
 
type
TForm1 = class(TForm)
Panel1: TPanel;
BtnRectangle: TBitBtn;
BtnEllipse: TBitBtn;
BtnRoundRect: TBitBtn;
Panel2: TPanel;
editRed: TEdit;
editGreen: TEdit;
editBlue: TEdit;
RedUpDown: TUpDown;
GreenUpDown: TUpDown;
Label1: TLabel;
Label2: TLabel;
Label3: TLabel;
sbRedScroll: TScrollBar;
sbGreenScroll: TScrollBar;
sbBlueScroll: TScrollBar;
shShape: TShape;
StatusBar1: TStatusBar;
blueUpDown: TUpDown;
XPManifest1: TXPManifest;
procedure FormCreate(Sender: TObject);
procedure FGK(n: TObject);
procedure sbScrollChange(Sender: TObject);
procedure BtnClick(Sender: TObject);
procedure editChange(Sender: TObject);
private
RedColor,GreenColor,BlueColor: TColor;
{ Private declarations }
public
{ Public declarations }
end;
 
var
Form1: TForm1;
implementation
 
{$R *.dfm}
 
procedure TForm1.FormCreate(Sender: TObject);

  procedure SetCntrls(AUpDown : TUpDown; AScrollBar : TScrollBar; AEdit : TEdit; AValue : TColor);
  begin
    AupDown.Position := AValue;
    AScrollBar.Position := AValue;
    AEdit.Text := IntToStr(AValue);
  end;
  
begin
  RedColor := 127;
  SetCntrls(redUpDown, sbRedScroll, editRed, RedColor);
 
  GreenColor := 127;
  SetCntrls(greenUpDown, sbGreenScroll, editGreen, GreenColor);
 
  BlueColor := 127;
  SetCntrls(blueUpDown, sbBlueScroll, editBlue, BlueColor);
 
  shShape.Brush.Color:=RGB(RedColor,G reenColor,BlueColor);
end;
 
procedure TForm1.BtnClick(Sender: TObject);
begin
  case (sender as TBitBtn).tag of
    0: shShape.Shape:=stRectangle;
    1: shShape.Shape:=stEllipse;
    2: shShape.Shape:=stRoundRect;
  end;
end;
 
procedure TForm1.editChange(Sender: TObject);

  procedure UpdEditCntrls(AEdit : TEdit; AUpDown : TUpDown; AScrollBar : TScrollBar; var AValue : TColor);
  var
    S: String;
  begin
    S:=AEdit.Text;
    S := StringReplace(S,' ','',[rfReplaceAll])
    if S = '' then Exit;
    AValue := StrToInt(S);
    if AValue < 0 then AValue := 0;
    if AValue > 255 then AValue := 255;
    AUpDown.Position:=AValue;
    AScrollBar.Position:=AValue;
  end;
  
begin
  if (sender as TEdit).Name='editred' 
    then UpdEditCntrls((sender as TEdit).Text, RedUpDown, sbRedScroll, RedColor);
  if (sender as TEdit).Name='editgreen'
    then UpdEditCntrls((sender as TEdit).Text, GreenUpDown, sbGreenScroll, GreenColor);
  if (sender as TEdit).Name='editblue'
    then UpdEditCntrls((sender as TEdit).Text, BlueUpDown, sbBlueScroll, BlueColor);
  shShape.Brush.Color:=RGB(RedColor,GreenColor,BlueColor);    
end;
 
procedure TForm1.sbScrollChange(Sender: TObject);

  procedure UpdScrollCntrls(AScrollBar : TScrollBar; AUpDown : TUpDown; AEdit : TEdit; var AValue : TColor);
  begin
    AValue := AScrollBar.Position;
    AUpDown.Position := AValue;
    AEdit.Text := IntToStr(AValue);
    FGK(AScrollBar);
  end;
  
begin
  if (sender as TScrollBar).Name='sbRedScroll' 
    then UpdScrollCntrls(sbRedScroll, RedUpDown, editRed, RedColor);
  if (sender as TScrollBar).Name='sbGreenScroll'
    then UpdScrollCntrls(sbGreenScroll, GreenUpDown, editGreen, GreenColor);
  if (sender as TScrollBar).Name='sbBlueScroll'
    then UpdScrollCntrls(sbBlueScroll, BlueUpDown, editBlue, BlueColor);
  shShape.Brush.Color:=RGB(RedColor,G reenColor,BlueColor);
end;
 
procedure TForm1.FGK(n: TObject);
begin
  case (n as TScrollBar).Position of
    1..50: StatusBar1.Panels[(n as TScrollBar).tag].Text:= 'Насыщенние цвета отсутсвует'; 
    51..100: StatusBar1.Panels[(n as TScrollBar).tag].Text:= 'Слабо насыщенный';
    101..150: StatusBar1.Panels[(n as TScrollBar).tag].Text:= 'Слабо насыщенный';
    151..200: StatusBar1.Panels[(n as TScrollBar).tag].Text:= 'Сильно насыщенный';
    201..255: StatusBar1.Panels[(n as TScrollBar).tag].Text:= 'Насыщеннеее максимальное';
  end;
end;
 
end.

Там особо сокращать нечего, только общие части вытащить в отдельные процедурки.