BSOne.SFC/Tocsg.Lib/VCL/Tocsg.WebBrowser.pas

{*******************************************************}
{                                                       }
{       Tocsg.WebBrowser                                }
{                                                       }
{       Copyright (C) 2022 kku                          }
{                                                       }
{*******************************************************}

unit Tocsg.WebBrowser;

interface

uses
  Windows, ComObj, ActiveX, SHDocVw;

procedure ClearInternetExplorerHistory;

const
  CLSID_CUrlHistory: TGUID = '{3C374A40-BAE4-11CF-BF7D-00AA006946EE}';

type
// 자바 스크립트 오류 뜨는 문제 해결 19_0918 23:06:50 kku
  TWebBrowser = class(SHDocVw.TWebBrowser, IOleCommandTarget)
  private
    function QueryStatus(CmdGroup: PGUID; cCmds: Cardinal; prgCmds: POleCmd;
      CmdText: POleCmdText): HRESULT; stdcall;
    function Exec(CmdGroup: PGUID; nCmdID, nCmdexecopt: DWORD;
      const vaIn: OleVariant; var vaOut: OleVariant): HRESULT; stdcall;
  end;

  TSTATURL = record
    cbSize: DWORD;
    pwcsUrl: DWORD;
    pwcsTitle: DWORD;
    ftLastVisited: FILETIME;
    ftLastUpdated: FILETIME;
    ftExpires: FILETIME;
    dwFlags: DWORD;
  end;

  IEnumSTATURL = interface(IUnknown)
    ['{3C374A42-BAE4-11CF-BF7D-00AA006946EE}']
    function Next(celt: Integer; out elt; pceltFetched: PLongint): HRESULT; stdcall;
    function Skip(celt: Longint): HRESULT; stdcall;
    function Reset: HResult; stdcall;
    function Clone(out ppenum: IEnumSTATURL): HResult; stdcall;
    function SetFilter(poszFilter: PWideChar; dwFlags: DWORD): HResult; stdcall;
  end;

  IUrlHistoryStg = interface(IUnknown)
    ['{3C374A41-BAE4-11CF-BF7D-00AA006946EE}']
    function AddUrl(pocsUrl: PWideChar; pocsTitle: PWideChar; dwFlags: Integer): HResult; stdcall;
    function DeleteUrl(pocsUrl: PWideChar; dwFlags: Integer): HResult; stdcall;
    function QueryUrl(pocsUrl: PWideChar; dwFlags: Integer; var lpSTATURL: TSTATURL): HResult; stdcall;
    function BindToObject(pocsUrl: PWideChar; var riid: TIID; out ppvOut: Pointer): HResult; stdcall;
    function EnumUrls(out ppenum: IEnumSTATURL): HResult; stdcall;
  end;

  IUrlHistoryStg2 = interface(IUrlHistoryStg)
    ['{AFA0DC11-C313-11D0-831A-00C04FD5AE38}']
    function AddUrlAndNotify(pocsUrl: PWideChar; pocsTitle: PWideChar; dwFlags: Integer;
fWriteHistory: Integer; var poctNotify: Pointer;
    const punkISFolder: IUnknown): HResult; stdcall;
    function ClearHistory: HResult; stdcall;
  end;

function GetHtmlFromWebBrowser(webBrowser: SHDocVw.TWebBrowser): String;
function GetEntraIdFromBrowserHis(sHisPath, sUrlHead, sChDomain, sDomain: String): String;

implementation

uses
  MSHTML, EM.SQLiteTable3, Tocsg.Safe, System.SysUtils, Tocsg.Exception;

function GetHtmlFromWebBrowser(webBrowser: SHDocVw.TWebBrowser): String;
var
  doc2: IHTMLDocument2;
begin
  doc2 := webBrowser.Document as IHTMLDocument2;
  result := doc2.body.innerHTML;
end;

procedure ClearInternetExplorerHistory;
var
  stg: IUrlHistoryStg2;
begin
  stg := CreateComObject(CLSID_CUrlHistory) as IUrlHistoryStg2;
  stg.ClearHistory;
end;

{ TWebBrowser }

function TWebBrowser.QueryStatus(CmdGroup: PGUID; cCmds: Cardinal;
  prgCmds: POleCmd; CmdText: POleCmdText): HRESULT; stdcall;
begin
  Result := S_OK;
end;

function TWebBrowser.Exec(CmdGroup: PGUID; nCmdID, nCmdexecopt: DWORD;
  const vaIn: OleVariant; var vaOut: OleVariant): HRESULT; stdcall;
begin
  // presume that all commands can be executed; for list of available commands
  // see SHDocVw.pas unit, using this event you can suppress or create custom
  // events for more than just script error dialogs, there are commands like
  // undo, redo, refresh, open, save, print etc. etc.
  // be careful, because not all command results are meaningful, like the one
  // with script error message boxes, I would expect that if you return S_OK,
  // the error dialog will be displayed, but it's vice-versa
  Result := S_OK;

  // there's a script error in the currently executed script, so
  if nCmdID = OLECMDID_SHOWSCRIPTERROR then
  begin
    // if you return S_FALSE, the script error dialog is shown
    Result := S_FALSE;
    // if you return S_OK, the script error dialog is suppressed
    Result := S_OK;
  end;
end;

// 브라우저에서 MS Entra에 로그인 사용 시 히스토리에서 계정 정보를 가져온다 25_0902 09:49:58 kku
// 크롬, 엣지 지원
// sUrlHead = enpulse365-my.sharepoint.com
// sChDomain = _partner_enpulse_co_kr
// sDomain = @partner.enpulse.co.kr
function GetEntraIdFromBrowserHis(sHisPath, sUrlHead, sChDomain, sDomain: String): String;
var
  db: TSQLiteDatabase;
  tbl: TSQLiteTable;
  i, n: Integer;
  sTable, SQL, sUrl: String;
begin
  Result := '';

  try
    Guard(db, TSQLiteDatabase.Create(sHisPath));

    sTable := 'urls'; // Opera, Chrome, Edge
//    sTable := 'moz_places'; // Firefox
    SQL := 'select url from urls';
//    SQL := 'select url, title, VISIT_COUNT, LAST_VISIT_time from urls';
//    SQL := 'select url, title, VISIT_COUNT, LAST_VISIT_DATE from moz_places'; // Firefox

    if db.TableExists(sTable) then
    begin
      Guard(tbl, db.GetTable(SQL));

      if tbl.MoveLast then
      begin
        for i := tbl.Count - 1 downto 0 do
        begin
          sUrl := tbl.Fields[0];
//          sUrl := 'https://enpulse365-my.sharepoint.com/:p:/r/personal/shlee_partner_enpulse_co_kr/_layouts/15/doc2.aspx';
          if Pos('enpulse365-my.sharepoint.com', sUrl) > 0 then
          begin
            n := Pos('personal/', sUrl);
            if n > 0 then
            begin
              Delete(sUrl, 1, n + 8);
              n := Pos('/', sUrl);
              if n > 0 then
              begin
                Delete(sUrl, n, Length(sUrl) - n + 1);
              // ID에 _ 가 있을 수 있어서 아래처럼 치환
                Result := StringReplace(sUrl, '_partner_enpulse_co_kr', '@partner.enpulse.co.kr', [rfReplaceAll]);
                break;
              end;
            end;
          end;

          if not tbl.Previous then
            break;
        end;
      end;
    end;
  except
    on E: Exception do
      ETgException.TraceException(E, 'Fail .. GetEntraIdFromBrowserHis()');
  end;
end;

end.