home *** CD-ROM | disk | FTP | other *** search
/ Borland Programmer's Resource / Borland_Programmers_Resource_CD_1995.iso / fonts / sysfon10 / sysfon.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1995-05-19  |  15.7 KB  |  463 lines
  1. PROGRAM SysFon;
  2.  
  3.   { Version 1.0, 01/22/93 - written by Peter Karrer, pkarrer@bernina.ethz.ch }
  4.  
  5.   {$M 16384,16384}
  6.   {$R SYSFON.RES}
  7.   {$I-}
  8.  
  9.   USES WObjects, WinTypes, WinProcs, Strings, Win31, CommDlg;
  10.  
  11.   CONST
  12.     appName: PCHAR = 'SysFon';
  13.     fntHdSize = 126;
  14.     fonHdSize = 356;
  15.  
  16.   TYPE
  17.     FontDirEntry =
  18.       RECORD
  19.         version: WORD;
  20.         size: LONGINT;
  21.         copyright: ARRAY[0..59] OF CHAR;
  22.         typ, point, vRes, hRes, asc, iLead, eLead: WORD;
  23.         ita, usc, strike: byte;
  24.         weight: WORD;
  25.         charset: BYTE;
  26.         w, h: WORD;
  27.         pitchAndFam: BYTE;
  28.         avgW, maxW: WORD;
  29.         fCh, lCh, dCh, bCh: BYTE;
  30.         widthBytes: WORD;
  31.         dev, face, rsvd: LONGINT;
  32.       END;
  33.  
  34.     HdrBufR = RECORD
  35.       constantStuff: ARRAY[0..$DF] OF BYTE;
  36.       fntSize: WORD;
  37.       otherStuff: ARRAY[0..48] OF BYTE;
  38.       moduleDescriptionLen: BYTE;
  39.       moduleDescription: ARRAY[0..73] OF CHAR;
  40.       trailer: ARRAY[0..31] OF CHAR;
  41.     END;
  42.  
  43.     TThisApp = OBJECT(TApplication)
  44.       PROCEDURE InitMainWindow; VIRTUAL;
  45.     END;
  46.  
  47.     PFnWin = ^TFnWin;
  48.     TFnWin = OBJECT(TDlgWindow)
  49.       dc: HDC;
  50.       fnH: HFont;
  51.       cf: TChooseFont;
  52.       lf: TLogFont;
  53.       tm: TTextMetric;
  54.       fd: FontDirEntry;
  55.       ofn: TOpenFileName;
  56.       faceName, orgFaceName: ARRAY[0..lf_FaceSize-1] OF CHAR;
  57.       CONSTRUCTOR Init;
  58.       PROCEDURE SetupWindow; VIRTUAL;
  59.       FUNCTION GetClassName: PCHAR; VIRTUAL;
  60.       PROCEDURE GetWindowClass(VAR c: TWndClass); VIRTUAL;
  61.       PROCEDURE SelectFont(VAR msg: TMessage); VIRTUAL id_first + 101;
  62.       PROCEDURE SaveFont(VAR msg: TMessage); VIRTUAL id_first + 103;
  63.       PROCEDURE Help(VAR msg: TMessage); VIRTUAL id_first + 102;
  64.       PROCEDURE WMPaint(VAR msg: TMessage); VIRTUAL wm_first + wm_Paint;
  65.       PROCEDURE FillFontDir(wBytes: WORD);
  66.       PROCEDURE WMDestroy(VAR msg: TMessage); VIRTUAL wm_first + wm_Destroy;
  67.     END;
  68.  
  69.   VAR
  70.     thisApp: TThisApp;
  71.     outF: FILE;
  72.  
  73.   FUNCTION HelpDlgProc(win: HWnd; m, w: WORD; l: LONGINT): BOOL; EXPORT;
  74.   BEGIN
  75.     HelpDlgProc := FALSE;
  76.     IF m = wm_InitDialog THEN BEGIN
  77.       HelpDlgProc := TRUE;
  78.     END ELSE IF m = wm_Command THEN BEGIN
  79.       EndDialog(win, 0);
  80.       HelpDlgProc := TRUE;
  81.     END;
  82.   END;
  83.  
  84.   PROCEDURE TFnWin.FillFontDir(wBytes: WORD);
  85.     {Fill FontDir structure with info from text metrics and computed FNT size}
  86.   BEGIN
  87.     WITH fd, tm DO BEGIN
  88.       version := 512;
  89.       face := wBytes * tmHeight + (tmLastChar - tmFirstChar) * 4 + fntHdSize;
  90.       size := face + STRLEN(faceName) + 1;
  91.       FillChar(copyright, SIZEOF(copyright), #0);
  92.       STRPCOPY(copyright, '(c) of orig. font "' + STRPAS(orgFaceName) + '" applies');
  93.       typ := 0;
  94.       point := (cf.iPointSize + 5) DIV 10;
  95.       vRes := tmDigitizedAspectY;
  96.       hRes := tmDigitizedAspectX;
  97.       asc := tmAscent;
  98.       iLead := tmInternalLeading;
  99.       eLead := tmExternalLeading;
  100.       ita := tmItalic;
  101.       usc := tmUnderlined;
  102.       strike := tmStruckOut;
  103.       weight := tmWeight;
  104.       charset := ANSI_Charset;
  105.       h := tmHeight;
  106.       pitchAndFam := tmPitchAndFamily AND NOT (TMPF_Vector OR TMPF_TrueType OR TMPF_Device);
  107.       IF (pitchAndFam AND TMPF_Fixed_Pitch) <> 0 THEN BEGIN {*not* fixed pitch}
  108.         w := 0;
  109.       END ELSE BEGIN
  110.         w := tmAveCharWidth;
  111.       END;
  112.       avgW := tmAveCharWidth;
  113.       maxW := tmMaxCharWidth;
  114.       fCh := tmFirstChar;
  115.       lCh := tmLastChar;
  116.       dCh := tmDefaultChar - tmFirstChar;
  117.       bCh := tmBreakChar - tmFirstChar;
  118.       widthBytes := wBytes;
  119.       dev := 0;
  120.       rsvd := 0;
  121.     END;
  122.   END;
  123.  
  124.   CONSTRUCTOR TFnWin.Init;
  125.   BEGIN
  126.     TDlgWindow.Init(NIL, appName);
  127.   END;
  128.  
  129.   FUNCTION TFnWin.GetClassName: PCHAR;
  130.     VAR
  131.       d: PCHAR;
  132.   BEGIN
  133.     GetClassName := appName;
  134.   END;
  135.  
  136.   PROCEDURE TFnWin.GetWindowClass(VAR c: TWndClass);
  137.   BEGIN
  138.     TDlgWindow.GetWindowClass(c);
  139.     {c.hIcon := LoadIcon(hInstance, appName);}
  140.     {doesn't work with TDlgWindow!?, do it in SetupWindow }
  141.   END;
  142.  
  143.   PROCEDURE TFnWin.SetupWindow;
  144.   BEGIN
  145.     TDlgWindow.SetupWindow;
  146.     SetClassWord(hWindow, GCW_HICON, LoadIcon(hInstance, appName));
  147.     GetObject(GetStockObject(System_Font), SIZEOF(TLogFont), @lf);
  148.     lf.lfFaceName[31] := #0; {safety}
  149.     fnH := CreateFontIndirect(lf);
  150.   END;
  151.  
  152.   PROCEDURE TFnWin.WMPaint(VAR msg: TMessage);
  153.     VAR
  154.       ps: TPaintStruct;
  155.       b: HBrush;
  156.       pen: HPen;
  157.       r: TRect;
  158.       w, h, h1: INTEGER;
  159.       oldfnH: HFont;
  160.   BEGIN
  161.     {Paint simulated window title and menu bar}
  162.     BeginPaint(hWindow, ps);
  163.     GetClientRect(hWindow, r);
  164.     w := r.right - r.left - 11;
  165.     SetBkMode(ps.hDC, transparent);
  166.     oldfnH := SelectObject(ps.hDC, fnH);
  167.     GetTextMetrics(ps.hDC, tm);
  168.     h := GetSystemMetrics(sm_CYSize);
  169.     IF tm.tmHeight > h THEN BEGIN
  170.       h := tm.tmHeight - 1;
  171.     END;
  172.     h1 := GetSystemMetrics(sm_CYSize);
  173.     IF (tm.tmHeight + tm.tmExternalLeading) >= h1 THEN BEGIN
  174.       h1 := tm.tmHeight + tm.tmExternalLeading + 1;
  175.     END;
  176.     SetRect(r, 11, 11, w, 11 + h);
  177.     b := CreateSolidBrush(GetSysColor(color_ActiveCaption));
  178.     FillRect(ps.hDC, r, b);
  179.     DeleteObject(b);
  180.     pen := SelectObject(ps.hDC, CreatePen(ps_Solid, 1, GetSysColor(color_WindowFrame)));
  181.     MoveTo(ps.hDC, 10, 10);
  182.     LineTo(ps.hDC, w, 10);
  183.     LineTo(ps.hDC, w, 10 + h + 1);
  184.     LineTo(ps.hDC, 10, 10 + h + 1);
  185.     LineTo(ps.hDC, 10, 10);
  186.     MoveTo(ps.hDC, 10, 10 + h + 2);
  187.     LineTo(ps.hDC, 10, 10 + h + 2 + h1);
  188.     LineTo(ps.hDC, w, 10 + h + 2 + h1);
  189.     LineTo(ps.hDC, w, 10 + h + 1);
  190.     DeleteObject(SelectObject(ps.hDC, pen));
  191.     SetTextColor(ps.hDC, GetSysColor(color_CaptionText));
  192.     DrawText(ps.hDC, 'Sample Window Title', -1, r, dt_Center OR dt_VCenter OR dt_SingleLine);
  193.     SetRect(r, 11, 10 + h + 2, w, 10 + h + 2 + h1);
  194.     b := CreateSolidBrush(GetSysColor(color_Menu));
  195.     FillRect(ps.hDC, r, b);
  196.     DeleteObject(b);
  197.     r.bottom := r.bottom - 1;
  198.     SetTextColor(ps.hDC, GetSysColor(color_MenuText));
  199.     DrawText(ps.hDC, '   &Sample Menu Bar', -1, r, dt_VCenter OR dt_SingleLine);
  200.     SelectObject(ps.hDC, oldfnH);
  201.     EndPaint(hWindow, ps);
  202.   END;
  203.  
  204.   PROCEDURE TFnWin.Help(VAR msg: TMessage);
  205.     VAR
  206.       inst: TFarProc;
  207.   BEGIN
  208.     inst := MakeProcInstance(@HelpDlgProc, hInstance);
  209.     DialogBox(hInstance, 'SYSFONH', hWindow, inst);
  210.     FreeProcInstance(inst);
  211.   END;
  212.  
  213.   PROCEDURE TFnWin.SelectFont(VAR msg: TMessage);
  214.     VAR
  215.       oldFnH: HFont;
  216.       mDC: HDC;
  217.   BEGIN
  218.     FillChar(cf, SIZEOF(TChooseFont), #0);
  219.     WITH cf DO BEGIN
  220.       lStructSize := SIZEOF(TChooseFont);
  221.       hWndOwner := hWindow;
  222.       {nFontType := Screen_FontType;}
  223.       lpLogFont := @lF;
  224.       flags := CF_ScreenFonts OR CF_InitToLogFontStruct;
  225.     END;
  226.     {Standard ChooseFont dialog}
  227.     IF ChooseFont(cf) THEN BEGIN
  228.       {Create a memory device context}
  229.       dc := GetDC(hWindow);
  230.       mDC := CreateCompatibleDC(dc);
  231.       ReleaseDC(hWindow, dc);
  232.       {Create and select chosen font, get text metrics info}
  233.       DeleteObject(fnH);
  234.       fnH := CreateFontIndirect(lf);
  235.       lf.lfFaceName[31] := #0; {safety}
  236.       InvalidateRect(hWindow, NIL, TRUE);
  237.       oldFnH := SelectObject(mDC, fnH);
  238.       GetTextMetrics(mDC, tm);
  239.       IF lf.lfCharset <> ANSI_CharSet THEN BEGIN
  240.         MessageBeep(mb_IconExclamation);
  241.         MessageBox(0, 'Character set is not ANSI', lf.lfFaceName, mb_OK OR mb_IconExclamation);
  242.       END;
  243.       IF (tm.tmFirstChar > 32) OR (tm.tmLastChar < 255) THEN BEGIN
  244.         MessageBeep(mb_IconExclamation);
  245.         MessageBox(0, 'Font doesn''t contain all characters from 0x20 to 0xFF',
  246.                    lf.lfFaceName, mb_OK OR mb_IconExclamation);
  247.       END;
  248.       {Cleanup}
  249.       SelectObject(mDC, oldFnH);
  250.       DeleteDC(mDC);
  251.     END;
  252.   END;
  253.  
  254.   PROCEDURE TFnWin.SaveFont(VAR msg: TMessage);
  255.     VAR
  256.       wBytes: WORD;
  257.       oldFnH: HFont;
  258.       off, w, h, ix, ix1, ix2: WORD;
  259.       mDC, mDC1: HDC;
  260.       bmH, bmH1: HBitmap;
  261.       raster: ARRAY[0..511] OF BYTE;
  262.       st: ARRAY[0..1] OF CHAR;
  263.       s1, s2, s3: STRING[8];
  264.       rasterOff: WORD;
  265.       fnTab: ARRAY[0..255] OF RECORD width, off: WORD END;
  266.       dirName, fileName, fileTitle, filter: ARRAY[0..255] OF CHAR;
  267.       defExt: ARRAY[0..3] OF CHAR;
  268.       hdrBuf: HdrBufR;
  269.       textExt: LONGINT;
  270.       rH, mH: THandle;
  271.       mP: ^CHAR;
  272.   BEGIN
  273.     {Save as... Dialog}
  274.     FillChar(ofn, SIZEOF(TOpenFileName), #0);
  275.     GetSystemDirectory(dirName, SIZEOF(dirName));
  276.     fileName[0] := #0;
  277.     STRCOPY(filter, 'Font File(*.FON);*.FON');
  278.     STRCOPY(defExt, 'FON');
  279.     filter[16] := #0;
  280.     filter[23] := #0;
  281.     WITH ofn DO BEGIN
  282.       lStructSize := SIZEOF(TOpenFileName);
  283.       hWndOwner := hWindow;
  284.       lpstrFilter := filter;
  285.       lpstrFile := fileName;
  286.       nMaxFile := SIZEOF(fileName);
  287.       lpstrFileTitle := fileTitle;
  288.       nMaxFileTitle := SIZEOF(fileTitle);
  289.       lpstrInitialDir := dirName;
  290.       flags := ofn_OverwritePrompt OR ofn_NoChangeDir OR ofn_pathMustExist;
  291.       lpstrDefExt := defExt;
  292.       lpstrTitle := 'Save generated system font as';
  293.     END;
  294.     IF GetSaveFileName(ofn) THEN BEGIN
  295.       {Create a memory device context}
  296.       dc := GetDC(hWindow);
  297.       mDC := CreateCompatibleDC(dc);
  298.       ReleaseDC(hWindow, dc);
  299.       {Create a monochrome 256x256 bitmap}
  300.       bmH := CreateBitmap(256, 256, 1, 1, NIL);
  301.       {Make the memory DC's area 256x256}
  302.       SelectObject(mDC, bmH);
  303.       {Select chosen font into the memory DC, get text metrics}
  304.       oldFnH := SelectObject(mDC, fnH);
  305.       GetTextMetrics(mDC, tm);
  306.       {Create another memory DC}
  307.       mDC1 := CreateCompatibleDC(mDC);
  308.       {Create a monochrome 8x256 bitmap}
  309.       bmH1 := CreateBitmap(8, 256, 1, 1, NIL);
  310.       {Make the memory DC's area 8x256}
  311.       SelectObject(mDC1, bmH1);
  312.       {offset of raster pattern part in FNT resource}
  313.       rasterOff := fntHdSize + 4 * (tm.tmLastChar - tm.tmFirstChar);
  314.       off := rasterOff;
  315.       {Compute width and offset of each character pattern}
  316.       wBytes := 1;
  317.       st[1] := #0;
  318.       h := tm.tmHeight;
  319.       FOR ix := ORD(tm.tmFirstChar) TO ORD(tm.tmLastChar) DO BEGIN
  320.         {For each font character:}
  321.         st[0] := CHR(ix);
  322.         {Get width and height in pixels}
  323.         textExt := GetTextExtent(mDC, st, 1);
  324.         fnTab[ix].width := LoWord(textExt);
  325.         fnTab[ix].off := off;
  326.         w := (LoWord(textExt) + 7) DIV 8;
  327.         wBytes := wBytes + w;
  328.         off := off + w * h;
  329.       END; {FOR ix}
  330.       IF (LONGINT(wBytes) * h) > 64350 THEN BEGIN
  331.         MessageBeep(mb_IconExclamation);
  332.         MessageBox(0, 'Font resource too big (> 65535 bytes)', lf.lfFaceName,
  333.                    mb_OK OR mb_IconExclamation);
  334.       END ELSE BEGIN
  335.         {If original font generated by SysFon, remove the 'SysFon: ' string}
  336.         IF STRLCOMP(lf.lfFaceName, 'SysFon: ', 8) = 0 THEN BEGIN
  337.           STRCOPY(orgFaceName, ADDR(lf.lfFaceName[8]));
  338.         END ELSE BEGIN
  339.           STRCOPY(orgFaceName, lf.lfFaceName);
  340.         END;
  341.         {Construct new face name}
  342.         FillChar(faceName, SIZEOF(faceName), #0);
  343.         STRCOPY(faceName, 'SysFon: ');
  344.         STRLCAT(faceName, orgFaceName, lf_FaceSize - 1);
  345.         {Fill FontDir structure from text metrics and computed size (wBytes)}
  346.         FillFontDir(wBytes);
  347.         {Use filter as null buffer}
  348.         FillChar(filter, SIZEOF(filter), #0);
  349.         {retrieve .FON header from resource #12345}
  350.         rH := FindResource(hInstance, MakeIntResource(12345), MakeIntResource(12345));
  351.         mH := LoadResource(hInstance, rH);
  352.         mP := LockResource(mH);
  353.         MOVE(mP^, hdrBuf, fonHdSize);
  354.         UnlockResource(mH);
  355.         FreeResource(mH);
  356.         {Fill variable part of .FON header}
  357.         hdrBuf.fntSize := (fd.size + 15) DIV 16;
  358.         STR(100 * fd.hRes DIV fd.vRes, s1);
  359.         STR(fd.hRes, s2);
  360.         STR(fd.vRes, s3);
  361.         STRPCOPY(hdrBuf.moduleDescription, 'FONTRES ' + s1 + ',' + s2 + ',' +
  362.                  s3 + ': System Font (' + STRPAS(orgFaceName) + ')');
  363.         hdrBuf.moduleDescriptionLen := STRLEN(hdrBuf.moduleDescription);
  364.         {Write .FON header}
  365.         IF IORESULT = 0 THEN BEGIN END; {Clear I/O error flag}
  366.         ASSIGN(outF, fileName);
  367.         REWRITE(outF, 1);
  368.         BLOCKWRITE(outF, hdrBuf, fonHdSize);
  369.         {Write FONTDIR resource}
  370.         BLOCKWRITE(outF, fd, SIZEOF(FontDirEntry));
  371.         BLOCKWRITE(outF, filter, 1); {null device name}
  372.         BLOCKWRITE(outF, faceName, STRLEN(faceName) + 1);
  373.         BLOCKWRITE(outF, filter, 41 - STRLEN(faceName));
  374.         {Write FNT resource}
  375.         BLOCKWRITE(outF, fd, SIZEOF(FontDirEntry));
  376.         {Write offset to raster patterns}
  377.         BLOCKWRITE(outF, rasterOff, 2);
  378.         {Write 3 null bytes (meaning unknown)}
  379.         BLOCKWRITE(outF, filter, 3);
  380.         {Write the width/offset table}
  381.         BLOCKWRITE(outF, fnTab[tm.tmFirstChar], 4 * (tm.tmLastChar - tm.tmFirstChar + 1));
  382.         {Extra char at end}
  383.         w := 8;
  384.         BLOCKWRITE(outF, w, 2);
  385.         BLOCKWRITE(outF, off, 2);
  386.         FOR ix := ORD(tm.tmFirstChar) TO ORD(tm.tmLastChar) DO BEGIN
  387.           st[0] := CHR(ix);
  388.           w := fnTab[ix].width;
  389.           off := (w + 7) DIV 8;
  390.           {Clear background to 8 pixel boundary}
  391.           PatBlt(mDC, 0, 0, off * 8, h, Whiteness);
  392.           {Write the character}
  393.           TextOut(mDC, 0, 0, st, 1);
  394.           {mDC now contains the pixel representation of the character}
  395.           w := 0;
  396.           FOR ix1 := 1 TO off DO BEGIN
  397.             {Get next 8-pixel column of raster pattern}
  398.             BitBlt(mDC1, 0, 0, 8, h, mDC, w, 0, NotSrcCopy);
  399.             {Bitmaps are always padded to multiples of 16 bit}
  400.             GetBitmapBits(bmH1, h*2, @raster);
  401.             FOR ix2 := 1 TO h - 1 DO BEGIN
  402.               raster[ix2] := raster[2*ix2];
  403.             END;
  404.             BLOCKWRITE(outF, raster, h);
  405.             w := w + 8;
  406.           END;
  407.         END;
  408.         {Extra char at end}
  409.         BLOCKWRITE(outF, filter, h);
  410.         {Face Name}
  411.         BLOCKWRITE(outF, faceName, STRLEN(faceName) + 1);
  412.         {Trailer}
  413.         BLOCKWRITE(outF, filter, hdrBuf.fntSize * 16 - fd.size);
  414.         CLOSE(outF);
  415.         IF IORESULT <> 0 THEN BEGIN
  416.           MessageBeep(mb_IconExclamation);
  417.           MessageBox(0, 'Save failed', fileName, mb_OK OR mb_IconExclamation);
  418.         END ELSE BEGIN
  419.           {MessageBeep(mb_IconQuestion);}
  420.           IF MessageBox(0, 'Font saved. Update system settings? ' + #13 + #10 +
  421.                            '(You must restart Windows for changes to take effect.)',
  422.                         filename, mb_YesNo OR mb_IconQuestion) = idYes THEN BEGIN
  423.             {Update SYSTEM.INI}
  424.             GetWindowsDirectory(filter, SIZEOF(filter));
  425.             IF filter[STRLEN(filter)-1] <> '\' THEN BEGIN
  426.               STRCAT(filter, '\');
  427.             END;
  428.             STRCAT(filter, 'SYSTEM.INI');
  429.             {Use full path name if not saved in the windows system directory}
  430.             IF STRLCOMP(fileName, dirName, STRLEN(dirName)) = 0 THEN BEGIN
  431.               WritePrivateProfileString('boot', 'fonts.fon', fileTitle, filter);
  432.             END ELSE BEGIN
  433.               WritePrivateProfileString('boot', 'fonts.fon', fileName, filter);
  434.             END;
  435.           END; {idYes}
  436.         END; {IOResult = 0}
  437.       END; {not too big}
  438.       {Cleanup}
  439.       SelectObject(mDC, oldFnH);
  440.       DeleteDC(mDC);
  441.       DeleteObject(bmH);
  442.       DeleteDC(mDC1);
  443.       DeleteObject(bmH1);
  444.     END; {IF GetSaveFileName}
  445.   END; {SaveFont}
  446.  
  447.   PROCEDURE TFnWin.WMDestroy(VAR msg: TMessage);
  448.   BEGIN
  449.     DeleteObject(fnH);
  450.     TDlgWindow.WMDestroy(msg);
  451.   END;
  452.  
  453.   PROCEDURE TThisApp.InitMainWindow;
  454.   BEGIN
  455.     mainWindow := NEW(pFnWin, Init);
  456.   END;
  457.  
  458. BEGIN
  459.   thisApp.Init(appName);
  460.   thisApp.Run;
  461.   thisApp.Done;
  462. END.
  463.