program TestRender; {$APPTYPE CONSOLE} uses Winapi.Windows, Winapi.Messages, Winapi.RichEdit, System.SysUtils, System.Classes, System.Math, Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.ComCtrls, Vcl.Imaging.pngimage; procedure RenderHtmlToBitmapAutoFit( ARichEdit: TRichEdit; const AHtml: string; ABitmap: TBitmap; AWidthPx, AHeightPx: Integer; AScale: Double ); var i, Len, TagStart, TagEnd: Integer; TagContent, UpperTag: string; CurText: string; IsBold, IsUnderline: Boolean; CurSize, BaseSize: Integer; SizeVal: Integer; Fr: TFormatRange; HdcTarget: HDC; LTwipsWidth, LTwipsHeight: Integer; LHorizMarginTwips: Integer; LTotalLen: Integer; LFitScale: Double; Ret: LRESULT; LTextHeightTwips, LOffsetYTwips: Integer; procedure FlushChunk(AFactor: Double); var StartPos: Integer; begin if CurText <> '' then begin StartPos := ARichEdit.GetTextLen; ARichEdit.SelStart := StartPos; ARichEdit.SelLength := 0; ARichEdit.SelAttributes.Name := 'Arial'; ARichEdit.SelAttributes.Color := clBlack; ARichEdit.SelAttributes.Style := []; if IsBold then ARichEdit.SelAttributes.Style := ARichEdit.SelAttributes.Style + [fsBold]; if IsUnderline then ARichEdit.SelAttributes.Style := ARichEdit.SelAttributes.Style + [fsUnderline]; ARichEdit.SelAttributes.Size := Max(6, Round(CurSize * AFactor)); ARichEdit.SelText := CurText; CurText := ''; end; end; procedure PopulateRichEdit(AFactor: Double); begin ARichEdit.Lines.BeginUpdate; try ARichEdit.Clear; BaseSize := Round(12 * AScale); CurSize := BaseSize; IsBold := False; IsUnderline := False; CurText := ''; if Pos('<', AHtml) = 0 then begin CurText := Trim(AHtml); CurSize := Round(13 * AScale); IsBold := True; FlushChunk(AFactor); end else begin i := 1; Len := Length(AHtml); while i <= Len do begin if AHtml[i] = '<' then begin TagStart := i; TagEnd := Pos('>', Copy(AHtml, TagStart, Len - TagStart + 1)); if TagEnd > 0 then begin TagEnd := TagStart + TagEnd - 1; TagContent := Trim(Copy(AHtml, TagStart + 1, TagEnd - TagStart - 1)); UpperTag := UpperCase(TagContent); FlushChunk(AFactor); if (UpperTag = 'B') or (UpperTag = 'STRONG') then IsBold := True else if (UpperTag = '/B') or (UpperTag = '/STRONG') then IsBold := False else if UpperTag = 'U' then IsUnderline := True else if UpperTag = '/U' then IsUnderline := False else if Pos('FONT', UpperTag) = 1 then begin var LSizePos := Pos('SIZE=', UpperTag); if LSizePos > 0 then begin var LValStr := Copy(TagContent, LSizePos + 5, Length(TagContent)); LValStr := StringReplace(LValStr, '"', '', [rfReplaceAll]); LValStr := StringReplace(LValStr, '''', '', [rfReplaceAll]); LValStr := Trim(LValStr); var LSpacePos := Pos(' ', LValStr); if LSpacePos > 0 then LValStr := Copy(LValStr, 1, LSpacePos - 1); SizeVal := StrToIntDef(LValStr, 0); if SizeVal > 0 then CurSize := Round(SizeVal * AScale); end; end else if UpperTag = '/FONT' then CurSize := BaseSize else if (UpperTag = 'BR') or (UpperTag = 'BR/') or (UpperTag = 'BR /') then CurText := CurText + sLineBreak; i := TagEnd + 1; Continue; end; end; if AHtml[i] = '&' then begin if Copy(AHtml, i, 4) = '<' then begin CurText := CurText + '<'; Inc(i, 4); Continue; end else if Copy(AHtml, i, 4) = '>' then begin CurText := CurText + '>'; Inc(i, 4); Continue; end else if Copy(AHtml, i, 5) = '&' then begin CurText := CurText + '&'; Inc(i, 5); Continue; end else if Copy(AHtml, i, 6) = '"' then begin CurText := CurText + '"'; Inc(i, 6); Continue; end; end; CurText := CurText + AHtml[i]; Inc(i); end; FlushChunk(AFactor); end; ARichEdit.SelectAll; ARichEdit.Paragraph.Alignment := taCenter; ARichEdit.SelLength := 0; finally ARichEdit.Lines.EndUpdate; end; end; begin if not Assigned(ARichEdit) or (Trim(AHtml) = '') then Exit; ARichEdit.HandleNeeded; ABitmap.SetSize(AWidthPx, AHeightPx); ABitmap.PixelFormat := pf24bit; HdcTarget := ABitmap.Canvas.Handle; LTwipsWidth := MulDiv(AWidthPx, 1440, 96); LTwipsHeight := MulDiv(AHeightPx, 1440, 96); LHorizMarginTwips := MulDiv(Round(8 * AScale), 1440, 96); LFitScale := 1.0; while LFitScale >= 0.30 do begin PopulateRichEdit(LFitScale); LTotalLen := ARichEdit.GetTextLen; // Limpiar bitmap con fondo blanco ABitmap.Canvas.Brush.Color := clWhite; ABitmap.Canvas.FillRect(Rect(0, 0, AWidthPx, AHeightPx)); HdcTarget := ABitmap.Canvas.Handle; FillChar(Fr, SizeOf(Fr), 0); Fr.hdc := HdcTarget; Fr.hdcTarget := HdcTarget; Fr.rcPage.Left := 0; Fr.rcPage.Top := 0; Fr.rcPage.Right := LTwipsWidth; Fr.rcPage.Bottom := LTwipsHeight; Fr.rc.Left := LHorizMarginTwips; Fr.rc.Top := MulDiv(Round(6 * AScale * LFitScale), 1440, 96); Fr.rc.Right := LTwipsWidth - LHorizMarginTwips; Fr.rc.Bottom := LTwipsHeight; Fr.chrg.cpMin := 0; Fr.chrg.cpMax := -1; // Renderizar directamente (wParam = 1) Ret := SendMessage(ARichEdit.Handle, EM_FORMATRANGE, 1, LPARAM(@Fr)); SendMessage(ARichEdit.Handle, EM_FORMATRANGE, 0, 0); Writeln(Format('LFitScale: %.2f -> Ret: %d / %d', [LFitScale, Ret, LTotalLen])); if (Ret >= LTotalLen) or (LFitScale <= 0.31) then begin Writeln(Format('Fit succeeded at scale: %.2f | rc.Top: %d, rc.Bottom: %d, pageBottom: %d', [LFitScale, Fr.rc.Top, Fr.rc.Bottom, LTwipsHeight])); LTextHeightTwips := Fr.rc.Bottom - Fr.rc.Top; if (LTextHeightTwips > 0) and (LTextHeightTwips < LTwipsHeight) then begin LOffsetYTwips := (LTwipsHeight - LTextHeightTwips) div 2; if LOffsetYTwips > Fr.rc.Top then begin ABitmap.Canvas.Brush.Color := clWhite; ABitmap.Canvas.FillRect(Rect(0, 0, AWidthPx, AHeightPx)); FillChar(Fr, SizeOf(Fr), 0); Fr.hdc := ABitmap.Canvas.Handle; Fr.hdcTarget := ABitmap.Canvas.Handle; Fr.rcPage.Left := 0; Fr.rcPage.Top := 0; Fr.rcPage.Right := LTwipsWidth; Fr.rcPage.Bottom := LTwipsHeight; Fr.rc.Left := LHorizMarginTwips; Fr.rc.Top := LOffsetYTwips; Fr.rc.Right := LTwipsWidth - LHorizMarginTwips; Fr.rc.Bottom := LTwipsHeight; Fr.chrg.cpMin := 0; Fr.chrg.cpMax := -1; Ret := SendMessage(ARichEdit.Handle, EM_FORMATRANGE, 1, LPARAM(@Fr)); SendMessage(ARichEdit.Handle, EM_FORMATRANGE, 0, 0); Writeln(Format('Centered pass -> Ret: %d, Top: %d', [Ret, LOffsetYTwips])); end; end; Break; end; LFitScale := LFitScale - 0.05; end; end; procedure Test; var LForm: TForm; LRich: TRichEdit; LBmp: TBitmap; LPng: TPngImage; begin LForm := TForm.CreateNew(nil); try LRich := TRichEdit.Create(LForm); LRich.Parent := LForm; LRich.Visible := False; LRich.HandleNeeded; LBmp := TBitmap.Create; try // Test 1: Long text with mixed sizes RenderHtmlToBitmapAutoFit(LRich, 'PANETTONE BOMBÓN (XL)', LBmp, 950, 168, 2.5); LPng := TPngImage.Create; try LPng.Assign(LBmp); LPng.SaveToFile('scratch\test_autofit_long.png'); Writeln('Saved to scratch\test_autofit_long.png'); finally LPng.Free; end; finally LBmp.Free; end; finally LForm.Free; end; end; begin Test; end.