function ShellExecute_AndWait(const FileName: string; const Params: string): bool; var exInfo: TShellExecuteInfo; Ph: DWORD; begin FillChar(exInfo, SizeOf(exInfo), 0); with exInfo do begin cbSize := SizeOf(exInfo); fMask := SEE_MASK_NOCLOSEPROCESS or SEE_MASK_FLAG_DDEWAIT; Wnd := GetActiveWindow(); exInfo.lpVerb := 'open'; exInfo.lpParameters := PChar(Params); lpFile := PChar(FileName); nShow := SW_HIDE; end; if ShellExecuteEx(@exInfo) then Ph := exInfo.hProcess else begin ShowMessage(SysErrorMessage(GetLastError)); Result := true; exit; end; while WaitForSingleObject(exInfo.hProcess, 50) <> WAIT_OBJECT_0 do Application.ProcessMessages; CloseHandle(Ph); Result := true; end;
Collection of Delphi useful functions and procedures
ON THIS BLOG, DELPHI PROGRAMMERS CAN FIND FREE USEFUL FUNCTIONS AND PROCEDURES
Delphi function for wait until an external process has completed
Categories:
Miscellaneous,
System Control
Download file with Delphi
uses Forms, URLMon, Wininet, IdHTTP, IdComponent; type TEventHandler = class procedure HttpWork(ASender: TObject; AWorkMode: TWorkMode; AWorkCount: Integer); end; var ProgressBar1: TProgressBar; Form1: TForm; procedure TEventHandler.HttpWork(ASender: TObject; AWorkMode: TWorkMode; AWorkCount: Integer); var Http: TIdHTTP; ContentLength: Int64; Percent: Integer; origin : cardinal; begin Http := TIdHTTP(ASender); if not InternetGetConnectedState(@origin,0) then begin Application.MessageBox('Connection lost!','Warning',MB_OK+MB_ICONWARNING); Abort; end; ContentLength := Http.Response.ContentLength; if (Pos('chunked', LowerCase(Http.Response.ResponseText)) = 0) and (ContentLength > 0) then begin Percent := 100*AWorkCount div ContentLength; ProgressBar1.Position := Round(Percent); Form1.Refresh; end else begin Percent := 99; ProgressBar1.Position := Round(Percent); Form1.Refresh; end; end; function DownloadFile(SourceFile, DestFile: string): Boolean; const RECV_BUFFER_SIZE = 32768; var HttpClient: TIdHttp; FileSize: Int64; Buffer: TMemoryStream; handler: TEventHandler; origin : cardinal; begin HttpClient := TIdHttp.Create(nil); try if not InternetGetConnectedState(@origin,0) then begin Application.MessageBox('No internet connection available!','Warning',MB_OK+MB_ICONWARNING); Abort; end; try HttpClient.Head(SourceFile); except Application.MessageBox('No internet connection available!','Warning',MB_OK+MB_ICONWARNING); Abort; end; FileSize := HttpClient.Response.ContentLength; Buffer := TMemoryStream.Create; try Form1 := TForm.Create(nil); Form1.Width := 400; Form1.Height := 200; Form1.Caption := 'Download file'; Form1.Position := poDesktopCenter; ProgressBar1 := TProgressBar.Create(Form1); ProgressBar1.Parent := Form1; ProgressBar1.Width := 300; ProgressBar1.Height := 40; ProgressBar1.Left := 20; ProgressBar1.Top := 50; ProgressBar1.Max := 100; Form1.Show; while Buffer.Size < FileSize do begin HttpClient.Request.ContentRangeStart := Buffer.Size; if Buffer.Size + RECV_BUFFER_SIZE < FileSize then HttpClient.Request.ContentRangeEnd := Buffer.Size + RECV_BUFFER_SIZE - 1 else HttpClient.Request.ContentRangeEnd := FileSize; handler := TEventHandler.Create; HttpClient.OnWork:= handler.HttpWork; HttpClient.Get(HttpClient.URL.URI, Buffer); // wait until it is done Buffer.SaveToFile(DestFile); ProgressBar1.Position := 99; ProgressBar1.Refresh; Form1.Refresh; Sleep(2000); end; finally Buffer.Free; ProgressBar1.Free; Form1.Free; end; finally HttpClient.Free; end; end;
Categories:
Files functions
Delphi function to check a string if it's number
function IsNumber(Text: String): Boolean;
var i: Integer;
c: char;
begin
Result := True;
if Length(Text) <= 0 then
Result := False;
for i := 1 to Length(Text) do
begin
c := Text[i];
if not ((c >= '0') and (c <= '9')) then
if not ((c = DecimalSeparator) and (i > 1)) then
if not ((c = '-') and (i = 1)) then
if not ((c = '+') and (i = 1)) then
begin
Result
:= False;
//Break;
end;
end;
end;
Extract integer part of a string - Delphi function
function ExtractIntegerPartOfString(const AValue: String; var StrPart: String; var IntPart: Integer): String;
var
I: Integer;
begin
Result := '0';
StrPart := '';
IntPart := 1;
for I := length(AValue)-1 downto 0 do
begin
if not (Ord(AValue[I]) in [Ord('0')..Ord('9')]) then
begin
if Length(AValue)-I > 0 then
begin
StrPart := LeftStr(AValue,I);
try
IntPart := StrToInt(RightStr(AValue,Length(AValue)-I))+1;
except
IntPart := 1;
StrPart := LeftStr(AValue,I+1);
end;
Result := FormatFloat(Copy('000000000000',1,Length(AValue)-I),IntPart);
end;
Break;
end;
end;
end;
Delphi function for sending an email using MAPI
uses
MAPI;
function SendMailMAPI(const Subject, Body, FileName, SenderName, SenderEMail,
RecepientName, RecepientEMail: String) : Integer;
var
message: TMapiMessage;
lpSender,
lpRecepient: TMapiRecipDesc;
FileAttach: TMapiFileDesc;
SM: TFNMapiSendMail;
MAPIModule: HModule;
begin
FillChar(message, SizeOf(message), 0);
with message do
begin
if (Subject<>'') then
begin
lpszSubject
:= PChar(Subject)
end;
if (Body<>'') then
begin
lpszNoteText
:= PChar(Body)
end;
if (SenderEMail<>'') then
begin
lpSender.ulRecipClass
:= MAPI_ORIG;
if (SenderName='') then
begin
lpSender.lpszName := PChar(SenderEMail)
end
else
begin
lpSender.lpszName := PChar(SenderName)
end;
lpSender.lpszAddress
:= PChar('SMTP:'+SenderEMail);
lpSender.ulReserved
:= 0;
lpSender.ulEIDSize
:= 0;
lpSender.lpEntryID
:= nil;
lpOriginator
:= @lpSender;
end;
if (RecepientEMail<>'') then
begin
lpRecepient.ulRecipClass
:= MAPI_TO;
if (RecepientName='') then
begin
lpRecepient.lpszName := PChar(RecepientEMail)
end
else
begin
lpRecepient.lpszName := PChar(RecepientName)
end;
lpRecepient.lpszAddress
:= PChar('SMTP:'+RecepientEMail);
lpRecepient.ulReserved
:= 0;
lpRecepient.ulEIDSize
:= 0;
lpRecepient.lpEntryID
:= nil;
nRecipCount
:= 1;
lpRecips
:= @lpRecepient;
end
else
begin
lpRecips
:= nil
end;
if (FileName='') then
begin
nFileCount
:= 0;
lpFiles
:= nil;
end
else
begin
FillChar(FileAttach, SizeOf(FileAttach), 0);
FileAttach.nPosition
:= Cardinal($FFFFFFFF);
FileAttach.lpszPathName
:= PChar(FileName);
nFileCount
:= 1;
lpFiles
:= @FileAttach;
end;
end;
MAPIModule := LoadLibrary(PChar(MAPIDLL));
if MAPIModule=0 then
begin
Result := -1
end
else
begin
try
@SM := GetProcAddress(MAPIModule, 'MAPISendMail');
if @SM<>nil then
begin
Result := SM(0, Application.Handle, message, MAPI_DIALOG
or
MAPI_LOGON_UI, 0);
end
else
begin
Result := 1
end;
finally
FreeLibrary(MAPIModule);
end;
end
if Result<>0 then
begin
MessageDlg('Error
sending mail ('+IntToStr(Result)+').', mtError, [mbOk],
0)
end;
end;
Categories:
Miscellaneous
Subscribe to:
Posts (Atom)