text.pas

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

  nuPos := CursorPos;
  Dec(nuPos);
  nuPos := GetPriorEditChar(nuPos);
  if (nuPos<>(CursorPos-1)) and FAutoAligning then
    ValidateEdit(CursorPos);
  if (CursorPos=MaxLength) and FAutoAligning then ValidIt;
  if NuPos<0 then NuPos := CursorPos;
  SetCursor(NuPos);
end;

procedure TText.CursorInc(CursorPos: Integer);
var
  nuPos: Integer;
begin
  nuPos := CursorPos;
  Inc(nuPos);
  //if (Text[nuPos]in LeadBytes) then Inc(nuPos);
  nuPos := GetNextEditChar(nuPos);

  if (nuPos<>(CursorPos+1)) and FAutoAligning then
    ValidateEdit(CursorPos);
  if (CursorPos=-1) and FAutoAligning then ValidIt;
  if NuPos>=MaxLength then NuPos := CursorPos;
  SetCursor(NuPos);
end;

function TText.IsCombo: Boolean;
begin
  Result := False;
end;

function TText.GetPriorEditChar(Offset: Integer): Integer;
begin
  Result := Offset;
  while (IsLiteralChar(FMaskString,Text, Result)) do
    Dec(Result);
end;

function TText.GetNextEditChar(Offset: Integer): Integer;
begin
  Result := Offset;
  while (IsLiteralChar(FMaskString,Text, Result)) do
    Inc(Result);
end;

procedure TText.SetCursor(Pos: Integer);
begin
  SetSel(Pos,Pos);
end;

function TText.GetTextMargins: TPoint;
var
  DC: HDC;
  SaveFont: HFont;
  I: Integer;
  SysMetrics, Metrics: TTextMetric;
begin
  if NewStyleControls then
  begin
    if BorderStyle = bsNone then I := 0 else
      if Ctl3D then I := 1 else I := 2;
    Result.X := SendMessage(Handle, EM_GETMARGINS, 0, 0) and $0000FFFF + I;
    Result.Y := I;
  end else
  begin
    if BorderStyle = bsNone then I := 0 else
    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;
      I := I div 4;
    end;
    Result.X := I;
    Result.Y := I;
  end;
end;

procedure TText.NewAdjustHeight;
var
  DC: HDC;
  SaveFont: HFONT;
  Metrics: TTextMetric;
begin
  DC := GetDC(0);
  SaveFont := SelectObject(DC, Font.Handle);
  GetTextMetrics (DC, Metrics);
  SelectObject (DC, SaveFont);
  ReleaseDC (0, DC);

  Height := Metrics.tmHeight + 6;
end;

procedure TText.CMMouseEnter (var Message: TMessage);
begin
  inherited;
  MouseInControl := True;
  Repaint;
end;

procedure TText.CMMouseLeave (var Message: TMessage);
begin
  inherited;
  MouseInControl := False;
  Repaint;
end;

procedure TText.CMEnabledChanged (var Message: TMessage);
const
  EnableColors: array[Boolean] of TColor = (clBtnFace, clWindow);
begin
  inherited;
  Color := EnableColors[Enabled];
  ButtonEnabled := Enabled;
  FButton.Enabled := Enabled;
  Invalidate;
end;

procedure TText.CMFontChanged (var Message: TMessage);
begin
  inherited;
  if not((csDesigning in ComponentState) and (csLoading in ComponentState)) then
    NewAdjustHeight;
end;

procedure TText.WMSetFocus (var Message: TWMSetFocus);
begin
  inherited;
  if not FCaret then HideCaret(Handle);
  if not(csDesigning in ComponentState) then
    Repaint;
end;

procedure TText.WMKillFocus (var Message: TWMKillFocus);
begin
  inherited;
  if not(csDesigning in ComponentState) then
    Repaint;
end;

procedure TText.WMNCCalcSize (var Message: TWMNCCalcSize);
begin
  inherited;
  //if (csDesigning in ComponentState) then Exit;
{  if (FFlat) then
    InflateRect (Message.CalcSize_Params^.rgrc[0], -3, -3)
  else }
//    InflateRect (Message.CalcSize_Params^.rgrc[0], -1, -1);
end;

procedure TText.WMNCPaint (var Message: TMessage);
begin
  inherited;
  Repaint;
end;

procedure TText.WMPaint(var Message: TWMPaint);
const
  AlignStyle : array[Boolean, TAlignment] of DWORD =
   ((WS_EX_LEFT, WS_EX_RIGHT, WS_EX_LEFT),
    (WS_EX_RIGHT, WS_EX_LEFT, WS_EX_LEFT));
var
  Left: Integer;
  Margins: TPoint;
  R: TRect;
  DC: HDC;
  PS: TPaintStruct;
  S: string;
  AAlignment: TAlignment;
  ExStyle: DWORD;
  BtnWidth: Integer;
begin
  AAlignment := FAlignment;
  if UseRightToLeftAlignment then ChangeBiDiModeAlignment(AAlignment);
  if  Focused and not (csPaintCopy in ControlState) then
  begin
    if SysLocale.MiddleEast and HandleAllocated and (IsRightToLeft) then
    begin
      ExStyle := DWORD(GetWindowLong(Handle, GWL_EXSTYLE)) and (not WS_EX_RIGHT) and
        (not WS_EX_RTLREADING) and (not WS_EX_LEFTSCROLLBAR);
      if UseRightToLeftReading then ExStyle := ExStyle or WS_EX_RTLREADING;
      if UseRightToLeftScrollbar then ExStyle := ExStyle or WS_EX_LEFTSCROLLBAR;
      ExStyle := ExStyle or
        AlignStyle[UseRightToLeftAlignment, AAlignment];
      if DWORD(GetWindowLong(Handle, GWL_EXSTYLE)) <> ExStyle then
        SetWindowLong(Handle, GWL_EXSTYLE, ExStyle);
    end;
    inherited;
    //Exit;
  end;
  if FCanvas = nil then
  begin
    FCanvas := TControlCanvas.Create;
    FCanvas.Control := Self;
  end;

  FCanvas.Handle := 0;
  DC := GetWindowDC(Handle);
  if DC = 0 then DC := BeginPaint(Handle, PS);
  with FCanvas do
  begin
    Handle := DC;
    R := ClipRect;
    //if Enabled and not ReadOnly and (FFlat) and (FFocused or MouseInControl) then begin
    if ((csDesigning in ComponentState) and Enabled) or
     (not(csDesigning in ComponentState) and
      (FFocused or (MouseInControl) ){ and not ReadOnly}) then begin
      if (FFlat) and not ReadOnly then
      begin
        Frame3D(FCanvas, R, clBtnShadow, clBtnHighlight, 1);
        Frame3D(FCanvas, R, clBtnFace,clBtnFace, 1);
        if not FTransparent then
          Frame3D(FCanvas, R, Color,Color, 1);
      end;
    end else
    begin
      CopyParentImage(Self,FCanvas,0);
      if FFlat then
      begin
        InflateRect(R, -1, -1);
        if FSingleBorder then
          Frame3D(FCanvas, R, clGrayText, clGrayText, 1)
      end else
      begin
        Frame3D(FCanvas, R, clWindowFrame, clBtnHighlight, 1);
        Frame3D(FCanvas, R, clBtnShadow, clBtnFace, 1);
      end;
      if not FTransparent then
      begin
        if FFlat then
        begin
          Frame3D(FCanvas, R, Color, Color, 1);
        end else
        begin
          Frame3D(FCanvas, R, Color, Color, 1);
          Frame3D(FCanvas, R, Color, Color, 1);
        end;
      end;
    end;
  end;

  if FBtnControl.Visible then
    BtnWidth := FBtnControl.Width
  else
    BtnWidth := 0;
  DC := Message.DC;

  if DC = 0 then DC := BeginPaint(Handle, PS);
  FCanvas.Handle := DC;
  try
    FCanvas.Font := Font;
    with FCanvas do
    begin
      R := ClientRect;
      if not (NewStyleControls and Ctl3D) and (BorderStyle = bsSingle) then
      begin
        Brush.Color := clWindowFrame;
        InflateRect(R, -1, -1);
      end;
      if not FFlat then
        Brush.Color := Color
      else
        Brush.Color := clWindow;
      Brush.Color := Color;
      if not Enabled and not (csDesigning in ComponentState) then
      begin
        Font.Color := clGrayText;
        Brush.Color := clBtnFace;
      end;
      if (csPaintCopy in ControlState) then
      begin
        S := Text;
        case CharCase of
          ecUpperCase: S := AnsiUpperCase(S);
          ecLowerCase: S := AnsiLowerCase(S);
        end;
      end else
        S := EditText;
      if FValueType<>vtString then
        S := AllTrim(S);
      if PasswordChar <> #0 then FillChar(S[1], Length(S), PasswordChar);
      Margins := GetTextMargins;
      case AAlignment of
        taLeftJustify: Left := Margins.X;
        taRightJustify: Left := ClientWidth - BtnWidth - TextWidth(S) - Margins.X - 1;
      else
        Left := (ClientWidth - BtnWidth - TextWidth(S)) div 2;
      end;
      if SysLocale.MiddleEast then UpdateTextFlags;
      if FTransparent then
      begin
        if not (csDesigning in ComponentState)
          and not (csPaintCopy in ControlState) then
          CopyParentImage(Self,FCanvas,-3);
        Brush.Style := bsClear;
      end else
        Brush.Style := bsSolid;
      TextRect(R, Left, Margins.Y, S);
    end;
    FButton.Repaint;
  finally
    FCanvas.Handle := 0;
    if Message.DC = 0 then EndPaint(Handle, PS);
  end;
end;

procedure TText.WMPaste(var Message: TMessage);
var
  Value: string;
  SelStart, SelStop : Integer;
begin
  if ReadOnly then exit;
  if not IsMasked then
    inherited
  else
  begin
    Clipboard.Open;
    Value := Clipboard.AsText;
    Clipboard.Close;
    GetSel(SelStart, SelStop);
    DeleteSelection(Value, SelStart, SelStop);
    SetCursor(SelStart);
  end;
end;

procedure TText.WMSize(var Message: TWMSize);
begin
  inherited;
  SetEditRect;
end;


procedure TText.CMTextChanged(var Message: TMessage);
var
  SelStart, SelStop : Integer;
  Temp: Integer;
begin
  inherited;
  FOldValue := Text;
  if (csDesigning in ComponentState) then
  begin
    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 IsMasked then Text := FMaskString;
    end;
  end else
  begin
    if not CheckValue(FMaskString,Text) then
    begin
    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 IsMasked then Text := FMaskString;
    end;
    end;
  end;
  if HandleAllocated then
  begin
    GetSel(SelStart, SelStop);
    Temp := GetNextEditChar(SelStart);
    if Temp <> SelStart then
      SetCursor(Temp);
  end;
  Invalidate;
end;

procedure TText.CMEnter(var Message: TCMEnter);
begin
  if IsMasked and not (csDesigning in ComponentState) then
  begin
    inherited;
    FOldValue := Text;
  end else
    inherited;
  FFocused := True;
  MouseInControl := True;
end;

procedure TText.CMExit(var Message: TCMExit);
begin
  if IsMasked and not (csDesigning in ComponentState) then
  begin
    inherited;
    ValidIt;
  end else
    inherited;
  FFocused := False;
  MouseInControl := False;
  Invalidate;
end;



procedure TText.ArrowKeys(CharCode: Word; Shift: TShiftState);
var
  SelStart, SelStop : Integer;
begin
  if (ssCtrl in Shift) or (ssShift In Shift) then Exit;
  GetSel(SelStart, SelStop);
  case CharCode of
  VK_LEFT: CursorDec(SelStart);
  VK_RIGHT: CursorInc(SelStart);
  VK_HOME: CursorInc(-1);
  VK_END: CursorDec(MaxLength);
  end;
end;

function TText.CharKeys(var CharCode: Char): Boolean;
var
  Temp,SelStart, SelStop : Integer;
  Txt: string;
  CharMsg: TMsg;
begin
  Result := False;
  GetSel(SelStart, SelStop);
  if ReadOnly then Exit;
  if Word(CharCode) = VK_ESCAPE then
  begin
    Reset;
    Exit;
  end;
  if Char(CharCode) in [Char(VK_BACK),^V,^X] then Exit;
  if (SelStop - SelStart) > 1 then
  begin
    DeleteKeys(VK_DELETE);
    SelStart := GetNextEditChar(SelStart);
    SetCursor(SelStart);
  end;
  if (CharCode in LeadBytes) then
    if PeekMessage(CharMsg, Handle, WM_CHAR, WM_CHAR, PM_REMOVE) then
      if CharMsg.Message = WM_Quit then
        PostQuitMessage(CharMsg.wparam);
  Temp := SelStart;
  if IsMaskChars(CharCode,SelStart,Temp) then
  begin
    if FAutoAligning then
      ValidateEdit(SelStart);
    SetCursor(Temp);
    Exit;
  end;
  Result := InputChar(CharCode, SelStart);
  if Result then
  begin
    if (CharCode in LeadBytes) then
    begin
      Txt := CharCode + Char(CharMsg.wParam);
      SetSel(SelStart, SelStart + 2);
    end
    else begin
      Txt := CharCode;
      SetSel(SelStart,SelStart+1);
    end;
    SendMessage(Handle, EM_REPLACESEL, 0, LongInt(PChar(Txt)));
    CursorInc(SelStart);
  end;
end;

function TText.DeleteSelection(PStr: String; SelStart,SelStop: Integer): String;
var
  I,J,K,M: Integer;
  Str: String;
begin
  J := 0; K := 0; M := 0;
  Str := Copy(Text,SelStart,SelStop-SelStart+1);
  for I:=SelStart to SelStop do
  begin
    if (IsLiteralChar(FMaskString,Text,I-1)) then
      Str[J] := FMaskString[I]
    else
    begin
      Str[J] := PStr[K+1];
      Inc(K);
    end;
    Inc(J);
    M := I;
  end;
  if M>MaxLength then begin
    Str[J-1] := FMaskString[MaxLength];
    Str[J-2] := FMaskString[MaxLength-1];
  end;
  Result := Str;
end;

procedure TText.ButtonReleased;
begin
end;

procedure TText.DeleteKeys(CharCode: Word);
var
  I,SelStart, SelStop : Integer;
  Txt: String;
begin
  if ReadOnly then Exit;
  GetSel(SelStart, SelStop);
  if (SelStop - SelStart) < 1 then
  begin
    if (CharCode = VK_BACK) then
    begin
      CursorDec(SelStart);
      GetSel(SelStart, SelStop);
    end;
    while not (IsLiteralChar(FMaskString,Text, SelStop)) do
      Inc(SelStop);
    Txt := Copy(Text,SelStart+2, SelStop - SelStart-1);
    Txt := Txt+' ';
    SetSel(SelStart,SelStop);
    SendMessage(Handle, EM_REPLACESEL, 0, LongInt(PChar(Txt)));
    SetCursor(SelStart);
    Exit;
  end;
  for I:=SelStart to SelStop do
    Txt := Txt+' ';
  if IsMasked then
    Txt := DeleteSelection(Txt,SelStart,SelStop);
  SetSel(SelStart,SelStop);
  SendMessage(Handle, EM_REPLACESEL, 0, LongInt(PChar(Txt)));
  SetCursor(SelStart);
end;

function TText.IsMaskChars(Const NewChar: Char; Offset: Integer; var uPos: Integer): Boolean;
var
  I: Integer;
begin
  Result := False;
  for I:=OffSet to Length(FInputMask) do
  begin