analoge Uhr mit Hintergrundbild und Farbänderungen

Böser Borstel · Beiträge: 154

hatte bißchen langeweile, habe den forum durch forstet und habe mal gelesen jemand möchte gerne so eine uhr.
bitte hier ist sie.

markieren

Delphi-Quelltext

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:
107:
108:
109:
110:
111:
112:
113:
114:
115:
116:
117:
118:
119:
120:
121:
122:
123:
124:
125:
126:
127:
128:
129:
130:
131:
132:
133:
134:
135:
136:
137:
138:
139:
140:
141:
142:
143:
144:
145:
146:
147:
148:
149:
150:
151:
152:
153:
154:
155:
156:
157:
158:
159:
160:
161:
162:
163:
164:
165:
166:
167:
168:
169:
170:
171:
172:
173:
174:
175:
176:
177:
178:
179:

  TClock = class
  private
    FPicture: TPicture;
    FBrush,
    FPen  : TColor;
    FBack,
    FClock,
    FImage: TImage;
    FTimer: TTimer;
    procedure Circle;
    procedure FOnTimer(Sender: TObject);
    procedure SetBrush(AValue: TColor);
    procedure SetPen(AValue: TColor);
    procedure SetPicture(AValue: TPicture);
  public
    constructor Create(const ARect: TRect; const AParent: TWinControl);
    destructor Destroy; override;
  published
    property BrushColor: TColor read FBrush write SetBrush;
    property PenColor: TColor read FPen write SetPen;
    property Picture: TPicture read FPicture write SetPicture;
  end; //TClock

implementation

constructor TClock.Create(const ARect: TRect; const AParent: TWinControl);
begin
  inherited Create;
  FPen := clBlack;
  FBrush := clWhite;
  FPicture := TPicture.Create;
  FBack := TImage.Create(AParent);
  FClock := TImage.Create(AParent);
  FImage := TImage.Create(AParent);
  with FBack do
  begin
    Parent := AParent;
    Left := ARect.Left;
    Top := ARect.Top;
    Width := ARect.Right - Left;
    if Width < 50 then
      Width := 50;
    Height := ARect.Bottom - Top;
    if Height < 50 then
      Height := 50;
  end;
  with FClock do
  begin
    Parent := AParent;
    Transparent := TRUE;
    Left := FBack.Left;
    Top := FBack.Top;
    Width := FBack.Width;
    Height := FBack.Height;
    Circle;
  end;
  with FImage do
  begin
    Transparent := TRUE;
    Parent := AParent;
    Left := FBack.Left;
    Top := FBack.Top;
    Width := FBack.Width;
    Height := FBack.Height;
    Canvas.Pen.Width := (Width + Height) div 100;
  end;
  FTimer := TTimer.Create(AParent);
  with FTimer do
  begin
    Interval := 1000;
    OnTimer := FOnTimer;
    Enabled := TRUE;
  end;
end; //TClock.Create

procedure TClock.Circle;
begin
  with FClock do
    with Canvas do
    begin
      Pen.Width := (Width + Height) div 100;
      Pen.Color := Parent.Brush.Color;
      Brush.Color := Parent.Brush.Color;
      Font.Style := Font.Style + [fsBold]; 
      Font.Size := (Width + Height) div 30;
      Font.Color := FPen;
      Rectangle(Rect(Left, Top, Left + Width, Top + Height));
      Pen.Color := FPen;
      if (FBack.Picture.Graphic = nil) or
        (FBack.Picture.Graphic.Empty) then
        Brush.Color := FBrush;
      Ellipse(Rect(Left, Top, Left + Width, Top + Height));
      TextOut((Width - TextWidth('12')) div 2, Pen.Width + 2, '12');
      TextOut((Width - TextWidth('6')) div 2, Height - TextHeight('6') - Pen.Width, '6');
      TextOut(Left + 2 + Pen.Width, (Height - TextHeight('9')) div 2, '9');
      TextOut(Width - TextWidth('3') - 2 - Pen.Width, (Height - TextHeight('3')) div 2, '3');
    end;
end; //TClock.Circle

procedure TClock.FOnTimer(Sender: TObject);
var
  Default: Integer;
  Hour,
  Min,
  Sec,
  MSec: Word;
begin
  DecodeTime(Now, Hour, Min, Sec, MSec);
  Sec := Sec * 6;
  Min := Min * 6;
  Hour := Hour * 30;
  with FImage do
  begin
    with Canvas do
    begin
      if FPen <> clWhite then
        CopyMode := cmWhiteness
      else
        CopyMode := cmBlackness;
      CopyRect(FImage.BoundsRect, Canvas, FImage.BoundsRect);
      Pen.Color := FPen;
      MoveTo(Width div 2, Height div 2);
      LineTo(Width div 2 + Trunc(Sin(DegToRad(Sec)) * (Width div 2 - Width div 8)), Height div 2 + Trunc(Cos(DegToRad(Sec)) * - (Height div 2 - Height div 8)));
      MoveTo(Width div 2, Height div 2);
      Default := Pen.Width;
      Pen.Width := Pen.Width + 1;
      LineTo(Width div 2 + Trunc(Sin(DegToRad(Min)) * (Width div 2 - Width div 8)), Height div 2 + Trunc(Cos(DegToRad(Min)) * - (Height div 2 - Height div 8)));
      MoveTo(Width div 2, Height div 2);
      Pen.Width := Pen.Width + 1;
      LineTo(Width div 2 + Trunc(Sin(DegToRad(Hour)) * (Width div 3)), Height div 2 + Trunc(Cos(DegToRad(Hour)) * - (Height div 3)));
      Pen.Width := Default;
    end;
  end;
end; //TClock.FOnTimer

procedure TClock.SetBrush(AValue: TColor);
begin
  if FBrush <> AValue then
  begin
    FBrush := AValue;
    Circle;
    FOnTimer(FTimer);
  end;
end; //TClock.SetBrush

procedure TClock.SetPen(AValue: TColor);
begin

  if FPen <> AValue then
  begin
    FPen := AValue;
    Circle;
    FOnTimer(FTimer);
  end;
end; //TClock.SetPen

procedure TClock.SetPicture(AValue: TPicture);
begin
  FPicture.Assign(AValue);
  with FBack do
  begin
    Width := FImage.Width;
    Height := FImage.Height;
    Picture.Assign(FPicture);
    Stretch := TRUE;
    Circle;
    FOnTimer(FTimer);
  end;
end; //TClock.SetPicture

destructor TClock.Destroy;
begin
  FImage.Free;
  FPicture.Free;
  FBack.Free;
  FClock.Free;
  FTimer.Free;
  inherited Destroy;
end; //TClock.Destroy

[meta]
uhr, analog, hintergrundbild
[/meta]

Moderiert von Udontknow: Code- durch Delphi-Tags ersetzt, Thema verschoben.

Udontknow · Beiträge: 2596 Win7 D2006 WIN32, .NET (C#)

Hallo!

Mach doch aus dem TObject- einen TPanel-Nachfahren und nimm direkt diesen als Parent, so kann man die TClock-Class dann auch als visuelle Komponente per RegisterComponents in der Komponentenleiste einfügen.

Cu,
Udontknow

Böser Borstel · Beiträge: 154

keine schlechte idee, mal sehen wann ich dazu zeit finde

Mr Anderson · Hält's aus hier Beiträge: 5

ích habe eine kleine Frage zu diesem Code:
Nachdem ich ihn eingebunden habe erhalte ich eine Zugriffsverletzung :

markieren

Delphi-Quelltext

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:
107:
108:
109:
110:
111:
112:
113:
114:
115:
116:
117:
118:
119:
120:
121:
122:
123:
124:
125:
126:
127:
128:
129:
130:
131:
132:
133:
134:
135:
136:
137:
138:
139:
140:
141:
142:
143:
144:
145:
146:
147:
148:
149:
150:
151:
152:
153:
154:
155:
156:
157:
158:
159:
160:
161:
162:
163:
164:
165:
166:
167:
168:
169:
170:
171:
172:
173:
174:
175:
176:
177:
178:
179:
180:
181:
182:
183:
184:
185:
186:
187:
188:
189:
190:
191:
192:
193:
194:

unit mUhr_v2;

interface

uses Forms,    {TForm}
     Windows,
     Messages,
     SysUtils,
     Variants,
     Classes,
     Controls,
     Dialogs,
     ExtCtrls,
     math,
     Graphics; {TCanvas, TColor}

type TClock = class (TObject)
  private
    FPicture: TPicture;
    FBrush,FPen  : TColor;
    FBack,FClock,FImage: TImage;
    FTimer: TTimer;
    procedure Circle;
    procedure FOnTimer(Sender: TObject);
    procedure SetBrush(AValue: TColor);
    procedure SetPen(AValue: TColor);
    procedure SetPicture(AValue: TPicture);
  public
    constructor Create(const ARect: TRect; const AParent: TWinControl);
    destructor Destroy; override;
  published
    property BrushColor: TColor read FBrush write SetBrush;
    property PenColor: TColor read FPen write SetPen;
    property Picture: TPicture read FPicture write SetPicture;
  end; //TClock

implementation

constructor TClock.Create(const ARect: TRect; const AParent: TWinControl);
begin
  inherited Create;
  FPen := clBlack;
  FBrush := clWhite;
  FPicture := TPicture.Create;
  FBack := TImage.Create(AParent);
  FClock := TImage.Create(AParent);
  FImage := TImage.Create(AParent);
  with FBack do
  begin
    Parent := AParent;
    Left := ARect.Left;
    Top := ARect.Top;
    Width := ARect.Right - Left;
    if Width < 50 then
      Width := 50;
    Height := ARect.Bottom - Top;
    if Height < 50 then
      Height := 50;
  end;
  with FClock do
  begin
    Parent := AParent;
    Transparent := TRUE;
    Left := FBack.Left;
    Top := FBack.Top;
    Width := FBack.Width;
    Height := FBack.Height;
    Circle;
  end;
  with FImage do
  begin
    Transparent := TRUE;
    Parent := AParent;
    Left := FBack.Left;
    Top := FBack.Top;
    Width := FBack.Width;
    Height := FBack.Height;
    Canvas.Pen.Width := (Width + Height) div 100;
  end;
  FTimer := TTimer.Create(AParent);
  with FTimer do
  begin
    Interval := 1000;
    OnTimer := FOnTimer;
    Enabled := TRUE;
  end;
end; //TClock.Create

procedure TClock.Circle;
begin
  with FClock do
    with Canvas do
    begin
      Pen.Width := (Width + Height) div 100;
      Pen.Color := Parent.Brush.Color;
      Brush.Color := Parent.Brush.Color;
      Font.Style := Font.Style + [fsBold];
      Font.Size := (Width + Height) div 30;
      Font.Color := FPen;
      Rectangle(Rect(Left, Top, Left + Width, Top + Height));
      Pen.Color := FPen;
      if (FBack.Picture.Graphic = nil) or
        (FBack.Picture.Graphic.Empty) then
        Brush.Color := FBrush;
      Ellipse(Rect(Left, Top, Left + Width, Top + Height));
      TextOut((Width - TextWidth('12')) div 2, Pen.Width + 2, '12');
      TextOut((Width - TextWidth('6')) div 2, Height - TextHeight('6') - Pen.Width, '6');
      TextOut(Left + 2 + Pen.Width, (Height - TextHeight('9')) div 2, '9');
      TextOut(Width - TextWidth('3') - 2 - Pen.Width, (Height - TextHeight('3')) div 2, '3');
    end;
end; //TClock.Circle

procedure TClock.FOnTimer(Sender: TObject);
var
  Default: Integer;
  Hour,
  Min,
  Sec,
  MSec: Word;
begin
  DecodeTime(Now, Hour, Min, Sec, MSec);
  Sec := Sec * 6;
  Min := Min * 6;
  Hour := Hour * 30;
  with FImage do
  begin
    with Canvas do
    begin
      if FPen <> clWhite then
        CopyMode := cmWhiteness
      else
        CopyMode := cmBlackness;
      CopyRect(FImage.BoundsRect, Canvas, FImage.BoundsRect);
      Pen.Color := FPen;
      MoveTo(Width div 2, Height div 2);
      LineTo(Width div 2 + Trunc(Sin(DegToRad(Sec)) * (Width div 2 - Width div 8)), Height div 2 + Trunc(Cos(DegToRad(Sec)) * - (Height div 2 - Height div 8)));
      MoveTo(Width div 2, Height div 2);
      Default := Pen.Width;
      Pen.Width := Pen.Width + 1;
      LineTo(Width div 2 + Trunc(Sin(DegToRad(Min)) * (Width div 2 - Width div 8)), Height div 2 + Trunc(Cos(DegToRad(Min)) * - (Height div 2 - Height div 8)));
      MoveTo(Width div 2, Height div 2);
      Pen.Width := Pen.Width + 1;
      LineTo(Width div 2 + Trunc(Sin(DegToRad(Hour)) * (Width div 3)), Height div 2 + Trunc(Cos(DegToRad(Hour)) * - (Height div 3)));
      Pen.Width := Default;
    end;
  end;
end; //TClock.FOnTimer

procedure TClock.SetBrush(AValue: TColor);
begin
  if FBrush <> AValue then
  begin
    FBrush := AValue;
    Circle;
    FOnTimer(FTimer);
  end;
end; //TClock.SetBrush

procedure TClock.SetPen(AValue: TColor);
begin

  if FPen <> AValue then
  begin
    FPen := AValue;
    Circle;
    FOnTimer(FTimer);
  end;
end; //TClock.SetPen

procedure TClock.SetPicture(AValue: TPicture);
begin
  FPicture.Assign(AValue);
  with FBack do
  begin
    Width := FImage.Width;
    Height := FImage.Height;
    Picture.Assign(FPicture);
    Stretch := TRUE;
    Circle;
    FOnTimer(FTimer);
  end;
end; //TClock.SetPicture

destructor TClock.Destroy;
begin
  FImage.Free;
  FPicture.Free;
  FBack.Free;
  FClock.Free;
  FTimer.Free;
  inherited Destroy;
end; //TClock.Destroy

end.

In der Testumgebung deklariere ich eine Variable test : TClock;

Im FormCreate weise ich der Var Kor noch Werte zu und lasse die Uhr sich zeichnen.

markieren

Delphi-Quelltext

1:
2:
3:
4:
5:

kor.Top := 100;
kor.Left:= 200;
kor.Right:=100;
kor.Bottom:=100;
test.Create(kor,Form1);

Nun stürtzt er immer ab. Hab ich die Klasse falsch eingebunden ?

MfG

Böser Borstel · Beiträge: 154

so funktioniert es bei mir unter D7.

markieren

Delphi-Quelltext

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:
107:
108:
109:
110:
111:
112:
113:
114:
115:
116:
117:
118:
119:
120:
121:
122:
123:
124:
125:
126:
127:
128:
129:
130:
131:
132:
133:
134:
135:
136:
137:
138:
139:
140:
141:
142:
143:
144:
145:
146:
147:
148:
149:
150:
151:
152:
153:
154:
155:
156:
157:
158:
159:
160:
161:
162:
163:
164:
165:
166:
167:
168:
169:
170:
171:
172:
173:
174:
175:
176:
177:
178:
179:
180:
181:
182:
183:
184:
185:
186:
187:
188:
189:
190:
191:
192:
193:
194:
195:
196:
197:
198:
199:
200:
201:
202:
203:
204:
205:
206:
207:
208:
209:
210:
211:
212:
213:
214:
215:
216:
217:
218:
219:
220:
221:

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs,
  ExtCtrls, //TImage
  Math, jpeg; //DegToRad

type

  TClock = class
  private
    FPicture: TPicture;
    FBrush,
    FPen  : TColor;
    FBack,
    FClock,
    FImage: TImage;
    FTimer: TTimer;
    procedure Circle;
    procedure FOnTimer(Sender: TObject);
    procedure SetBrush(AValue: TColor);
    procedure SetPen(AValue: TColor);
    procedure SetPicture(AValue: TPicture);
  public
    constructor Create(const ARect: TRect; const AParent: TWinControl);
    destructor Destroy; override;
  published
    property BrushColor: TColor read FBrush write SetBrush;
    property PenColor: TColor read FPen write SetPen;
    property Picture: TPicture read FPicture write SetPicture;
  end; //TClock

  TForm1 = class(TForm)
    Image1: TImage;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    Clock: TClock;
  public
    { Public-Deklarationen }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

constructor TClock.Create(const ARect: TRect; const AParent: TWinControl);
begin
  inherited Create;
  FPen := clBlack;
  FBrush := clWhite;
  FPicture := TPicture.Create;
  FBack := TImage.Create(AParent);
  FClock := TImage.Create(AParent);
  FImage := TImage.Create(AParent);
  with FBack do
  begin
    Parent := AParent;
    Left := ARect.Left;
    Top := ARect.Top;
    Width := ARect.Right - Left;
    if Width < 50 then
      Width := 50;
    Height := ARect.Bottom - Top;
    if Height < 50 then
      Height := 50;
  end;
  with FClock do
  begin
    Parent := AParent;
    Transparent := TRUE;
    Left := FBack.Left;
    Top := FBack.Top;
    Width := FBack.Width;
    Height := FBack.Height;
    Circle;
  end;
  with FImage do
  begin
    Transparent := TRUE;
    Parent := AParent;
    Left := FBack.Left;
    Top := FBack.Top;
    Width := FBack.Width;
    Height := FBack.Height;
    Canvas.Pen.Width := (Width + Height) div 100;
  end;
  FTimer := TTimer.Create(AParent);
  with FTimer do
  begin
    Interval := 1000;
    OnTimer := FOnTimer;
    Enabled := TRUE;
  end;
end; //TClock.Create

procedure TClock.Circle;
begin
  with FClock do
    with Canvas do
    begin
      Pen.Width := (Width + Height) div 100;
      Pen.Color := Parent.Brush.Color;
      Brush.Color := Parent.Brush.Color;
      Font.Style := Font.Style + [fsBold]; 
      Font.Size := (Width + Height) div 30;
      Font.Color := FPen;
      Rectangle(Rect(Left, Top, Left + Width, Top + Height));
      Pen.Color := FPen;
      if (FBack.Picture.Graphic = nil) or
        (FBack.Picture.Graphic.Empty) then
        Brush.Color := FBrush;
      Ellipse(Rect(Left, Top, Left + Width, Top + Height));
      TextOut((Width - TextWidth('12')) div 2, Pen.Width + 2, '12');
      TextOut((Width - TextWidth('6')) div 2, Height - TextHeight('6') - Pen.Width, '6');
      TextOut(Left + 2 + Pen.Width, (Height - TextHeight('9')) div 2, '9');
      TextOut(Width - TextWidth('3') - 2 - Pen.Width, (Height - TextHeight('3')) div 2, '3');
    end;
end; //TClock.Circle

procedure TClock.FOnTimer(Sender: TObject);
var
  Default: Integer;
  Hour,
  Min,
  Sec,
  MSec: Word;
begin
  DecodeTime(Now, Hour, Min, Sec, MSec);
  Sec := Sec * 6;
  Min := Min * 6;
  Hour := Hour * 30;
  with FImage do
  begin
    with Canvas do
    begin
      if FPen <> clWhite then
        CopyMode := cmWhiteness
      else
        CopyMode := cmBlackness;
      CopyRect(FImage.BoundsRect, Canvas, FImage.BoundsRect);
      Pen.Color := FPen;
      MoveTo(Width div 2, Height div 2);
      LineTo(Width div 2 + Trunc(Sin(DegToRad(Sec)) * (Width div 2 - Width div 8)), Height div 2 + Trunc(Cos(DegToRad(Sec)) * - (Height div 2 - Height div 8)));
      MoveTo(Width div 2, Height div 2);
      Default := Pen.Width;
      Pen.Width := Pen.Width + 1;
      LineTo(Width div 2 + Trunc(Sin(DegToRad(Min)) * (Width div 2 - Width div 8)), Height div 2 + Trunc(Cos(DegToRad(Min)) * - (Height div 2 - Height div 8)));
      MoveTo(Width div 2, Height div 2);
      Pen.Width := Pen.Width + 1;
      LineTo(Width div 2 + Trunc(Sin(DegToRad(Hour)) * (Width div 3)), Height div 2 + Trunc(Cos(DegToRad(Hour)) * - (Height div 3)));
      Pen.Width := Default;
    end;
  end;
end; //TClock.FOnTimer

procedure TClock.SetBrush(AValue: TColor);
begin
  if FBrush <> AValue then
  begin
    FBrush := AValue;
    Circle;
    FOnTimer(FTimer);
  end;
end; //TClock.SetBrush

procedure TClock.SetPen(AValue: TColor);
begin
  if FPen <> AValue then
  begin
    FPen := AValue;
    Circle;
    FOnTimer(FTimer);
  end;
end; //TClock.SetPen

procedure TClock.SetPicture(AValue: TPicture);
begin
  FPicture.Assign(AValue);
  with FBack do
  begin
    Width := FImage.Width;
    Height := FImage.Height;
    Picture.Assign(FPicture);
    Stretch := TRUE;
    Circle;
    FOnTimer(FTimer);
  end;
end; //TClock.SetPicture

destructor TClock.Destroy;
begin
  FImage.Free;
  FPicture.Free;
  FBack.Free;
  FClock.Free;
  FTimer.Free;
  inherited Destroy;
end; //TClock.Destroy

procedure TForm1.FormCreate(Sender: TObject);
begin
  Clock := TClock.Create(Rect(0, 0, 200, 200), Self);
  with Clock do
  begin
    BrushColor := RGB(240, 240, 240);
    PenColor := clWhite;
    Picture := Image1.Picture;
  end;
end; //TForm1.FormCreate

procedure TForm1.FormDestroy(Sender: TObject);
begin
  Clock.Free;
end;

Moderiert von matze: Code- durch Delphi-Tags ersetzt.

	Mitgliederliste
	Gruppen
	Das Team
	Richtlinien
	Synonyme