expertcad/SRC/Main/U_HintW.pas
2025-05-12 10:07:51 +03:00

607 lines
16 KiB
ObjectPascal
Raw Blame History

unit U_HintW;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Registry, ShellAPI, FastStrings, Dialogs, StdCtrls, OleCtrls, SHDocVw, ucCustomizedWebBrowser, ActiveX,
IdCoderMIME, Menus, ExtCtrls;
type
TVariantArray = array of Variant;
TCustomizedWebBrowser = class(ucCustomizedWebBrowser.TCustomizedWebBrowser)
protected
procedure InvokeEvent(DispID: TDispID; var Params: TDispParams); override;
end;
TF_HintW = class(TForm)
WebBrowser: TCustomizedWebBrowser;
PopupMenu1: TPopupMenu;
Timer1: TTimer;
Panel1: TPanel;
CustomizedWebBrowser1: TCustomizedWebBrowser;
procedure WebBrowserBeforeNavigate2(Sender: TObject;
const pDisp: IDispatch; var URL, Flags, TargetFrameName, PostData,
Headers: OleVariant; var Cancel: WordBool);
procedure WebBrowserEnter(Sender: TObject);
function WebBrowserPressAccelerator(Sender: TObject;
const lpMsg: tagMSG): Boolean;
procedure WebBrowserDocumentComplete(Sender: TObject;
const pDisp: IDispatch; var URL: OleVariant);
procedure WebBrowserNavigateComplete2(Sender: TObject;
const pDisp: IDispatch; var URL: OleVariant);
procedure WebBrowserMenuPopup(Sender: TObject; X, Y: Integer;
ID: Cardinal);
procedure Timer1Timer(Sender: TObject);
procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
protected
FBNext: String;
FBBack: String;
FBFirst: String;
FTplPath: String;
FMainForm: TForm;
procedure AssignEmptyDocument;
procedure Go(Url: string);
procedure GoStat(Url: string);
procedure HideHints;
function LoadFromStream(const AStream: TStream): HRESULT;
function LoadFromStrings(const AStrings: TStrings): HRESULT;
function LoadFromString(const S: string): HRESULT;
function LoadFromFile(const FileName: string): HRESULT;
procedure LoadNavButton(var aBtCode: String; const aTplDir, aTpl, aDefText: String);
procedure StepWizard(aDirection: Integer);
public
FCurrStep: Integer;
FStepCount: Integer;
function GetPathTpl(aRelative: Boolean=false): String;
procedure FirstWizard;
procedure NextWizard;
procedure BackWizard;
procedure StartWizard;
end;
procedure CheckAndShowHint(aUrl: string; aProgIdent: string; aMainForm: TForm = nil; DaysCheck: integer = 7; CheckNeedOpen: boolean = True);
procedure SendStat(aUrlStat, aProgIdent, prog_full_ver_str, prog_ver, build_or_date, req_code, answ_code: string; is_trial, is_flash: boolean);
const
RegRootKey = HKEY_CURRENT_USER;
var
F_HintW: TF_HintW;
WasNavError: boolean;
Reg: TRegistry = nil;
NumTime: integer;
implementation
uses IdCoder;
{$R *.dfm}
{ TF_HintW }
procedure SendStat(aUrlStat, aProgIdent, prog_full_ver_str, prog_ver, build_or_date, req_code, answ_code: string; is_trial, is_flash: boolean);
var
aFullURL: string;
IdEncoderMIME: TIdEncoderMIME;
begin
if assigned(F_HintW) then
FreeAndNil(F_HintW);
if Not assigned(F_HintW) then
Application.CreateForm(TF_HintW, F_HintW);
try
IdEncoderMIME := TIdEncoderMIME.Create(nil);
aFullURL := aUrlStat + '?ProgIdent=' + IdEncoderMIME.EncodeString(aProgIdent);
aFullURL := aFullURL + '&prog_full_ver_str=' + IdEncoderMIME.EncodeString(prog_full_ver_str);
aFullURL := aFullURL + '&prog_ver=' + IdEncoderMIME.EncodeString(prog_ver);
aFullURL := aFullURL + '&build_or_date=' + IdEncoderMIME.EncodeString(build_or_date);
aFullURL := aFullURL + '&req_code=' + IdEncoderMIME.EncodeString(req_code);
aFullURL := aFullURL + '&answ_code=' + IdEncoderMIME.EncodeString(answ_code);
aFullURL := aFullURL + '&is_trial=' + IdEncoderMIME.EncodeString(inttostr(byte(is_trial)));
aFullURL := aFullURL + '&is_flash=' + IdEncoderMIME.EncodeString(inttostr(byte(is_flash)));
finally
IdEncoderMIME.Free;
end;
F_HintW.GoStat(aFullURL);
end;
procedure CheckAndShowHint(aUrl: string; aProgIdent: string; aMainForm: TForm = nil; DaysCheck: integer = 7; CheckNeedOpen: boolean = True);
var
LastDate: integer;
NeedOpen: boolean;
vRefresh : OleVariant;
begin
NumTime := 0;
if Not Assigned(Reg) then
Reg := TRegistry.Create;
Reg.RootKey := RegRootKey;
if (DaysCheck > 0) and CheckNeedOpen then
begin
try
if Reg.OpenKey('\Software\Expertsoft\Hints\' + aProgIdent, True) then
begin
if Reg.ValueExists('DontShow') then
begin
if Reg.ReadBool('DontShow') then
begin
Reg.CloseKey;
exit;
end;
end;
end;
except
end;
end;
NeedOpen := True;
if CheckNeedOpen then
begin
NeedOpen := False;
LastDate := 0;
if Reg.OpenKey('\Software\Expertsoft\Hints\' + aProgIdent, True) then
begin
try
if Reg.ValueExists('Date') then
begin
LastDate := Reg.ReadInteger('Date');
end;
except
LastDate := 0;
end;
end;
if Now - LastDate >= DaysCheck then
NeedOpen := True
end;
if NeedOpen then
begin
if assigned(F_HintW) then
begin
if F_HintW.Caption = aUrl then
FreeAndNil(F_HintW);
end;
if Not assigned(F_HintW) then
Application.CreateForm(TF_HintW, F_HintW);
F_HintW.FMainForm := aMainForm;
//if F_HintW.Caption = '' then
begin
F_HintW.Caption := aUrl;
F_HintW.CustomizedWebBrowser1.Visible := False;
F_HintW.CustomizedWebBrowser1.Height := 1;
F_HintW.CustomizedWebBrowser1.Width := 1;
F_HintW.CustomizedWebBrowser1.left := -1;
F_HintW.CustomizedWebBrowser1.top := -1;
if F_HintW.FMainForm <> nil then
begin
F_HintW.Left := aMainForm.Left + aMainForm.Width - F_HintW.Width - (GetSystemMetrics(SM_CXBORDER) + 2);
F_HintW.Top := aMainForm.Top + aMainForm.Height - F_HintW.Height - (GetSystemMetrics(SM_CXBORDER) + 2);
end;
//F_HintW.WebBrowser.Navigate(aUrl);
//F_HintW.WebBrowser.Stop; <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>
F_HintW.Go(aUrl);
//F_HintW.Show;
end;
end;
end;
procedure TCustomizedWebBrowser.InvokeEvent(DispID: TDispID;
var Params: TDispParams);
const
DISPID_NAVIGATEERROR = 271;
INET_E_RESOURCE_NOT_FOUND = -2146697211;
var
Code: Integer;
ParamCount, I: Integer;
VarArray: TVariantArray;
begin
inherited;
if DispID = DISPID_NAVIGATEERROR then
begin
ParamCount := Params.cArgs;
SetLength(VarArray, ParamCount);
for I := Low(VarArray) to High(VarArray) do
VarArray[High(VarArray) - I] := OleVariant(Params.rgvarg^[I]);
{ StatusCode }
Code := VarArray[3];
if (Code = INET_E_RESOURCE_NOT_FOUND) or (Code = 404) then
begin
//ShowMessage('Not found!');
WasNavError := True;
end;
end;
end;
procedure TF_HintW.AssignEmptyDocument;
begin
Go('about:blank');
end;
procedure TF_HintW.BackWizard;
begin
StepWizard(-1);
end;
procedure TF_HintW.Go(Url: string);
var
Flags, TargetFrameName, PostData, Headers: OleVariant;
begin
WasNavError := False;
Flags := 0;
TargetFrameName := 0;
Postdata := 0;
Headers := 0;
if (Trim(Url) <> '') then
WebBrowser.Navigate(Url, Flags, TargetFrameName, PostData, Headers);
end;
procedure TF_HintW.GoStat(Url: string);
var
Flags, TargetFrameName, PostData, Headers: OleVariant;
begin
WasNavError := False;
Flags := 0;
TargetFrameName := 0;
Postdata := 0;
Headers := 0;
if (Trim(Url) <> '') then
CustomizedWebBrowser1.Navigate(Url, Flags, TargetFrameName, PostData, Headers);
end;
procedure TF_HintW.HideHints;
begin
//
end;
function TF_HintW.LoadFromFile(const FileName: string): HRESULT;
var
Stream: TStream;
begin
Stream := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
try
Result := LoadFromStream(Stream);
finally
Stream.Free;
end;
end;
function TF_HintW.LoadFromStream(const AStream: TStream): HRESULT;
begin
if not Assigned(WebBrowser.Document) then
AssignEmptyDocument;
AStream.seek(0, 0);
Result := (WebBrowser.Document as IPersistStreamInit).Load(TStreamadapter.Create(AStream));
end;
function TF_HintW.LoadFromStrings(const AStrings: TStrings): HRESULT;
var
M: TMemoryStream;
begin
if not Assigned(WebBrowser.document) then
AssignEmptyDocument;
M := TMemoryStream.Create;
try
AStrings.SaveToStream(M);
Result := LoadFromStream(M);
except
Result := S_False;
end;
M.free;
end;
function TF_HintW.LoadFromString(const S: string): HRESULT;
var
Strings: TStringList;
begin
Strings := TStringList.Create;
try
Strings.Text := S;
Result := LoadFromStrings(Strings);
finally
FreeAndNil(Strings);
end;
end;
function TF_HintW.GetPathTpl(aRelative: Boolean=false): String;
begin
Result := '\HintBox\';
end;
procedure TF_HintW.FirstWizard;
begin
StepWizard(1-FCurrStep);
end;
procedure TF_HintW.NextWizard;
begin
StepWizard(1);
end;
procedure TF_HintW.StartWizard;
begin
end;
procedure TF_HintW.StepWizard(aDirection: Integer);
begin
// LoadFromString(tplBegin + Tpl +TplNav + tplEnd);
end;
function SplitString(const AStr, ASeparator: string; AIncludeEmptySections: Boolean): TStringList;
var
i: Integer;
LenStr: Integer;
BuffStr: String;
SepLookIdx: Integer;
SepBuff: String;
IsFullSep: Boolean;
begin
Result := TStringList.Create;
BuffStr := '';
LenStr := Length(AStr);
SepLookIdx := 1;
SepBuff := '';
for i := 1 to LenStr do
begin
IsFullSep := false;
if AStr[i] = ASeparator[SepLookIdx] then
begin
if SepLookIdx = Length(ASeparator) then
begin
IsFullSep := true;
SepLookIdx := 1;
SepBuff := '';
end
else
begin
SepBuff := SepBuff + AStr[i];
Inc(SepLookIdx);
Continue; //// CONTINUE ////
end;
end
else
begin
// <20><><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>
if SepLookIdx > 1 then
begin
BuffStr := BuffStr + SepBuff;
SepLookIdx := 1;
SepBuff := '';
end;
end;
if Not IsFullSep then
BuffStr := BuffStr + AStr[i];
if IsFullSep or (i=LenStr) then
if (BuffStr <> '') or AIncludeEmptySections then
begin
Result.Add(BuffStr);
BuffStr := '';
// <20><><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> - <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>, <20><> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD>
if AIncludeEmptySections then
if IsFullSep and (i=LenStr) then
Result.Add('');
end;
end;
end;
procedure TF_HintW.WebBrowserBeforeNavigate2(Sender: TObject;
const pDisp: IDispatch; var URL, Flags, TargetFrameName, PostData,
Headers: OleVariant; var Cancel: WordBool);
var
PosAbout: Integer;
UrlParts: TStringList;
UrlCmd: String;
ovElem: OleVariant;
Str: String;
//SprComponentType: TNBComponentType;
FileName: String;
function DefineWorkList: Boolean;
begin
Result := true;
end;
begin
if (URL <> 'about:blank') then
begin
URL := FastReplace(URL, 'about:blank', 'about:', false);
PosAbout := Pos('about:shell:', URL);
if PosAbout = 1 then
begin
URL := FastReplace(URL, 'about:shell:', 'about:', false);
UrlParts := SplitString(Copy(URL, Length('about:')+1, Length(URL)-(Length('about:'))), #255, false);
if UrlParts.Count > 0 then
begin
UrlCmd := UrlParts[0];
ShellExecute(Handle, 'open', PChar(UrlCmd), nil, nil, SW_MAXIMIZE);
end;
Cancel := true;
end
else
begin
PosAbout := Pos('about:', URL);
if PosAbout = 1 then
begin
UrlParts := SplitString(Copy(URL, Length('about:')+1, Length(URL)-(Length('about:'))), '_', false);
if UrlParts.Count > 0 then
begin
UrlCmd := UrlParts[0];
if UrlCmd = 'actClose' then
begin
Close;
end
else if UrlCmd = 'actToolTip' then
begin
if UrlParts.Count > 1 then
begin
ovElem := WebBrowser.OleObject.document.getElementbyId('ttContent'+UrlParts[1]);
if ovElem.tagName = 'SPAN' then
begin
Str := ovElem.InnerHTML;
Str := FastReplace(Str, 'about:blank', 'about:', false);
end
else
if ovElem.tagName = 'IMG' then
begin
FileName := ovElem.href;
FileName := FastReplace(FileName, 'about:blank', 'about:', false);
FileName := Copy(FileName, Length('about:')+1, Length(URL)-(Length('about:')));
try
except
end;
end;
end;
end
else
if UrlCmd = 'actNewProj' then
begin
//FSCS_Main.aNew.Execute
end;
end;
Cancel := true;
end;
end;
end;
end;
procedure TF_HintW.WebBrowserEnter(Sender: TObject);
begin
// HideHints;
end;
function TF_HintW.WebBrowserPressAccelerator(Sender: TObject;
const lpMsg: tagMSG): Boolean;
begin
//
end;
procedure TF_HintW.LoadNavButton(var aBtCode: String; const aTplDir, aTpl, aDefText: String);
var
btPath: String;
begin
if aBtCode = '' then
begin
btPath := aTplDir + aTpl;
//if FileExists(btPath) then
// aBtCode := GetFileContents(btPath)
//else
// aBTCode := aDefText;
end;
end;
procedure TF_HintW.WebBrowserDocumentComplete(Sender: TObject;
const pDisp: IDispatch; var URL: OleVariant);
var
str1: string;
begin
if WasNavError then
begin
Close;
exit;
end;
str1 := WebBrowser.OleObject.Document.All.Tags('title').Item(0).InnerHtml;
if pos('HTTP 404', str1) <= 0 then
Show
else
exit;
Timer1.Enabled := True;
try
if Reg.CurrentPath <> '' then
begin
try
Reg.WriteInteger('Date', Trunc(Now));
except
end;
end;
except
end;
end;
procedure Explode(var a: array of string; Border, S: string; MaxLen: integer);
var
S2: string;
i: Integer;
begin
i := 0;
S2 := S + Border;
repeat
a[i] := Copy(S2, 0,Pos(Border, S2) - 1);
Delete(S2, 1,Length(a[i] + Border));
Inc(i);
if i > MaxLen then
break;
until S2 = '';
end;
procedure TF_HintW.WebBrowserNavigateComplete2(Sender: TObject;
const pDisp: IDispatch; var URL: OleVariant);
var
str1: string;
i: integer;
A: array of String;
begin
F_HintW.WebBrowser.Ctl3D := False;
F_HintW.webbrowser.Left := - (GetSystemMetrics(SM_CXBORDER) + 1);
F_HintW.webbrowser.Top := - (GetSystemMetrics(SM_CYBORDER) + 1);
F_HintW.webbrowser.Height := F_HintW.Height + (GetSystemMetrics(SM_CYBORDER) + 1) * 2;
F_HintW.webbrowser.Width := F_HintW.Width + (GetSystemMetrics(SM_CXBORDER) + 1) * 2;
if not WasNavError then
begin
try
str1 := WebBrowser.OleObject.Document.Title;
SetLength(A, 3);
Explode(A, '_', str1, 3);
F_HintW.Width := strtoint(A[1]);
F_HintW.Height := strtoint(A[2]);
if F_HintW.FMainForm <> nil then
begin
F_HintW.Left := FMainForm.Left + FMainForm.Width - F_HintW.Width - (GetSystemMetrics(SM_CXBORDER) + 2);
F_HintW.Top := FMainForm.Top + FMainForm.Height - F_HintW.Height - (GetSystemMetrics(SM_CXBORDER) + 2);
end;
F_HintW.webbrowser.Left := - (GetSystemMetrics(SM_CXBORDER) + 1);
F_HintW.webbrowser.Top := - (GetSystemMetrics(SM_CYBORDER) + 1);
F_HintW.webbrowser.Height := F_HintW.Height + (GetSystemMetrics(SM_CYBORDER) + 1) * 2;
F_HintW.webbrowser.Width := F_HintW.Width + (GetSystemMetrics(SM_CXBORDER) + 1) * 2;
except
end;
Show;
end;
end;
procedure TF_HintW.WebBrowserMenuPopup(Sender: TObject; X, Y: Integer;
ID: Cardinal);
begin
//
end;
procedure TF_HintW.Timer1Timer(Sender: TObject);
begin
NumTime := NumTime + 1;
F_HintW.Show;
if NumTime > 5 then
Timer1.Enabled := False;
end;
procedure TF_HintW.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
if Timer1.Enabled then
CanClose := False;
end;
end.