jvwindialogs.pas

East make Tray Icon in delphi

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;

  {$IFDEF VCL}
  OSCheck(LongBool(ShellAbout(Application.MainForm.Handle,
    PChar(CaptionText), PChar(OtherText), FIcon.Handle)));
  {$ENDIF VCL}
  {$IFDEF VisualCLX}
  OSCheck(LongBool(ShellAbout(QWidget_winId(Application.MainForm.Handle),
    PChar(CaptionText), PChar(OtherText), 0)));
  {$ENDIF VisualCLX}
  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
    {$IFDEF VCL}
    SHRunDialog(GetForegroundWindow, FIcon.Handle, nil, CaptionBuffer,
      DescriptionBuffer, 0)
    {$ENDIF VCL}
    {$IFDEF VisualCLX}
    SHRunDialog(GetForegroundWindow, 0, nil, CaptionBuffer,
      DescriptionBuffer, 0)
    {$ENDIF VisualCLX}
  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
  if Desc <> '' then
    OleCheck(SL.SetDescription(PChar(Desc))); // set description
  { create a path location and filename for link file }
  LnkName := GetSpecialFolderPath(Dest, True) + '\' +
    ChangeFileExt(AppName, 'lnk');
  PF.Save(PWideChar(LnkName), True); // save link file
  Result := LnkName;
end;

procedure GetShellLinkInfo(const LinkFile: WideString; var SLI: TShellLinkInfo);
{ Retrieves information on an existing shell link }
var
  SL: IShellLink;
  PF: IPersistFile;
  FindData: TWin32FindData;
  AStr: array [0..MAX_PATH] of Char;
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;
  { Load file into IPersistFile object }
  OleCheck(PF.Load(PWideChar(LinkFile), STGM_READ));
  { Resolve the link by calling the Resolve interface function. }
  OleCheck(SL.Resolve(0, SLR_ANY_MATCH or SLR_NO_UI));
  { Get all the info! }
  with SLI do
  begin
    OleCheck(SL.GetPath(AStr, MAX_PATH, FindData, SLGP_SHORTPATH));
    PathName := AStr;
    OleCheck(SL.GetArguments(AStr, MAX_PATH));
    Arguments := AStr;
    OleCheck(SL.GetDescription(AStr, MAX_PATH));
    Description := AStr;
    OleCheck(SL.GetWorkingDirectory(AStr, MAX_PATH));
    WorkingDirectory := AStr;
    OleCheck(SL.GetIconLocation(AStr, MAX_PATH, IconIndex));
    IconLocation := AStr;
    OleCheck(SL.GetShowCmd(ShowCmd));
    OleCheck(SL.GetHotKey(HotKey));
  end;
end;

procedure SetShellLinkInfo(const LinkFile: WideString;
  const SLI: TShellLinkInfo);
{ Sets information for an existing shell link }
var
  SL: IShellLink;
  PF: IPersistFile;
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;
  { Load file into IPersistFile object }
  OleCheck(PF.Load(PWideChar(LinkFile), STGM_SHARE_DENY_WRITE));
  { Resolve the link by calling the Resolve interface function. }
  OleCheck(SL.Resolve(0, SLR_ANY_MATCH or SLR_UPDATE or SLR_NO_UI));
  { Set all the info! }
  with SLI, SL do
  begin
    OleCheck(SetPath(PChar(PathName)));
    OleCheck(SetArguments(PChar(Arguments)));
    OleCheck(SetDescription(PChar(Description)));