jvqwindialogs.pas

East make Tray Icon in delphi

    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';  
  if AOwner is TCustomForm then
    FHandle := QWidget_winId(TCustomForm(AOwner).Handle)
  else
    FHandle := Windows.HWND_DESKTOP; 
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;

procedure AddToRecentDocs(const FileName: string);
begin
  SHAddToRecentDocs(SHARD_PATH, PChar(FileName));
end;

procedure ClearRecentDocs;
begin
  SHAddToRecentDocs(SHARD_PATH, nil);
end;

function ExecuteShellMessageBox(MethodPtr: Pointer; Instance: THandle;
  Owner: HWND; Text: Pointer; Caption: Pointer; Style: UINT;
  Parameters: array of Pointer): Integer;
type
  PPointer = ^Pointer;
var
  ParamCount: Integer;
  ParamBuffer: PChar;
  BufferIndex: Integer;
begin
  ParamCount := High(Parameters) + 1;
  GetMem(ParamBuffer, ParamCount * SizeOf(Pointer));
  try
    for BufferIndex := 0 to High(Parameters) do
    begin
      PPointer(@ParamBuffer[BufferIndex * SizeOf(Pointer)])^ :=
      Parameters[High(Parameters) - BufferIndex];
    end;
    asm
      mov ECX, ParamCount
      cmp ECX, 0
      je  @MethodCall
      mov EDX, ParamBuffer
      @StartLoop:
      push DWORD PTR[EDX]
      add  EDX, 4
      loop @StartLoop
      @MethodCall:
      push Style
      push Caption
      push Text
      push Owner
      push Instance

      call MethodPtr
      mov  Result, EAX
    end;
  finally
    FreeMem(ParamBuffer);
  end;
end;

function ShellMessageBox(Instance: THandle; Owner: HWND; Text: PChar;
  Caption: PChar; Style: UINT; Parameters: array of Pointer): Integer;
var
  MethodPtr: Pointer;
  ShellDLL: HMODULE;
begin
  ShellDLL := LoadLibrary(PChar(Shell32));
  MethodPtr := GetProcAddress(ShellDLL, PChar(183));
  if MethodPtr <> nil then
  begin
    Result := ExecuteShellMessageBox(MethodPtr, Instance, Owner, Text, Caption,
      Style, Parameters);
  end
  else
  begin
    Result := ID_CANCEL;
  end;
end;

//=== { TJvOutOfMemoryDialog } ===============================================

function TJvOutOfMemoryDialog.Execute: Boolean;
var
  CaptionBuffer: Pointer;
begin
  CaptionBuffer := nil;
  if FCaption <> '' then
    GetMem(CaptionBuffer, (Length(FCaption) + 1) * SizeOf(WideChar));

  if Win32Platform = VER_PLATFORM_WIN32_NT then
  begin
    if CaptionBuffer <> nil then
      StringToWideChar(FCaption, PWideChar(CaptionBuffer), Length(FCaption) + 1);
  end
  else
  begin
    if CaptionBuffer <> nil then
      StrPCopy(PChar(CaptionBuffer), FCaption);
  end;
  if Assigned(SHOutOfMemoryMessageBox) then
    Result := Boolean(SHOutOfMemoryMessageBox(GetForegroundWindow, CaptionBuffer,
      MB_OK or MB_ICONHAND))
  else
    raise EWinDialogError.CreateRes(@RsENotSupported);
end;

//=== { TJvShellAboutDialog } ================================================

constructor TJvShellAboutDialog.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FIcon := TIcon.Create;
end;

destructor TJvShellAboutDialog.Destroy;
begin
  FIcon.Free;
  inherited Destroy;
end;

procedure TJvShellAboutDialog.SetIcon(NewValue: TIcon);
begin
  FIcon.Assign(NewValue);
end;

function TJvShellAboutDialog.StoreIcon: Boolean;
begin
  Result := (not FIcon.Empty);
end;

function TJvShellAboutDialog.Execute: Boolean;
const
  AboutText = 'JvDialogs 2.0';
  CaptionSeparator = '#';
var
  CaptionText: string;
begin
  if Caption = '' then
    CaptionText := AboutText
  else
    CaptionText := Caption;

  CaptionText := CaptionText + CaptionSeparator + Product;
  
  OSCheck(LongBool(ShellAbout(QWidget_winId(Application.MainForm.Handle),
    PChar(CaptionText), PChar(OtherText), 0))); 
  Result := True;
end;

//=== { TJvRunDialog } =======================================================

constructor TJvRunDialog.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FCaption := '';
  FDescription := '';
  FIcon := TIcon.Create;
end;

destructor TJvRunDialog.Destroy;
begin
  FIcon.Free;
  inherited Destroy;
end;

procedure TJvRunDialog.Execute;
var
  CaptionBuffer: Pointer;
  DescriptionBuffer: Pointer;
begin
  CaptionBuffer := nil;
  DescriptionBuffer := nil;

  if FCaption <> '' then
    GetMem(CaptionBuffer, (Length(FCaption) + 1) * SizeOf(WideChar));

  if FDescription <> '' then
    GetMem(DescriptionBuffer, (Length(FDescription) + 1) * SizeOf(WideChar));

  if Win32Platform = VER_PLATFORM_WIN32_NT then
  begin
    if CaptionBuffer <> nil then
      StringToWideChar(FCaption, PWideChar(CaptionBuffer), Length(FCaption) + 1);
    if DescriptionBuffer <> nil then
      StringToWideChar(FDescription, PWideChar(DescriptionBuffer),
        Length(FDescription) + 1);
  end
  else
  begin
    if CaptionBuffer <> nil then
      StrPCopy(PChar(CaptionBuffer), FCaption);
    if DescriptionBuffer <> nil then
      StrPCopy(PChar(DescriptionBuffer), FDescription);
  end;

  if Assigned(SHRunDialog) then  
    SHRunDialog(GetForegroundWindow, 0, nil, CaptionBuffer,
      DescriptionBuffer, 0) 
  else
    raise EWinDialogError.CreateRes(@RsENotSupported);
end;

procedure TJvRunDialog.SetIcon(const Value: TIcon);
begin
  FIcon.Assign(Value);
end;

//=== { TJvObjectPropertiesDialog } ==========================================

function TJvObjectPropertiesDialog.Execute: Boolean;
var
  ObjectNameBuffer: Pointer;
  TabNameBuffer: Pointer;
begin
  GetMem(ObjectNameBuffer, (Length(ObjectName) + 1) * SizeOf(WideChar));
  try
    if SysUtils.Win32Platform = VER_PLATFORM_WIN32_NT then
    begin
      StringToWideChar(ObjectName, PWideChar(ObjectNameBuffer),
        Length(ObjectName) + 1);
    end
    else
    begin
      StrPCopy(PChar(ObjectNameBuffer), ObjectName);
    end;

    GetMem(TabNameBuffer, (Length(InitialTab) + 1) * SizeOf(WideChar));
    try
      if SysUtils.Win32Platform = VER_PLATFORM_WIN32_NT then
      begin
        StringToWideChar(InitialTab, PWideChar(TabNameBuffer),
          Length(InitialTab) + 1);
      end
      else
      begin
        StrPCopy(PChar(TabNameBuffer), InitialTab);
      end;
      Result := SHObjectProperties(GetForegroundWindow,
        ShellObjectTypeEnumToConst(ObjectType), ObjectNameBuffer,
        TabNameBuffer);
    finally
      FreeMem(TabNameBuffer);
    end;
  finally
    FreeMem(ObjectNameBuffer);
  end;
end;

function ShellObjectTypeEnumToConst(ShellObjectType: TShellObjectType): UINT;
begin
  case ShellObjectType of
    sdPathObject:
      Result := OPF_PATHNAME;
    sdPrinterObject:
      Result := OPF_PRINTERNAME;
  else
    Result := 0;
  end;
end;

function ShellObjectTypeConstToEnum(ShellObjectType: UINT): TShellObjectType;
begin
  case ShellObjectType of
    OPF_PATHNAME:
      Result := sdPathObject;
    OPF_PRINTERNAME:
      Result := sdPrinterObject;
  else
    Result := sdPathObject;
  end;
end;

//=== { TJvNewLinkDialog } ===================================================

procedure TJvNewLinkDialog.Execute;
begin
  NewLinkHere(0, 0, PChar(DestinationFolder), 0);
end;

//=== { TJvAddHardwareDialog } ===============================================

procedure TJvAddHardwareDialog.Execute;
var
  APModule: THandle;
  Applet: TCplApplet;
begin
  APModule := LoadLibrary('hdwwiz.cpl');
  if APModule <= HINSTANCE_ERROR then
    Exit;
  Applet := TCplApplet(GetProcAddress(APModule, 'CPlApplet'));
  Applet(0, CPL_DBLCLK, 0, 0);
  FreeLibrary(APModule);
end;

function CreateShellLink(const AppName, Desc: string; Dest: string): string;
{ Creates a shell link for application or document specified in  }
{ AppName with description Desc.  Link will be located in folder }
{ specified by Dest, which is one of the string constants shown  }
{ at the top of this unit.  Returns the full path name of the    }
{ link file. }
var
  SL: IShellLink;
  PF: IPersistFile;
  LnkName: WideString;
begin
  OleCheck(CoCreateInstance(CLSID_ShellLink, nil, CLSCTX_INPROC_SERVER,
    IShellLink, SL));
  { The IShellLink implementer must also support the IPersistFile }
  { interface. Get an interface pointer to it. }
  PF := SL as IPersistFile;
  OleCheck(SL.SetPath(PChar(AppName))); // set link path to proper file