Et ur i en tråd

Hej

Kig på borrisholt's thread timer, her på sitet.
Ellers gøres noget lign:

//..


unit Unit1;

interface

uses
  Windows, SysUtils, Classes, Controls, Forms, StdCtrls;

type
tSimpleEvent=procedure of object; //som "tNotifyEvent"

//----------------------------------------------------------------------
type
  tMyThrd=class;
//--
  TForm1 = class(TForm)
    Label1: TLabel;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    thrd  :tMyThrd;            //der oprettes evt en reference til tråden
  public
    procedure notifyThrdClock;  //En procedure til at modtage fra tråd
  end;
//--
  tMyThrd=class(tThread)
  private
    fForm          :TForm1;      //reference til evt en form.
  protected
    procedure execute;override;  //Når tråd køres
    procedure notifyCurrentTime; //Til at sende til referencen
  public
    klokken        :string;
    constructor create(aForm:TForm1);reintroduce;//nye arguenter
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

//----------------------------------------------------------------------
//tMyThrd:

constructor tMyThrd.create(aForm:TForm1);//reintroduce;
begin inherited create(true);//suspended
freeOnTerminate:=true;
fForm:=aForm;  //Reference til form
end;

procedure tMyThrd.execute;//override;
begin
while not terminated do begin
  klokken:=timeToStr(time);
  synchronize(notifyCurrentTime);//send til form
  sleep(500);
end
end;

procedure tMyThrd.notifyCurrentTime; //Til at sende til referencen
begin
fForm.notifyThrdClock
end;


//----------------------------------------------------------------------
//TForm1:

procedure TForm1.FormCreate(Sender :TObject);
begin
thrd:=tMyThrd.create(self);
thrd.resume; //Start tråden
end;

procedure TForm1.FormDestroy(Sender :TObject);
begin
thrd.terminate;
end;

procedure TForm1.notifyThrdClock;
begin
label1.caption:=thrd.klokken;
end;


end.

//mvh mbs

mbsnet> kan ikke lige få noget fornuftigt ud af det kode. Men det forbavser ikke mig :-)

Det optimale set med mine øjne ville være hvis man kunne lave en unit med en procedure man kalder med et formnavn og et controlnavn og så stod den unit og skrev et tidspunkt der hele tiden. Men det er måske utopi at tænke sig.

Jeg har i skrivende stund ikke kunne lokalisere Jens' timer her på sitet. Men da der er mange indlæg fra han skal jeg nok lede lidt længere.

hej. først og fremmest er det ikke i en unit, men i trådens klasse, at arbejdet gøres :)

Hvis du ønsker at flytte tråden til en ny unit, kan det let gøres. Jeg sendte ovenstående eksempel for at vise hvordan en tråd ret hurtigt "kan" bygges.

Det vigtigste for mig var, at vise, at tråde benytter en "execute" procedure, hvor man gør arbejdet. Derudover en "custom" constructor (som du kan ændre til at håndtere hvilke som helst typer man måtte ønske). Referencen "TForm1" kan også ændres til noget andet.

Hvis det ønskes, kan jeg lave et andet eksempel med 2 units, men jeg vil sige, at det kræver en smule åbenhed, at se lyset i forhold til tråde, og samtidig, at når man har prøvet det et par gange, er det ret let.

//mbs

Borrisholt's timer er blevet omtalt mange gange i løbet af årene, og kan bla findes her: http://www.eksperten.dk/spm/21009

OK - den vil jeg lige kigge lidt på.

Jeg tror dog jeg har fået et ur til at køre i en tråd nu. Desværre ser det bare ud til at de overførsler jeg kører tager så meget kraft ud af maskinen at uret hakker alligevel.

Gad vide om man kan lave en måde at starte en given funktion op i en tråd for sig selv. Altså et eller andet med en generel ting der kan kaldes med navnet på en funktion/procedure som så køres i en tråd - det må kunne fjerne lidt af belastningen fra opdateringen af mit skærmbillede.
Jeg har set nogle indlæg om bekymring om tilgang til samme data fra flere tråde, men det vil ikke være et problem her da det er en sekventiel indlæsning af filer en for en.

Men du må hellere smide et svar for dine hints der har hjulpet mig videre.

ok. Jeg tror der må være noget andet i dit program, som opbruger ressourcerne, og får uret til at hakke.. Det er sansynligvis dette, som bør flyttes til en tråd. Det med uret kan så løses, evt sammen med andre små-opgaver, ved at benytte en anden timer/tråd til disse. Ellers prøv at maile dit projekt til mig på pub_@mbsnet.dk (uden underscore)

Det er et ret stort projekt der kræver brug af en MySQL server og nogle Paradox tabeller med forretningsdata i så............

Men du har ret i at der er noget der tager resourcer - der overføres data fra Paradox tabeller til MySQL i rå mængder. Den ene tabel på MySQL indeholder ca. 9 millioner records så det tager lidt kræfter at finde ud af om den record jeg vil overføre er ny eller eksisterer :-)

(ny kan jeg pludselig ikke bruge FireFox her på Eksperten! - den vil ikke opdatere siden når jeg trykker på knappen)

Nå ja så.. :) Men prøv at se om du eventuelt kan flytte noget af det database-håndtering til en tråd.

browser: Det har været det samme i IE6 hos mig, siden ekspertens nye site kom på. Kan i øvrigt varmt anbefale Google's browser: "Chrome"

Det var lige derfor jeg gerne vil eksperimentere lidt og finde ud af om der evt. er en måde hvor man kan kalde en eksisterende funktion så den starter for sig selv i en tråd. Jeg tror jeg har fundet noget, men det er lidt langhåret.

Ja, men det lyder som en forkert rækkefølge at gøre det i. Normalt indtastes funktionskaldene under "execute" på tråden, og i stedet for at køre funktionerne fra programmet, startes tråden... Når så tråden er afsluttet sendes data til form, eller gemmes på disk.

En tråd kan i øvrigt "fyres af", uden at have en reference på formen. Kræver nok lidt øvelse først, men gøres således:

with tMyThrd.create(argument) do begin
resume
end;

mbsnet> du er vel ikke tilfældigvis aktiv på Messenger?

nej, har ikke brugt det et stykke tid, men kontrollerer jævnligt email.

Et ur kodet i en tråd (GRATIS KODE):

unit ThreadClockU;

interface
uses
  Windows, SysUtils, Messages, Classes, Graphics, Controls, ExtCtrls;

{$M+}
type
  TThreadClock = class(TThread)
  private
    FPen: TPen;
    FBitMap: TBitMap;

    FOnSecond, FOnMinute, FOnHour: TNotifyEvent;

    CenterPoint: TPoint;
    Radius: Integer;
    LapStepW: Integer;
    PrevTime: TDateTime;
    ShowSecond: Boolean;
    FArrowColor: TColor;
    FFaceColor: TColor;
    FDrawTo: TWinControl;
    FActive: Boolean;
    OldWndMethod: TWndMethod;

    procedure NewDrawToWndMethod(var Message: TMessage);

    procedure SetFaceColor(Value: TColor);
    procedure SetArrowColor(Value: TColor);
    procedure SetShowSecond(Value: Boolean);

    function MinuteAngle(Minute: word): Extended;
    function HourAngle(Hour, Minute: word): Extended;
    procedure CalcClockSettings;
    procedure DrawClockBkg;
    procedure DrawArrows;

    procedure SetDrawTo(const Value: TWinControl);
    procedure SetActive(const Value: Boolean);
    function GetHeight: Integer;
    function GetWidth: Integer;

  protected
    procedure TickerCall;
    procedure CallEvents;
    procedure DoDrawToScreen;
    procedure Execute; override;
  public
    constructor Create; overload;
    constructor Create(aDrawTo: TWinControl); overload;
    destructor Destroy; override;
    property DrawTo: TWinControl read FDrawTo write SetDrawTo;
  published
    property Active: Boolean read FActive write SetActive;
    property Width: Integer read GetWidth;
    property Height: Integer read GetHeight;
    property ClkArrowColor: TColor read FArrowColor write SetArrowColor default clBlack;
    property ClkFaceColor: TColor read FFaceColor write SetFaceColor default clBtnFace;

    property SecArrow: Boolean read ShowSecond write SetShowSecond;
    property OnSecond: TNotifyEvent read FOnSecond write FOnSecond;
    property OnMinute: TNotifyEvent read FOnMinute write FOnMinute;
    property OnHour: TNotifyEvent read FOnHour write FOnHour;
  end;

  TClock = class(TPanel)
  private
    ThreadClock: TThreadClock;
  public
    constructor Create(AOwner: TComponent); override;
  end;

implementation

const
  SecScale = 1;
  SecThick = 1;
  MinScale = 0.95;
  MinThick = 3;
  HouScale = 0.60;
  HouThick = 6;

constructor TThreadClock.Create;
begin
  inherited Create(False);
  FFaceColor := clBtnFace;
  FArrowColor := clBlack;

  PrevTime := 0;
  ShowSecond := True;

  FPen := TPen.Create;
  CalcClockSettings;
end;

procedure TThreadClock.SetFaceColor(Value: TColor);
begin
  FFaceColor := Value;
end;

procedure TThreadClock.SetActive(const Value: Boolean);
begin
  FActive := Value;
  if FActive then
    Resume
  else
    Suspend;
end;

procedure TThreadClock.SetArrowColor(Value: TColor);
begin
  FArrowColor := Value;
end;

procedure TThreadClock.SetShowSecond(Value: Boolean);
begin
  ShowSecond := Value;
  PrevTime := 0;
end;

procedure TThreadClock.CallEvents;
var
  H, M, S, MSec, pH, pM, pS: Word;
begin
  DecodeTime(Time, H, M, S, MSec);
  DecodeTime(PrevTime, pH, pM, pS, MSec);

  if Assigned(FOnSecond) then
    FOnSecond(Self);

  if Assigned(FOnMinute) and (pS > S) then
    FOnMinute(Self);

  if Assigned(FOnHour) and (pM > M) then
    FOnHour(Self);

  PrevTime := Time;
end;

constructor TThreadClock.Create(aDrawTo: TWinControl);
begin
  Self.Create;
  DrawTo := aDrawTo;
end;

destructor TThreadClock.Destroy;
begin
  FPen.Free;
  FBitMap.Free;
  inherited;
end;

procedure TThreadClock.DoDrawToScreen;
var
  DC: HDC;
begin
  if Assigned(FDrawTo) then
  begin
    DC := GetDC(FDrawTo.Handle);
    if DC <> 0 then
      BitBlt(DC, 0, 0, FBitMap.Width, FBitMap.Height, FBitMap.Canvas.Handle, 0, 0, SRCCOPY);

    ReleaseDC(FDrawTo.Handle, DC);
  end;
end;

procedure TThreadClock.SetDrawTo(const Value: TWinControl);
begin
  if Assigned(FDrawTo) then
    FDrawTo.WindowProc := OldWndMethod;

  FDrawTo := Value;

  OldWndMethod := FDrawTo.WindowProc;
  FDrawTo.WindowProc := NewDrawToWndMethod;
end;

function TThreadClock.MinuteAngle(Minute: word): Extended;
begin
  MinuteAngle := Minute * 2 * Pi / 60;
end;

procedure TThreadClock.NewDrawToWndMethod(var Message: TMessage);
begin
  if Message.Msg in [WM_PAINT, WM_SIZE] then
    Synchronize(DoDrawToScreen);

  OldWndMethod(Message);
end;

function TThreadClock.HourAngle(Hour, Minute: word): Extended;
begin
  HourAngle := (Hour mod 12) * 2 * Pi / 12 + MinuteAngle(Minute) / 12;
end;

procedure TThreadClock.TickerCall;
begin
  CalcClockSettings;
  DrawClockBkg;
  DrawArrows;
end;

procedure TThreadClock.DrawArrows;

  procedure DrawArrow(Angle, Scale: Extended; AWidth: Integer);
  var
    SR: Extended;
  begin
    with FBitMap.Canvas do
    begin
      Pen.Width := AWidth;
      MoveTo(CenterPoint.X, CenterPoint.Y);
      SR := Scale * Radius;
      LineTo(Trunc(SR * Sin(Angle)) + CenterPoint.X, Trunc(-SR * Cos(Angle)) + CenterPoint.Y);
    end;
  end;

var
  H, M, S, MSec: word;
begin
  FPen.Color := ClkArrowColor;

  with FBitMap.Canvas do
  begin
    Pen := FPen;
    Brush.Color := ClkFaceColor;
  end;

  DecodeTime(Time, H, M, S, MSec);
  if ShowSecond then
    DrawArrow(MinuteAngle(S), SecScale, SecThick);

  DrawArrow(MinuteAngle(M), MinScale, MinThick);
  DrawArrow(HourAngle(H, M), HouScale, HouThick);
end;

procedure TThreadClock.CalcClockSettings;
begin
  if Assigned(FBitMap) then
    FBitMap.Free;

  FBitMap := TBitMap.Create;
  FBitMap.Width := Width;
  FBitMap.Height := Height;

  CenterPoint := Point(Width div 2, Height div 2);

  with CenterPoint do
    if X <= Y then
      Radius := X
    else
      Radius := Y;

  LapStepW := Radius div 8;
  if LapStepW < 6 then
    LapStepW := 6;

  dec(Radius, LapStepW + 2);
end;

procedure TThreadClock.DrawClockBkg;

  procedure DrawMinSteps;
  var
    OffsetX, OffsetY: Integer;
    MinuteCount: word;
    CurrentPoint: TPoint;
    TmpRect: TRect;
    SR, Angle: Extended;
  begin
    OffsetX := LapStepW div 2;
    OffsetY := OffsetX;
    MinuteCount := 0;

    while MinuteCount < 56 do
    begin
      SR := Radius + OffsetX;
      Angle := MinuteAngle(MinuteCount);
      CurrentPoint := Point(Trunc(SR * Sin(Angle)) + CenterPoint.X, Trunc(-SR * Cos(Angle)) + CenterPoint.Y);

      if MinuteCount mod 15 = 0 then
        TmpRect := Rect(CurrentPoint.X - OffsetX, CurrentPoint.Y - OffsetY, CurrentPoint.X + OffsetX, CurrentPoint.Y + OffsetY)
      else
        TmpRect := Rect(CurrentPoint.X - 2, CurrentPoint.Y - 2, CurrentPoint.X + 2, CurrentPoint.Y + 2);

      Frame3D(FBitMap.Canvas, TmpRect, clBtnHighlight, clBtnShadow, 1);

      Inc(MinuteCount, 5);
    end;
  end;

begin
  with FBitMap.Canvas do
  begin
    Brush.Style := bsSolid;
    Brush.Color := ClkFaceColor;
    FillRect(ClipRect);
  end;

  DrawMinSteps;
end;

procedure TThreadClock.Execute;
begin
  while not Terminated do
  begin
    Synchronize(CallEvents);
    TickerCall;
    Synchronize(DoDrawToScreen);
    Sleep(100);
  end;
end;

function TThreadClock.GetHeight: Integer;
begin
  Result := 100;
  if Assigned(FDrawTo) then
    Result := FDrawTo.Height;
end;

function TThreadClock.GetWidth: Integer;
begin
  Result := 100;
  if Assigned(FDrawTo) then
    Result := FDrawTo.Width;
end;

{ TClock }

constructor TClock.Create(AOwner: TComponent);
begin
  inherited;
  Caption := '';
  BevelOuter := bvNone;
  ThreadClock := TThreadClock.Create(Self);
end;

end.