// Hiermit erstellt man ein Ampere-Meter (bzw. Voltmeter durch Änderung
// von Label2.Caption in 'V') mit einem plastischen Zeiger (im Gegensatz
// zu einem Strich-Zeiger wie bei einfaches Zeiger-Instrument erstellen).
// Voraussetzung sind vier Bitmaps. Dazu müssen Sie Bilder4.zip
// herunterladen, da alle Positions- und Größenbestimmungen auf die darin
// befindlichen Bilder bezogen sind. Die Variablen "Start" und "Spacing"
// bestimmen das Aussehen der in 5 Bereiche aufgeteilten Skala. Bei der
// Abbildung zum Beispiel ist Start=0 und Spacing=1. Bei Start=50 und
// Spacing=20 wäre die Beschriftung der Skala: 50  70  90  110  130  150
// Durch Aufruf der Prozedur "Multi" wird ein Multiplikator eingeführt.
// Im Beispiel reicht die Skala von 0 bis 5, aber durch "Multi(10)" werden
// Werte von 0 bis 50 verarbeitet. Die Digital-Anzeige zeigt aber immer
// den echten Wert an. Bei Multi(0) oder Multi(1) stimmen Skala und
// realer Wert überein. Mittels der Variablen "Threshold" kann ein
// kritischer Wert eingestellt werden, bei dessen erreichen die Led von
// grün auf rot wechselt und ein Warnton ausgegeben wird.

// Sie müssen 3 TImage, 3 TLabel und 1 TTimer auf die Form setzen sowie die
// 4 Bilder zur verfügung stellen. Die Prozedur "Timer1Timer" wird durch
// Doppelklick auf den Timer erzeugt. Der Rest ergibt sich aus dem Code.


// Getestet mit D2010 unter Win7

unit Unit1; 
 
interface 
 
uses 
  Windows, SysUtils, Classes, Graphics, Controls, Forms, 
  Dialogs, ExtCtrls, StdCtrls, ComCtrls; 
 
type 
  TForm1 = class(TForm) 
    Image1: TImage; 
    Image2: TImage; 
    Image3: TImage; 
    Timer1: TTimer; 
    Label1: TLabel; 
    Label2: TLabel; 
    Label3: TLabel; 
    CheckBox2: TCheckBox; 
    CheckBox1: TCheckBox; 
    CheckBox3: TCheckBox; 
    CheckBox4: TCheckBox; 
    TrackBar1: TTrackBar; 
    CheckBox5: TCheckBox; 
    procedure FormCreate(Sender: TObject); 
    procedure FormDestroy(Sender: TObject); 
    procedure Timer1Timer(Sender: TObject); 
    procedure CheckBox1Click(Sender: TObject); 
    procedure CheckBox2Click(Sender: TObject); 
    procedure CheckBox3Click(Sender: TObject); 
    procedure CheckBox4Click(Sender: TObject); 
    procedure TrackBar1Change(Sender: TObject); 
    procedure CheckBox5Click(Sender: TObject); 
  private 
    { Private-Deklarationen } 
  public 
    function Rotate(deg: Single; BackGround: TColor): TPoint; 
    function Examination(Test: Single): boolean; 
    function Calculate(Spot: Single): Single; 
    procedure Preparation(c: TColor); 
    procedure ShowLed(b: boolean); 
    procedure Multi(w: Word); 
    procedure WhichLed; 
    procedure Display; 
    procedure Quader; 
    procedure Movit; 
    procedure Go; 
  end; 
 
var 
  Form1: TForm1; 
 
implementation 
 
{$R *.dfm} 
 
uses mmsystem; 
 
type 
  TOfs = record 
    xx, yy: Single; 
  end; 
 
const 
  p180 = pi / 180;

var 
  Ground: TColor = clWhite; // wichtig 
  Dark: TColor = $303030; 
  Back: TColor; 
  ow, oh: Byte; 
  Midpoint: TPoint; 
  DStep, Pdst, SStep, PSrc: Cardinal; 
  offset: array [1 .. 4, 0 .. 8] of TOfs; 
  LedRot, LedGruen, SRC, DST, HLP, Zeiger: TBitmap; 
  leftside, above, Value, Start, LedTop, rctw, rcth: Integer; 
  cx, cy, dw2, Spacing: Word; 
  Step, Threshold, Stock, Target: Single; 
  Multiplicator: Word = 1; 
  Damping: boolean = True; 
  Digital: boolean = True; 
  Signal: boolean = True; 
  Stop: boolean = False; 
  Leds: boolean = True; 
  Red: boolean = False; 
  FName: String; 
  Place: array [0 .. 5, 0 .. 1] of Byte = ((44, 144), (50, 112), (64, 85), 
    (86, 63), (112, 48), (141, 43));

procedure TForm1.FormCreate(Sender: TObject); 
var 
  i, b, z: Integer; 
  s: string; 
  procedure labels(lb: TLabel; sz: Integer); 
  begin 
    with lb do 
    begin 
      Font.Name := FName; 
      Font.Color := Dark; 
      Font.Style := [fsBold]; 
      Transparent := True; 
      Font.Size := sz; 
    end; 
  end; 
 
begin 
  Timer1.Interval := 0; 
  DoubleBuffered := True; 
  Scaled := False; 
 
  Start := 0; 
  Spacing := 1; 
  Threshold := 35; // z.B. 
 
  FName := 'Arial'; 
  LedRot := TBitmap.Create; 
  // LedRot.LoadFromFile('LedRot.bmp'); 
  LedRot.Handle := LoadBitmap(Hinstance, 'LedRot'); 
  LedGruen := TBitmap.Create; 
  // LedGruen.LoadFromFile('LedGruen.bmp'); 
  LedGruen.Handle := LoadBitmap(Hinstance, 'LedGruen'); 
  leftside := 41; 
  above := 144; 
  Image3.Picture.Assign(LedGruen); 
  Image3.AutoSize := True; 
  Image3.Transparent := True; 
  Zeiger := TBitmap.Create; 
  // Zeiger.LoadFromFile('Zeiger.bmp'); 
  Zeiger.Handle := LoadBitmap(Hinstance, 'Zeiger'); 
  SRC := TBitmap.Create; 
  SRC.Width := Zeiger.Width * 2 - 13; 
  SRC.Height := Zeiger.Height; 
  SRC.Canvas.Draw(0, 0, Zeiger); 
  SRC.Transparent := True; 
  DST := TBitmap.Create; 
  HLP := TBitmap.Create; 
  with Image1, Picture.Bitmap do 
  begin 
    AutoSize := True; 
    // LoadFromFile('Ampere.bmp'); 
    Handle := LoadBitmap(Hinstance, 'Ampere'); 
    with Canvas do 
    begin 
      Font.Name := FName; 
      Font.Color := Dark; 
      Font.Size := 10; 
      brush.Style := bsClear; 
      for i := 0 to 5 do 
      begin 
        s := IntToStr(Start + i * Spacing); 
        b := TextWidth(s); 
        if (i > 3) and (b < 14) then 
        begin 
          if i = 5 then 
            z := 13 - b 
          else 
            z := 10 - b; 
        end 
        else 
          z := 0; 
        TextOut(Place[i, 0] + z, Place[i, 1], s); 
      end; 
    end; 
  end; 
  with Image2 do 
  begin 
    BringToFront; 
    AutoSize := True; 
    Left := Image1.Left; 
    Top := Image1.Top; 
    with Picture.Bitmap, Canvas do 
    begin 
      with Picture.Bitmap, Canvas do 
      begin 
        brush.Color := Ground; 
        Width := Image1.Width; 
        Height := Image1.Height; 
      end; 
    end; 
    Transparent := True; 
  end; 
  With Label1 do 
  begin 
    Transparent := False; 
    Font.Name := FName; 
    Font.Size := 10; 
    Font.Color := clWhite; 
    Color := Dark; 
    Font.Style := [fsBold]; 
    Top := Image1.BoundsRect.Bottom - 45; 
  end; 
  labels(Label2, 16); 
  labels(Label3, 12); 
  Label3.Top := Image1.Top + 100; 
  Image3.Left := Image1.Left + 30; 
  rctw := Image1.Width - 50; 
  rcth := Image1.Height - 50; 
  Back := Image1.Canvas.Pixels[100, 100]; 
  Quader; 
  ShowLed(False); 
  Preparation(Ground); 
  With Label2 do 
  begin 
    Top := Image1.Top + 30; 
    Left := Image1.Left + 30; 
    Caption := 'mA'; 
  end; 
 
  Multi(10); 
  Value := 0; 
  Go; 
end; 
 
procedure TForm1.Multi(w: Word); 
begin 
  if w < 1 then 
    w := 1; 
  Multiplicator := w; 
  Label3.Caption := 'x' + IntToStr(w); 
  Label3.Left := Image1.BoundsRect.Right - 55 - Label3.Width; 
  Label3.visible := w > 1; 
end; 
 
function TForm1.Calculate(Spot: Single): Single; 
begin 
  Result := ((Spot - Start) * 90 / (5 * Spacing)) / Multiplicator; 
end; 
 
function TForm1.Examination(Test: Single): boolean; 
begin 
  if (Test < 0) or (Test > 90) then 
  begin 
    Stop := True; 
    Timer1.Interval := 0; 
    if Test > 90 then 
    begin 
      Target := 90; 
      Stock := 90; 
    end 
    else 
    begin 
      Target := 0; 
      Stock := 0; 
    end; 
    Result := True; 
    Movit; 
    showmessage('"' + IntToStr(Value) + '"  ist nicht zulässig!'); 
    Stop := False; 
  end 
  else 
    Result := False; 
end; 
 
procedure TForm1.WhichLed; 
begin 
  if not Red and (Value >= Threshold) then 
  begin 
    Image3.Picture.Bitmap.Assign(LedRot); 
    Red := True; 
    if Signal then 
      PlaySound('SYSTEMEXCLAMATION', Hinstance, SND_ASYNC or SND_LOOP); 
  end 
  else if Red and (Value < Threshold) then 
  begin 
    Image3.Picture.Bitmap.Assign(LedGruen); 
    Red := False; 
    PlaySound(nil, Hinstance, SND_PURGE); 
  end; 
end; 
 
procedure TForm1.Display; 
begin 
  if Leds then 
    WhichLed; 
  if Digital then 
  begin 
    Label1.Caption := IntToStr(Value); 
    Label1.Left := Image1.Left + (Image1.Width - Label1.Width) div 2; 
  end; 
end; 
 
procedure TForm1.Go; 
begin 
  if Stop then 
    Exit; 
  Display; 
  if Damping then 
  begin 
    Target := Calculate(Value); 
    if Examination(Target) then 
      Exit; 
    if (Stock = Target) then 
      Step := 0 
    else if Stock < Target then 
      Step := 1.25 
    else 
      Step := -1.25; 
    Timer1.Interval := 10; 
  end 
  else 
  begin 
    Stock := Calculate(Value); 
    if Examination(Stock) then 
      Exit; 
    Movit; 
  end; 
end; 
 
procedure TForm1.Movit; 
begin 
  DST.Transparent := False; 
  Midpoint := Rotate(Stock, Ground); 
  DST.Transparent := True; 
  with Image2.Picture.Bitmap, Canvas do 
    FillRect(rect(leftside, 38, rctw, rcth)); 
  Image2.Canvas.Draw(leftside - Midpoint.x, above - Midpoint.y, DST); 
end; 
 
procedure TForm1.Timer1Timer(Sender: TObject); 
begin 
  Stock := Stock + Step; 
  if (Stock > Target) and (Step > 0) or (Stock < Target) and (Step < 0) then 
  begin 
    Stock := Target; 
    Timer1.Interval := 0; 
  end; 
  Movit; 
end; 
 
procedure TForm1.ShowLed(b: boolean); 
begin 
  if Leds then 
  begin 
    if Label2.visible then 
      LedTop := 55 
    else 
      LedTop := 30; 
    Image3.Top := LedTop + Image1.Top; 
    if b then 
      Red := Value < Threshold; 
    WhichLed; 
    Image3.visible := True; 
  end 
  else 
  begin 
    Image3.visible := False; 
    PlaySound(nil, Hinstance, SND_PURGE); 
  end; 
end; 
 
procedure TForm1.Quader; 
begin 
  Label1.visible := Digital; 
  With Image1.Canvas do 
  begin 
    if Digital then 
      brush.Color := Label1.Color 
    else 
      brush.Color := Back; 
    FillRect(rect(80, Label1.Top - Image1.Top, 127, 
        Label1.BoundsRect.Bottom - Image1.Top)); 
  end; 
end; 
 
procedure TForm1.FormDestroy(Sender: TObject); 
begin 
  FreeAndNil(LedGruen); 
  FreeAndNil(LedRot); 
  FreeAndNil(Zeiger); 
  FreeAndNil(HLP); 
  FreeAndNil(DST); 
  FreeAndNil(SRC); 
end; 
 
procedure TForm1.Preparation(c: TColor); 
var 
  cw, ch: Cardinal; 
  w, H: Byte; 
begin 
  DST.PixelFormat := pf32bit; 
  DST.Canvas.brush.Color := c; 
  ow := ord(odd(SRC.Width)); 
  oh := ord(odd(SRC.Height)); 
  w := ow xor 1; 
  H := oh xor 1; 
  HLP.PixelFormat := pf32bit; 
  HLP.Canvas.brush.Color := c; 
  HLP.Width := SRC.Width + w; 
  HLP.Height := SRC.Height + H; 
  HLP.Canvas.Draw(w, H, SRC); 
  cx := pred(HLP.Width) div 2; 
  cy := pred(HLP.Height) div 2; 
  cw := HLP.Width * HLP.Width; 
  ch := HLP.Height * HLP.Height; 
  DST.Width := trunc(sqrt(cw + ch)) or 1; 
  DST.Height := DST.Width; 
  dw2 := DST.Width div 2; 
  PSrc := dword(HLP.scanline[0]); 
  SStep := PSrc - Cardinal(HLP.scanline[1]); 
  Pdst := Cardinal(DST.scanline[0]); 
  DStep := Pdst - Cardinal(DST.scanline[1]); 
end; 
 
function TForm1.Rotate(deg: Single; BackGround: TColor): TPoint; 
var 
  x, y, tt: Word; 
  rad, vsin, vcos, tx, ty, xtx, xty, ytx, yty: Single; 
  px, b1, b2, PS, PD: Cardinal; 
  ofx, ofy: SmallInt; 
  i, j, q: Byte; 
  vi, vj: Single; 
  ttx, tty, sumR, sumG, sumB: Word; 
  bgR, bgG, bgB: Byte; 
begin 
  while deg > 360 do 
    deg := deg - 360; 
  while deg < 0 do 
    deg := deg + 360; 
  Result.x := 1 + (DST.Width - SRC.Width) div 2 - ow; 
  Result.y := 1 + (DST.Height - SRC.Height) div 2 - oh; 
  bgR := getRvalue(BackGround); 
  bgG := getGvalue(BackGround); 
  bgB := getBvalue(BackGround); 
  rad := p180 * deg; 
  vsin := sin(rad); 
  vcos := cos(rad); 
  tx := 0; 
  ty := tx; 
  PD := 0; 
  for j := 0 to 2 do 
  begin 
    vj := 0.333 * j; 
    yty := vj * vcos; 
    ytx := vj * vsin; 
    for i := 0 to 2 do 
    begin 
      vi := 0.333 * i; 
      xtx := vi * vcos; 
      xty := vi * vsin; 
      for q := 1 to 4 do 
        with offset[q, i + 3 * j] do 
          case q of 
            1: 
              begin 
                xx := xtx + ytx; 
                yy := -xty + yty; 
              end; 
            2: 
              begin 
                xx := -xtx + ytx; 
                yy := xty + yty; 
              end; 
            3: 
              begin 
                xx := -xtx - ytx; 
                yy := xty - yty; 
              end; 
            4: 
              begin 
                xx := xtx - ytx; 
                yy := -xty - yty; 
              end; 
          end; 
    end; 
  end; 
  for y := 0 to dw2 do 
  begin 
    yty := y * vcos; 
    ytx := y * vsin; 
    b1 := Pdst - (dw2 + y) * DStep; 
    tt := dw2 - y; 
    b2 := Pdst - tt * DStep; 
    for x := 0 to dw2 do 
    begin 
      xtx := x * vcos; 
      xty := x * vsin; 
      for i := 1 to 4 do 
      begin 
        case i of 
          1: 
            begin 
              PD := b1 + ((dw2 + x) shl 2); 
              tx := xtx + ytx; 
              ty := -xty + yty; 
            end; 
          2: 
            begin 
              tt := dw2 - x; 
              PD := b1 + (tt shl 2); 
              tx := -xtx + ytx; 
              ty := xty + yty; 
            end; 
          3: 
            begin 
              PD := b2 + (tt shl 2); 
              tx := -xtx - ytx; 
              ty := xty - yty; 
            end; 
          4: 
            begin 
              PD := b2 + ((dw2 + x) shl 2); 
              tx := xtx - ytx; 
              ty := -xty - yty; 
            end; 
        end; 
        sumR := 0; 
        sumG := sumR; 
        sumB := sumR; 
        for j := 0 to 8 do 
        begin 
          ofx := trunc(tx + offset[i, j].xx); 
          ofy := trunc(ty + offset[i, j].yy); 
          if (abs(ofx) > cx) or (abs(ofy) > cy) then 
          begin 
            sumR := sumR + bgR; 
            sumG := sumG + bgG; 
            sumB := sumB + bgB; 
          end 
          else 
          begin 
            ttx := cx + ofx; 
            tty := cy + ofy; 
            PS := PSrc - tty * SStep + (ttx shl 2); 
            px := PCardinal(PS)^; 
            sumR := sumR + ((px shr 16) and $FF); 
            sumG := sumG + ((px shr 8) and $FF); 
            sumB := sumB + (px and $FF); 
          end; 
        end; 
        sumR := sumR div 9; 
        sumG := sumG div 9; 
        sumB := sumB div 9; 
        px := (sumR shl 16) or (sumG shl 8) or sumB; 
        PCardinal(PD)^ := px; 
      end; 
    end; 
  end; 
end; 

// --- Beispielaufrufe --- 
 
// Dämpfung ein/aus 
procedure TForm1.CheckBox1Click(Sender: TObject); 
begin 
  Damping := CheckBox1.Checked; 
end; 
 
// digitale Anzeige ein/aus 
procedure TForm1.CheckBox2Click(Sender: TObject); 
begin 
  Digital := CheckBox2.Checked; 
  Quader; 
end; 
 
// LED + Signalton ein/aus 
procedure TForm1.CheckBox3Click(Sender: TObject); 
begin 
  Leds := CheckBox3.Checked; 
  ShowLed(True); 
end; 
 
// Maßeinheit-Anzeige ein/aus 
procedure TForm1.CheckBox4Click(Sender: TObject); 
begin 
  Label2.visible := CheckBox4.Checked; 
  ShowLed(False); 
end; 
 
// nur Signalton (nicht LED) ein/aus 
procedure TForm1.CheckBox5Click(Sender: TObject); 
begin 
  Signal := CheckBox5.Checked; 
  if not Signal then 
    PlaySound(nil, Hinstance, SND_PURGE) 
  else 
    ShowLed(True); 
end; 
 
// Ansteuern 
procedure TForm1.TrackBar1Change(Sender: TObject); 
begin 
  Value := TrackBar1.Position; 
  Go; 
end; 
 
end.