title: How do I draw zoomed text without changing effective text width?
body: <p>I have some code that does custom drawing.  Basically it is form fill program that has a WYSIWYG editor.  The editor allows a zoom level to be set.  I am having problems with the width of my labels jumping to different sizes relative to everything else on the form.</p>
  
  <p>An example of the code I am using to output the text is below.  I'm pretty sure the problem is related to the change in font size not matching up with how everything else scales.  The zoom level must change by enough to bump the font up to the next size before the text changes, even though everything else on the form is moving by a few pixels with every changes.  </p>
  
  <p>This leads to two different problems - the text can either look way to small with lots of white space, or the text will be two large and overlap the next control.  Things look really bad when I have a full line of text.  A one word label does not change enough to cause any problems.</p>
  
  <p>I have thought about limiting the zoom levels - right now I have a slider in 1% increments. But I can't see that any one set of levels is better than any other.  My forms have multiple labels in different font sizes that jump between shorter and longer at different times.</p>
  
  <p>The MultDiv function rounds the result.  I could truncate this value to make sure I am always smaller versus longer, but that looks just as bad because the gaps look that much larger at those zoom levels.</p>
  
  <p>Notes on the code:</p>
  
  <p>This is currently on Delphi 7. This is our last project that has not moved forward, so answers related to newer versions of Delphi are welcome.</p>
  
  <p>We looking into this I did see that a ExtDrawText function exists.  However, changing to that function did not seem to make a difference.</p>
  
  <p>The right of the bounding box is set to 0 and the text is drawn with no clipping because the tool that we use to build the form definition does not keep track of the right boundary of the text.  We just visually line it up to the correct location.</p>
  
  <pre><code>
  procedure OutputText(Canvas: TCanvas; LineNumber: integer; CurrentZoomLevel: integer; FontSize: integer; Text: string);
  const
    FormatFlags = DT_BOTTOM + DT_SINGLELINE + DT_NOPREFIX + DT_LEFT + DT_NOCLIP;
  var
    OutputBox: TRect;
    ZoomedLineHeight: integer;
  begin
    ZoomedLineHeight := MulDiv(UnZoomedLineHeight, CurrentZoomLevel, 96);
    Canvas.Font.Height := -MulDiv(FontSize, CurrentZoomLevel, 96);
  
    OutputBox.Left := ZoomedLineHeight;
    OutputBox.Right := 0;
    OutputBox.Top := (LineNumber * ZoomedLineHeight);
    OutputBox.Bottom := OutputBox.Top + ZoomedLineHeight;
  
    DrawText(Canvas.Handle, PChar(Text), length(Text), OutputBox, FormatFlags);
  end;
  </code></pre>
  
  <h2><p></h2>
  
  <p><strong>Edit:</strong></p>
  
  <p>Using mghie's answer here is my modified test app.  The zooming code is gone with setting the MapMode.  However, the TextOut function still seems to be picking a full font size.  Nothing seem to have changed for the text other than I don't need to calculate the hight of the font myself - the map mode does that for me.</p>
  
  <p>I did find this webpage <a href="http://www.functionx.com/bcb/gdi/gdicoord.htm" rel="nofollow noreferrer">"The GDI Coordinate Systems"</a> that was very useful, but it didn't address text size.</p>
  
  <p>Here is my test app.  It is resizing as you resize the form and has a grid drawn so you can see how the end of the text jumps around.</p>
  
  <pre><code>procedure DrawGrid(Canvas: TCanvas);
  var
    StartPt: TPoint;
    EndPt: TPoint;
    LineCount: integer;
    HeaderString: string;
    OutputBox: TRect;
  begin
    Canvas.Pen.Style := psSolid;
    Canvas.Pen.Width := 1;
    StartPt.X := 0;
    StartPt.Y := LineHeight;
    EndPt.X := Canvas.ClipRect.Right;
    EndPt.Y := LineHeight;
  
    LineCount := 0;
    while (StartPt.Y &lt; Canvas.ClipRect.Bottom) do
    begin
      StartPt.Y := StartPt.Y + LineHeight;
      EndPt.Y := EndPt.Y + LineHeight;
  
      Inc(LineCount);
      if LineCount mod 5 = 0 then
        Canvas.Pen.Color := clRed
      else
        Canvas.Pen.Color := clBlack;
  
      Canvas.MoveTo(StartPt.X, StartPt.Y);
      Canvas.LineTo(EndPt.X, EndPt.Y);
    end;
  
    StartPt.X := 0;
    StartPt.Y := 2 * LineHeight;
  
    EndPt.X := 0;
    EndPt.Y := Canvas.ClipRect.Bottom;
  
    LineCount := 0;
    while StartPt.X &lt; Canvas.ClipRect.Right do
    begin
      StartPt.X := StartPt.X + LineHeight;
      EndPt.X := EndPt.X + LineHeight;
  
      Inc(LineCount);
      if LineCount mod 5 = 0 then
        Canvas.Pen.Color := clRed
      else
        Canvas.Pen.Color := clBlack;
  
      Canvas.MoveTo(StartPt.X, StartPt.Y);
      Canvas.LineTo(EndPt.X, EndPt.Y);
  
      if Canvas.Pen.Color = clRed then
      begin
        HeaderString := IntToStr(LineCount);
        OutputBox.Left := StartPt.X - (4 * LineHeight);
        OutputBox.Right := StartPt.X + (4 * LineHeight);
        OutputBox.Top := 0;
        OutputBox.Bottom := OutputBox.Top + (LineHeight * 2);
        DrawText(Canvas.Handle, PChar(HeaderString), Length(HeaderString),
          OutputBox, DT_BOTTOM + DT_SINGLELINE + DT_NOPREFIX + DT_CENTER);
      end;
    end;
  
  end;
  
  procedure OutputText(Canvas: TCanvas; LineNumber: integer; Text: string);
  const
    FormatFlags = DT_BOTTOM + DT_SINGLELINE + DT_NOPREFIX + DT_LEFT + DT_NOCLIP;
  var
    OutputBox: TRect;
  begin
    OutputBox.Left := LineHeight;
    OutputBox.Right := 0;
    OutputBox.Top := (LineNumber * LineHeight);
    OutputBox.Bottom := OutputBox.Top + LineHeight;
    Windows.TextOut(Canvas.Handle, OutputBox.Left, OutputBox.Top, PChar(Text), Length(Text));
  end;
  
  procedure TForm1.FormCreate(Sender: TObject);
  begin
    DoubleBuffered := false;
  end;
  
  procedure TForm1.FormResize(Sender: TObject);
  begin
    Invalidate;
  end;
  
  procedure TForm1.FormPaint(Sender: TObject);
  const
    ShortString = 'Short';
    MediumString = 'This is a little longer';
    LongString = 'Here is something that is really long here is where I see the problem with zooming.';
  
    PhysicalHeight = 500;
    PhysicalWidth = 400;
  var
    DC: HDC;
    OldMode, i, xy: integer;
    LF: TLogFont;
    OldFont: HFONT;
  
  begin
  
    Canvas.Brush.Style := bsClear;
  
    FillChar(LF, SizeOf(TLogFont), 0);
    LF.lfOutPrecision := OUT_TT_ONLY_PRECIS;
    LF.lfFaceName := 'Arial';
    LF.lfHeight := -12;
  
    DC := Self.Canvas.Handle;
    OldMode := SetMapMode(DC, MM_ISOTROPIC);
    // OldMode := SetMapMode(DC, MM_HIMETRIC);
  
    SetWindowExtEx(DC, PhysicalWidth, PhysicalHeight, nil);
    SetViewportExtEx(DC, Self.Width, Self.Height, nil);
  
    try
      OldFont := Windows.SelectObject(DC, CreateFontIndirect(LF));
  
      DrawGrid(Self.Canvas);
      OutputText(Self.Canvas, 3, ShortString);
      OutputText(Self.Canvas, 4, MediumString);
      OutputText(Self.Canvas, 5, LongString);
  
      DeleteObject(SelectObject(DC, OldFont));
    finally
      SetMapMode(DC, OldMode);
    end;
  
  end;
  </code></pre>