فایل ضمیمه همان پست اصلاح شد ...نوشته شده توسط ali_abbasi22145
فایل ضمیمه همان پست اصلاح شد ...
دوست عزیز
میشه منظورتون رو از بحث کردن توضیح بدید؟
معمولا وقتی که روی یک کدی کسی به مشکل بر می خوره سوال می پرسه و جوابش رو هم میگیره ...
procedure TForm1.Button1Click(Sender: TObject) ;
function FuncAvail(_dllname, _funcname: string;
var _p: pointer): boolean;
{return True if _funcname exists in _dllname}
var _lib: tHandle;
begin
Result := false;
if LoadLibrary(PChar(_dllname)) = 0 then exit;
_lib := GetModuleHandle(PChar(_dllname)) ;
if _lib <> 0 then begin
_p := GetProcAddress(_lib, PChar(_funcname)) ;
if _p <> NIL then Result := true;
end;
end;
{
Call SHELL32.DLL for Win < Win98
otherwise call URL.dll
}
{button code:}
var
InetIsOffline : function(dwFlags: DWORD):
BOOL; stdcall;
begin
if FuncAvail('URL.DLL', 'InetIsOffline',
@InetIsOffline) then
if InetIsOffLine(0) = true
then ShowMessage('Not connected')
else ShowMessage('Connected!') ;
end;
uses ExtActns, ...
type
TfrMain = class(TForm)
...
private
procedure URL_OnDownloadProgress
(Sender: TDownLoadURL;
Progress, ProgressMax: Cardinal;
StatusCode: TURLDownloadStatus;
StatusText: String; var Cancel: Boolean) ;
...
implementation
...
procedure TfrMain.URL_OnDownloadProgress;
begin
ProgressBar1.Max:= ProgressMax;
ProgressBar1.Position:= Progress;
end;
function DoDownload;
begin
with TDownloadURL.Create(self) do
try
URL:='http://z.about.com/6/g/delphi/b/index.xml';
FileName := 'c:\ADPHealines.xml';
OnDownloadProgress := URL_OnDownloadProgress;
ExecuteTarget(nil) ;
finally
Free;
end;
end;
function GetIEFavourites
(const favpath: string):TStrings;
var
searchrec:TSearchrec;
str:TStrings;
path,dir,filename:String;
Buffer: array[0..2047] of Char;
found:Integer;
begin
str:=TStringList.Create;
try
path:=FavPath+'\*.url';
dir:=ExtractFilepath(path) ;
found:=FindFirst(path,faAnyFile,searchrec) ;
while found=0 do begin
SetString(filename, Buffer,
GetPrivateProfileString('InternetShortcut',
PChar('URL'), NIL, Buffer, SizeOf(Buffer),
PChar(dir+searchrec.Name))) ;
str.Add(filename) ;
found:=FindNext(searchrec) ;
end;
found:=FindFirst(dir+'\*.*',faAnyFile,searchrec) ;
while found=0 do begin
if ((searchrec.Attr and faDirectory) > 0)
and (searchrec.Name[1]<>'.') then
str.AddStrings(GetIEFavourites
(dir+'\'+searchrec.name)) ;
found:=FindNext(searchrec) ;
end;
FindClose(searchrec) ;
finally
Result:=str;
end;
end;
procedure TForm1.Button1Click(Sender: TObject) ;
var pidl: PItemIDList;
FavPath: array[0..MAX_PATH] of char;
begin
SHGetSpecialFolderLocation(Handle, CSIDL_FAVORITES, pidl) ;
SHGetPathFromIDList(pidl, favpath) ;
ListBox1.Items:=GetIEFavourites(StrPas(FavPath)) ;
end;
uses Registry;
...
function SetIEHomePage(PageName: string): Boolean;
begin
with TRegistry.Create do
try
RootKey := HKEY_CURRENT_USER;
OpenKey('Software\Microsoft\Internet Explorer\Main', False) ;
try
WriteString('Start Page', PageName) ;
Result := True;
except
Result := False;
end;
CloseKey;
finally
Free;
end;
end;
//Usage:
SetIEHomePage('http://delphi.about.com')
function GetNetworkDriveMappings (SList: TStrings): integer;
var
c: Char;
ThePath: string;
MaxNetPathLen: DWord;
begin
SList.Clear;
MaxNetPathLen := MAX_PATH;
SetLength(ThePath, MAX_PATH) ;
for c := 'A' to 'Z' do
if WNetGetConnection(PChar('' + c + ':'), PChar(ThePath),MaxNetPathLen) = NO_ERROR then sList.Add(c + ': ' + ThePath) ;
Result := SList.Count;
end;
با تشکر از دوستانی که در این تاپیک فعالیت میکنند،
پیشنهاد میکنم که در پست اول عنوان نکته و آدرس ذکر شود :
1- کاربرانی که مراجعه میکنند به سرعت بتوانند به نکات دسترسی پیدا کنند.
2- پستهای تکراری اضافه نشوند.
این کار را حقیر برای چند مورد ، در پست اول با اجازه آقا محمد انجام می‌دهم.
... چه بگویم که غم از دل برود چون تو بیایی
uses Registry;
function SetScreenSaver(FullSCRName : string):boolean;
var Reg: TRegistry;
begin
Reg := TRegistry.Create;
Result:=True;
with Reg do begin
try
RootKey := HKEY_CURRENT_USER;
if OpenKey('\Control Panel\Desktop', TRUE) then
begin
WriteString('SCRNSAVE.EXE',
ExtractShortPathName (FullSCRName)) ;
BroadCastSystemMessage
(0, @r, WM_SETTINGCHANGE, 0, 0) ;
SystemParametersInfo
(SPI_SETSCREENSAVEACTIVE,10,@b,0) ;
end
else Result:=False;
Finally
Free;
end; //try
end;//with
end;
{
Usage:
SetScreenSaver('C:\MyData\SFXScreenSave.SCR') ;
}
در این کد، از تابع GetTickCount که از توابع API می باشد، استفاده شده است. این تابع میلی ثانیه های سپری شده از زمان اجرای ویندوز را بر می گرداند. این کد این زمان را به فرمت مناسب تری تبدیل می کند. هدف از گذاشتن این کدها بیشتر آشنایی با چگونگی کار با توابع مختلف دلفی و API می باشد.
function WindowsUpTime : string ;
function MSecToTime(mSec: Integer): string;
const
secondTicks = 1000;
minuteTicks = 1000 * 60;
hourTicks = 1000 * 60 * 60;
dayTicks = 1000 * 60 * 60 * 24;
var
D, H, M, S: string;
ZD, ZH, ZM, ZS: Integer;
begin
ZD := mSec div dayTicks;
Dec(mSec, ZD * dayTicks) ;
ZH := mSec div hourTicks;
Dec(mSec, ZH * hourTicks) ;
ZM := mSec div hourTicks;
Dec(mSec, ZM * minuteTicks) ;
ZS := mSec div secondTicks;
D := IntToStr(ZD) ;
H := IntToStr(ZH) ;
M := IntToStr(ZM) ;
S := IntToStr(ZS) ;
Result := D + '.' + H + ':' + M + ':' + S;
end;
begin
result := MSecToTime(GetTickCount) ;
end;
unit WindowsUser;
interface
uses Windows;
//returns True if the currently logged Windows user has Administrator rights
function IsWindowsAdmin: Boolean;
implementation
const
SECURITY_NT_AUTHORITY: TSIDIdentifierAuthority = (Value: (0, 0, 0, 0, 0, 5)) ;
const
SECURITY_BUILTIN_DOMAIN_RID = $00000020;
DOMAIN_ALIAS_RID_ADMINS = $00000220;
function IsWindowsAdmin: Boolean;
var
hAccessToken: THandle;
ptgGroups: PTokenGroups;
dwInfoBufferSize: DWORD;
psidAdministrators: PSID;
g: Integer;
bSuccess: BOOL;
begin
Result := False;
bSuccess := OpenThreadToken(GetCurrentThread, TOKEN_QUERY, True, hAccessToken) ;
if not bSuccess then
begin
if GetLastError = ERROR_NO_TOKEN then
bSuccess := OpenProcessToken(GetCurrentProcess, TOKEN_QUERY, hAccessToken) ;
end;
if bSuccess then
begin
GetMem(ptgGroups, 1024) ;
bSuccess := GetTokenInformation(hAccessToken, TokenGroups, ptgGroups, 1024, dwInfoBufferSize) ;
CloseHandle(hAccessToken) ;
if bSuccess then
begin
AllocateAndInitializeSid(SECURITY_NT_AUTHORITY, 2, SECURITY_BUILTIN_DOMAIN_RID, DOMAIN_ALIAS_RID_ADMINS, 0, 0, 0, 0, 0, 0, psidAdministrators) ;
for g := 0 to ptgGroups.GroupCount - 1 do
if EqualSid(psidAdministrators, ptgGroups.Groups[g].Sid) then
begin
Result := True;
Break;
end;
FreeSid(psidAdministrators) ;
end;
FreeMem(ptgGroups) ;
end;
end;
end.
uses Math;
function RGBtoCMYK(const rgbColor : TRGBColor) : TCMYKColor;
begin
with Result do
begin
Cyan := 1 - rgbColor.Red;
Magenta := 1 - rgbColor.Green;
Yellow := 1 - rgbColor.Blue;
KeyPlate := Min(Min(Cyan, Magenta), Yellow) ;
Cyan := Cyan - KeyPlate;
Magenta := Magenta - KeyPlate;
Yellow := Yellow - KeyPlate;
end;
end;
استفاده به صورت:
var
rgbColor : TRGBColor;
cmykColor : TCMYKColor;
begin
rgbColor.Red := 128;
rgbColor.Green := 64;
rgbColor.Blue := 192;
cmykColor := RGBtoCMYK(rgbColor) ;
Caption := Format('%d-%d-%d-%d',[cmykColor.Cyan, cmykColor.Magenta, cmykColor.Yellow, cmykColor.KeyPlate])
end;
uses shlobj, ...
function GetMyDocuments: string;
var
r: Bool;
path: array[0..Max_Path] of Char;
begin
r := ShGetSpecialFolderPath(0, path, CSIDL_Personal, False) ;
if not r then raise Exception.Create('Could not find MyDocuments folder location.') ;
Result := Path;
end;
procedure TMyForm.FormCreate(Sender: TObject) ;
var
myDocFolder : string;
begin
myDocFolder := GetMyDocuments;
ShowMessage(Format('MyDocuments folder for the current user: "%s"',[myDocFolder])) ;
end;
how Can I Read a unicode text file in Delphi?
procedure TForm1.Button1Click(Sender: TObject);
var
F: TStream;
UnicodeString: WideString;
UnicodeSign: Word;
FileName: string;
FileSize: Cardinal;
begin
FileName := 'SchedLgU.Txt';
F := TFileStream.Create(FileName, fmOpenRead);
try
FileSize := F.Size;
if FileSize >= SizeOf(UnicodeSign) then
begin
F.ReadBuffer(UnicodeSign, SizeOf(UnicodeSign));
if UnicodeSign = $FEFF then
begin
Dec(FileSize, SizeOf(UnicodeSign));
SetLength(UnicodeString, FileSize div SizeOf(WideChar));
F.ReadBuffer(UnicodeString[1], FileSize);
// now UnicodeString contains Unicode string read from stream
Memo1.Lines.Text := UnicodeString;
end
else
// not a Unicode format;
Memo1.Lines.LoadFromFile(FileName);
end;
finally
F.Free;
end;
end;
تغییر اندازه کلید Start..
procedure TForm1.Button1Click(Sender: TObject);
begin
MoveWindow(FindWindowEx(FindWindow('Shell_TrayWnd' , nil), 0, 'Button', nil),
300, 0, 80, 22, true);
end;
چک کردن اینکه آیا فایل در Local Drive می باشد.
function IsOnLocalDrive(aFileName: string): Boolean;
var
aDrive: string;
begin
aDrive := ExtractFileDrive(aFileName);
if (GetDriveType(PChar(aDrive)) = DRIVE_REMOVABLE) or
(GetDriveType(PChar(aDrive)) = DRIVE_FIXED) then
Result := True
else
Result := False;
end;
// Example:
procedure TForm1.Button1Click(Sender: TObject);
begin
if OpenDialog1.Execute then
if IsOnLocalDrive(OpenDialog1.FileName) then
ShowMessage(OpenDialog1.FileName + ' is on a local drive.');
end;
چک کردن اینکه پارتیشن Fat میباشد یا NTFS
function GetHardDiskPartitionType(const DriveLetter: Char): string;
var
NotUsed: DWORD;
VolumeFlags: DWORD;
VolumeInfo: array[0..MAX_PATH] of Char;
VolumeSerialNumber: DWORD;
PartitionType: array[0..32] of Char;
begin
GetVolumeInformation(PChar(DriveLetter + ':\'),
nil, SizeOf(VolumeInfo), @VolumeSerialNumber, NotUsed,
VolumeFlags, PartitionType, 32);
Result := PartitionType;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
ShowMessage(GetHardDiskPartitionType('c'));
ShowMessage(GetHardDiskPartitionType('a'));
end;
چک کردن اینکه آیا سرویسی مورد نظر start می باشد
uses
WinSvc;
function ServiceGetStatus(sMachine, sService: PChar): DWORD;
{******************************************}
{*** Parameters: ***}
{*** sService: specifies the name of the service to open
{*** sMachine: specifies the name of the target computer
{*** ***}
{*** Return Values: ***}
{*** -1 = Error opening service ***}
{*** 1 = SERVICE_STOPPED ***}
{*** 2 = SERVICE_START_PENDING ***}
{*** 3 = SERVICE_STOP_PENDING ***}
{*** 4 = SERVICE_RUNNING ***}
{*** 5 = SERVICE_CONTINUE_PENDING ***}
{*** 6 = SERVICE_PAUSE_PENDING ***}
{*** 7 = SERVICE_PAUSED ***}
{******************************************}
var
SCManHandle, SvcHandle: SC_Handle;
SS: TServiceStatus;
dwStat: DWORD;
begin
dwStat := 0;
// Open service manager handle.
SCManHandle := OpenSCManager(sMachine, nil, SC_MANAGER_CONNECT);
if (SCManHandle > 0) then
begin
SvcHandle := OpenService(SCManHandle, sService, SERVICE_QUERY_STATUS);
// if Service installed
if (SvcHandle > 0) then
begin
// SS structure holds the service status (TServiceStatus);
if (QueryServiceStatus(SvcHandle, SS)) then
dwStat := ss.dwCurrentState;
CloseServiceHandle(SvcHandle);
end;
CloseServiceHandle(SCManHandle);
end;
Result := dwStat;
end;
function ServiceRunning(sMachine, sService: PChar): Boolean;
begin
Result := SERVICE_RUNNING = ServiceGetStatus(sMachine, sService);
end;
// Check if Eventlog Service is running
procedure TForm1.Button1Click(Sender: TObject);
begin
if ServiceRunning(nil, 'Eventlog') then
ShowMessage('Eventlog Service Running')
else
ShowMessage('Eventlog Service not Running')
end;
چک کردن اینکه آیا Sound card نصب شده است
uses
MMSystem;
function SoundCardAvailable: Boolean;
begin
Result := WaveOutGetNumDevs > 0;
end;
چک کردن اینکه آیا دلفی در حال اجراست
function WindowExists(AppWindowName, AppClassName: string): Boolean;
var
hwd: LongWord;
begin
hwd := 0;
hwd := FindWindow(PChar(AppWindowName), PChar(AppClassName));
Result := False;
if not (Hwd = 0) then {window was found if not nil}
Result := True;
end;
function DelphiLoaded: Boolean;
begin
DelphiLoaded := False;
if WindowExists('TPropertyInspector', 'Object Inspector') then
if WindowExists('TMenuBuilder', 'Menu Designer') then
if WindowExists('TAppBuilder', '(AnyName)') then
if WindowExists('TApplication', 'Delphi') then
if WindowExists('TAlignPalette', 'Align') then
DelphiLoaded := True;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if DelphiLoaded then
begin
ShowMessage('Delphi is running');
end;
end;
function DelphiIsRunning: Boolean;
begin
Result := DebugHook <> 0;
end;
پیدا کردن و بارگذاری Icon داخل فایل
uses
shellApi;
{...}
procedure TForm1.Button1Click(Sender: TObject);
const
ExtrFileName = 'C:\WINNT\system32\moricons.dll';
var
icon: TIcon;
NumberOfIcons, i: Integer;
begin
icon := TIcon.Create;
try
// Get the number of Icons
NumberOfIcons := ExtractIcon(Handle, PChar(ExtrFileName), UINT(-1));
ShowMessage(Format('%d Icons', [NumberOfIcons]));
// Extract the first 5 icons
for i := 1 to 5 do
begin
// Extract an icon
icon.Handle := ExtractIcon(Handle, PChar(ExtrFileName), i);
// Draw the icon on your form
DrawIcon(Form1.Canvas.Handle, 10, i * 40, icon.Handle);
end;
finally
icon.Free;
end;
end;
با این تابع می توانید ولوم سریالِ دیسک را بدست آوردید
Function GetDiscVolSerialID(cDriveName : char) :DWORD;
var
dwtemp1,dwtemp2 : DWORD;
begin
GetVolumeInformation(PChar(cDriveName + ':\'),Nil,0,@Result , dwtemp1 ,dwtemp2,Nil, 0);
end;
چگونه Edit فقط عدد بگیرد
تابعی که میشه اون رو در رویدادهای کیبورد برای Edit قرار داد تا فقط عدد بگیره
Function IsNum(ch : char) : char;
begin
if Pos(ch,#8#13'1234567890') = 0 then
ch := #0;
Result := ch;
end;
چگونه برنامه مان فقط یک نسخه اجرا شود
برای اینکه بعد از اجرای برنامه اگر کاربر روی آیکن برنامه کلیک کرد ، همزمان چند نسخه از اون اجرا نشه می تونیم فایل DPR پروژه رو بصورت زیر تغییر بدیم
uses
windows;
var
hmutex : THandle;
begin
hmutex := CreateMutex(nil,false,'OneCopyMutex');
if waitforsingleobject(hmutex, 0) <> wait_timeout then
begin
Application.Initialize;
.
.
.
Application.Run;
end;
end.
تغییر رزولوشن مانیتور
این رو از وبلاگی برداشتم ولی چون قدیمی هست منبعش رو متاسفانه یادم نیست
function SetDisplay1024x768: Boolean;
var
DevMode: TDeviceMode;
begin
EnumDisplaySettings(nil, 0, DevMode);
DevMode.dmFields := DM_PELSWIDTH or DM_PELSHEIGHT;
DevMode.dmPelsWidth := 1024;
DevMode.dmPelsHeight := 768;
Result := ChangeDisplaySettings(DevMode, CDS_UPDATEREGISTRY)
= DISP_CHANGE_SUCCESSFUL;
end;
در اکثر فرمهایی که برای دریافت اطلاعات از کاربر هستند ، معمولا دکمه ای داریم که برای پاک کردن فرم یا در حقیقت پاک کردن محتوای Edit ها بکار میره
میتونید کد زیر رو برای این دکمه قرار بدین تا لازم نباشه که برای هر فرم تک تک edit ها رو بنویسید
این کد به این صورت کار میکنه که روی فرم تمام Edit ها رو پیدا میکنه و اونها رو Clear می کنه
procedure clear_Edits;
var
cnt : integer;
begin
for cnt := 0 to ComponentCount - 1 do
begin
if Components[cnt].ClassName = 'TEdit' then
TEdit(Components[cnt]).Clear
end;
end;
حالا اگه توابعتون رو در یک کتابخونه نگهداری می کنید و اون Unit رو در فرمتون Use می کنید ، می تونید این تابع رو به شکل زیر تغییر بدین تا با فراخوانی از یک Unit دیگه هم بدرستی کار کنه
procedure clear_Edits;
var
cnt : integer;
begin
for cnt := 0 to Screen.ActiveForm.ComponentCount - 1 do
begin
if (Screen.ActiveForm.Components[cnt].ClassName = 'TEdit') then
TEdit(Screen.ActiveForm.Components[cnt]).Clear
end;
end
چک کردن خالی بودن یک مسیر
function DirectoryIsEmpty(Directory: string): Boolean;
var
SR: TSearchRec;
i: Integer;
begin
Result := False;
FindFirst(IncludeTrailingPathDelimiter(Directory) + '*', faAnyFile, SR);
for i := 1 to 2 do
if (SR.Name = '.') or (SR.Name = '..') then
Result := FindNext(SR) <> 0;
FindClose(SR);
end;
فایل مورد نظر باینری است یا نوشتاری ؟؟
function IsTextFile(const sFile: TFileName): boolean;
var
oIn: TFileStream;
iRead: Integer;
iMaxRead: Integer;
iData: Byte;
dummy:string;
begin
result:=true;
dummy :='';
oIn := TFileStream.Create(sFile, fmOpenRead or fmShareDenyNone);
try
iMaxRead := 1000; //only text the first 1000 bytes
if iMaxRead > oIn.Size then
iMaxRead := oIn.Size;
for iRead := 1 to iMaxRead do
begin
oIn.Read(iData, 1);
if (idata) > 127 then result:=false;
end;
finally
FreeAndNil(oIn);
end;
end;
چگونه فایلهای INI را نصب کنیم ؟
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;
چگونه تعداد ایتمها ی ListBox را با API بدست اوریم ؟
function LB_GetItemCount(hListBox: THandle): Integer;
begin
Result := SendMessage(hListBox, LB_GETCOUNT, 0, 0);
end;
چگونه یک ایتم ListBox را با API حذف کنیم ؟
procedure LB_DeleteItem(hListBox: THandle; Index: Integer);
begin
SendMessage(hListBox, LB_DELETESTRING, Index, 0);
end;
چگونه ایتم انتخاب شده ی ListBox را توسط API بدست اوریم ؟
function LB_GetSelectedItem(hListBox: THandle): string;
var
Index, len: Integer;
s: string;
buffer: PChar;
begin
Index := SendMessage(hListBox, LB_GETCURSEL, 0, 0);
len := SendMessage(hListBox, LB_GETTEXTLEN, wParam(Index), 0);
GetMem(buffer, len + 1);
SendMessage(hListBox, LB_GETTEXT, wParam(Index), lParam(buffer));
SetString(s, buffer, len);
FreeMem(buffer);
Result := IntToStr(Index) + ' : ' + s;
end;
گرفتن ایتم یک ایتم ListBox توسط API
function LB_GetListBoxItem(hWnd: Hwnd; LbItem: Integer): string;
var
l: Integer;
buffer: PChar;
begin
l := SendMessage(hWnd, LB_GETTEXTLEN, LbItem, 0);
GetMem(buffer, l + 1);
SendMessage(hWnd, LB_GETTEXT, LbItem, Integer(buffer));
Result := StrPas(buffer);
FreeMem(buffer);
end;
بدست اوردن تمامی ایتم های یک ListBox توسط API
function LB_GetAllItems(hWnd: Hwnd; sl: TStrings): string;
var
RetBuffer: string;
i, x, y: Integer;
begin
x := SendMessage(hWnd, LB_GETCOUNT, 0, 0);
for i := 0 to x - 1 do
begin
y := SendMessage(hWnd, LB_GETTEXTLEN, i, 0);
SetLength(RetBuffer, y);
SendMessage(hWnd, LB_GETTEXT, i, lParam(PChar(RetBuffer)));
sl.Add(RetBuffer);
end;
end;
تغییر نام یک پوشه ....
uses
ShellApi;
procedure RenameDir(DirFrom, DirTo: string);
var
shellinfo: TSHFileOpStruct;
begin
with shellinfo do
begin
Wnd := 0;
wFunc := FO_RENAME;
pFrom := PChar(DirFrom);
pTo := PChar(DirTo);
fFlags := FOF_FILESONLY or FOF_ALLOWUNDO or
FOF_SILENT or FOF_NOCONFIRMATION;
end;
SHFileOperation(shellinfo);
end;
باز کردن یک پوشه توسط Windows Explorer
procedure ShowFolder(strFolder: string);
begin
ShellExecute(Application.Handle,
PChar('explore'),
PChar(strFolder),
nil,
nil,
SW_SHOWNORMAL);
end;
بدست اوردن مالک ( Owner ) یک فایل
function GetFileOwner(FileName: string;
var Domain, Username: string): Boolean;
var
SecDescr: PSecurityDescriptor;
SizeNeeded, SizeNeeded2: DWORD;
OwnerSID: PSID;
OwnerDefault: BOOL;
OwnerName, DomainName: PChar;
OwnerType: SID_NAME_USE;
begin
GetFileOwner := False;
GetMem(SecDescr, 1024);
GetMem(OwnerSID, SizeOf(PSID));
GetMem(OwnerName, 1024);
GetMem(DomainName, 1024);
try
if not GetFileSecurity(PChar(FileName),
OWNER_SECURITY_INFORMATION,
SecDescr, 1024, SizeNeeded) then
Exit;
if not GetSecurityDescriptorOwner(SecDescr,
OwnerSID, OwnerDefault) then
Exit;
SizeNeeded := 1024;
SizeNeeded2 := 1024;
if not LookupAccountSID(nil, OwnerSID, OwnerName,
SizeNeeded, DomainName, SizeNeeded2, OwnerType) then
Exit;
Domain := DomainName;
Username := OwnerName;
finally
FreeMem(SecDescr);
FreeMem(OwnerName);
FreeMem(DomainName);
end;
GetFileOwner := True;
end;
مقایسه ی اندازه ی دو فایل
function Are2FilesEqual(const File1, File2: TFileName): Boolean;
var
ms1, ms2: TMemoryStream;
begin
Result := False;
ms1 := TMemoryStream.Create;
try
ms1.LoadFromFile(File1);
ms2 := TMemoryStream.Create;
try
ms2.LoadFromFile(File2);
if ms1.Size = ms2.Size then
Result := CompareMem(ms1.Memory, ms2.memory, ms1.Size);
finally
ms2.Free;
end;
finally
ms1.Free;
end
end;
بدست اوردن تاریخ یک فایل
function GetFileModifyDate(FileName: string): TDateTime;
var
h: THandle;
Struct: TOFSTRUCT;
lastwrite: Integer;
t: TDateTime;
begin
h := OpenFile(PChar(FileName), Struct, OF_SHARE_DENY_NONE);
try
if h <> HFILE_ERROR then
begin
lastwrite := FileGetDate(h);
Result := FileDateToDateTime(lastwrite);
end;
finally
CloseHandle(h);
end;
end;
ایا فایل ما ASCII است ؟
function isAscii(NomeFile: string): Boolean;
const
SETT = 2048;
var
i: Integer;
F: file;
a: Boolean;
TotSize, IncSize, ReadSize: Integer;
c: array[0..Sett] of Byte;
begin
if FileExists(NomeFile) then
begin
{$I-}
AssignFile(F, NomeFile);
Reset(F, 1);
TotSize := FileSize(F);
IncSize := 0;
a := True;
while (IncSize < TotSize) and (a = True) do
begin
ReadSize := SETT;
if IncSize + ReadSize > TotSize then ReadSize := TotSize - IncSize;
IncSize := IncSize + ReadSize;
BlockRead(F, c, ReadSize);
// Iterate
for i := 0 to ReadSize - 1 do
if (c[i] < 32) and (not (c[i] in [9, 10, 13, 26])) then a := False;
end; { while }
CloseFile(F);
{$I+}
if IOResult <> 0 then Result := False
else
Result := a;
end;
end;
قوانین ایجاد تاپیک در تالار
پاسخ با نقل قول