Tag "Delphi" (12)
Delphi: Delay without blocking of the main thread
Function delays program logic execution for a number of miliseconds, The GUI and Windows messages will continue to work. ... Reveal Code
//------------------------------------------------------------------------------
// Provides a waiting (delay) for a given count of MSec (Sec*10^-3).
// The message processing will continue to work.
procedure Delay(MSec: Cardinal);
var
BeginTime: Cardinal;
begin
BeginTime := GetTickCount;
repeat
Application.ProcessMessages;
until Cardinal(Abs(GetTickCount - BeginTime)) >= MSec;
end;
Delphi: Version of EXE or DLL file
Function returns version of Exe/Dll file as "1.2.3.4" string ... Reveal Code
//------------------------------------------------------------------------------
// Returns version from file resource as string "1.2.3.4"
function GetFileVersion(const AFileName: string): string;
var
VerInfoSize: DWORD;
VerInfo: Pointer;
VerValueSize: DWORD;
VerValue: PVSFixedFileInfo;
Dummy: DWORD;
begin
VerInfoSize := GetFileVersionInfoSize(PChar(AFileName), Dummy);
GetMem(VerInfo, VerInfoSize);
try
GetFileVersionInfo(PChar(AFileName), 0, VerInfoSize, VerInfo);
VerQueryValue(VerInfo, '\', Pointer(VerValue), VerValueSize);
with VerValue^ do
begin
Result := IntToStr(dwFileVersionMS shr 16);
Result := Result + '.' + IntToStr(dwFileVersionMS and $FFFF);
Result := Result + '.' + IntToStr(dwFileVersionLS shr 16);
Result := Result + '.' + IntToStr(dwFileVersionLS and $FFFF);
end;
finally
FreeMem(VerInfo, VerInfoSize);
end;
end;
Delphi: Give a new name if the file already exists
Give a new name if the file already exists ... Reveal Code
function file_newname($path, $filename){
if ($pos = strrpos($filename, '.')) {
$name = substr($filename, 0, $pos);
$ext = substr($filename, $pos);
} else {
$name = $filename;
}
$newpath = $path.'/'.$filename;
$newname = $filename;
$counter = 0;
while (file_exists($newpath)) {
$newname = $name .'_'. $counter . $ext;
$newpath = $path.'/'.$newname;
$counter++;
}
return $newname;
}
Delphi: Get MAC address
Get MAC address for 1st network adapter ... Reveal Code
function GetMACAddress: string;
var
AdapterList: TLanaEnum;
NCB: TNCB;
begin
FillChar(NCB, SizeOf(NCB), 0);
NCB.ncb_command := Char(NCBENUM);
NCB.ncb_buffer := @AdapterList;
NCB.ncb_length := SizeOf(AdapterList);
Netbios(@NCB);
if Byte(AdapterList.length) > 0 then
Result := GetAdapterInfo(AdapterList.lana[0])
end;
Delphi: Get temp directory
Get Windows temp directory. Will return something like this: C:UsersMyUserNameAppDataLocalTemp ... Reveal Code
function GetTempDir: WideString; stdcall;
var
Buffer: array[0..MAX_PATH] of Char;
begin
GetTempPath((SizeOf(Buffer) div SizeOf(Char)) - 1, Buffer);
Result := Buffer;
end;
procedure TForm1.btn1Click(Sender: TObject);
begin
ShowMessage(GetTempDir);
end;
Open URL in a default browser ... Reveal Code
uses Winapi.ShellAPI;
...
procedure OpenURL(url:string);
begin
ShellExecute(Handle, 'open', pChar(url), nil, nil, SW_NORMAL);
end;
Delphi: Clear the IE cache
Completely clean the IE cache ... Reveal Code
procedure ClearIECache;
var
lpEntryInfo: PInternetCacheEntryInfo;
hCacheDir: LongWord;
dwEntrySize: LongWord;
begin
dwEntrySize := 0;
FindFirstUrlCacheEntry(nil, TInternetCacheEntryInfo(nil^), dwEntrySize);
GetMem(lpEntryInfo, dwEntrySize);
if dwEntrySize > 0 then
lpEntryInfo^.dwStructSize := dwEntrySize;
hCacheDir := FindFirstUrlCacheEntry(nil, lpEntryInfo^, dwEntrySize);
if hCacheDir <> 0 then
begin
repeat
DeleteUrlCacheEntry(lpEntryInfo^.lpszSourceUrlName);
FreeMem(lpEntryInfo, dwEntrySize);
dwEntrySize := 0;
FindNextUrlCacheEntry(hCacheDir, TInternetCacheEntryInfo(nil^),
dwEntrySize);
GetMem(lpEntryInfo, dwEntrySize);
if dwEntrySize > 0 then
lpEntryInfo^.dwStructSize := dwEntrySize;
until not FindNextUrlCacheEntry(hCacheDir, lpEntryInfo^, dwEntrySize);
end;
FreeMem(lpEntryInfo, dwEntrySize);
FindCloseUrlCache(hCacheDir);
end;
Delphi: Bytes formatting
Formatting byte values to a more readable values ... Reveal Code
function FormatByteSize(const bytes: Longint): string;
const
B = 1; //byte
KB = 1024 * B; //kilobyte
MB = 1024 * KB; //megabyte
GB = 1024 * MB; //gigabyte
begin
if bytes > GB then
result := FormatFloat('#.## Gb', bytes / GB)
else if bytes > MB then
result := FormatFloat('#.## Mb', bytes / MB)
else if bytes > KB then
result := FormatFloat('#.## Kb', bytes / KB)
else
result := FormatFloat('#.## bytes', bytes);
end;
Delphi: Замена подстроки в сторке
Замена всех подстрок в данной строке. Функция была использована от Delphi 7 до Delphi XE3. ... Reveal Code
function ReplaceSub(str, sub1, sub2: string): string;
var
aPos: Integer;
rslt: string;
begin
aPos := pos(sub1, str);
rslt := '';
while (aPos <> 0) do
begin
rslt := rslt + Copy(str, 1, aPos - 1) + sub2;
Delete(str, 1, aPos + Length(sub1) - 1);
aPos := pos(sub1, str);
end;
result := rslt + str;
end;
procedure TForm1.btn1Click(Sender: TObject);
var
my_str: string;
begin
my_str := 'My cool string is very cool!';
ShowMessage(ReplaceSub(my_str, 'cool', 'awesome'));
end;
Delphi: Add a message to log
Add a message to TRichEdit based log. Message will be in a format: [CURRENT_DATE CURRENT_TIME]: MESSAGE_TEXT ... Reveal Code
function timetolog(reqdate: TdateTime): string;
var
Y, m, d, hh, mm, ss, ms: WORD;
newy, newm, newd, newhh, newmm, newss: string;
begin
DecodeDate(reqdate, Y, m, d);
DecodeTime(reqdate, hh, mm, ss, ms);
newy := inttostr(Y);
newm := inttostr(m);
newd := inttostr(d);
newhh := inttostr(hh);
newmm := inttostr(mm);
newss := inttostr(ss);
if length(newm) = 1 then
newm := '0' + newm;
if length(newd) = 1 then
newd := '0' + newd;
if length(newhh) = 1 then
newhh := '0' + newhh;
if length(newmm) = 1 then
newmm := '0' + newmm;
if length(newss) = 1 then
newss := '0' + newss;
Result := '[' + newd + '.' + newm + '.' + newy + ' ' + newhh + ':' + newmm +
':' + newss + '] ';
end;
procedure AddLog(ARichEdit: TRichEdit; AText: string);
var
Count: Integer;
begin
AText := timetolog(now) + AText;
Count := pos(']', AText) + 1;
if pos('ERROR', AText) > 0 then
begin
ARichEdit.Lines.Add(AText);
ARichEdit.SelStart := length(ARichEdit.Text);
ARichEdit.SelStart := ARichEdit.SelStart - length(AText) - 1;
ARichEdit.SelLength := Count;
ARichEdit.SelAttributes.Style := [fsbold];
ARichEdit.SelAttributes.Color := rgb(180, 10, 10);
ARichEdit.SelStart := ARichEdit.SelStart + Count;
ARichEdit.SelLength := length(AText) - Count;
ARichEdit.SelAttributes.Style := [];
ARichEdit.SelAttributes.Color := rgb(180, 10, 10);
ARichEdit.SelLength := 0;
end
else
begin
ARichEdit.Lines.Add(AText);
ARichEdit.SelStart := length(ARichEdit.Text);
ARichEdit.SelStart := ARichEdit.SelStart - length(AText) - 1;
ARichEdit.SelLength := Count;
ARichEdit.SelAttributes.Style := [fsbold];
ARichEdit.SelStart := ARichEdit.SelStart + Count;
ARichEdit.SelLength := length(AText) - Count;
ARichEdit.SelAttributes.Style := [];
ARichEdit.SelLength := 0;
end;
SendMessage(ARichEdit.Handle, EM_SCROLL, SB_LINEDOWN, 0);
try
ARichEdit.SetFocus;
ARichEdit.SelStart := ARichEdit.GetTextLen;
ARichEdit.Perform(EM_SCROLLCARET, 0, 0);
CreateCaret(ARichEdit.handle, 0, 0, 0);
except
//
end;
application.ProcessMessages;
end;
procedure TForm1.btn1Click(Sender: TObject);
begin
AddLog(Form1.RichEdit1, 'ERROR: Something Wrong!'); //Error Message
AddLog(Form1.RichEdit1, 'Some text here'); //Regular Message
end;
Delphi: Get MD5 value
Get MD5 value, in the same way as it PHP does. ... Reveal Code
Uses IdHashMessageDigest;
function getmd5(SourceString: string): string;
var
md5: TIdHashMessageDigest5;
begin
result := '';
md5 := TIdHashMessageDigest5.Create;
try
result := AnsiLowerCase(md5.HashStringAsHex(SourceString));
finally
FreeAndNil(md5);
end;
end;
procedure TForm1.btn1Click(Sender: TObject);
begin
ShowMessage(getmd5('Hash, darling!'));
end;
Delphi: Get the version of a file
Get the version of a file. The function was used from Delphi 7 to Delphi XE3. ... Reveal Code
function GetFileVersion(const FileName: string): string;
type
PDWORD = ^dword;
PLangAndCodePage = ^TLangAndCodePage;
TLangAndCodePage = packed record
wLanguage: word;
wCodePage: word;
end;
PLangAndCodePageArray = ^TLangAndCodePageArray;
TLangAndCodePageArray = array[0..0] of TLangAndCodePage;
var
loc_InfoBufSize: dword;
loc_InfoBuf: PChar;
loc_VerBufSize: dword;
loc_VerBuf: PChar;
cbTranslate: dword;
lpTranslate: PDWORD;
i: dword;
begin
result := '';
if (Length(FileName) = 0) or (not Fileexists(FileName)) then
exit;
loc_InfoBufSize := GetFileVersionInfoSize(PChar(FileName), loc_InfoBufSize);
if loc_InfoBufSize > 0 then
begin
loc_VerBuf := nil;
loc_InfoBuf := AllocMem(loc_InfoBufSize);
try
if not GetFileVersionInfo(PChar(FileName), 0, loc_InfoBufSize, loc_InfoBuf)
then
exit;
if not VerQueryValue(loc_InfoBuf, '\\VarFileInfo\\Translation',
Pointer(lpTranslate), dword(cbTranslate)) then
exit;
for i := 0 to (cbTranslate div SizeOf(TLangAndCodePage)) - 1 do
begin
if VerQueryValue(loc_InfoBuf,
PChar(Format('StringFileInfo\0x\FileVersion',
[PLangAndCodePageArray(lpTranslate)[i].wLanguage,
PLangAndCodePageArray(lpTranslate)[i].wCodePage])),
Pointer(loc_VerBuf), dword(loc_VerBufSize)) then
begin
result := loc_VerBuf;
Break;
end;
end;
finally
FreeMem(loc_InfoBuf, loc_InfoBufSize);
end;
end;
end;
procedure TForm1.btn1Click(Sender: TObject);
begin
ShowMessage(GetFileVersion(Application.ExeName));
end;