syntextdrawer.pas

SynEditStudio delphi 代码编辑器

procedure TheTextDrawer.SetBaseFont(Value: TFont);
begin
  if Assigned(Value) then
  begin
    ReleaseETODist;
    with FFontStock do
    begin
      SetBaseFont(Value);
      Style := FCalcExtentBaseStyle;
      FBaseCharWidth := CharAdvance;
      FBaseCharHeight := CharHeight;
    end;
    SetStyle(Value.Style);

    // Modified by Administrator 2007-11-28 上午 09:49:17
    UnicodeFontChange;
  end
  else
    raise EheTextDrawerException.Create('SetBaseFont: ''Value'' must be specified.');
end;

procedure TheTextDrawer.SetBaseStyle(const Value: TFontStyles);
begin
  if FCalcExtentBaseStyle <> Value then
  begin
    FCalcExtentBaseStyle := Value;
    ReleaseETODist;
    with FFontStock do
    begin
      Style := Value;
      FBaseCharWidth := CharAdvance;
      FBaseCharHeight := CharHeight;
    end;
  end;
end;

procedure TheTextDrawer.SetStyle(Value: TFontStyles);
begin
  with FFontStock do
  begin
    SetStyle(Value);
    Self.FCrntFont := FontHandle;
  end;
  FUnicodeFontStock.SetStyle(Value);
  AfterStyleSet;
end;

procedure TheTextDrawer.SetUnicodeFontName(const Value: TFontName);
begin
  FUnicodeFont.Name := value;
  UnicodeFontChange;
end;

procedure TheTextDrawer.AfterStyleSet;
begin
  if FDC <> 0 then
    SelectObject(FDC, FCrntFont);
end;

procedure TheTextDrawer.SetForeColor(Value: TColor);
begin
  if FColor <> Value then
  begin
    FColor := Value;
    if FDC <> 0 then
      SetTextColor(FDC, ColorToRGB(Value));
  end;
end;

procedure TheTextDrawer.SetBackColor(Value: TColor);
begin
  if FBkColor <> Value then
  begin
    FBkColor := Value;
    if FDC <> 0 then
      Windows.SetBkColor(FDC, ColorToRGB(Value));
  end;
end;

procedure TheTextDrawer.SetCharExtra(Value: Integer);
begin
  if FCharExtra <> Value then
  begin
    FCharExtra := Value;
    DoSetCharExtra(FCharExtra);
  end;
end;

procedure TheTextDrawer.DoSetCharExtra(Value: Integer);
begin
  if FDC <> 0 then
    SetTextCharacterExtra(FDC, Value);
end;

procedure TheTextDrawer.TextOut(X, Y: Integer; Text: PChar;
  Length: Integer);
begin
  Windows.TextOut(FDC, X, Y, Text, Length);
end;

procedure TheTextDrawer.ExtTextOut(X, Y: Integer; fuOptions: UINT;
  const ARect: TRect; Text: PChar; Length: Integer);

  procedure InitETODist(InitValue: Integer);
  const
    EtoBlockSize = $40;
  var
    NewSize: Integer;
    TmpLen: Integer;
    p: PInteger;
    i: Integer;
  begin
    TmpLen := ((not (EtoBlockSize - 1)) and Length) + EtoBlockSize;
    NewSize := TmpLen * SizeOf(Integer);
    ReallocMem(FETODist, NewSize);
    p := PInteger(Integer(FETODist) + FETOSizeInChar * SizeOf(Integer));
    for i := 1 to TmpLen - FETOSizeInChar do
    begin
      p^ := InitValue;
      Inc(p);
    end;
    FETOSizeInChar := TmpLen;
  end;

var
  i : Integer;
  CurrByteType, PrevByteType : TMbcsByteType;
  PrevPos : Integer;
  SText, S: String;
  StrLen : Integer;
  BRect : TRect;
  Buffer : TBitmap;
begin
  if FETOSizeInChar < Length then
    InitETODist(GetCharWidth);

  // Modified by Administrator 2007-11-28 下午 11:03:45
  if UseUnicodeFont and (Length > 0) then
  begin
    Buffer := nil;
    try
      SText := StrPas(Text);
      StrLen := System.Length(SText);
      BRect.Top := 0;
      BRect.Left := 0;
      BRect.Right := ARect.Right - ARect.Left;
      BRect.Bottom := ARect.Bottom - ARect.Top;
      Buffer := TBitmap.Create;
      Buffer.Width := BRect.Right;
      Buffer.Height := BRect.Bottom;
      Buffer.Canvas.Brush.Color := FBkColor;
      Buffer.Canvas.Font.Assign(FFontStock.BaseFont);
      Buffer.Canvas.Font.Color := FColor;
      SelectObject(Buffer.Canvas.Handle, FFontStock.FCrntFont);
      SetBkMode(Buffer.Canvas.Handle, GetBkMode(FDC));
      BitBlt(Buffer.Canvas.Handle, 0, 0, Buffer.Width, Buffer.Height,
        FDC, ARect.Left, ARect.Top, SRCCOPY);

      PrevByteType := ByteType(SText, 1);
      PrevPos := 1;
      I := 2;
      X := X - ARect.Left;

      while i <= StrLen do
      begin
        CurrByteType := ByteType(SText, i);
        if ((PrevByteType = mbLeadByte) and (CurrByteType = mbSingleByte)) or
          ((PrevByteType = mbLeadByte) and (i = StrLen)) then
        begin
          S := Copy(SText, PrevPos, I-PrevPos);
          Buffer.Canvas.Font.Name := FUnicodeFont.Name;
          Buffer.Canvas.Font.Size := FUnicodeFont.Size;
          SelectObject(Buffer.Canvas.Handle, FUnicodeFontStock.FCrntFont);
          Windows.ExtTextOut(Buffer.Canvas.Handle, X,
            (Buffer.Height - FUnicodeFontStock.CharHeight) div 2, fuOptions,
            @BRect, PChar(S), System.Length(S), PInteger(FETODist));
          Buffer.Canvas.Font.Name := FFontStock.BaseFont.Name;
          Buffer.Canvas.Font.Size := FFontStock.BaseFont.Size;
          SelectObject(Buffer.Canvas.Handle, FFontStock.FCrntFont);
          BRect.Left := BRect.Left + (I-PrevPos) * GetCharWidth;
          X := X+(I-PrevPos) * GetCharWidth;
          PrevPos := I;
          PrevByteType := mbSingleByte;
          Inc(i);
        end
        else if ((PrevByteType = mbSingleByte) and (CurrByteType = mbLeadByte))
          or ((PrevByteType = mbSingleByte) and (i = StrLen)) then
        begin
          S := Copy(SText, PrevPos, I-PrevPos);
          Windows.ExtTextOut(Buffer.Canvas.Handle, X,
            (Buffer.Height - FFontStock.CharHeight) div 2, fuOptions,
            @BRect, PChar(S), System.Length(S),
            PInteger(FETODist));
          BRect.Left := BRect.Left + (I-PrevPos) * GetCharWidth;
          X := X+(I-PrevPos) * GetCharWidth;
          PrevPos := I;
          PrevByteType := mbLeadByte;
          Inc(i, 2);
        end
        else Inc(i);
      end;
      BitBlt(FDC, ARect.Left, ARect.Top, Buffer.Width, Buffer.Height,
        Buffer.Canvas.Handle, 0, 0, SRCCOPY);
    finally
      Buffer.Free;
    end;
  end
  else Windows.ExtTextOut(FDC, X, Y, fuOptions, @ARect, Text,
    Length, PInteger(FETODist));
end;

procedure TheTextDrawer.ReleaseTemporaryResources;
begin
  FFontStock.ReleaseFontHandles;
end;

procedure TheTextDrawer.UnicodeFontChange;
var
  Name : string;
begin
  Name := FUnicodeFont.Name;
  FUnicodeFont.Assign(FontStock.BaseFont);
  FUnicodeFont.Name := Name;
  FUnicodeFont.Style := FCalcExtentBaseStyle;
  FUnicodeFontStock.SetBaseFont(FUnicodeFont);
  if (FUnicodeFontStock.CharAdvance > GetCharWidth) or
    (FUnicodeFontStock.CharHeight > GetCharHeight) then
  begin
    while (FUnicodeFontStock.CharAdvance > GetCharWidth) or
      (FUnicodeFontStock.CharHeight > GetCharHeight) do
    begin
      FUnicodeFont.Size := FUnicodeFont.Size - 1;
      FUnicodeFont.Style := FCalcExtentBaseStyle;
      FUnicodeFontStock.SetBaseFont(FUnicodeFont);
    end
  end
  else if (FUnicodeFontStock.CharAdvance < GetCharWidth) and
    (FUnicodeFontStock.CharHeight < GetCharHeight) then
  begin
    repeat
      FUnicodeFont.Height := FUnicodeFont.Height - 1;
      FUnicodeFont.Style := FCalcExtentBaseStyle;
      FUnicodeFontStock.SetBaseFont(FUnicodeFont);
    until (FUnicodeFontStock.CharAdvance > GetCharWidth) or
      (FUnicodeFontStock.CharHeight > GetCharHeight);
    FUnicodeFont.Height := FUnicodeFont.Height + 1;
  end;
end;

{ TheTextDrawer2 }

procedure TheTextDrawer2.SetStyle(Value: TFontStyles);
var
  idx: Integer;
begin
  idx := PByte(@Value)^;
  if FFonts[idx] <> 0 then
  begin
    FCrntFont := FFonts[idx];
    AfterStyleSet;
  end
  else
  begin
    inherited;
    FFonts[idx] := FCrntFont;
  end;
end;

procedure TheTextDrawer2.SetBaseFont(Value: TFont);
var
  i: Integer;
begin
  for i := Low(FFonts) to High(FFonts) do
    FFonts[i] := 0;
  inherited;
end;

{ TheTextDrawerEx }

procedure TheTextDrawerEx.AfterStyleSet;
begin
  inherited;
  with FontStock do
  begin
    FCrntDx := BaseCharWidth - CharAdvance;
    case IsDBCSFont of
      False:
        begin
          if StockDC <> 0 then
            SetTextCharacterExtra(StockDC, CharExtra + FCrntDx);
          if IsTrueType or (not (fsItalic in Style)) then
            FExtTextOutProc := TextOutOrExtTextOut
          else
            FExtTextOutProc := ExtTextOutFixed;
        end;
      True:
        begin
          FCrntDBDx := DBCHAR_CALCULATION_FALED;
          FExtTextOutProc := ExtTextOutWithETO;
        end;
    end;
  end;
end;

procedure TheTextDrawerEx.DoSetCharExtra(Value: Integer);
begin
  if not FontStock.IsDBCSFont then
  begin
    SetBkMode(StockDC, OPAQUE);
    SetTextCharacterExtra(StockDC, Value + FCrntDx);
  end
  else if FCrntDBDx = DBCHAR_CALCULATION_FALED then
    SetTextCharacterExtra(StockDC, Value);
end;

procedure TheTextDrawerEx.ExtTextOut(X, Y: Integer; fuOptions: UINT;
  const ARect: TRect; Text: PChar; Length: Integer);
begin
  FExtTextOutProc(X, Y, fuOptions, ARect, Text, Length);
end;

procedure TheTextDrawerEx.ExtTextOutFixed(X, Y: Integer; fuOptions: UINT;
  const ARect: TRect; Text: PChar; Length: Integer);
begin
  Windows.ExtTextOut(StockDC, X, Y, fuOptions, @ARect, Text, Length, nil);
end;

procedure TheTextDrawerEx.ExtTextOutForDBCS(X, Y: Integer; fuOptions: UINT;
  const ARect: TRect; Text: PChar; Length: Integer);
var
  pCrnt: PChar;
  pTail: PChar;
  pRun: PChar;

  procedure GetSBCharRange;
  begin
    while (pRun <> pTail) and (not (pRun^ in LeadBytes)) do
      Inc(pRun);
  end;

  procedure GetDBCharRange;
  begin
    while (pRun <> pTail) and (pRun^ in LeadBytes) do
      Inc(pRun, 2);
  end;

var
  TmpRect: TRect;
  Len: Integer;
  n: Integer;
begin
  pCrnt := Text;
  pRun := Text;
  pTail := PChar(Integer(Text) + Length);
  TmpRect := ARect;
  while pCrnt < pTail do
  begin
    GetSBCharRange;
    if pRun <> pCrnt then
    begin
      SetTextCharacterExtra(StockDC, FCharExtra + FCrntDx);
      Len := Integer(pRun) - Integer(pCrnt);
      with TmpRect do
      begin
        n := GetCharWidth * Len;
        Right := Min(Left + n + GetCharWidth, ARect.Right);
        Windows.ExtTextOut(StockDC, X, Y, fuOptions, @TmpRect, pCrnt, Len, nil);
        Inc(X, n);
        Inc(Left, n);
      end;
    end;
    pCrnt := pRun;
    if pRun = pTail then
      break;
    
    GetDBCharRange;
    SetTextCharacterExtra(StockDC, FCharExtra + FCrntDBDx);
    Len := Integer(pRun) - Integer(pCrnt);
    with TmpRect do
    begin
      n := GetCharWidth * Len;
      Right := Min(Left + n + GetCharWidth, ARect.Right);
      Windows.ExtTextOut(StockDC, X, Y, fuOptions, @TmpRect, pCrnt, Len, nil);
      Inc(X, n);
      Inc(Left, n);
    end;
    pCrnt := pRun;
  end;

  if (pCrnt = Text) or // maybe Text is not assigned or Length is 0
     (TmpRect.Right < ARect.Right) then
  begin
    SetTextCharacterExtra(StockDC, FCharExtra + FCrntDx);
    Windows.ExtTextOut(StockDC, X, Y, fuOptions, @TmpRect, nil, 0, nil);
  end;
end;

procedure TheTextDrawerEx.ExtTextOutWithETO(X, Y: Integer; fuOptions: UINT;
  const ARect: TRect; Text: PChar; Length: Integer);
begin
  inherited ExtTextOut(X, Y, fuOptions, ARect, Text, Length);
end;

procedure TheTextDrawerEx.TextOutOrExtTextOut(X, Y: Integer;
  fuOptions: UINT; const ARect: TRect; Text: PChar; Length: Integer);
begin
  // this function may be used when:
  //  a. the text does not containing any multi-byte characters
  // AND
  //   a-1. current font is TrueType.
  //   a-2. current font is RasterType and it is not italicic.
  with ARect do
    if Assigned(Text) and (Length > 0) and
       (Left = X) and (Top = Y) and
       ((Bottom - Top) = GetCharHeight) and
       (Left + GetCharWidth * (Length + 1) > Right) then
    Windows.TextOut(StockDC, X, Y, Text, Length)
  else
    Windows.ExtTextOut(StockDC, X, Y, fuOptions, @ARect, Text, Length, nil)
end;

{$IFNDEF HE_LEADBYTES}
procedure InitializeLeadBytes;
var
  c: Char;
begin
  for c := Low(Char) to High(Char) do
    if IsDBCSLeadByte(Byte(c)) then
      Include(LeadBytes, c);
end;
{$ENDIF} // HE_LEADBYTES

initialization

{$IFNDEF HE_LEADBYTES}
  InitializeLeadBytes;
{$ENDIF} 

finalization

  gFontsInfoManager.Free;

end.