text.pas

人制作的可输入不同类型数据的TText控件。并具有 Office 的外观(10KB)6363.zip非常著名的一组非常不错的控件。有许多图形化控件.

    if FMaskString[I] = NewChar then
    begin
      Result := True;
      uPos := I;
      if FMaskString[I] in LeadBytes then
        Inc(uPos);
      Exit;
    end;
  end;
end;

function TText.InputChar(var NewChar: Char; Offset: Integer): Boolean;
var
  CaseChar: Char;
  nusPos: Integer;
begin
  Result := False;
  if FInputMask='' then
  begin
    Result := True;
    Exit;
  end;
  CaseChar := FInputMask[OffSet+1];
  if (Ord(NewChar) = VK_SPACE) then  Result := True;
  if ((CaseChar='#') or (CaseChar=' ')) then Result := True;
  if (CaseChar='9') then
  begin
    if ((NewChar>='0') and (NewChar<='9')) then
      Result := True;
    if (FValueType=vtDouble) or (FValueType=vtCurrency) or (FValueType=vtInteger) then
    begin
      if ((NewChar='+') or (NewChar='-')) then
      begin
        if Pos(NewChar,Text)=0 then
        begin
        NusPos := OffSet;
        while not (IsLiteralChar(FMaskString,Text, NusPos)) do
          Dec(NusPos);
        if FValueType=vtCurrency then NusPos := nusPos+2;
        if AllTrim(Copy(Text,nusPos,OffSet-nusPos+1))='' then
        begin
          NusPos := OffSet;
          while not (IsLiteralChar(FMaskString,Text, NusPos)) do
            Inc(NusPos);
          if NusPos<>OffSet+1 then
            Result := True;
        end;
        end else
          SetSel(Pos(NewChar,Text),Pos(NewChar,Text));
      end;
    end;
  end;
end;

function TText.GetMasked: Boolean;
begin
  Result := (FInputMask<>'');
end;

function TText.GetText: String;
begin
  Result := Text;
end;

function TText.GetMaskString(Val: String): String;
var
  I: Integer;
  Str: String;
begin
  Str := Val;
  if Str='' then
  begin
    Result := '';
    Exit;
  end;
  for I:=1 to Length(Val) do
  begin
    if (not (Char(Val[I]) in ['#','9',' '])) then
      Str[I] := Val[I]
    else Str[I] := ' ';
  end;
  Result := Str;
end;

procedure TText.SetInputMask(Val: String);
begin
  case FValueType of
    vtInteger: Val := '99999999';
    vtDate: Val := '9999'+'年'+'99'+'月'+'99'+'日';
    vtTime: Val := '99'+TimeSeparator+'99'+TimeSeparator+'99';
    //vtDateTime: Val := '9999'+DateSeparator+'99'+DateSeparator+'99'+'/'+'99'+TimeSeparator+'99'+TimeSeparator+'99';
    vtCurrency: Val := CurrencyString+'999999999.99';
    vtDouble: Val := '999999999.99';
  end;
  if FInputMask<>Val then
  begin
    FInputMask := Val;
    FMaskString := GetMaskString(Val);
    case FValueType of
      vtInteger   : Text := '       0';
      vtDate      : Text := DateToStrProc(Date);
      vtTime      : Text := TimeToStrProc(Time);
      //vtDateTime: Text := '9999'+DateSeparator+'99'+DateSeparator+'99'+'/'+'99'+TimeSeparator+'99'+TimeSeparator+'99';
      vtCurrency  : Text := CurrencyString+'        0.00';
      vtDouble    : Text := '        0.00';
      vtString    :
        if AllTrim(FMaskString)='' then
          Text := Name
        else
          Text := FMaskString;
    end;
    MaxLength := Length(Val);
  end;
end;


procedure TText.SetReadOnly(Val: Boolean);
begin
  if FReadOnly<>Val then
    FReadOnly := Val;
end;

procedure TText.SetAutoAligning(Val: Boolean);
begin
  if FAutoAligning <> Val then
    FAutoAligning := Val
end;

procedure TText.SetAlignment(Val: TAlignment);
begin
  if FAlignment <> Val then
  begin
    FAlignment := Val;
    Invalidate;
  end;
end;

procedure TText.WMLButtonDown(var Message: TWMLButtonDown);
begin
  inherited;
  if not FFocused then
  begin
    FFocused := True;
    SelectAll;
    Invalidate;
  end;
end;

procedure TText.KeyPress(var Key: Char);
begin
  if (Key=#13) then Key := #0;
  if (Key <> #0) and not (Char(Key) in [^X,^C,^V]) then
  begin
    if ReadOnly then Key := #0;
    if not IsMasked then Exit;
    CharKeys(Key);
    Key := #0;
  end;
  if (Key <> #0) and (Char(Key) in [^X]) then
  begin
    if ReadOnly then Key := #0;
    if not IsMasked then Exit;
    DeleteKeys(VK_DELETE);
    Key := #0;
  end;
  inherited KeyPress(Key);
end;

procedure TText.KeyDown(var Key: Word; Shift: TShiftState);
begin
  if Key=0 then Exit;
  if (Key = VK_LEFT) or(Key = VK_RIGHT) or (Key = VK_HOME) or (Key = VK_END) then
  begin
    if not IsMasked then Exit;
    ArrowKeys(Key, Shift);
    if not ((ssShift in Shift) or (ssCtrl in Shift)) then
    Key := 0;
    Exit;
  end else if (Key = VK_DELETE) or (Key = VK_BACK) then
  begin
    if ReadOnly then Key := 0;
    if not IsMasked then Exit;
    DeleteKeys(Key);
    Key := 0;
    Exit;
  end else if (Key = VK_UP) then
  begin
    SendMessage(GetParentForm(Self).Handle,WM_NextDlgCtl,1,0);
    //Key := 0;
  end else  if (Key = VK_RETURN) or (Key = VK_DOWN) then
  begin
    SetSel(1,1);
    SendMessage(GetParentForm(Self).Handle,WM_NextDlgCtl,0,0);
    //Key := 0;
  end;
  inherited KeyDown(Key, Shift);
end;

procedure TText.SetFlat(Value: Boolean);
begin
  if FFlat<>Value then
  begin
    FFlat := Value;
    if FFlat then
    begin
      AutoSize := True;
      Ctl3D := True;
      BorderStyle := bsSingle;
      ControlStyle := ControlStyle - [csFramed]; {fixes a VCL bug with Win 3.x}
      FButton.Flat := True;
    end else
    begin
      AutoSize := True;
      Ctl3D := True;
      BorderStyle := bsSingle;
      ControlStyle := ControlStyle + [csFramed]; {fixes a VCL bug with Win 3.x}
      FButton.Flat := False;
    end;
    RePaint;
  end;
end;


procedure TText.SetTransparent(Value: Boolean);
begin
  if Value <> FTransparent then begin
    FTransparent := Value;
    Repaint;
  end;
end;

procedure TText.Loaded;
begin
  inherited Loaded;
  //if not(csDesigning in ComponentState) then
    NewAdjustHeight;
end;

procedure TText.Reset;
begin
  if Modified then
  begin
    Text := FOldValue;
    Modified := False;
  end;
end;

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


procedure TText.ValidateEdit(aPos: Integer);
var
  StartPos,EndPos: Integer;
  Str,MaskStr: String;
  iMSec,iYear,iMonth,iDay: Word;
  Len: Integer;
function GetLastDay(Month: Word): Word;
begin
  case Month of
    2: Result := 28;
    1,3,5,7,8: Result := 31;
    else Result := 30;
  end;
end;
begin
  StartPos := aPos;
  while not (IsLiteralChar(FMaskString,Text, StartPos)) do
    Dec(StartPos);
  Inc(StartPos);
  EndPos := aPos;
  while not (IsLiteralChar(FMaskString,Text, EndPos)) do
    Inc(EndPos);
  if (StartPos<=0) then StartPos := 0;
  if (StartPos >= MaxLength) then StartPos := MaxLength;
  if (EndPos<=0) then EndPos := 0;
  if (EndPos >= MaxLength) then EndPos := MaxLength;
  if (StartPos>EndPos) then StartPos := EndPos;
  Str := Copy(Text,StartPos+1,EndPos-StartPos+1);
  Len := Length(Str);
  Str := AllTrim(Str);

  // Type is Float or Currentcy
  if (FValueType=vtDouble) or (FValueType=vtCurrency)then
  begin
    if (Str)='' then Str := '00';
    if (Str)='.' then Str := '0.';
  end;
  // Type is Date
  if (FValueType=vtDate) then
  begin
    if Length(Str)=3 then
    begin
      if aPos<=3 then
      begin
        DeCodeDate(Date,iYear,iMonth,iDay);
        Str := Copy(IntToStr(iYear),1,2)+Str;
      end;
    end else if Length(Str)=2 then
    begin
      if aPos<=3 then
      begin
        DeCodeDate(Date,iYear,iMonth,iDay);
        Str := Copy(IntToStr(iYear),1,2)+'0'+Str;
      end else
        Str := '0'+Str;
    end else if Length(Str)=1 then
    begin
      DeCodeDate(Date,iYear,iMonth,iDay);
      if aPos<=3 then
        Str := IntToStr(iYear)+Str
      else if aPos<=7 then
      begin
        if iMonth<10 then
          Str := '0'+IntToStr(iMonth)+Str
        else
          Str := IntToStr(iMonth)+Str;
      end else
      begin
        if iDay<10 then
          Str := '0'+IntToStr(iDay)+Str
        else
          Str := IntToStr(iDay)+Str;
      end;
    end;
    if (aPos>=6) and (aPos<=7) then
    begin
      if StrToInt(Copy(Str,1,2))>12 then
        Str := '12月'
      else if StrToInt(Copy(Str,1,2))<=0 then
        Str := '01月';
    end else if (aPos>=10) then
    begin
      if AllTrim(Copy(Text,7,2))='' then
        iDay := GetLastDay(iMonth)
      else
        iDay := GetLastDay(StrToInt(Copy(Text,7,2)));
      if AllTrim(Str)='' then
      begin
        if iDay<10 then
          Str := '0'+IntToStr(iDay)+'日'
        else
          Str := IntToStr(iDay)+'日';
      end else
      begin
        if (StrToInt(Copy(Str,1,2))>iDay) then
          Str := IntToStr(iDay)+'日'
        else if StrToInt(Copy(Str,1,2))<=0 then
          Str := '01日';
      end;
    end;
  end;

  // Type is Time
  if (FValueType=vtTime) then
  begin
    DeCodeTime(Time,iYear,iMonth,iDay,iMSec);
    if (aPos>=3) and (aPos<=4) then
    begin
      if Length(Str)=2 then
        Str := '0'+Str;
      if Length(Str)=1 then
      begin
        if iMonth<10 then
          Str := '0'+IntToStr(iMonth)+Str
        else
          Str := IntToStr(iMonth)+Str
      end;
      if StrToInt(Copy(Str,1,2))>=60 then
        Str := '00:';
    end else if (aPos>=6) and (aPos<=7) then
    begin
      if Length(Str)=1 then
        Str := '0'+Str;
      if Length(Str)=0 then
      begin
        if iDay<10 then
          Str := '0'+IntToStr(iDay)+Str
        else
          Str := IntToStr(iDay)+Str
      end;
      if StrToInt(Copy(Str,1,2))>=60 then
        Str := '00';
    end else if (aPos<=1) then
    begin
      if Length(Str)=1 then
      begin
        if iYear<10 then
          Str := '0'+IntToStr(iYear)+Str
        else
          Str := IntToStr(iYear)+Str
      end;
      if Length(Str)=3 then
      begin
        if StrToInt(Copy(Str,1,2))>24 then
          Str := '24:';
      end else
      begin
        if StrToInt(Copy(Str,1,1))>24 then
          Str := '24:';
      end;
    end;
  end;

  if (FValueType=vtDouble) or (FValueType=vtCurrency)then
  begin
    if Pos('.',Str)=0 then
      MaskStr := SlashStr(Str,'0',Len,True)
    else
      MaskStr := SlashStr(Str,' ',Len,False);
  end else
    MaskStr := SlashStr(Str,' ',Len,False);

  SetSel(StartPos,EndPos);
  SendMessage(Handle, EM_REPLACESEL, 0, LongInt(PChar(MaskStr)));
end;



procedure Register;
begin
  RegisterComponents('Standard', [TText]);
end;

procedure TText.ButtonClick;
begin
  if Assigned(FOnButtonClick) then FOnButtonClick(Self);
end;

function TText.GetButtonWidth: Integer;
begin
  Result := FBtnControl.Width - 1;
end;

procedure TText.SetButtonWidth(Value: Integer);
begin
  FBtnControl.Width := Value + 1;
  FButton.SetBounds(1, 0, FBtnControl.Width - 1, Height);
  SetEditRect;
  Invalidate;
end;

procedure TText.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  Params.Style := Params.Style or WS_CLIPCHILDREN;
end;

function TText.GetButtonVisible: Boolean;
begin
  Result := FBtnControl.Visible;
end;

procedure TText.SetButtonVisible(Value: Boolean);
begin
  FBtnControl.Visible := Value;
  SetEditRect;
  Invalidate;
end;

procedure TText.SetGlyphKind(Value: TGlyphKind);
begin
  if FGlyphKind <> Value then
  begin
    FGlyphKind := Value;
    case FGlyphKind of
      gkDropDown:
        begin
          FButton.Glyph.Handle := LoadBitmap(0, PChar(32738));
          NumGlyphs := 1;
          SetButtonWidth(GetSystemMetrics(SM_CXVSCROLL));
        end;
      end;
  end;
end;

function TText.GetGlyph: TBitmap;
begin
  Result := FButton.Glyph;
end;

function TText.GetNumGlyphs: TNumGlyphs;
begin
  Result := FButton.NumGlyphs;
end;

procedure TText.SetGlyph(Value: TBitmap);
begin
  FButton.Glyph := Value;
  FGlyphKind := gkCustom;
end;

procedure TText.SetNumGlyphs(Value: TNumGlyphs);
begin
  case FGlyphKind of
    gkDropDown:
      FButton.NumGlyphs := 1
  else
    FButton.NumGlyphs := Value;
  end;
end;

function TText.IsCustomGlyph: Boolean;
begin
  Result := FGlyphKind = gkCustom;
end;

function TText.GetButtonEnabled: Boolean;
begin
  Result := FBtnControl.Enabled;
end;

procedure TText.SetCaret(Value: Boolean);
begin
  if (FCaret <> Value) then
  begin
    FCaret := Value;
    if FFocused then
      if not Caret then HideCaret(Handle) else ShowCaret(Handle);
  end;
end;


procedure TText.SetButtonEnabled(Value: Boolean);
begin
  if csDesigning in ComponentState then
  begin
    FBtnControl.Enabled := Value;
    FButton.Enabled := Enabled and Value;
  end else
    FButton.Enabled := Value;
end;


end.