Unit1.pas
上传用户:daoqigc
上传日期:2021-04-20
资源大小:2795k
文件大小:5k
源码类别:

RichEdit

开发平台:

Delphi

  1. unit Unit1;
  2. interface
  3. uses
  4.   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  5.   Dialogs, StdCtrls, ComCtrls, RVStyle, RVScroll, RichView, RVEdit,
  6.   ExtCtrls, CRVData, RVTable;
  7. type
  8.   TForm1 = class(TForm)
  9.     PageControl1: TPageControl;
  10.     TabSheet1: TTabSheet;
  11.     TabSheet2: TTabSheet;
  12.     Panel1: TPanel;
  13.     cmbA: TComboBox;
  14.     rveA: TRichViewEdit;
  15.     rvsA: TRVStyle;
  16.     btnOpenA: TButton;
  17.     Label1: TLabel;
  18.     Panel2: TPanel;
  19.     Label2: TLabel;
  20.     cmbH: TComboBox;
  21.     btnOpenH: TButton;
  22.     rveH: TRichViewEdit;
  23.     rvsH: TRVStyle;
  24.     od: TOpenDialog;
  25.     procedure FormCreate(Sender: TObject);
  26.     procedure cmbAClick(Sender: TObject);
  27.     procedure cmbHClick(Sender: TObject);
  28.     procedure btnOpenAClick(Sender: TObject);
  29.     procedure btnOpenHClick(Sender: TObject);
  30.   private
  31.     { Private declarations }
  32.     CurrentCharset: TFontCharset;
  33.     Found: Boolean;
  34.     procedure FillComboBox(cmb: TComboBox; Charset: TFontCharset);
  35.     procedure ApplyFont(const FontName: String; rvs: TRVStyle;
  36.                         Charset: TFontCharset;
  37.                         rve: TRichViewEdit);
  38.   public
  39.     { Public declarations }
  40.     procedure OpenFile(rve: TRichViewEdit);
  41.   end;
  42. var
  43.   Form1: TForm1;
  44. implementation
  45. {$R *.dfm}
  46. // Callback function for EnumFontFamilies
  47. function EnumFontCharsets(var EnumLogFont: TEnumLogFontEx;
  48.   PTextMetric: PNewTextMetricEx; FontType: Integer; Data: LPARAM): Integer;
  49.   export; stdcall;
  50. var frm: TForm1;
  51. begin
  52.   frm := TForm1(Data);
  53.   frm.Found := EnumLogFont.elfLogFont.lfCharSet=frm.CurrentCharset;
  54.   if frm.Found then
  55.     Result := 0
  56.   else
  57.     Result := 1;
  58. end;
  59. {=============================== TForm1 =======================================}
  60. procedure TForm1.FormCreate(Sender: TObject);
  61. begin
  62.   Screen.Cursor := crHourGlass;
  63.   FillComboBox(cmbA, ARABIC_CHARSET);
  64.   FillComboBox(cmbH, HEBREW_CHARSET);
  65.   rveA.Clear;
  66.   rveH.Clear;
  67.   if cmbA.Items.Count>0 then begin
  68.     rveA.AddNL('Open Arabic RTF or text file, for example ARABIC.RTF',0,0);
  69.     rveA.Format;
  70.     cmbA.ItemIndex := 0;
  71.     cmbAClick(cmbA);
  72.     end
  73.   else begin
  74.     rveA.AddNL('There are no Arabic fonts installed',0,0);
  75.     rveA.Format;
  76.     btnOpenA.Enabled := False;
  77.   end;
  78.   if cmbH.Items.Count>0 then begin
  79.     rveH.AddNL('Open Hebrew RTF or text file, for example HEBREW.RTF',0,0);
  80.     rveH.Format;
  81.     cmbH.ItemIndex := 0;
  82.     cmbHClick(cmbH);
  83.     end
  84.   else begin
  85.     rveH.AddNL('There are no Hebrew fonts installed',0,0);
  86.     rveH.Format;
  87.     btnOpenH.Enabled := False;
  88.   end;
  89.   Screen.Cursor := crDefault;
  90. end;
  91. {------------------------------------------------------------------------------}
  92. // Filling combobox with fonts with given charset
  93. procedure TForm1.FillComboBox(cmb: TComboBox; Charset: TFontCharset);
  94. var DC: HDC;
  95.     i: Integer;
  96. begin
  97.   CurrentCharset := Charset;
  98.   DC := GetDC(0);
  99.   cmb.Items.BeginUpdate;
  100.   try
  101.     for i := 0 to Screen.Fonts.Count-1 do begin
  102.       Found := False;
  103.       EnumFontFamilies(DC, PChar(Screen.Fonts[i]), @EnumFontCharsets, Longint(Self));
  104.       if Found then
  105.         cmb.Items.Add(Screen.Fonts[i]);
  106.     end;
  107.   finally
  108.     cmb.Items.EndUpdate;
  109.     ReleaseDC(0, DC);
  110.   end;
  111. end;
  112. {------------------------------------------------------------------------------}
  113. // Changing font of all text styles
  114. procedure TForm1.ApplyFont(const FontName: String; rvs: TRVStyle;
  115.                            Charset: TFontCharset; rve: TRichViewEdit);
  116. var i: Integer;
  117. begin
  118.   for i := 0 to rvs.TextStyles.Count-1 do begin
  119.     rvs.TextStyles[i].FontName := FontName;
  120.     rvs.TextStyles[i].Charset := Charset;
  121.   end;
  122.   rve.SetSelectionBounds(0, rve.GetOffsBeforeItem(0),0, rve.GetOffsBeforeItem(0));
  123.   rve.Format;
  124. end;
  125. {------------------------------------------------------------------------------}
  126. procedure TForm1.OpenFile(rve: TRichViewEdit);
  127. var r: Boolean;
  128. begin
  129.   if not od.Execute then
  130.     exit;
  131.   rve.Clear;
  132.   r := False;
  133.   case od.FilterIndex of
  134.     1: r := rve.LoadRTF(od.FileName);
  135.     2: r := rve.LoadText(od.FileName,0,0,False);
  136.   end;
  137.   if not r then
  138.     Application.MessageBox('Error loading file', 'Error', MB_OK or MB_ICONSTOP);
  139.   rve.Format;
  140. end;
  141. {------------------------------------------------------------------------------}
  142. procedure TForm1.cmbAClick(Sender: TObject);
  143. begin
  144.   if cmbA.ItemIndex>=0 then
  145.     ApplyFont(cmbA.Items[cmbA.ItemIndex], rvsA, ARABIC_CHARSET, rveA);
  146. end;
  147. {------------------------------------------------------------------------------}
  148. procedure TForm1.cmbHClick(Sender: TObject);
  149. begin
  150.   if cmbH.ItemIndex>=0 then
  151.     ApplyFont(cmbH.Items[cmbH.ItemIndex], rvsH, HEBREW_CHARSET, rveH);
  152. end;
  153. {------------------------------------------------------------------------------}
  154. procedure TForm1.btnOpenAClick(Sender: TObject);
  155. begin
  156.   OpenFile(rveA);
  157.   cmbAClick(cmbA);
  158. end;
  159. {------------------------------------------------------------------------------}
  160. procedure TForm1.btnOpenHClick(Sender: TObject);
  161. begin
  162.   OpenFile(rveH);
  163.   cmbHClick(cmbH);
  164. end;
  165. end.