getdata.pas

Motorola 集群通信系统中SDTS车载台PEI端测试程序

begin
  if AutoSelect and not (csLButtonDown in ControlState) then
    SelectAll;
  inherited;
end;


{ TGetHexLong }

constructor TGetHexLong.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  SetDigits(4);
  CharCase := ecUpperCase;
end;

function TGetHexLong.IsValidChar(Key: Char): Boolean;
begin
  Result := (Key in ['A'..'F', 'a'..'f', '0'..'9']) or
    ((Key < #32) and (Key <> Chr(VK_RETURN)));
  if not FEditorEnabled and Result and ((Key >= #32) or
      (Key = Char(VK_BACK)) or (Key = Char(VK_DELETE))) then
    Result := False;
end;

function TGetHexLong.GetValue: LongInt;
begin
  try
    Result := StrToInt('$'+Text);
  except
    on EConvertError do begin
      Result := FMinValue;
      SetValue(FMinValue);
    end;
  end;
end;

procedure TGetHexLong.SetDigits(NewValue: Integer);
begin
  if NewValue < 1 then NewValue := 1;
  if NewValue > 15 then NewValue := 15;
  FDigits := NewValue;
  SetValue(Value);       //update display
end;

procedure TGetHexLong.SetValue(NewValue: LongInt);
begin
  Text := IntToHex(CheckValue(NewValue),FDigits);
end;


{ TGetFloat }

constructor TGetFloat.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FButton := TSpinButton.Create(Self);
  FButton.Width := 15;
  FButton.Height := 17;
  FButton.Visible := True;
  FButton.Parent := Self;
  FButton.FocusControl := Self;
  FButton.OnUpClick := UpClick;
  FButton.OnDownClick := DownClick;
  ControlStyle := ControlStyle - [csSetCaption];
  FPrecision := 7;
  FDigits := 4;
  FIncrement := 0;
  FEditorEnabled := True;
  FFormat := ffGeneral;
  FEngFormat := False;
  Text := '0';
{  Text := FloatToStrF(CheckValue(Value),FFormat,FPrecision,FDigits)}
  Text := ConvToEng(FloatToStrF(CheckValue(Value),FFormat,FPrecision,FDigits));
end;

destructor TGetFloat.Destroy;
begin
  FButton := nil;
  inherited Destroy;
end;

function TGetFloat.ConvToEng(s : String) : string;
var
  s1,s2 : string;
  n1,n2 : integer;
  P : boolean;
begin
  if (FFormat <> ffExponent) OR (NOT FEngFormat) then
    Result := s
  else begin
    if FPrecision < 3 then FPrecision := 3;
    s1 := copy(s,1,Pos('E',s)-1);
    P := Pos('.',s1) > 0;
    if P then
      Delete(s1,Pos('.',s1),1)
    else
      Delete(s1,Pos(',',s1),1);
    s2 := copy(s,Pos('E',s)+1,255);
    n2 := StrToInt(s2);
    n2 := n2+48;
    n1 := n2 - 3*(n2 DIV 3);
    n2 := n2-48;
    if P then begin
      if n2 = n1 then
        Result := copy(s1,1,n1+1)+'.'+copy(s1,n1+2,255)
      else
        Result := copy(s1,1,n1+1)+'.'+copy(s1,n1+2,255)+'E'+IntToStr(n2-n1);
    end
    else begin
      if n2 = n1 then
        Result := copy(s1,1,n1+1)+','+copy(s1,n1+2,255)
      else
        Result := copy(s1,1,n1+1)+','+copy(s1,n1+2,255)+'E'+IntToStr(n2-n1);
    end;
  end;
end;

procedure TGetFloat.KeyDown(var Key: Word; Shift: TShiftState);
begin
  if Key = VK_UP then UpClick(Self)
  else if Key = VK_DOWN then DownClick(Self);
  inherited KeyDown(Key, Shift);
end;

procedure TGetFloat.KeyPress(var Key: Char);
begin
  if not IsValidChar(Key) then
  begin
    Key := #0;
    MessageBeep(0)
  end;
  if Key <> #0 then inherited KeyPress(Key);
end;

function TGetFloat.IsValidChar(Key: Char): Boolean;
begin
  if FEngFormat then begin
    Result := (Key in [DecimalSeparator,'+','-','0'..'9','e','E','f','p','n','u','m','k','M','G','T']) or ((Key < #32) and (Key <> Chr(VK_RETURN)));
  end
  else begin
    Result := (Key in [DecimalSeparator,'+', '-', '0'..'9', 'e', 'E']) or ((Key < #32) and (Key <> Chr(VK_RETURN)));
  end;
  if not FEditorEnabled and Result and ((Key >= #32) or
      (Key = Char(VK_BACK)) or (Key = Char(VK_DELETE))) then
    Result := False;
end;

procedure TGetFloat.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
{  Params.Style := Params.Style and not WS_BORDER;  }
  Params.Style := Params.Style {or ES_MULTILINE} or WS_CLIPCHILDREN;
end;

procedure TGetFloat.CreateWnd;
begin
  inherited CreateWnd;
  SetEditRect;
end;

procedure TGetFloat.Loaded;
begin
  inherited Loaded;
  if FIncrement <= 0 then begin
    FButton.Visible := False;
    FIncrement := 0;
  end;
end;

procedure TGetFloat.SetEditRect;
var
  Loc: TRect;
begin
  SendMessage(Handle, EM_GETRECT, 0, LongInt(@Loc));
  Loc.Bottom := ClientHeight + 1;
  Loc.Right := ClientWidth - FButton.Width - 2;
  Loc.Top := 0;
  Loc.Left := 0;
  SendMessage(Handle, EM_SETRECTNP, 0, LongInt(@Loc));
  SendMessage(Handle, EM_GETRECT, 0, LongInt(@Loc));  {debug}
end;

procedure TGetFloat.WMSize(var Message: TWMSize);
var
  MinHeight: Integer;
begin
  inherited;
  MinHeight := GetMinHeight;
    { text edit bug: if size to less than minheight, then edit ctrl does
      not display the text }
  if Height < MinHeight then
    Height := MinHeight
  else if FButton <> nil then begin
    if NewStyleControls and Ctl3D then
      FButton.SetBounds(Width - FButton.Width - 5, 0, FButton.Width, Height - 4)//5)
    else FButton.SetBounds (Width - FButton.Width, 1, FButton.Width, Height - 2);//3);
    {FButton.SetBounds (Width - FButton.Width, 0, FButton.Width, Height);}
    SetEditRect;
  end;
end;

function TGetFloat.GetMinHeight: Integer;
var
  DC: HDC;
  SaveFont: HFont;
  I: Integer;
  SysMetrics, Metrics: TTextMetric;
begin
  DC := GetDC(0);
  GetTextMetrics(DC, SysMetrics);
  SaveFont := SelectObject(DC, Font.Handle);
  GetTextMetrics(DC, Metrics);
  SelectObject(DC, SaveFont);
  ReleaseDC(0, DC);
  I := SysMetrics.tmHeight;
  if I > Metrics.tmHeight then I := Metrics.tmHeight;
  Result := Metrics.tmHeight + I div 4 + GetSystemMetrics(SM_CYBORDER) * 4 + 2;
end;

procedure TGetFloat.UpClick (Sender: TObject);
begin
  if ReadOnly then MessageBeep(0)
  else Value := Value + FIncrement;
end;

procedure TGetFloat.DownClick (Sender: TObject);
begin
  if ReadOnly then MessageBeep(0)
  else Value := Value - FIncrement;
end;

procedure TGetFloat.WMPaste(var Message: TWMPaste);
begin
  if not FEditorEnabled or ReadOnly then Exit;
  inherited;
end;

procedure TGetFloat.WMCut(var Message: TWMPaste);
begin
  if not FEditorEnabled or ReadOnly then Exit;
  inherited;
end;

procedure TGetFloat.CMExit(var Message: TCMExit);
begin
  inherited;
  if CheckValue(Value) <> Value then SetValue(Value);
end;

function TGetFloat.GetValue: Float;
var
  Txt: string;
  p: word;
begin
  try
    Txt := Text;
    if FFormat in [ffNumber, ffCurrency] then begin
      p := Pos(ThousandSeparator,Txt);
      while p <> 0 do begin
        Delete(Txt,p,1);
        p := Pos(ThousandSeparator,Txt);
      end;
    end;
    if FFormat = ffCurrency then begin
      p := Pos(CurrencyString,Txt);
      if p <> 0 then Delete(Txt,p,Length(CurrencyString));
      case NegCurrFormat of
        0,4: begin
               p := Pos('(',Txt);
               if p <> 0 then Txt[p] := '-';
               p := Pos(')',Txt);
               if p <> 0 then Delete(Txt,p,1);
             end;
        1,5: { OK - do nothing };
        2,6: { OK - do nothing };
        3,7: begin
               p := Pos('-',Txt);
               if p <> 0 then begin
                 Delete(Txt,p,1);
                 Txt := '-' + Txt;
               end;
             end;
      end;
    end;
    if FEngFormat then begin
      if Pos('f',Txt) > 0 then begin
        Delete(Txt,Pos('f',Txt),1);
        Result := StrToFloat(Txt)*1E-15;
        exit;
      end;
      if Pos('p',Txt) > 0 then begin
        Delete(Txt,Pos('p',Txt),1);
        Result := StrToFloat(Txt)*1E-12;
        exit;
      end;
      if Pos('n',Txt) > 0 then begin
        Delete(Txt,Pos('n',Txt),1);
        Result := StrToFloat(Txt)*1E-9;
        exit;
      end;
      if Pos('u',Txt) > 0 then begin
        Delete(Txt,Pos('u',Txt),1);
        Result := StrToFloat(Txt)*1E-6;
        exit;
      end;
      if Pos('m',Txt) > 0 then begin
        Delete(Txt,Pos('m',Txt),1);
        Result := StrToFloat(Txt)*1E-3;
        exit;
      end;
      if Pos('k',Txt) > 0 then begin
        Delete(Txt,Pos('k',Txt),1);
        Result := StrToFloat(Txt)*1E3;
        exit;
      end;
      if Pos('M',Txt) > 0 then begin
        Delete(Txt,Pos('M',Txt),1);
        Result := StrToFloat(Txt)*1E6;
        exit;
      end;
      if Pos('G',Txt) > 0 then begin
        Delete(Txt,Pos('G',Txt),1);
        Result := StrToFloat(Txt)*1E9;
        exit;
      end;
      if Pos('T',Txt) > 0 then begin
        Delete(Txt,Pos('T',Txt),1);
        Result := StrToFloat(Txt)*1E12;
        exit;
      end;
      Result := StrToFloat(Txt);
    end
    else
      Result := StrToFloat(Txt);
  except
    Result := FMinValue;
    SetValue(FMinValue);
  end;
end;

procedure TGetFloat.SetValue(NewValue: Float);
begin
  Text := ConvToEng(FloatToStrF(CheckValue(NewValue),FFormat,FPrecision,FDigits));
end;


procedure TGetFloat.SetPrecision(NewValue: Integer);
begin
  if NewValue < 1 then NewValue := 1;
  if NewValue > 32 then NewValue := 32;
  FPrecision := NewValue;
  SetValue(Value);
end;


procedure TGetFloat.SetDigits(NewValue: Integer);
begin
  if NewValue < 0 then NewValue := 0;
  if NewValue > 32 then NewValue := 32;
  FDigits := NewValue;
  SetValue(Value);
end;

procedure TGetFloat.SetFormat(NewValue: TFloatFormat);
begin
  FFormat := NewValue;
  SetValue(Value);
end;

function TGetFloat.CheckValue (NewValue: Float): Float;
begin
  Result := NewValue;
  if (FMaxValue <> FMinValue) then begin
    if NewValue < FMinValue then
      Result := FMinValue
    else if NewValue > FMaxValue then
      Result := FMaxValue;
  end;
end;


procedure TGetFloat.CMEnter(var Message: TCMGotFocus);
begin
  if AutoSelect and not (csLButtonDown in ControlState) then
    SelectAll;
  inherited;
end;



procedure TGetString.WMSize(var Message: TWMSize);
var
  MinHeight: Integer;
begin
  inherited;
  MinHeight := GetMinHeight;
    { text edit bug: if size to less than minheight, then edit ctrl does
      not display the text }
  if Height < MinHeight then Height := MinHeight
end;

function TGetString.GetMinHeight: Integer;
var
  DC: HDC;
  SaveFont: HFont;
  I: Integer;
  SysMetrics, Metrics: TTextMetric;
begin
  DC := GetDC(0);
  GetTextMetrics(DC, SysMetrics);
  SaveFont := SelectObject(DC, Font.Handle);
  GetTextMetrics(DC, Metrics);
  SelectObject(DC, SaveFont);
  ReleaseDC(0, DC);
  I := SysMetrics.tmHeight;
  if I > Metrics.tmHeight then I := Metrics.tmHeight;
  Result := Metrics.tmHeight + I div 4 + GetSystemMetrics(SM_CYBORDER) * 4 + 2;
end;



procedure Register;
begin
  RegisterComponents('Utils',[TGetLong, TGetHexLong, TGetFloat, TGetString, THistComboBox]);
  RegisterPropertyEditor(TypeInfo(Float),nil,'',TFloatProperty);
  RegisterPropertyEditor(TypeInfo(TFloatFormat),nil,'',TEnumProperty);
end;


end.