jvqobjectpickerdialog.pas

East make Tray Icon in delphi

    Result := Result or DSOP_DOWNLEVEL_FILTER_AUTHENTICATED_USER;
  if dlAnonymous in Filter then
    Result := Result or DSOP_DOWNLEVEL_FILTER_ANONYMOUS;
  if dlBatch in Filter then
    Result := Result or DSOP_DOWNLEVEL_FILTER_BATCH;
  if dlCreatorOwner in Filter then
    Result := Result or DSOP_DOWNLEVEL_FILTER_CREATOR_OWNER;
  if dlCreatorGroup in Filter then
    Result := Result or DSOP_DOWNLEVEL_FILTER_CREATOR_GROUP;
  if dlDialUp in Filter then
    Result := Result or DSOP_DOWNLEVEL_FILTER_DIALUP;
  if dlInteractive in Filter then
    Result := Result or DSOP_DOWNLEVEL_FILTER_INTERACTIVE;
  if dlNetwork in Filter then
    Result := Result or DSOP_DOWNLEVEL_FILTER_NETWORK;
  if dlService in Filter then
    Result := Result or DSOP_DOWNLEVEL_FILTER_SERVICE;
  if dlSystem in Filter then
    Result := Result or DSOP_DOWNLEVEL_FILTER_SYSTEM;
  if dlExcludeBuiltinGroups in Filter then
    Result := Result or DSOP_DOWNLEVEL_FILTER_EXCLUDE_BUILTIN_GROUPS;
  if dlTerminalServer in Filter then
    Result := Result or DSOP_DOWNLEVEL_FILTER_TERMINAL_SERVER;
  if dlAllWellKnownSids in Filter then
    Result := Result or DSOP_DOWNLEVEL_FILTER_ALL_WELLKNOWN_SIDS;
  if dlLocalService in Filter then
    Result := Result or DSOP_DOWNLEVEL_FILTER_LOCAL_SERVICE;
  if dlNetworkService in Filter then
    Result := Result or DSOP_DOWNLEVEL_FILTER_NETWORK_SERVICE;
  if dlRemoteLogon in Filter then
    Result := Result or DSOP_DOWNLEVEL_FILTER_REMOTE_LOGON;
end;

function OptionsToOrdinal(const Options: TObjectPickerOptions): Cardinal;
begin
  Result := 0;
  if opAllowMultiSelect in Options then
    Result := Result or DSOP_FLAG_MULTISELECT;
  if opSkipTargetComputerDCCheck in Options then
    Result := Result or DSOP_FLAG_SKIP_TARGET_COMPUTER_DC_CHECK;
end;

//=== { TObjectPickerScope } =================================================

procedure TObjectPickerScope.Assign(Source: TPersistent);
begin
  if Source is TObjectPickerScope then
  begin
    FDownLevelFilter := TObjectPickerScope(Source).DownLevelFilter;
    FScopeTypes := TObjectPickerScope(Source).ScopeTypes;
    FScopeFlags := TObjectPickerScope(Source).ScopeFlags;
    FDcName := TObjectPickerScope(Source).DcName;
    FResult := TObjectPickerScope(Source).Result;
    FUpLevelFilterBoth := TObjectPickerScope(Source).UpLevelFilterBoth;
    FUpLevelFilterNative := TObjectPickerScope(Source).UpLevelFilterNative;
    FUpLevelFilterMixed := TObjectPickerScope(Source).UpLevelFilterMixed;
  end
  else
    inherited Assign(Source);
end;

//=== { TObjectPickerScopes } ================================================

constructor TObjectPickerScopes.Create({OWNER AOwner: TComponent});
begin
  inherited Create(TObjectPickerScope);
  //OWNER FOwner := AOwner;
end;

function TObjectPickerScopes.Add: TObjectPickerScope;
begin
  Result := TObjectPickerScope(inherited Add);
end;

procedure TObjectPickerScopes.Assign(Source: TPersistent);
var
  I: Integer;
begin
  if Source is TObjectPickerScopes then
    for I := 0 to TCollection(Source).Count - 1 do
      Add.Assign(TCollection(Source).Items[I])
  else
    inherited Assign(Source);
end;

function TObjectPickerScopes.GetItem(Index: Integer): TObjectPickerScope;
begin
  Result := TObjectPickerScope(inherited Items[Index]);
end;

procedure TObjectPickerScopes.Initialize(var ScopesInitInfo: array of TDsOpScopeInitInfo);
var
  I: Integer;
begin
  for I := 0 to Count - 1 do
  begin
    FillChar(ScopesInitInfo[I], SizeOf(TDsOpScopeInitInfo), 0);
    ScopesInitInfo[I].cbSize := SizeOf(TDsOpScopeInitInfo);
    ScopesInitInfo[I].flType := ScopeTypesToOrdinal(Items[I].ScopeTypes);
    ScopesInitInfo[I].flScope := ScopeFlagsToOrdinal(Items[I].ScopeFlags);
    ScopesInitInfo[I].FilterFlags.Uplevel.flBothModes :=
      UpLevelFilterToOrdinal(Items[I].UpLevelFilterBoth);
    ScopesInitInfo[I].FilterFlags.Uplevel.flMixedModeOnly :=
      UpLevelFilterToOrdinal(Items[I].UpLevelFilterMixed);
    ScopesInitInfo[I].FilterFlags.Uplevel.flNativeModeOnly :=
      UpLevelFilterToOrdinal(Items[I].UpLevelFilterNative);
    ScopesInitInfo[I].FilterFlags.flDownlevel :=
      DownLevelFilterToOrdinal(Items[I].DownLevelFilter);
    ScopesInitInfo[I].pwzDcName := PWideChar(WideString(Items[I].DcName));
    ScopesInitInfo[I].pwzADsPath := nil;
    ScopesInitInfo[I].hr := S_OK;
  end;
end;

//OWNER function TObjectPickerScopes.Owner: TComponent;
//OWNER begin
//OWNER   Result := FOwner;
//OWNER end;

procedure TObjectPickerScopes.SetItem(Index: Integer;
  Value: TObjectPickerScope);
begin
  TObjectPickerScope(inherited Items[Index]).Assign(Value);
end;

//=== { TObjectPickerSelection } =============================================

constructor TObjectPickerSelection.Create(Selection: PDsSelection;
  const AttributeCount: Integer);
begin
  inherited Create;
  FAttributeCount := AttributeCount;
  FSelection := Selection;
end;

function TObjectPickerSelection.GetAdsPath: string;
begin
  Result := WideCharToString(FSelection^.pwzADsPath);
end;

function TObjectPickerSelection.GetAttribute(Index: Integer): OleVariant;
type
  TOleVariantArray = array [0..(MaxInt div SizeOf(OleVariant)) - 1] of OleVariant;
  POleVariantArray = ^TOleVariantArray;
begin
  if (Index < 0) or (Index >= AttributeCount) then
    raise EObjectPickerError.CreateResFmt(@RsEAttributeIndexOutOfBounds, [Index]);
  Result := POleVariantArray(FSelection^.pvarFetchedAttributes)^[Index];
end;

function TObjectPickerSelection.GetName: string;
begin
  Result := WideCharToString(FSelection^.pwzName);
end;

function TObjectPickerSelection.GetObjectClass: string;
begin
  Result := WideCharToString(FSelection^.pwzClass);
end;

function TObjectPickerSelection.GetScopeTypes: TScopeTypes;
begin
  Result := OrdinalToScopeTypes(FSelection^.flScopeType);
end;

function TObjectPickerSelection.GetUPN: string;
begin
  Result := WideCharToString(FSelection^.pwzUPN);
end;

//=== { TObjectPickerSelections } ============================================

destructor TObjectPickerSelections.Destroy;
begin
  FreeSelection;
  inherited Destroy;
end;

procedure TObjectPickerSelections.FreeSelection;
var
  I: Integer;
begin
  if FSelections <> nil then
  begin
    for I := 0 to Length(FItems) - 1 do
      FItems[I].Free;
    SetLength(FItems, 0);
    GlobalUnlock(FMedium.hGlobal);
    ReleaseStgMedium(FMedium);
    FSelections := nil;
  end;
end;

function TObjectPickerSelections.GetAttributeCount: Integer;
begin
  Result := -1;
  if FSelections <> nil then
    Result := FSelections^.cFetchedAttributes;
end;

function TObjectPickerSelections.GetCount: Integer;
begin
  Result := -1;
  if FSelections <> nil then
    Result := FSelections^.cItems;
end;

function TObjectPickerSelections.GetItem(Index: Integer): TObjectPickerSelection;
begin
  Result := nil;
  if FSelections <> nil then
  begin
    if (Index < 0) or (Index >= Count) then
      raise EObjectPickerError.CreateResFmt(@RsESelectionIndexOutOfBounds, [Index]);
    Result := FItems[Index];
  end;
end;

procedure TObjectPickerSelections.SetSelection(const DataObj: IDataObject);
var
  Format: TFormatEtc;
  I: Integer;
  Selection: PDsSelection;
  HRes: HRESULT;
begin
  FreeSelection;
  Format.cfFormat := RegisterClipboardFormat(CFSTR_DSOP_DS_SELECTION_LIST);
  Format.ptd := nil;
  Format.dwAspect := DVASPECT_CONTENT;
  Format.lindex := -1;
  Format.tymed := TYMED_HGLOBAL;
  FillChar(FMedium, SizeOf(FMedium), 0);
  FMedium.tymed := TYMED_HGLOBAL;
  HRes := DataObj.GetData(Format, FMedium);
  if Succeeded(HRes) then
  begin
    FSelections := GlobalLock(FMedium.hGlobal);
    SetLength(FItems, FSelections^.cItems);
    for I := 0 to FSelections^.cItems - 1 do
    begin
      {$RANGECHECKS OFF}
      Selection := @FSelections^.aDsSelection[I];
      {$IFDEF RANGECHECKS_ON}
      {$RANGECHECKS ON}
      {$ENDIF RANGECHECKS_ON}
      FItems[I] := TObjectPickerSelection.Create(Selection,
        FSelections^.cFetchedAttributes);
    end;
  end
  else
    OleCheck(HRes);
end;

//=== { TJvObjectPickerDialog } ==============================================

constructor TJvObjectPickerDialog.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
//  OleCheck(CoCreateInstance(CLSID_DsObjectPicker, nil, CLSCTX_INPROC_SERVER, IID_IDsObjectPicker, FObjectPicker));
  FAttributes := TStringList.Create;
  FOptions := [];
  FScopes := TObjectPickerScopes.Create({OWNER Self});
  FSelection := TObjectPickerSelections.Create;
  FTargetComputer := '';
end;

destructor TJvObjectPickerDialog.Destroy;
begin
  FSelection.Free;
  FScopes.Free;
  FAttributes.Free;
  FObjectPicker := nil;
  inherited Destroy;
end;

function TJvObjectPickerDialog.Execute: Boolean;
var
  InitInfo: TDsOpInitInfo;
  ScopesInitInfo: array of TDsOpScopeInitInfo;
  Attrs: array of PWideChar;
  AttrStrs: array of WideString;
  HRes: HRESULT;
  DataObj: IDataObject;

  procedure InitializeAttributes;
  var
    I: Integer;
  begin
    InitInfo.cAttributesToFetch := Attributes.Count;
    if Attributes.Count = 0 then
      InitInfo.apwzAttributeNames := nil
    else
    begin
      SetLength(Attrs, Attributes.Count);
      SetLength(AttrStrs, Attributes.Count);
      for I := 0 to Attributes.Count - 1 do
      begin
        AttrStrs[I] := WideString(Attributes[I]);
        Attrs[I] := PWideChar(AttrStrs[I]);
      end;
      InitInfo.apwzAttributeNames := @Attrs[0];
    end;
  end;

  procedure PropogateInitResults;
  var
    I: Integer;
  begin
    for I := 0 to Scopes.Count - 1 do
      Scopes[I].FResult := ScopesInitInfo[I].hr;
  end;

begin
  Result := False;
  OleCheck(CoCreateInstance(CLSID_DsObjectPicker, nil, CLSCTX_INPROC_SERVER,
    IID_IDsObjectPicker, FObjectPicker));
  FillChar(InitInfo, SizeOf(InitInfo), 0);
  InitInfo.cbSize := SizeOf(InitInfo);
  InitInfo.flOptions := OptionsToOrdinal(FOptions);
  InitInfo.cDsScopeInfos := Scopes.Count;
  SetLength(ScopesInitInfo, Scopes.Count);
  InitInfo.aDsScopeInfos := @ScopesInitInfo[0];
  Scopes.Initialize(ScopesInitInfo);
  InitializeAttributes;
  Selection.FreeSelection;
  HRes := FObjectPicker.Initialize(InitInfo);
  // (p3) this won't raise a second exception
  if not Succeeded(HRes) then
    Exit;
  PropogateInitResults;
//  OleCheck(HRes);
  HRes := FObjectPicker.InvokeDialog(0, DataObj);
  case HRes of
    S_OK:
      begin
        Result := True;
        FSelection.SetSelection(DataObj);
      end;
    S_FALSE:
      Result := False;
  else
    Result := False;
    OleCheck(HRes);
  end;
end;

procedure TJvObjectPickerDialog.Reset;
begin
  Attributes.Clear;
  Options := [];
  Scopes.Clear;
  Selection.FreeSelection;
end;

function TJvObjectPickerDialog.GetAttributes: TStrings;
begin
  Result := FAttributes;
end;

procedure TJvObjectPickerDialog.SetAttributes(Value: TStrings);
begin
  FAttributes.Assign(Value);
end;

procedure TJvObjectPickerDialog.SetScopes(Value: TObjectPickerScopes);
begin
  FScopes.Assign(Value);
end;

{$IFDEF UNITVERSIONING}
const
  UnitVersioning: TUnitVersionInfo = (
    RCSfile: '$RCSfile: JvQObjectPickerDialog.pas,v $';
    Revision: '$Revision: 1.13 $';
    Date: '$Date: 2004/09/07 23:11:18 $';
    LogPath: 'JVCL\run'
  );

initialization
  RegisterUnitVersion(HInstance, UnitVersioning);

finalization
  UnregisterUnitVersion(HInstance);
{$ENDIF UNITVERSIONING}

end.