was ist neu ¦  programmier tips ¦  indy artikel ¦  intraweb artikel ¦  informationen ¦  links ¦  interviews
 sonstiges ¦  tutorials ¦  Add&Win Gewinnspiel

Tips (1541)

Dateien (137)
Datenbanken (90)
Drucken (35)
Grafik (114)
IDE (21)
Indy (5)
Internet / LAN (130)
IntraWeb (0)
Mathematik (76)
Multimedia (45)
Oberfläche (107)
Objekte/
ActiveX (51)

OpenTools API (3)
Sonstiges (126)
Strings (83)
System (266)
VCL (242)

Tips sortiert nach
Komponente


Tip suchen

Tip hinzufügen

Add&Win Gewinnspiel

Werbung

45 Visitors Online


 
...den SelectDirectory Dialog mit einem Startverzeichnis anzeigen?
Autor: Guest
[ Tip ausdrucken ]  

Tip Bewertung (20):  
     


uses
  
ShlObj, ActiveX;

function SelectDirectoryEx(hOwn: HWND; var Path: string; Caption, Root: string;
  uFlag: DWORD = $25): Boolean;
const
  
BIF_NEWDIALOGSTYLE = $0040;
var
  
BrowseInfo: TBrowseInfo;
  Buffer: PChar;
  RootItemIDList, ItemIDList: PItemIDList;
  ShellMalloc: IMalloc;
  IDesktopFolder: IShellFolder;
  Dummy: LongWord;

  function BrowseCallbackProc(hwnd: HWND; uMsg: UINT; lParam: Cardinal;
    lpData: Cardinal): Integer; stdcall;
  var
    
PathName: array[0..MAX_PATH] of Char;
  begin
    case 
uMsg of
      
BFFM_INITIALIZED:
        SendMessage(Hwnd, BFFM_SETSELECTION, Ord(True), Integer(lpData));
      BFFM_SELCHANGED:
        begin
          
SHGetPathFromIDList(PItemIDList(lParam), @PathName);
          SendMessage(hwnd, BFFM_SETSTATUSTEXT, 0, Longint(PChar(@PathName)));
        end;
    end;
    Result := 0;
  end;
begin
  
Result := False;
  FillChar(BrowseInfo, SizeOf(BrowseInfo), 0);
  if (ShGetMalloc(ShellMalloc) = S_OK) and (ShellMalloc <> nilthen
  begin
    
Buffer := ShellMalloc.Alloc(MAX_PATH);
    try
      
RootItemIDList := nil;
      if Root <> '' then
      begin
        
SHGetDesktopFolder(IDesktopFolder);
        IDesktopFolder.ParseDisplayName(hOwn, nil, POleStr(WideString(Root)),
          Dummy, RootItemIDList, Dummy);
      end;
      with BrowseInfo do
      begin
        
hwndOwner := hOwn;
        pidlRoot := RootItemIDList;
        pszDisplayName := Buffer;
        lpszTitle := PChar(Caption);
        ulFlags := uFlag;
        lpfn := @BrowseCallbackProc;
        lParam := Integer(PChar(Path));
      end;
      ItemIDList := ShBrowseForFolder(BrowseInfo);
      Result := ItemIDList <> nil;
      if Result then
      begin
        
ShGetPathFromIDList(ItemIDList, Buffer);
        ShellMalloc.Free(ItemIDList);
        Path := StrPas(Buffer);
      end;
    finally
      
ShellMalloc.Free(Buffer);
    end;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  
Path: string;
begin
  
Path := 'C:\Windows';
  if SelectDirectoryEx(Handle, Path, 'Select Directory Sample', 'C:\') then
    
ShowMessage(Path);
end;


{******************************************************************}

{
  Heres an example on how to locate a folder with a specific filer,
  using SHBrowseForFolder and a BrowseCallBack function
  ( by Jack Kallestrup )
}

uses ShlObj, ShellApi;

function BrowseCallBack ( Hwnd : THandle; uMsg : UINT; lpParam, lpData : LPARAM): integer; stdcall;
var
  
Buffer : Array[0..255] of char;
  Buffer2 : Array[0..255] of char;
  TmpStr : String;
begin
  
// Initialize buffers
  
FillChar(Buffer,SizeOf(Buffer),#0);
  FillChar(Buffer2,SizeOf(Buffer2),#0);

  // Statusline text
  
TmpStr := 'Locate folder containing '+StrPas(PChar(lpData));

  // Copy statustext to pchar
  
StrPCopy(Buffer2,TmpStr);

  // Send message to BrowseForDlg that
  // the status text has changed
  
SendMessage(hwnd,BFFM_SETSTATUSTEXT,0,Integer(@Buffer2));

  // If directory in BrowswForDlg has changed ?
  
if uMsg = BFFM_SELCHANGED then begin
    
// Get the new folder name
    
SHGetPathFromIDList(PItemIDList(lpParam),Buffer);
    // And check for existens of our file.
    {$IFDEF RX_D3}  //RxLib - extentions
    
if FileExists(NormalDir(StrPas(Buffer))+StrPas(PChar(lpData)))
       and (StrLen(Buffer) > 0) then
    
{$ELSE}
      
if Length(StrPas(Buffer)) <> 0 then
       if 
Buffer[Length(StrPas(Buffer))-1] = '\' then
         
Buffer[Length(StrPas(Buffer))-1] := #0;
      if FileExists(StrPas(Buffer)+'\'+StrPas(PChar(lpData))) and
         
(StrLen(Buffer) > 0) then
    
{$ENDIF}
      // found : Send message to enable OK-button
      
SendMessage(hwnd,BFFM_ENABLEOK,1,1)
    else
      
// Send message to disable OK-Button
      
SendMessage(Hwnd,BFFM_ENABLEOK,0,0);
  end;
  result := 0
end;


function BrowseforFile(Handle : THandle; Title : String; Filename : String) : String;
var
  
BrowseInfo : TBrowseInfo;
  RetBuffer,
  FName,
  ResultBuffer : Array[0..255] of char;
  PIDL : PItemIDList;
begin
  
StrPCopy(Fname,FileName);

  //Initialize buffers
  
FillChar(BrowseInfo,SizeOf(TBrowseInfo),#0);
  Fillchar(RetBuffer,SizeOf(RetBuffer),#0);
  FillChar(ResultBuffer,SizeOf(ResultBuffer),#0);

  BrowseInfo.hwndOwner := Handle;
  BrowseInfo.pszDisplayName := @Retbuffer;
  BrowseInfo.lpszTitle := @Title[1];

  // we want a status-text
  
BrowseInfo.ulFlags := BIF_StatusText;

  // Our call-back function cheching for fileexist
  
BrowseInfo.lpfn := @BrowseCallBack;
  BrowseInfo.lParam := Integer(@FName);

  // Show BrowseForDlg
  
PIDL := SHBrowseForFolder(BrowseInfo);

  // Return fullpath to file
  
if SHGetPathFromIDList(PIDL,ResultBuffer) then
    
result := StrPas(ResultBuffer)
  else
    
Result := '';

  GlobalFreePtr(PIDL);  //Clean up
end;

// Example:

procedure TForm1.Button1Click(Sender: TObject);
const
  
FileName = 'File.xyz';
var
  
Answer: Integer;
begin
  if 
MessageBox(0, 'To locate the file yourself, click ok',
     PChar(Format('File %s not found.',[FileName])),MB_OKCANCEL) = 1 then
       
BrowseforFile(Handle, 'locate ' + FileName, FileName);
end;


 

Bewerten Sie diesen Tipp:

dürftig
ausgezeichnet


Copyright © by SwissDelphiCenter.ch
All trademarks are the sole property of their respective owners