{*******************************************************}
{                                                       }
{       Tocsg.Shell                                     }
{                                                       }
{       Copyright (C) 2022 kkuzil                       }
{                                                       }
{*******************************************************}

unit Tocsg.Shell;

interface

uses
  System.SysUtils, System.Classes, Winapi.Messages, Winapi.Windows,
  Vcl.Controls, Vcl.Graphics;

const
  TB_ENABLEBUTTON         = WM_USER + 1;
  TB_CHECKBUTTON          = WM_USER + 2;
  TB_PRESSBUTTON          = WM_USER + 3;
  TB_HIDEBUTTON           = WM_USER + 4;
  TB_INDETERMINATE        = WM_USER + 5;
  TB_MARKBUTTON           = WM_USER + 6;
  TB_ISBUTTONENABLED      = WM_USER + 9;
  TB_ISBUTTONCHECKED      = WM_USER + 10;
  TB_ISBUTTONPRESSED      = WM_USER + 11;
  TB_ISBUTTONHIDDEN       = WM_USER + 12;
  TB_ISBUTTONINDETERMINATE = WM_USER + 13;
  TB_ISBUTTONHIGHLIGHTED   = WM_USER + 14;
  TB_SETSTATE             = WM_USER + 17;
  TB_GETSTATE             = WM_USER + 18;
  TB_ADDBITMAP            = WM_USER + 19;
  TB_ADDBUTTONSA          = WM_USER + 20;
  TB_INSERTBUTTONA        = WM_USER + 21;
  TB_DELETEBUTTON         = WM_USER + 22;
  TB_GETBUTTON            = WM_USER + 23;
  TB_BUTTONCOUNT          = WM_USER + 24;
  TB_COMMANDTOINDEX       = WM_USER + 25;

  TB_SAVERESTOREA          = WM_USER + 26;
  TB_ADDSTRINGA            = WM_USER + 28;
  TB_GETBUTTONTEXTA        = WM_USER + 45;
//  TBN_GETBUTTONINFOA       = TBN_FIRST-0;

type
  TBBUTTON = packed record
    iBitmap: Integer;
    idCommand: Integer;
    fsState: BYTE;
    fsStyle: BYTE;
    bReserved: array [0..1] of BYTE;    // padding for alignment
    dwData: Pointer;                    //DWORD_PTR;
    iString: Pointer;                   //INT_PTR;
  end;

  TBBUTTON64 = packed record
    iBitmap: Integer;
    idCommand: Integer;
    fsState: BYTE;
    fsStyle: BYTE;
    bReserved: array [0..5] of BYTE;    // padding for alignment  64bit
    dwData: Pointer;                    //DWORD_PTR;
    iString: Pointer;                   //INT_PTR;
  end;

  TRAYDATA = packed record
    wnd: HWND;
    uID: UINT;
    uCallbackMessage: UINT;
    Reserved: array [0..1] of DWORD;
    hIcon: HICON;
  end;

function GetShellImageHandle(bSmall: Boolean = true; dwFileAttr: DWORD = 0): THandle;
function GetShellImageIndex_path(const sPath: String): Integer;

procedure OpenPath(const sPath: String; hParent: HWND = 0);
procedure ExecutePath(const sPath: String; sParam: String = ''; hParent: HWND = 0); inline;
procedure ExecutePath_hide(const sPath: String; sParam: String = ''); inline;
procedure ExecutePath_runAs(const sPath: String; sParam: String = '';
                nShowMode: Integer = SW_SHOWNORMAL);
procedure ExecuteExplorerOpen(const sPath: String); inline;

procedure ExplorerSelectedPath(sPath: String; bCheckFileExists: Boolean = true);

function GetShellExePathFromExt(sExt: String): String;
function GetTargetExeFromLink(const sPath: String): String;

function ClearZombieTray(hTray: HWND): Integer;
function AddFileSmallIconToImageList(aList: TImageList; const sPath: string): Integer;
function GetFileSmallIcon(const sPath: String): TIcon;

implementation

uses
  Winapi.ShellAPI, Tocsg.Exception, System.Win.Registry, Tocsg.Safe,
  Tocsg.Strings, Tocsg.Registry, Tocsg.Process, Winapi.ShlObj, Winapi.ActiveX,
  Tocsg.Trace;

function GetShellImageHandle(bSmall: Boolean = true; dwFileAttr: DWORD = 0): THandle;
var
  SFI: TSHFileInfo;
  dwIconSize: DWORD;
begin
  if bSmall then
    dwIconSize := SHGFI_SMALLICON
  else
    dwIconSize := SHGFI_LARGEICON;

  Result := SHGetFileInfo('', dwFileAttr, SFI, SizeOf(SFI), SHGFI_ICON or SHGFI_SYSICONINDEX or dwIconSize);
end;

// 11.1 기준, 64비트에서는 Range check error 에러가 뜬다...
// 10.x에서 만든 .dproj로 프로젝트를 다시 만들면 해결된다.. 델파이 버그...
// SearchLight.dproj로 해결함 22_0713 11:31:14 kku
function GetShellImageIndex_path(const sPath: String): Integer;
var
  SFI: TSHFileInfo;
  dwResult: DWORD;
begin
  Result := 0;

  try
    // 이걸로 체크하면 가상파일, 재문 분석이 필요한 파일 (드롭박스, 구글드라이브)의 경우
    // 파일이 바로 동기화 되어버린다. 23_0111 09:41:13 kku
//    if FileExists(sPath) or DirectoryExists(sPath) then

    if GetFileAttributes(PChar(sPath)) <> INVALID_FILE_ATTRIBUTES then
    begin
      ZeroMemory(@SFI, SizeOf(SFI));
      dwResult := SHGetFileInfo(PChar(sPath), 0, SFI, SizeOf(SFI),
//                                SHGFI_ICON or SHGFI_SYSICONINDEX or dwIconSize);
                                SHGFI_SYSICONINDEX); // 이렇게 해야 엄청 많이 시도했을때 out of system resources 오류 안난다... 22_0628 14:37:54 kku

//      if Succeeded(dwResult) then // 64 환경에서는 계속 실패 뜬다.. 그런데 SFI.iIcon 값은 잘 나옴 22_0705 17:02:16 kku
        Result := SFI.iIcon;
    end;
  except
    on E: Exception do
      ETgException.TraceException(E, 'Fail .. GetShellImageIndex_path()');
  end;
end;

procedure OpenPath(const sPath: String; hParent: HWND = 0);
//var
//  sCmd: String;
//  StrList: TStringList;
begin
//  Guard(StrList, TStringList.Create);
//
//  StrList.Add(Format('start "" "%s"', [sPath]));
//  StrList.Add('pause');
//
//  sCmd := 'C:\ProgramData\HE\test.cmd';
//  StrList.SaveToFile(sCmd, TEncoding.ANSI);
//  ShellExecute(hParent, nil, PChar(sCmd), nil, nil, SW_SHOWNORMAL);

// BSOne DRM 파일을 열람 하려면 start "" "경로" 이렇게 해야 실시간 복호화 열람이 가능하다
// 실행 기준 디렉토리를 일반사용자 권한으로 접근 가능한 곳으로 설정해야 정상 동작한다.
  ShellExecute(hParent, nil, 'cmd.exe', PChar(Format('/c start "" "%s"', [sPath])), 'C:\ProgramData\', SW_HIDE);
end;

procedure ExecutePath(const sPath: String; sParam: String = ''; hParent: HWND = 0);
begin
  ShellExecute(hParent, nil, PChar(sPath), PChar(sParam), '', SW_SHOWNORMAL);
end;

procedure ExecutePath_hide(const sPath: String; sParam: String = '');
begin
  ShellExecute(0, nil, PChar(sPath), PChar(sParam), '', SW_HIDE);
end;

procedure ExecutePath_runAs(const sPath: String; sParam: String = '';
                nShowMode: Integer = SW_SHOWNORMAL);
const
  RUN_AS: String = 'runas';
var
  ShellExecuteInfo: TShellExecuteInfo;
begin
  ZeroMemory(@ShellExecuteInfo, SizeOf(ShellExecuteInfo));
  with ShellExecuteInfo do
  begin
    cbSize := SizeOf(ShellExecuteInfo);
    fMask := SEE_MASK_FLAG_DDEWAIT or SEE_MASK_FLAG_NO_UI;
    Wnd := 0;
    lpVerb := PChar(RUN_AS);
    lpFile := PChar(Format('"%s"', [sPath]));
    lpParameters := PChar(sParam);
    lpDirectory := nil;
    nShow := nShowMode;
    hInstApp := 0;
  end;
  ShellExecuteEx(@ShellExecuteInfo);
end;

procedure ExecuteExplorerOpen(const sPath: String); inline;
begin
//  ShellExecute(0, 'open', PChar(sPath), PChar(sVPath), '', SW_SHOWNORMAL);
end;

procedure ExplorerSelectedPath(sPath: String; bCheckFileExists: Boolean = true);
begin
  if not bCheckFileExists or (bCheckFileExists and FileExists(sPath)) then
  begin
    sPath := '/select, "' + sPath + '"';
    ShellExecute(0, 'open', 'explorer.exe', PChar(sPath), nil, SW_SHOWNORMAL);
  end;
end;

function GetShellExePathFromExt(sExt: String): String;
var
  Reg: TRegistry;
  sVal,
  sUserSid: String;
  StrList: TStringList;
begin
  Result := '';
  if sExt = '' then
    exit;

  if sExt[1] <> '.' then
    sExt := '.' + sExt;

  sUserSid := GetProcesssUserSidFromName('explorer.exe');
  if sUserSid = '' then
    sUserSid := GetRegRecentUserSid;

  Guard(Reg, TRegistry.Create);

  sVal := '';
  if sUserSid <> '' then
  begin
    Reg.RootKey := HKEY_USERS;

    if Reg.OpenKeyReadOnly(Format('%s\SOFTWARE\Microsoft\Windows\CurrentVersion\' +
                  'Explorer\FileExts\%s\UserChoice', [sUserSid, sExt])) then
      sVal := Reg.ReadString('ProgId');

    Reg.CloseKey;
  end;

  Reg.RootKey := HKEY_CLASSES_ROOT;
  if sVal = '' then
  begin
    if not Reg.OpenKeyReadOnly(sExt) then
      exit;

    sVal := Reg.ReadString('');
    if sVal = '' then
      exit;

    Reg.CloseKey;
  end;

  if not Reg.OpenKeyReadOnly(sVal + '\shell\Open\command') then
    exit;

  sVal := Reg.ReadString('');
  if sVal = '' then
    exit;

  Guard(StrList, TStringList.Create);
  SplitString2(sVal, ' ', StrList);
  if StrList.Count > 0 then
    Result := StringReplace(StrList[0], '"', '', [rfReplaceAll]);
end;

function GetTargetExeFromLink(const sPath: String): String;
var
  psl: IShellLink;
  ppf: IPersistFile;
  info: array [0..MAX_PATH] of Char;
  wfs: TWin32FindData;
begin
  Result := '';

  try
    if not FileExists(sPath) then
      exit;

    CoCreateInstance(CLSID_SHELLLINK, nil, CLSCTX_INPROC_SERVER, IShellLink, psl);
    if (psl <> nil) and (psl.QueryInterface(IPersistFile, ppf) = 0) then
    begin
      ppf.Load(PWideChar(sPath), STGM_READ);
      psl.GetPath((@info), MAX_PATH, wfs, SLGP_UNCPRIORITY);
//      psl.GetPath((@info), MAX_PATH, wfs, SLGP_RELATIVEPRIORITY);
      Result := info;
//      if Result = '' then
//      begin
//        psl.GetPath((@info), MAX_PATH, wfs, SLGP_RELATIVEPRIORITY);
//        Result := info;
//      end;
    end;
  except
    on E: Exception do
      ETgException.TraceException(E, 'Fail .. GetTargetExeFromLink()');
  end;
end;

function ClearZombieTray(hTray: HWND): Integer;
var
  h: HWND;
  i, nCnt: Integer;
  dwTrayPid, dwPid: DWORD;
  hTrayProc: THandle;
  pData: ^TBBUTTON64; //^TBBUTTON;
  tb: TBBUTTON64; // TBBUTTON;
  tray: TRAYDATA;
  IconData: NOTIFYICONDATA;
  nRead: NativeUInt;
  sPName: String;
begin
  Result := 0;
  try
    nCnt := SendMessage(h, TB_BUTTONCOUNT, 0, 0);

    dwTrayPid := 0;
    GetWindowThreadProcessId(h, dwTrayPid);
    if dwTrayPid = 0 then
      exit;

    hTrayProc := OpenProcess(PROCESS_ALL_ACCESS, FALSE, dwTrayPid);
    if hTrayProc = 0 then
      exit;

    try
      pData := VirtualAllocEx(hTrayProc, nil, sizeof(TBBUTTON), MEM_COMMIT, PAGE_READWRITE);
      if pData = nil then
        exit;

      for i := 0 to nCnt - 1 do
      begin
        SendMessage(h, TB_GETBUTTON, i, NativeUInt(pData));

        ReadProcessMemory(hTrayProc, pData, @tb, sizeof(TBBUTTON), nRead);
        ReadProcessMemory(hTrayProc, tb.dwData, @tray, sizeof(tray), nRead);

        dwPid := 0;
        GetWindowThreadProcessId(tray.Wnd, dwPid);
        if dwPid <> 0 then
        begin
  //        sPName := GetProcessNameByPid(dwPid);
  //        mmInfo.Lines.Add(sPName);
        end else begin
          Inc(Result);
  //        mmInfo.Lines.Add('삭제됨 : ' + IntToStr(tray.wnd));
  //        ZeroMemory(@IconData, SizeOf(IconData));
  //        IconData.cbSize := SizeOf(IconData);
  //        IconData.hIcon := tray.hIcon;
  //        IconData.Wnd := tray.wnd;
  //        IconData.uCallbackMessage := tray.uCallbackMessage;
  //        IconData.uID := tray.uID;
  //        Shell_NotifyIcon(NIM_DELETE, @IconData);
        end;
      end;
    finally
      if pData <> nil then
        VirtualFreeEx(hTrayProc, pData, 0, MEM_RELEASE);
      if hTrayProc <> 0 then
        CloseHandle(hTrayProc);
    end;
  except
    on E: Exception do
      ETgException.TraceException(E, 'Fail .. ClearZombieTray()');
  end;
end;

function AddFileSmallIconToImageList(aList: TImageList; const sPath: string): Integer;
var
  ico: TICon;
  FileInfo: TSHFileInfo;
  dwFlags: UINT;
begin
  Result := -1;

  try
    dwFlags := SHGFI_ICON or SHGFI_USEFILEATTRIBUTES;
    dwFlags := dwFlags or SHGFI_SMALLICON;
  //  Flags := Flags or SHGFI_LARGEICON;

    // SHGFI_USEFILEATTRIBUTES를 써야 실제 파일이 없어도 확장자만으로 아이콘을 얻을 수 있음
    if SHGetFileInfo(PChar(sPath), FILE_ATTRIBUTE_NORMAL, FileInfo, SizeOf(FileInfo), dwFlags) <> 0 then
    begin
      Guard(ico, TIcon.Create);
      ico.Handle := FileInfo.hIcon;
      Result := aList.AddIcon(ico);
    end;
  except
  // ..
  end;
end;

function GetFileSmallIcon(const sPath: String): TIcon;
var
  FileInfo: TSHFileInfo;
  dwFlags: UINT;
begin
  Result := nil;

  try
    dwFlags := SHGFI_ICON or SHGFI_USEFILEATTRIBUTES;
    dwFlags := dwFlags or SHGFI_SMALLICON;
  //  Flags := Flags or SHGFI_LARGEICON;

    // SHGFI_USEFILEATTRIBUTES를 써야 실제 파일이 없어도 확장자만으로 아이콘을 얻을 수 있음
    if SHGetFileInfo(PChar(sPath), FILE_ATTRIBUTE_NORMAL, FileInfo, SizeOf(FileInfo), dwFlags) <> 0 then
    begin
      Result := TIcon.Create;
      Result.Handle := FileInfo.hIcon;
    end;
  except
  // ..
  end;
end;

end.