📄 formmainunit.pas
字号:
begin
StrPCopy(title, aName);
StrPCopy(url, aURL);
if Url <> '' then
begin
H := LoadLibrary(PChar('shdocvw.dll'));
if H <> 0 then
begin
SHGetSpecialFolderLocation(0, CSIDL_FAVORITES, pidl);
AddFav := GetProcAddress(H, PChar('DoAddToFavDlg'));
if Assigned(AddFav) then
FRetOK := AddFav(Handle, UrlPath, Sizeof(UrlPath), Title,
Sizeof(Title), pidl);
end;
FreeLibrary(h);
if FRetOK then
CreateUrl(UrlPath, Url);
end;
end;
function TFormMain.GetSysFolder(aRoot: integer): string;
var
pBrowse : PItemIDList;
hPChar : PChar;
begin
if (not SUCCEEDED(SHGetSpecialFolderLocation(Getactivewindow, aRoot,
pBrowse))) then
EXIT;
hPChar := StrAlloc(max_path);
if (SHGetPathFromIDList(pBrowse, hPChar)) then
Result := hPChar;
StrDispose(hPChar);
end;
procedure TformMain.SendMostToDesktop(aName, aURL: string);
var
URLfile : TIniFile;
begin
URLfile := TIniFile.Create(string(GetSysFolder(CSIDL_DESKTOP) + '\' + aName +
'.url'));
URLfile.WriteString('InternetShortcut', 'URL', string(aURL));
URLfile.Free;
end;
procedure TFormMain.readMostToTree;
var
I, N, Count, CCount: Integer;
MyIni : TIniFile;
myPath : string;
tmpNode : TTreeNode;
begin
Font := Screen.MenuFont;
myPath := GetExePath + 'Files\Most.ini';
if not FileExists(myPath) then
Exit;
MostTree.Items.Clear;
MyIni := TIniFile.Create(myPath);
try
Count := MyIni.ReadInteger('MostIndex', 'Counter', 0);
for I := 0 to Count - 1 do
begin
if MyIni.ReadString('MostIndex', 'Name' + IntToStr(I), '') <> 'Public'
then
begin
tmpNode := MostTree.Items.Add(nil, MyIni.ReadString('MostIndex', 'Name'
+
IntToStr(I), ''));
tmpNode.ImageIndex := 0;
tmpNode.SelectedIndex := 1;
CCount := MyIni.ReadInteger(tmpNode.Text, 'Counter', 0);
for n := 0 to CCount - 1 do
begin
New(MostInfos);
MostInfos^.name := MyIni.ReadString(tmpNode.Text, 'Name' +
Inttostr(n),
'');
MostInfos^.url := MyIni.ReadString(tmpNode.Text, 'Url' + Inttostr(n),
'');
with MostTree.Items.AddChild(tmpNode, MostInfos^.name) do
begin
ImageIndex := 13;
SelectedIndex := 13;
Data := MostInfos;
end;
end;
end;
end;
CCount := MyIni.ReadInteger('Public', 'Counter', 0);
for n := 0 to CCount - 1 do
begin
New(MostInfos);
MostInfos^.name := MyIni.ReadString('Public', 'Name' + Inttostr(n), '');
MostInfos^.url := MyIni.ReadString('Public', 'Url' + Inttostr(n), '');
with MostTree.Items.Add(nil, MostInfos^.name) do
begin
ImageIndex := 13;
SelectedIndex := 13;
Data := MostInfos;
end;
end;
finally
MyIni.Free;
end;
end;
procedure TFormMain.InitMbList;
begin
with TypeQuery do
begin
close;
SQL.Text :=
'select infombook.AutoID,infoContent.clsID,infombook.InfoName from Infombook left join infoContent on infombook.infoID=infocontent.AutoID';
try
open;
mblist.Items.Clear;
mbList.items.BeginUpdate;
while not eof do
begin
with mbList.Items.Add do
begin
caption := fieldbyname('infoName').asString;
subitems.Add(inttostr(fieldbyname('autoID').asInteger));
subitems.add(inttostr(fieldbyname('clsID').asInteger));
imageindex := 2;
StateIndex := 3;
end;
next;
end;
finally
mbList.Items.EndUpdate;
end;
end;
end;
function DaoActive(var DaoObject: OleVariant): Boolean;
begin
Result := False;
try
DaoObject := GetActiveOleObject('DAO.DBEngine.36');
Result := True;
except
try
DaoObject := CreateOleObject('DAO.DBEngine.36');
Result := True;
except
DaoObject := Null;
end;
end;
end;
//压缩Access数据库
function DaoCompactDB(const FileName: string): Boolean;
var
db : OleVariant;
TempFile : string;
begin
Result := False;
try
if not DaoActive(db) then
Exit;
try
TempFile := ExtractFilePath(FileName) + 'msaTemp.mdb';
db.CompactDatabase(FileName, TempFile);
DeleteFile(FileName);
RenameFile(TempFile, FileName);
Result := True;
except
on E: EOleException do
application.messagebox(pansiChar(E.Message), '提示', mb_ok or
mb_Iconinformation);
end
finally
db := Unassigned;
end;
end;
//修复Access数据库
function DaoRepairDB(const FileName: string): Boolean;
var
db : OleVariant;
begin
Result := False;
try
if not DaoActive(db) then
Exit;
try
db.RepairDatabase(FileName);
Result := True;
except
on E: EOleException do
application.messagebox(pansiChar(E.Message), '提示', mb_ok or
mb_Iconinformation);
end
finally
db := Unassigned;
end;
end;
procedure TFormMain.showHtml(fileName: string);
var
Tls : TStrings;
execName : string;
begin
execName := fileName;
if fileName = '' then
begin
Tls := TStringList.Create;
Tls.Text := ' <!-- ' + #13#10 +
' Copyright(c) 1996-2003 S.F. Software ' + #13#10 +
' Powered by frontPage 07/2003 ' + #13#10 +
' Email:chinasf@hotmail cn410000@Hotmail.com http://www.suifei.com ' + #13#10
+
' --> ' + #13#10 +
' <html> ' + #13#10 +
' <head> ' + #13#10 +
' <meta http-equiv="Content-Type" content="text/html; charset=gb2312"> ' + #13#10
+
' <meta http-equiv="Content-Language" content="zh-cn"> ' + #13#10 +
' <meta name="GENERATOR" content="Microsoft FrontPage 4.0"> ' + #13#10
+
' <meta name="ProgId" content="FrontPage.Editor.Document"> ' + #13#10 +
' <title>Infobase makes life easier</title> ' + #13#10 +
' <style> ' + #13#10 +
' <!-- ' + #13#10 +
' .a1 {text-decoration: none; color: #ffffff;} ' + #13#10 +
' .a1:visited {text-decoration: none; color: #ffffff} ' + #13#10 +
' .a1:hover {text-decoration: underline; color: #ff0000} ' + #13#10 +
' .a2 { text-decoration: none; color: #0099CC } ' + #13#10 +
' .a2:visited { text-decoration: none; color: #800000 } ' + #13#10 +
' .a2:hover {text-decoration: underline; color: #ff0000} ' + #13#10 +
' --> ' + #13#10 +
' </style> ' + #13#10 +
' <script language="JavaScript"> ' + #13#10 +
' <!-- ' + #13#10 +
' function NavigateURL(url){ ' + #13#10 +
' location.href=url; ' + #13#10 +
' } ' + #13#10 +
' //--> ' + #13#10 +
' </script> ' + #13#10 +
' </head> ' + #13#10 +
' <body bgcolor="#ffffff" topmargin="0" leftmargin="9" style="font-family: 宋体; font-size: 12px"> ' + #13#10
+
' <p align="center"> ' + #13#10 +
' <font face="宋体"> ' + #13#10 +
' <br> ' + #13#10 +
' </font> ' + #13#10 +
' <div align="center"> ' + #13#10 +
' <table border="0" cellpadding="0" cellspacing="0" width="100%" style="line-height: 13pt"> ' + #13#10
+
' <tr> ' + #13#10 +
' <td align="center"> ' + #13#10 +
' <font face="宋体"> ' + #13#10 +
' <br> ' + #13#10 +
' <font size="-1" color=#008000><b>当前附件框中没有什么可以浏览！</b></font> ' + #13#10
+
' </font> ' + #13#10 +
' <p> ' + #13#10 + #13#10 +
' <b> ' + #13#10 +
' <font face="宋体"> ' + #13#10 +
' <font size="-1" color=#008000> ' + #13#10 +
' 该嵌入式 ' + #13#10 +
' IE4/5 ' + #13#10 +
' 浏览器主要用于查看存储在附件框中的 ' + #13#10 +
' HTML 网页、图像及文本文件，也可以查看被链接的外部文件。 ' + #13#10
+
' <br><br><br> ' + #13#10 +
' </font></font> ' + #13#10 +
' </b> ' + #13#10 +
' <font face="宋体"> ' + #13#10 +
' <font size="-1" color=#008000> ' + #13#10 +
' <!-- ' + #13#10 +
' <form name="_user_surf" action=javascript:NavigateURL(_user_surf.url.value)> ' + #13#10
+
' <b>Now you may type an URL address to surf internet inplace : <br> ' + #13#10
+
' <input type="edit" name="url" value="http://www.suifei.com" size=50 style="color:Navy"> ' + #13#10
+
' <input type="button" name=navigate value="Go" onclick="NavigateURL(url.value)"> ' + #13#10
+
' </form> ' + #13#10 +
' --> ' + #13#10 +
' </font> ' + #13#10 +
' <br><br><br></font></p> ' + #13#10 +
' <hr width="90%" size="1" noshade> ' + #13#10 +
' <p><font face="宋体"> ' + #13#10 +
' <font color=#000000> ' + #13#10 +
' Infobase -- 自由形式、多功能之资料管理软件！<br> ' + #13#10
+
' 版权所有_ ' + #13#10 +
' (C) 1996-2008 黄少华，保留所有权利。<br> ' + #13#10 +
' 网址: <a href="http://www.aoblue.ful.cn" target="_blank" class="a2">http://www.aoblue.ful.cn<br> ' + #13#10
+
' </a></font><font color=#000000>邮箱: <a href="mailto:leonhsh@163.com" class="a2">leonhsh@163.com</a> ' + #13#10
+
' 或 <a href="mailto:leonhshster@Gmail.com" class="a2">leonhshster@Gmail.com</a></font></font> ' + #13#10
+
' </td> ' + #13#10 +
' </tr> ' + #13#10 +
' </table> ' + #13#10 +
' </div> ' + #13#10 +
' </body> ' + #13#10 +
' </html> ';
ExecName := GetExePath + 'files\' +
ChangeFileExt(RandomFileName('definfo.htm'),
ExtractFileExt('definfo.htm'));
Tls.SaveToFile(execname);
end;
WebBrowser1.Navigate('file:///' + fastreplace(execName, #32, '%20'));
if fileName = '' then
begin
try
Deletefile(execName);
except
end;
end;
end;
procedure TFormMain.SetEditMode(isRichEdit: Boolean);
begin
tbEditMode.Down := isRichEdit;
tbWbMode.Down := not isRichEdit;
richEdit.Visible := isRichEdit;
PageScroller2.Visible := isRichEdit;
WebBrowser1.Visible := not isRichEdit;
deleteFile(tmpFileName);
end;
function RunExeFile(const Prog, CommandLine, Dir: string; var ExitCode: DWORD):
string;
procedure CheckResult(b: Boolean);
begin
if not b then
raise Exception.Create(SysErrorMessage(GetLastError));
end;
var
HRead, HWrite : THandle;
StartInfo : TStartupInfo;
ProceInfo : TProcessInformation;
b : Boolean;
sa : TSecurityAttributes;
begin
Result := '';
FillChar(sa, sizeof(sa), 0);
//设置允许继承，否则在NT和2000下无法取得输出结果
sa.nLength := sizeof(sa);
sa.bInheritHandle := True;
sa.lpSecurityDescriptor := nil;
b := CreatePipe(HRead, HWrite, @sa, 0);
CheckResult(b);
FillChar(StartInfo, SizeOf(StartInfo), 0);
StartInfo.cb := SizeOf(StartInfo);
StartInfo.wShowWindow := SW_SHOW;
//使用指定的句柄作为标准输入输出的文件句柄,使用指定的显示方式
StartInfo.dwFlags := STARTF_USESTDHANDLES + STARTF_USESHOWWINDOW;
StartInfo.hStdError := HWrite;
StartInfo.hStdInput := GetStdHandle(STD_INPUT_HANDLE); //HRead;
StartInfo.hStdOutput := HWrite;
b := CreateProcess(PChar(Prog), //lpApplicationName: PChar
PChar(CommandLine), //lpCommandLine: PChar
nil, //lpProcessAttributes: PSecurityAttributes
nil, //lpThreadAttributes: PSecurityAttributes
True, //bInheritHandles: BOOL
CREATE_NEW_CONSOLE,
nil,
PChar(Dir),
StartInfo,
ProceInfo);
CheckResult(b);
WaitForSingleObject(ProceInfo.hProcess, INFINITE);
GetExitCodeProcess(ProceInfo.hProcess, ExitCode);
end;
procedure TFormMain.DBOLDSaveToFile(fileName: string; FID: Integer);
var
bStm : TADOBlobStream;
fStm : TFileStream;
begin
with TypeQuery do
begin
close;
sql.Clear;
sql.add('select FileBin,FileSize from InfoFile where AutoID = :AutoID');
Parameters.ParamByName('AutoID').DataType := ftInteger;
Parameters.ParamByName('AutoID').Value := FID;
TypeQuery.Prepared;
try
open;
while not eof do
begin
try
bStm := TADOBlobStream.Create(fieldbyname('fileBin') as TBlobField,
bmRead);
fStm := TFileStream.Create(fileName, fmCreate);
fStm.CopyFrom(bStm, bStm.Size);
fStm.Free;
//解压缩文件
decompressstream(fileName);
finally
bStm.Free;
end;
next;
end;
finally
close;
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -