Unit1.pas
上传用户:daoqigc
上传日期:2021-04-20
资源大小:2795k
文件大小:5k
- unit Unit1;
- interface
- uses
- Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
- Dialogs, StdCtrls, ComCtrls, RVStyle, RVScroll, RichView, RVEdit,
- ExtCtrls, CRVData, RVTable;
- type
- TForm1 = class(TForm)
- PageControl1: TPageControl;
- TabSheet1: TTabSheet;
- TabSheet2: TTabSheet;
- Panel1: TPanel;
- cmbA: TComboBox;
- rveA: TRichViewEdit;
- rvsA: TRVStyle;
- btnOpenA: TButton;
- Label1: TLabel;
- Panel2: TPanel;
- Label2: TLabel;
- cmbH: TComboBox;
- btnOpenH: TButton;
- rveH: TRichViewEdit;
- rvsH: TRVStyle;
- od: TOpenDialog;
- procedure FormCreate(Sender: TObject);
- procedure cmbAClick(Sender: TObject);
- procedure cmbHClick(Sender: TObject);
- procedure btnOpenAClick(Sender: TObject);
- procedure btnOpenHClick(Sender: TObject);
- private
- { Private declarations }
- CurrentCharset: TFontCharset;
- Found: Boolean;
- procedure FillComboBox(cmb: TComboBox; Charset: TFontCharset);
- procedure ApplyFont(const FontName: String; rvs: TRVStyle;
- Charset: TFontCharset;
- rve: TRichViewEdit);
- public
- { Public declarations }
- procedure OpenFile(rve: TRichViewEdit);
- end;
- var
- Form1: TForm1;
- implementation
- {$R *.dfm}
- // Callback function for EnumFontFamilies
- function EnumFontCharsets(var EnumLogFont: TEnumLogFontEx;
- PTextMetric: PNewTextMetricEx; FontType: Integer; Data: LPARAM): Integer;
- export; stdcall;
- var frm: TForm1;
- begin
- frm := TForm1(Data);
- frm.Found := EnumLogFont.elfLogFont.lfCharSet=frm.CurrentCharset;
- if frm.Found then
- Result := 0
- else
- Result := 1;
- end;
- {=============================== TForm1 =======================================}
- procedure TForm1.FormCreate(Sender: TObject);
- begin
- Screen.Cursor := crHourGlass;
- FillComboBox(cmbA, ARABIC_CHARSET);
- FillComboBox(cmbH, HEBREW_CHARSET);
- rveA.Clear;
- rveH.Clear;
- if cmbA.Items.Count>0 then begin
- rveA.AddNL('Open Arabic RTF or text file, for example ARABIC.RTF',0,0);
- rveA.Format;
- cmbA.ItemIndex := 0;
- cmbAClick(cmbA);
- end
- else begin
- rveA.AddNL('There are no Arabic fonts installed',0,0);
- rveA.Format;
- btnOpenA.Enabled := False;
- end;
- if cmbH.Items.Count>0 then begin
- rveH.AddNL('Open Hebrew RTF or text file, for example HEBREW.RTF',0,0);
- rveH.Format;
- cmbH.ItemIndex := 0;
- cmbHClick(cmbH);
- end
- else begin
- rveH.AddNL('There are no Hebrew fonts installed',0,0);
- rveH.Format;
- btnOpenH.Enabled := False;
- end;
- Screen.Cursor := crDefault;
- end;
- {------------------------------------------------------------------------------}
- // Filling combobox with fonts with given charset
- procedure TForm1.FillComboBox(cmb: TComboBox; Charset: TFontCharset);
- var DC: HDC;
- i: Integer;
- begin
- CurrentCharset := Charset;
- DC := GetDC(0);
- cmb.Items.BeginUpdate;
- try
- for i := 0 to Screen.Fonts.Count-1 do begin
- Found := False;
- EnumFontFamilies(DC, PChar(Screen.Fonts[i]), @EnumFontCharsets, Longint(Self));
- if Found then
- cmb.Items.Add(Screen.Fonts[i]);
- end;
- finally
- cmb.Items.EndUpdate;
- ReleaseDC(0, DC);
- end;
- end;
- {------------------------------------------------------------------------------}
- // Changing font of all text styles
- procedure TForm1.ApplyFont(const FontName: String; rvs: TRVStyle;
- Charset: TFontCharset; rve: TRichViewEdit);
- var i: Integer;
- begin
- for i := 0 to rvs.TextStyles.Count-1 do begin
- rvs.TextStyles[i].FontName := FontName;
- rvs.TextStyles[i].Charset := Charset;
- end;
- rve.SetSelectionBounds(0, rve.GetOffsBeforeItem(0),0, rve.GetOffsBeforeItem(0));
- rve.Format;
- end;
- {------------------------------------------------------------------------------}
- procedure TForm1.OpenFile(rve: TRichViewEdit);
- var r: Boolean;
- begin
- if not od.Execute then
- exit;
- rve.Clear;
- r := False;
- case od.FilterIndex of
- 1: r := rve.LoadRTF(od.FileName);
- 2: r := rve.LoadText(od.FileName,0,0,False);
- end;
- if not r then
- Application.MessageBox('Error loading file', 'Error', MB_OK or MB_ICONSTOP);
- rve.Format;
- end;
- {------------------------------------------------------------------------------}
- procedure TForm1.cmbAClick(Sender: TObject);
- begin
- if cmbA.ItemIndex>=0 then
- ApplyFont(cmbA.Items[cmbA.ItemIndex], rvsA, ARABIC_CHARSET, rveA);
- end;
- {------------------------------------------------------------------------------}
- procedure TForm1.cmbHClick(Sender: TObject);
- begin
- if cmbH.ItemIndex>=0 then
- ApplyFont(cmbH.Items[cmbH.ItemIndex], rvsH, HEBREW_CHARSET, rveH);
- end;
- {------------------------------------------------------------------------------}
- procedure TForm1.btnOpenAClick(Sender: TObject);
- begin
- OpenFile(rveA);
- cmbAClick(cmbA);
- end;
- {------------------------------------------------------------------------------}
- procedure TForm1.btnOpenHClick(Sender: TObject);
- begin
- OpenFile(rveH);
- cmbHClick(cmbH);
- end;
- end.