Programlama yapalım ve Öğrenelim.

neoturk: ...Get the free, total size of a disk disk volume ?...

{

* Place a Button1 and DriveComboBox1 on your form.

* The function "SetCurrentDir" well be true if the disk in drive

* The procedure "GetDiskFreeSpaceEx" returns the free and total disk size

}

uses

SysUtils;

implementation

function GetDiskSize(drive: Char; var free_size, total_size: Int64): Boolean;

var

RootPath: array[0..4] of Char;

RootPtr: PChar;

current_dir: string;

begin

RootPath[0] := Drive;

RootPath[1] := ':';

RootPath[2] := '';

RootPath[3] := #0;

RootPtr := RootPath;

current_dir := GetCurrentDir;

if SetCurrentDir(drive + ':') then

begin

GetDiskFreeSpaceEx(RootPtr, Free_size, Total_size, nil);

// this to turn back to original dir

SetCurrentDir(current_dir);

Result := True;

end

else

begin

Result := False;

Free_size := -1;

Total_size := -1;

end;

procedure TForm1.Button1Click(Sender: TObject);

var

free_size, total_size: Int64;

begin

if GetDiskSize(DriveComboBox1.Drive, free_size, total_size) then

ShowMessage('free space =' +

IntToStr(free_size) + #13 + 'total size=' +

IntToStr(total_size))

else

ShowMessage('No disk in drive!');

end;

Delphi - .....................................

neoturk: ...Get the free, total size of a disk disk volume ?...

{

* Place a Button1 and DriveComboBox1 on your form.

* The function "SetCurrentDir" well be true if the disk in drive

* The procedure "GetDiskFreeSpaceEx" returns the free and total disk size

}

uses

SysUtils;

implementation

function GetDiskSize(drive: Char; var free_size, total_size: Int64): Boolean;

var

RootPath: array[0..4] of Char;

RootPtr: PChar;

current_dir: string;

begin

RootPath[0] := Drive;

RootPath[1] := ':';

RootPath[2] := '';

RootPath[3] := #0;

RootPtr := RootPath;

current_dir := GetCurrentDir;

if SetCurrentDir(drive + ':') then

begin

GetDiskFreeSpaceEx(RootPtr, Free_size, Total_size, nil);

// this to turn back to original dir

SetCurrentDir(current_dir);

Result := True;

end

else

begin

Result := False;

Free_size := -1;

Total_size := -1;

end;

procedure TForm1.Button1Click(Sender: TObject);

var

free_size, total_size: Int64;

begin

if GetDiskSize(DriveComboBox1.Drive, free_size, total_size) then

ShowMessage('free space =' +

IntToStr(free_size) + #13 + 'total size=' +

IntToStr(total_size))

else

ShowMessage('No disk in drive!');

end;

Delphi - .....................................

neoturk: ...Concatenate and compress files into one destination file ?...

uses

Zlib;

procedure CompressFiles(Files : TStrings; const Filename : String);

var

infile, outfile, tmpFile : TFileStream;

compr : TCompressionStream;

i,l : Integer;

s : String;

begin

if Files.Count > 0 then

begin

outFile := TFileStream.Create(Filename,fmCreate);

try

{ the number of files }

l := Files.Count;

outfile.Write(l,SizeOf(l));

for i := 0 to Files.Count-1 do

begin

infile := TFileStream.Create(Files[i],fmOpenRead);

try

{ the original filename }

s := ExtractFilename(Files[i]);

l := Length(s);

outfile.Write(l,SizeOf(l));

outfile.Write(s[1],l);

{ the original filesize }

l := infile.Size;

outfile.Write(l,SizeOf(l));

{ compress and store the file temporary}

tmpFile := TFileStream.Create('tmp',fmCreate);

compr := TCompressionStream.Create(clMax,tmpfile);

try

compr.CopyFrom(infile,l);

finally

compr.Free;

tmpFile.Free;

end;

{ append the compressed file to the destination file }

tmpFile := TFileStream.Create('tmp',fmOpenRead);

try

outfile.CopyFrom(tmpFile,0);

finally

tmpFile.Free;

end;

finally

infile.Free;

end;

finally

outfile.Free;

end;

DeleteFile('tmp');

end;

procedure DecompressFiles(const Filename, DestDirectory : String);

var

dest,s : String;

decompr : TDecompressionStream;

infile, outfile : TFilestream;

i,l,c : Integer;

begin

// IncludeTrailingPathDelimiter (D6/D7 only)

dest := IncludeTrailingPathDelimiter(DestDirectory);

infile := TFileStream.Create(Filename,fmOpenRead);

try

{ number of files }

infile.Read(c,SizeOf(c));

for i := 1 to c do

begin

{ read filename }

infile.Read(l,SizeOf(l));

SetLength(s,l);

infile.Read(s[1],l);

{ read filesize }

infile.Read(l,SizeOf(l));

{ decompress the files and store it }

s := dest+s; //include the path

outfile := TFileStream.Create(s,fmCreate);

decompr := TDecompressionStream.Create(infile);

try

outfile.CopyFrom(decompr,l);

finally

outfile.Free;

decompr.Free;

end;

finally

infile.Free;

end;

Delphi - .....................................

neoturk: ...Concatenate and compress files into one destination file ?...

uses

Zlib;

procedure CompressFiles(Files : TStrings; const Filename : String);

var

infile, outfile, tmpFile : TFileStream;

compr : TCompressionStream;

i,l : Integer;

s : String;

begin

if Files.Count > 0 then

begin

outFile := TFileStream.Create(Filename,fmCreate);

try

{ the number of files }

l := Files.Count;

outfile.Write(l,SizeOf(l));

for i := 0 to Files.Count-1 do

begin

infile := TFileStream.Create(Files[i],fmOpenRead);

try

{ the original filename }

s := ExtractFilename(Files[i]);

l := Length(s);

outfile.Write(l,SizeOf(l));

outfile.Write(s[1],l);

{ the original filesize }

l := infile.Size;

outfile.Write(l,SizeOf(l));

{ compress and store the file temporary}

tmpFile := TFileStream.Create('tmp',fmCreate);

compr := TCompressionStream.Create(clMax,tmpfile);

try

compr.CopyFrom(infile,l);

finally

compr.Free;

tmpFile.Free;

end;

{ append the compressed file to the destination file }

tmpFile := TFileStream.Create('tmp',fmOpenRead);

try

outfile.CopyFrom(tmpFile,0);

finally

tmpFile.Free;

end;

finally

infile.Free;

end;

finally

outfile.Free;

end;

DeleteFile('tmp');

end;

procedure DecompressFiles(const Filename, DestDirectory : String);

var

dest,s : String;

decompr : TDecompressionStream;

infile, outfile : TFilestream;

i,l,c : Integer;

begin

// IncludeTrailingPathDelimiter (D6/D7 only)

dest := IncludeTrailingPathDelimiter(DestDirectory);

infile := TFileStream.Create(Filename,fmOpenRead);

try

{ number of files }

infile.Read(c,SizeOf(c));

for i := 1 to c do

begin

{ read filename }

infile.Read(l,SizeOf(l));

SetLength(s,l);

infile.Read(s[1],l);

{ read filesize }

infile.Read(l,SizeOf(l));

{ decompress the files and store it }

s := dest+s; //include the path

outfile := TFileStream.Create(s,fmCreate);

decompr := TDecompressionStream.Create(infile);

try

outfile.CopyFrom(decompr,l);

finally

outfile.Free;

decompr.Free;

end;

finally

infile.Free;

end;

Delphi - .....................................

neoturk: ...Change-read the document properties for a specified word document ?...

{ 1. Change MS Word properties via OLE }

uses

ComObj;

procedure TForm1.Button1Click(Sender: TObject);

const

wdPropertyTitle = $00000001;

wdPropertySubject = $00000002;

wdPropertyAuthor = $00000003;

wdPropertyKeywords = $00000004;

wdPropertyComments = $00000005;

wdPropertyTemplate = $00000006;

wdPropertyLastAuthor = $00000007;

wdPropertyRevision = $00000008;

wdPropertyAppName = $00000009;

wdPropertyTimeLastPrinted = $0000000A;

wdPropertyTimeCreated = $0000000B;

wdPropertyTimeLastSaved = $0000000C;

wdPropertyVBATotalEdit = $0000000D;

wdPropertyPages = $0000000E;

wdPropertyWords = $0000000F;

wdPropertyCharacters = $00000010;

wdPropertySecurity = $00000011;

wdPropertyCategory = $00000012;

wdPropertyFormat = $00000013;

wdPropertyManager = $00000014;

wdPropertyCompany = $00000015;

wdPropertyBytes = $00000016;

wdPropertyLines = $00000017;

wdPropertyParas = $00000018;

wdPropertySlides = $00000019;

wdPropertyNotes = $0000001A;

wdPropertyHiddenSlides = $0000001B;

wdPropertyMMClips = $0000001C;

wdPropertyHyperlinkBase = $0000001D;

wdPropertyCharsWSpaces = $0000001E;

const

AWordDoc = 'C:Test.doc';

wdSaveChanges = $FFFFFFFF;

var

WordApp: OLEVariant;

SaveChanges: OleVariant;

begin

try

WordApp := CreateOleObject('Word.Application');

except

// Error....

Exit;

end;

try

WordApp.Visible := False;

WordApp.Documents.Open(AWordDoc);

WordApp.ActiveDocument.BuiltInDocumentProperties[wdPropertyTitle].Value := 'Your Title...';

WordApp.ActiveDocument.BuiltInDocumentProperties[wdPropertySubject].Value := 'Your Subject...';

// ...

finally

SaveChanges := wdSaveChanges;

WordApp.Quit(SaveChanges, EmptyParam, EmptyParam);

end;

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

{

2. Read MS Word properties via Structured Storage.

by Serhiy Perevoznyk

}

uses

ComObj, ActiveX;

const

FmtID_SummaryInformation: TGUID =

'{F29F85E0-4FF9-1068-AB91-08002B27B3D9}';

function FileTimeToDateTimeStr(F: TFileTime): string;

var

LocalFileTime: TFileTime;

SystemTime: TSystemTime;

DateTime: TDateTime;

begin

if Comp(F) = 0 then Result := '-'

else

begin

FileTimeToLocalFileTime(F, LocalFileTime);

FileTimeToSystemTime(LocalFileTime, SystemTime);

with SystemTime do

DateTime := EncodeDate(wYear, wMonth, wDay) +

EncodeTime(wHour, wMinute, wSecond, wMilliseconds);

Result := DateTimeToStr(DateTime);

end;

function GetDocInfo(const FileName: WideString): string;

var

I: Integer;

PropSetStg: IPropertySetStorage;

PropSpec: array[2..19] of TPropSpec;

PropStg: IPropertyStorage;

PropVariant: array[2..19] of TPropVariant;

Rslt: HResult;

S: string;

Stg: IStorage;

begin

Result := '';

try

OleCheck(StgOpenStorage(PWideChar(FileName), nil, STGM_READ or

STGM_SHARE_DENY_WRITE,

nil, 0, Stg));

PropSetStg := Stg as IPropertySetStorage;

OleCheck(PropSetStg.Open(FmtID_SummaryInformation,

STGM_READ or STGM_SHARE_EXCLUSIVE, PropStg));

for I := 2 to 19 do

begin

PropSpec[I].ulKind := PRSPEC_PROPID;

PropSpec[I].PropID := I;

end;

Rslt := PropStg.ReadMultiple(18, @PropSpec, @PropVariant);

OleCheck(Rslt);

if Rslt <> S_FALSE then for I := 2 to 19 do

begin

S := '';

if PropVariant[I].vt = VT_LPSTR then

if Assigned(PropVariant[I].pszVal) then

S := PropVariant[I].pszVal;

case I of

2: S := Format('Title: %s', [S]);

3: S := Format('Subject: %s', [S]);

4: S := Format('Author: %s', [S]);

5: S := Format('Keywords: %s', [S]);

6: S := Format('Comments: %s', [S]);

7: S := Format('Template: %s', [S]);

8: S := Format('Last saved by: %s', [S]);

9: S := Format('Revision number: %s', [S]);

10: S := Format('Total editing time: %g sec',

[Comp(PropVariant[I].filetime) / 1.0E9]);

11: S := Format('Last printed: %s',

[FileTimeToDateTimeStr(PropVariant[I].filetime)]);

12: S := Format('Create time/date: %s',

[FileTimeToDateTimeStr(PropVariant[I].filetime)]);

13: S := Format('Last saved time/date: %s',

[FileTimeToDateTimeStr(PropVariant[I].filetime)]);

14: S := Format('Number of pages: %d', [PropVariant[I].lVal]);

15: S := Format('Number of words: %d', [PropVariant[I].lVal]);

16: S := Format('Number of characters: %d',

[PropVariant[I].lVal]);

17:; // thumbnail

18: S := Format('Name of creating application: %s', [S]);

19: S := Format('Security: %.8x', [PropVariant[I].lVal]);

end;

if S <> '' then Result := Result + S + #13;

end;

finally

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

if Opendialog1.Execute then

ShowMessage(GetDocInfo(opendialog1.FileName));

end;

Delphi - .....................................

neoturk: ...Change-read the document properties for a specified word document ?...

{ 1. Change MS Word properties via OLE }

uses

ComObj;

procedure TForm1.Button1Click(Sender: TObject);

const

wdPropertyTitle = $00000001;

wdPropertySubject = $00000002;

wdPropertyAuthor = $00000003;

wdPropertyKeywords = $00000004;

wdPropertyComments = $00000005;

wdPropertyTemplate = $00000006;

wdPropertyLastAuthor = $00000007;

wdPropertyRevision = $00000008;

wdPropertyAppName = $00000009;

wdPropertyTimeLastPrinted = $0000000A;

wdPropertyTimeCreated = $0000000B;

wdPropertyTimeLastSaved = $0000000C;

wdPropertyVBATotalEdit = $0000000D;

wdPropertyPages = $0000000E;

wdPropertyWords = $0000000F;

wdPropertyCharacters = $00000010;

wdPropertySecurity = $00000011;

wdPropertyCategory = $00000012;

wdPropertyFormat = $00000013;

wdPropertyManager = $00000014;

wdPropertyCompany = $00000015;

wdPropertyBytes = $00000016;

wdPropertyLines = $00000017;

wdPropertyParas = $00000018;

wdPropertySlides = $00000019;

wdPropertyNotes = $0000001A;

wdPropertyHiddenSlides = $0000001B;

wdPropertyMMClips = $0000001C;

wdPropertyHyperlinkBase = $0000001D;

wdPropertyCharsWSpaces = $0000001E;

const

AWordDoc = 'C:Test.doc';

wdSaveChanges = $FFFFFFFF;

var

WordApp: OLEVariant;

SaveChanges: OleVariant;

begin

try

WordApp := CreateOleObject('Word.Application');

except

// Error....

Exit;

end;

try

WordApp.Visible := False;

WordApp.Documents.Open(AWordDoc);

WordApp.ActiveDocument.BuiltInDocumentProperties[wdPropertyTitle].Value := 'Your Title...';

WordApp.ActiveDocument.BuiltInDocumentProperties[wdPropertySubject].Value := 'Your Subject...';

// ...

finally

SaveChanges := wdSaveChanges;

WordApp.Quit(SaveChanges, EmptyParam, EmptyParam);

end;

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

{

2. Read MS Word properties via Structured Storage.

by Serhiy Perevoznyk

}

uses

ComObj, ActiveX;

const

FmtID_SummaryInformation: TGUID =

'{F29F85E0-4FF9-1068-AB91-08002B27B3D9}';

function FileTimeToDateTimeStr(F: TFileTime): string;

var

LocalFileTime: TFileTime;

SystemTime: TSystemTime;

DateTime: TDateTime;

begin

if Comp(F) = 0 then Result := '-'

else

begin

FileTimeToLocalFileTime(F, LocalFileTime);

FileTimeToSystemTime(LocalFileTime, SystemTime);

with SystemTime do

DateTime := EncodeDate(wYear, wMonth, wDay) +

EncodeTime(wHour, wMinute, wSecond, wMilliseconds);

Result := DateTimeToStr(DateTime);

end;

function GetDocInfo(const FileName: WideString): string;

var

I: Integer;

PropSetStg: IPropertySetStorage;

PropSpec: array[2..19] of TPropSpec;

PropStg: IPropertyStorage;

PropVariant: array[2..19] of TPropVariant;

Rslt: HResult;

S: string;

Stg: IStorage;

begin

Result := '';

try

OleCheck(StgOpenStorage(PWideChar(FileName), nil, STGM_READ or

STGM_SHARE_DENY_WRITE,

nil, 0, Stg));

PropSetStg := Stg as IPropertySetStorage;

OleCheck(PropSetStg.Open(FmtID_SummaryInformation,

STGM_READ or STGM_SHARE_EXCLUSIVE, PropStg));

for I := 2 to 19 do

begin

PropSpec[I].ulKind := PRSPEC_PROPID;

PropSpec[I].PropID := I;

end;

Rslt := PropStg.ReadMultiple(18, @PropSpec, @PropVariant);

OleCheck(Rslt);

if Rslt <> S_FALSE then for I := 2 to 19 do

begin

S := '';

if PropVariant[I].vt = VT_LPSTR then

if Assigned(PropVariant[I].pszVal) then

S := PropVariant[I].pszVal;

case I of

2: S := Format('Title: %s', [S]);

3: S := Format('Subject: %s', [S]);

4: S := Format('Author: %s', [S]);

5: S := Format('Keywords: %s', [S]);

6: S := Format('Comments: %s', [S]);

7: S := Format('Template: %s', [S]);

8: S := Format('Last saved by: %s', [S]);

9: S := Format('Revision number: %s', [S]);

10: S := Format('Total editing time: %g sec',

[Comp(PropVariant[I].filetime) / 1.0E9]);

11: S := Format('Last printed: %s',

[FileTimeToDateTimeStr(PropVariant[I].filetime)]);

12: S := Format('Create time/date: %s',

[FileTimeToDateTimeStr(PropVariant[I].filetime)]);

13: S := Format('Last saved time/date: %s',

[FileTimeToDateTimeStr(PropVariant[I].filetime)]);

14: S := Format('Number of pages: %d', [PropVariant[I].lVal]);

15: S := Format('Number of words: %d', [PropVariant[I].lVal]);

16: S := Format('Number of characters: %d',

[PropVariant[I].lVal]);

17:; // thumbnail

18: S := Format('Name of creating application: %s', [S]);

19: S := Format('Security: %.8x', [PropVariant[I].lVal]);

end;

if S <> '' then Result := Result + S + #13;

end;

finally

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

if Opendialog1.Execute then

ShowMessage(GetDocInfo(opendialog1.FileName));

end;

Delphi - .....................................

neoturk: ...Install an inf file with delphi ?...

uses

ShellAPI;

function InstallINF(const PathName: string; hParent: HWND): Boolean;

var

instance: HINST;

begin

instance := ShellExecute(hParent,

PChar('open'),

PChar('rundll32.exe'),

PChar('setupapi,InstallHinfSection DefaultInstall 132 ' + PathName),

nil,

SW_HIDE);

Result := instance > 32;

end; { InstallINF }

// Example:

procedure TForm1.Button1Click(Sender: TObject);

begin

InstallINF('C:XYZ.inf', 0);

end;

Delphi - .....................................

neoturk: ...Install an inf file with delphi ?...

uses

ShellAPI;

function InstallINF(const PathName: string; hParent: HWND): Boolean;

var

instance: HINST;

begin

instance := ShellExecute(hParent,

PChar('open'),

PChar('rundll32.exe'),

PChar('setupapi,InstallHinfSection DefaultInstall 132 ' + PathName),

nil,

SW_HIDE);

Result := instance > 32;

end; { InstallINF }

// Example:

procedure TForm1.Button1Click(Sender: TObject);

begin

InstallINF('C:XYZ.inf', 0);

end;

Delphi - .....................................

neoturk: ...Show the select directory dialog and sepeify the initial directory ?...

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;

Result := 0;

end;

begin

Result := False;

FillChar(BrowseInfo, SizeOf(BrowseInfo), 0);

if (ShGetMalloc(ShellMalloc) = S_OK) and (ShellMalloc <> nil) then

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;

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;

Delphi - .....................................

neoturk: ...Show the select directory dialog and sepeify the initial directory ?...

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;

Result := 0;

end;

begin

Result := False;

FillChar(BrowseInfo, SizeOf(BrowseInfo), 0);

if (ShGetMalloc(ShellMalloc) = S_OK) and (ShellMalloc <> nil) then

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;

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;