jvwindialogs.pas

East make Tray Icon in delphi

}

const
  SHFMT_ID_DEFAULT = $FFFF;
  SHFMT_OPT_FULL = $0001;
  SHFMT_OPT_SYSONLY = $0002;
  // Special return values. PLEASE NOTE that these are DWORD values.
  SHFMT_ERROR = $FFFFFFFF; // Error on last format
  // drive may be formatable
  SHFMT_CANCEL = $FFFFFFFE; // Last format wascanceled
  SHFMT_NOFORMAT = $FFFFFFFD; // Drive is not formatable

type
  LPFNORGFAV = function(Wnd: hWnd; Str: LPTSTR): Integer; stdcall;

function ExtractIconFromFile(FileName: string; Index: Integer): HICON;
var
  iNumberOfIcons: Integer;
begin
  Result := 0;
  if FileExists(FileName) then
  begin
    iNumberOfIcons := ExtractIcon(hInstance, PChar(FileName), Cardinal(-1));
    if (Index >= 0) and (Index < iNumberOfIcons) and (iNumberOfIcons > 0) then
      Result := ExtractIcon(hInstance, PChar(FileName), Index);
  end;
end;

//=== { TJvOrganizeFavoritesDialog } =========================================

function TJvOrganizeFavoritesDialog.Execute: Boolean;
var
  SHModule: THandle;
  Path: string;
  lpfnDoOrganizeFavDlg: LPFNORGFAV;
begin
  Result := False;
  //  lpfnDoOrganizeFavDlg := nil;
  SHModule := SafeLoadLibrary('shdocvw.dll');
  try
    if SHModule <= HINSTANCE_ERROR then
      Exit;
    Path := GetSpecialFolderPath('Favorites', True) + #0#0;
    lpfnDoOrganizeFavDlg := LPFNORGFAV(GetProcAddress(SHModule, 'DoOrganizeFavDlg'));
    if not Assigned(lpfnDoOrganizeFavDlg) then
      raise EWinDialogError.CreateRes(@RsEFunctionNotSupported);
    lpfnDoOrganizeFavDlg(GetForegroundWindow, PChar(Path));
  finally
    FreeLibrary(SHModule);
  end;
  Result := True;
end;

//=== { TJvAppletDialog } ====================================================

const
  CPL_INIT = 1;
  CPL_GETCOUNT = 2;
  CPL_INQUIRE = 3;
  CPL_SELECT = 4;
  CPL_DBLCLK = 5;
  CPL_STOP = 6;
  CPL_EXIT = 7;
  CPL_NEWINQUIRE = 8;

type
  PCPLInfo = ^TCplInfo;
  TCplInfo = packed record
    idIcon: Integer;
    idName: Integer;
    idInfo: Integer;
    lData: Longint;
  end;

{$IFDEF VCL}

constructor TJvAppletDialog.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FAppletName := '';
  FAppletIndex := 0;
  FModule := HINSTANCE_ERROR;
  FCount := 0;
  FAppletFunc := nil;
  SetLength(FAppletInfo, 0);
end;

destructor TJvAppletDialog.Destroy;
begin
  Unload;
  inherited Destroy;
end;

procedure TJvAppletDialog.Unload;
var
  I: Integer;
begin
  if (FModule > HINSTANCE_ERROR) and Assigned(FAppletFunc) then
  begin
    FAppletFunc(GetForegroundWindow, CPL_EXIT, AppletIndex, AppletInfo[AppletIndex].lData);
    FreeLibrary(FModule);
  end;
  for I := 0 to Count - 1 do
  begin
    FAppletInfo[I].Icon.Free;
    FAppletInfo[I].Name := '';
    FAppletInfo[I].Info := '';
  end;
  FModule := HINSTANCE_ERROR;
  FCount := 0;
  FAppletFunc := nil;
  SetLength(FAppletInfo, 0);
end;

procedure TJvAppletDialog.Load;
var
  I: Integer;
  AplInfo: TCplInfo;
  Buffer: array [0..1023] of Char;
begin
  Unload;
  if AppletName <> '' then
  begin
    FModule := LoadLibrary(PChar(AppletName));
    if FModule <= HINSTANCE_ERROR then
      Exit;
    FAppletFunc := TCplApplet(GetProcAddress(FModule, 'CPlApplet'));
    if Assigned(FAppletFunc) and (FAppletFunc(GetForegroundWindow, CPL_INIT, 0, 0) <> 0) then
    begin
      FCount := FAppletFunc(GetForegroundWindow, CPL_GETCOUNT, 0, 0);
      SetLength(FAppletInfo, FCount);
      for I := 0 to Count - 1 do
      begin
        FAppletFunc(GetForegroundWindow, CPL_INQUIRE, I, Longint(@AplInfo));
        with FAppletInfo[I] do
        begin
          Icon := TIcon.Create;
          Icon.Handle := LoadIcon(FModule, MakeIntResource(AplInfo.idIcon));
          LoadString(FModule, AplInfo.idName, Buffer, SizeOf(Buffer));
          Name := Buffer;
          LoadString(FModule, AplInfo.idInfo, Buffer, SizeOf(Buffer));
          Info := Buffer;
        end;
      end;
    end
    else
    begin
      FreeLibrary(FModule);
      FModule := HINSTANCE_ERROR;
    end;
  end;
  if AppletIndex >= Count then
    AppletIndex := 0;
end;

function TJvAppletDialog.GetAppletInfo(Index: Integer): TJvCplInfo;
begin
  FillChar(Result, SizeOf(Result), #0);
  if (Index >= 0) and (Index < Count) then
    Result := FAppletInfo[Index];
end;

procedure TJvAppletDialog.SetAppletName(const AAppletName: string);
begin
  Unload;
  FAppletName := AAppletName;
  Load;
end;

function TJvAppletDialog.Execute: Boolean;
begin
  Result := ValidApplet;
  if Result then
    FAppletFunc(GetForegroundWindow, CPL_DBLCLK, AppletIndex, AppletInfo[AppletIndex].lData)
  else
    ShellExecute(GetFocus, 'open', 'Control.exe', nil, nil, SW_SHOWDEFAULT);
end;

function TJvAppletDialog.ValidApplet: Boolean;
begin
  Result := Assigned(FAppletFunc) and (AppletIndex >= 0) and (AppletIndex < Count);
end;

{$ENDIF VCL}

//=== { TJvComputerNameDialog } ==============================================

constructor TJvComputerNameDialog.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FComputerName := '';
end;

function TJvComputerNameDialog.Execute: Boolean;
var
  BrowseInfo: TBrowseInfo;
  ItemIDList: PItemIDList;
  NameBuffer: array [0..MAX_PATH] of Char;
  WindowList: Pointer;
begin
  Result := False;

  if Failed(SHGetSpecialFolderLocation(GetForegroundWindow, CSIDL_NETWORK,
    ItemIDList)) then
    Exit;

  FillChar(BrowseInfo, SizeOf(BrowseInfo), 0);
  BrowseInfo.hwndOwner := GetForegroundWindow;
  BrowseInfo.pidlRoot := ItemIDList;
  BrowseInfo.pszDisplayName := NameBuffer;
  BrowseInfo.lpszTitle := PChar(FCaption);
  BrowseInfo.ulFlags := BIF_BROWSEFORCOMPUTER;
  WindowList := DisableTaskWindows(0);
  try
    Result := SHBrowseForFolder(BrowseInfo) <> nil;
  finally
    EnableTaskWindows(WindowList);
    FreePIDL(BrowseInfo.pidlRoot);
  end;
  if Result then
    FComputerName := NameBuffer;
end;

//=== { TJvBrowseFolderDialog } ==============================================

constructor TJvBrowseFolderDialog.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FFolderName := '';
end;

function TJvBrowseFolderDialog.Execute: Boolean;
var
  BrowseInfo: TBrowseInfo;
  ItemIDList: PItemIDList;
  ItemSelected: PItemIDList;
  NameBuffer: array [0..MAX_PATH] of Char;
  WindowList: Pointer;
begin
  ItemIDList := nil;
  FillChar(BrowseInfo, SizeOf(BrowseInfo), 0);
  BrowseInfo.hwndOwner := GetForegroundWindow;
  BrowseInfo.pidlRoot := ItemIDList;
  BrowseInfo.pszDisplayName := NameBuffer;
  BrowseInfo.lpszTitle := PChar(FCaption);
  BrowseInfo.ulFlags := BIF_RETURNONLYFSDIRS;
  WindowList := DisableTaskWindows(0);
  try
    ItemSelected := SHBrowseForFolder(BrowseInfo);
    Result := ItemSelected <> nil;
  finally
    EnableTaskWindows(WindowList);
  end;

  if Result then
  begin
    SHGetPathFromIDList(ItemSelected, NameBuffer);
    FFolderName := NameBuffer;
  end;
  FreePIDL(BrowseInfo.pidlRoot);
end;

//=== { TJvFormatDialog } ====================================================

constructor TJvFormatDriveDialog.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FDrive := 'A';
  {$IFDEF VCL}
  if AOwner is TCustomForm then
    FHandle := TCustomForm(AOwner).Handle
  else
    FHandle := HWND_DESKTOP;
  {$ENDIF VCL}
  {$IFDEF VisualCLX}
  if AOwner is TCustomForm then
    FHandle := QWidget_winId(TCustomForm(AOwner).Handle)
  else
    FHandle := Windows.HWND_DESKTOP;
  {$ENDIF VisualCLX}
end;

function TJvFormatDriveDialog.Execute: Boolean;
var
  iDrive, iCapacity, iFormatType, RetVal: Integer;
begin
  iDrive := Ord(FDrive) - Ord('A');
  if Win32Platform = VER_PLATFORM_WIN32_NT then
  begin
    iCapacity := 0; // other styles not supported
    if FFormatType = ftQuick then
      iFormatType := 1
    else
      iFormatType := 0;
  end
  else
  begin
    case FCapacity of
      dcSize360kB:
        iCapacity := 3;
      dcSize720kB:
        iCapacity := 5;
    else
      iCapacity := 0;
    end;
    iFormatType := Ord(FFormatType);
  end;

  RetVal := SHFormatDrive(FHandle, iDrive, iCapacity, iFormatType);
  if Win32Platform = VER_PLATFORM_WIN32_NT then
    Result := RetVal = 0
  else
    Result := RetVal = 6;
  if not Result then
    DoError(RetVal);
end;

procedure TJvFormatDriveDialog.DoError(ErrValue: Integer);
var
  Err: TJvFormatDriveError;
begin
  if Assigned(FOnError) then
  begin
    if Win32Platform = VER_PLATFORM_WIN32_NT then
      Err := errOther
    else
      case ErrValue of
        0:
          Err := errParams;
        -1:
          Err := errSysError;
        -2:
          Err := errAborted;
        -3:
          Err := errCannotFormat;
      else
        Err := errOther;
      end;
    FOnError(Self, Err);
  end;
end;

procedure TJvFormatDriveDialog.SetDrive(Value: Char);
begin
  // (rom) secured
  Value := UpCase(Value);
  if Value in ['A'..'Z'] then
    FDrive := Value;
end;

function GetSpecialFolderPath(const FolderName: string; CanCreate: Boolean): string;
var
  Folder: Integer;
  Found: Boolean;
  I: Integer;
  PIDL: PItemIDList;
  Buf: array [0..MAX_PATH] of Char;
begin
  Found := False;
  Folder := 0;
  Result := '';
  for I := Low(SpecialFolders) to High(SpecialFolders) do
  begin
    if SameFileName(FolderName, SpecialFolders[I].Name) then
    begin
      Folder := SpecialFolders[I].ID;
      Found := True;
      Break;
    end;
  end;
  if not Found then
    Exit;
  { Get path of selected location }
  {JPR}
  if Succeeded(SHGetSpecialFolderLocation(0, Folder, PIDL)) then
  begin
    if SHGetPathFromIDList(PIDL, Buf) then
      Result := Buf;
    CoTaskMemFree(PIDL);
  end;
  {JPR}
end;