OberonCore

MODULE DiaHost;
   
   IMPORT WinApi, HostFonts, HostPorts, Ports, Fonts, Views;

   PROCEDURE DrawStringA* (f: Views.Frame; x, y, angle: INTEGER; col: Ports.Color; s: ARRAY OF CHAR; font: Fonts.Font);
      VAR n, a, res: INTEGER; df: HostFonts.DevFont; pt: HostPorts.Port;
         dc: WinApi.HANDLE; ind: WinApi.BOOL; NewFont: WinApi.HFONT;
         fsize: WinApi.SIZE;
   BEGIN
      pt := f.rider(HostPorts.Rider).port;
      dc := pt.dc;
      res := WinApi.SaveDC(dc);
      res := WinApi.SetBkMode(dc, WinApi.TRANSPARENT);
      res := WinApi.SetTextColor(dc, col);
      (* Вычисляем длину строки *)
      a := LEN(s) - 1; n := 0;
      WHILE (n < a) & (s[n] # 0X) DO
         INC(n)
      END;
      IF angle MOD 360 = 0 THEN
         (* Если угол поворота кратен 360, то использовать обычный шрифт *)
         df := font(HostFonts.Font).dev;
         res := WinApi.SelectObject(dc, df.id);
         res := WinApi.TextOutW(dc, x, y, s, n);
         res := WinApi.RestoreDC(dc, - 1)
      ELSE
         (* Иначе, создать новый шрифт *)
         NewFont := WinApi.CreateFontW( - ((font.size + pt.unit DIV 2) DIV pt.unit), 0, angle * 10, angle * 10, Fonts.normal, 0, 0, 0, 0, 7, 2, 1, 38, font.typeface);
         (* Вычислить ширину строки
         ind := WinApi.GetTextExtentPoint32W(dc, s, n, fsize); *)
         (* Выбрать шрифт *)
         res := WinApi.SelectObject(dc, NewFont);
         (* Вывести текст *)
         res := WinApi.TextOutW(dc, x, y, s, n);
         res := WinApi.RestoreDC(dc, - 1);
         (* Удалить шрифт *)
         ind := WinApi.DeleteObject(NewFont);
      END
   END DrawStringA;
   
END DiaHost.

Вычисление длины строки в Компонентном Паскале - встроенная операция.

PROCEDURE Create* (): Axes;
      VAR ar: Rendaxes; a: Axes;
   BEGIN
      NEW(ar);
      ar.curveCounter := 0;
      a := ar;
      RETURN a
   END Create;

   PROCEDURE Create* (): Axes;
      VAR ar: Rendaxes; a: Axes;
   BEGIN
      NEW(ar);
      ar.curveCounter := 0;
      a := ar;
      RETURN a
   END Create;

   PROCEDURE Create* (): Axes;
      VAR ar: Rendaxes; a: Axes;
   BEGIN
      NEW(ar);
      ar.curveCounter := 0;
      a := ar;
      RETURN a
   END Create;

   PROCEDURE Create* (): Axes;
      VAR ar: Rendaxes;
   BEGIN
      NEW(ar);
      ar.curveCounter := 0;
      RETURN ar
   END Create;

   PROCEDURE (a: Axes) Show*, NEW;
   PROCEDURE (a: Axes) Update*, NEW;
   PROCEDURE (a: Axes) SetStyle* (ident: INTEGER; mode: CHAR; size, color: INTEGER), NEW;

   PROCEDURE Show* (a: Axes);
   PROCEDURE Update* (a: Axes);
   PROCEDURE SetStyle* (a: Axes; ident: INTEGER; mode: CHAR; size, color: INTEGER);

   PROCEDURE (a: Axes) Update*, NEW;
   BEGIN
      Views.Update(a, TRUE)
   END Update;

Converters.Register("", "XhtmlExporter.ExportText", "TextViews.View", "html", {});

   Axes* = POINTER TO ABSTRACT RECORD (Views.View)
      title*: Views.Title;
      curve*: ARRAY 99 OF Curve;
      curveCounter: INTEGER;
      xtitle*, ytitle*: ARRAY 256 OF CHAR;
      grid*, legend*, auto*, isReady*: BOOLEAN;
      xmin*, xmax*, ymin*, ymax*: REAL;
      leg: Legend;
   END;
   Rendaxes = POINTER TO RECORD (Axes) END;
...
   PROCEDURE SaveRastr(a: Rendaxes; name1: ARRAY OF CHAR);
   VAR res: INTEGER; bmp: Converters.Converter; path: Files.Locator; name: Files.Name;
   BEGIN
      bmp := Converters.list;
      path := Files.dir.This("");
      name := name1$;
      WHILE (bmp # NIL) & (bmp.fileType # "bmp") DO bmp := bmp.next END;
      Views.Register(HostBitmaps.ViewToBitmap(a, 24), Views.dontAsk, path, name, bmp, res)
   END SaveRastr;

   PROCEDURE (axes: Rendaxes) Restore (f: Views.Frame; fl, ft, fr, fb: INTEGER);
...
      SaveRastr(axes, "test.bmp");
   END Restore;