📄 commonutils.pas
字号:
ArrStr[0] := Text;
finally
Free;
end; }
Autf8 := UTF8Encode('<html><head></head><body>我是中国人</body></html>') ;
ArrStr[0] := autf8;
AWeb.Navigate('about:blank');
if Assigned(AWeb.Document) then
begin
IDoc := AWeb.Document as IHtmlDocument2;
//IDoc.clear; 本来就是空页了
//IDoc.charset :=WideString('utf-8');
IDoc.write(PSafeArray(TVarData(ArrStr).VArray));
IDoc.close;
IDoc := nil;
IDoc := AWeb.Document as IHtmlDocument2;
//IDoc.
//IHTMLDocument2(AWeb.Document).charset := 'utf-8';
IDoc.charset := 'utf-8';
A := 2;
AWeb.Refresh2(A);
// IDoc.charset := 'unicode';
//AWeb.Refresh; // 关键，没有不行呀 --> 特别连续调用时必须有
end;
//(AWeb.Document as IPersistStreamInit).Load(TStreamAdapter.Create(AStream));
end;
procedure WriteWebBrowser(AWeb :TWebBrowser;AHTML :string);
var
doc:OleVariant;
begin
// Ole 方法
AWeb.Navigate('about:blank');
while Not Assigned(AWeb.Document) do //等待打开空页完成
begin
Sleep(10);
Application.ProcessMessages ;
end;
if Assigned(AWeb.Document) then
begin
doc := AWeb.Document ;
{ doc.Clear; // 本来就是空页
doc.charset :='utf-8';
with TStringList.Create do
try
LoadFromFile('E:\Documents and Settings\tssi\桌面\aaa.htm');
doc.Write(Text); //UTF8Encode(AHTML)
finally
free;
end;
doc.Write(UTF8Encode('我是中国人'));}
doc.Write(AHTML);
// doc.charset := 'utf-8';
doc.Close;
AWeb.Refresh ; // 关键，没有 不行呀 --> 特别连续调用时必须有
doc := UnAssigned;
end;
end;
function GetWebSource(AWeb :TWebBrowser;IsHTMLSource:boolean):string;
var
Doc : OleVariant;
//Item : IHtmlDocument2;
begin
if Assigned(AWeb.Document) then
begin
Doc := AWeb.Document;
if IsHTMLSource then
Result := Doc.documentElement.outerHTML
else
Result := Doc.documentElement.OuterText;
//Item := AWeb.Document as IHtmlDocument2;
//Item := Doc.all.item(1,VarEmpty);
//Result := Item.outerhtml;
//Doc := Unassigned;
//Item := nil;
end;
end;
procedure IninMainFrmWebBrowser;
begin
WriteWebBrowser(
TFrmMain(Application.MainForm).WebBrowser,
'<html><head></head><pre></pre><body></body></html>');
end;
function getMainWeb:TWebBrowser;
begin
Result := TFrmMain(Application.MainForm).WebBrowser;
end;
function GetWebSourceText({AWeb :TWebBrowser;}
const SrcFileName:string):string;
var
Item : OleVariant;
// IEle :IHTMLDocument3;
EndCount :Integer;
BWeb : TWebBrowser;
// s : string;
begin
//ToDo : params check Invaild...
BWeb := TFrmMain(Application.MainForm).WebBrowser;
BWeb.Navigate(SrcFileName);
//Sleep(2000);
//Str.Text :=
//Result :=GetWebSource(BWeb,False);
//Str.SaveToFile(DesFileName);
// EXIT;
//
Sleep(100);
EndCount :=Low(Integer);
while Not Assigned(BWeb.Document) do //等待打开空页完成
begin
Application.ProcessMessages ;
Inc(EndCount);
if EndCount >= High(Integer) then Exit;
end;
if Assigned(BWeb.Document) then
begin
//if AWeb.Document.QueryInterface(IHTMLDocument3,IEle)=S_OK then
begin
//Str.Text := IEle.documentElement.outerHTML ;
Item := BWeb.Document;
Result := Item.documentElement.OuterText ;
// Str.SaveToFile(DesFileName);
{ IDoc := AWeb.Document as IHtmlDocument2;
Item := IDoc.all.item(1,VarEmpty);
Result := Item.outerhtml;
IDoc := nil; }
Item := Unassigned;
end;
end;
end;
procedure FormShowModal(FormClass: TFormClass);
begin
with FormClass.Create(nil) do
try
ShowModal;
finally
Free;
end;
end;
{
功能:把文本文件Filename的文本转换成html代码,返回值是生成的html代码,格式如下
result:='<span> 生成的文本的html代码 </span>'
}
function SimpleTextToHtml(const Filename: string):string;
var
RawText: TStringList;
Checker: TStringList;
HtmlText: TStringList;
I, J, K, L: Integer;
S, Str, Tmp, TmpRes: string;
const
TAB = 9;
SPACE = 32;
// 分隔rawText[i],以tab,space为分割符,分割后连续的tab,space独成一行
procedure StrSlice(const Str: string; Source: TStrings);
var
I, J, K: Integer;
S: string;
Follow: Boolean;
begin
if (Length(Str) > 1) then
begin
I := 1;
while (I <= Length(Str)) do
begin
// white
if (Str[I] = Chr(SPACE)) or (Str[I] = Chr(TAB)) then
begin
J := I + 1;
Follow := TRUE;
while ((J <= Length(Str)) and Follow) do
if ((Str[J] = Chr(SPACE)) or (Str[J] = Chr(TAB))) then
Inc(J)
else
Follow := FALSE;
S := '';
for K := I to J - 1 do
S := S + Str[K];
Source.Add(S);
I := J;
end
else
begin
J := I + 1;
Follow := TRUE;
while ((J <= Length(Str)) and Follow) do
if ((Str[J] = Chr(SPACE)) or (Str[J] = Chr(TAB))) then
Follow := FALSE
else
Inc(J);
S := '';
for K := I to J - 1 do
S := S + Str[K];
Source.Add(S);
I := J;
end;
end; // while .. end.
end
else
Source.Add(Str);
end;
begin
RawText := TStringList.Create; // oryginalny plik
Checker := TStringList.Create; // string podzielony semantycznie
HtmlText := TStringList.Create; // tekst sformatowany na html
HtmlText.Add('<span>');
RawText.LoadFromFile(Filename);
for I := 0 to RawText.Count - 1 do
begin
Checker.Clear;
Str := '';
StrSlice(RawText[I], Checker);
for J := 0 to Checker.Count - 1 do
begin
if (Checker[J] <> '') then
begin
TmpRes := Checker[J];
if ((Checker[J][1] = Chr(SPACE)) or (Checker[J][1] = Chr(TAB))) then
begin
S := '';
if (Length(Checker[J]) = 1) and (J <> 0) then
// pojedyncza spacja nie rozpoczynajaca linii
Str := Str + ' '
else
begin
for K := 1 to Length(Checker[J]) do
S := S + '&' + 'nbsp' + ';';
Str := Str + S;
end;
end
else
begin
Tmp := '';
for L := 1 to Length(Checker[J]) do
begin
if Checker[J][L] = '<' then
Tmp := Tmp + '&' + 'lt' + ';'
else if Checker[J][L] = '>' then
Tmp := Tmp + '&' + 'gt' + ';'
else if Checker[J][L] = '&' then
Tmp := Tmp + '&' + 'amp' + ';'
else
Tmp := Tmp + Checker[J][L];
end;
Str := Str + Tmp;
end;
end;//if
end;//for checker
Str := Str + '<br>';
HtmlTExt.Add(Str);
end; //for rawtext
HtmlText.Add('</span>');
Result:=HtmlText.text;
RawText.Free;
Checker.Free;
HtmlText.Free;
end;
{ TpubResources }
constructor TpubResources.Create;
begin
inherited;
FNames := TStringList.Create;
FValues := TStringList.Create;
FNames.Sorted := True; // 名称排序 提高查询速度
// 值不处理，名称的Data记录值的索引
end;
destructor TpubResources.Destroy;
begin
FNames.Free;
FValues.Free;
inherited;
end;
procedure TpubResources.Add(const Ref, Str: String);
var
i: Integer;
begin
i := FNames.IndexOf(Ref);
if i = -1 then
begin
FNames.AddObject(Ref, Pointer(FValues.Count));
FValues.Add(Str);
end
else
FValues[Integer(FNames.Objects[i])] := Str;
end;
procedure TpubResources.AddStrings(const Str: String);
var
i: Integer;
sl: TStringList;
nm, vl: String;
begin
sl := TStringList.Create;
sl.Text := Str;
for i := 0 to sl.Count - 1 do
begin
nm := sl[i];
vl := Copy(nm, Pos('=', nm) + 1, MaxInt);
nm := Copy(nm, 1, Pos('=', nm) - 1);
if (nm <> '') and (vl <> '') then
Add(nm, vl);
end;
sl.Free;
end;
procedure TpubResources.Clear;
begin
FNames.Clear;
FValues.Clear;
end;
function TpubResources.Get(const StrName: string): string;
var
i: Integer;
begin
i := FNames.IndexOf(StrName);
if i <> -1 then
Result := FValues[Integer(FNames.Objects[i])] else
Result := StrName;
end;
procedure TpubResources.LoadFromFile(const FileName: string);
var
sl: TStringList;
i: Integer;
nm, vl: string;
begin
sl := TStringList.Create;
try
sl.LoadFromFile(FileName);
Clear;
for i := 0 to sl.Count - 1 do
begin
nm := sl[i];
vl := Copy(nm, Pos('=', nm) + 1, MaxInt);
nm := Copy(nm, 1, Pos('=', nm) - 1);
if (nm <> '') and (vl <> '') then
Add(nm, vl);
end;
finally
sl.Free;
end;
end;
function pubResources: TpubResources;
begin
if FResources = nil then
FResources := TpubResources.Create;
Result := FResources;
end;
function pubGet(ID: Integer): string;overload;
begin
Result := ReplaceEnter(pubResources.Get(IntToStr(ID)));
end;
function pubGet(Name: string): string;overload;
begin
Result := ReplaceEnter(pubResources.Get(Name));
end;
procedure LoadResources;
var
lngFileName :string;
begin
lngFileName := GetCfgValue('Langs','LangFileName','','Language\Chinaese.lng');
if lngFileName='' then Exit;
lngFileName := GetAbsolutePath(lngFileName);
if Not FileExists(lngFileName) then
begin
// 使用默认值 ，即编译入可执行文件的资源
end
else
pubResources.LoadFromFile(lngFileName);
end;
function GetCfgValue(const Section, AttrName,NameValue,
Default,AppSection: string;IsCreate:boolean):string;
begin
if AttrName <>'' then
Result :=gAppConfig.GetAttrValue(Section,AttrName,
Default,AppSection,IsCreate)
else
if NameValue <>'' then
Result :=gAppConfig.GetValue(Section,NameValue,Default,
AppSection,IsCreate)
else
Result := Default;
end;
procedure ShowDlg(Msg :string;Flag :integer ;Icon :Integer);
begin
MessageBox(0,PChar(Msg),PChar(pubGet(4)),Flag + Icon);// Mb_OK=0
end;
function ReplaceEnter(const s :string):string;
begin
result := StringReplace(s,'<br>',#13#10,[rfReplaceAll,rfIgnoreCase]);
end;
function GetCharSet:string;
begin
// 大写
Result := UpperCase(GetCfgValue('Sections','','HTMLUsesCharSet','GB2312'));
end;
initialization
finalization
if FResources <> nil then
FResources.Free;
FResources := nil;
if Assigned(uAppConfig) then
begin
uAppConfig.Save;
FreeAndNil(uAppConfig);
end;
end.
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -