01-09-19, 12:25 AM
(26-08-19, 04:27 PM)samir28شكراً كتب : [quote pid='140221' dateline='1555878414']
وعليكم السلام اخي
تفضل عملت لك مثال لتفهم طريقة فحص الروابط
بتوفيق
أخي هل مساعدتي في تحويل الكود الى الدلفي
[/quote]
تفضل هدا كود بالدالفي
كود :
uses wininet;
function urlcheck(const sUrl: string; CheckTimeout: DWORD = 3000): DWORD;
var
hInet, hConnect: HINTERNET;
StatusCode, dummy, bufLen, Option: DWORD;
begin
Result := 0;
hInet := InternetOpen(PChar(Application.Title),
INTERNET_OPEN_TYPE_PRECONFIG_WITH_NO_AUTOPROXY, nil, nil, 0);
if Assigned(hInet) then
try
Option := CheckTimeout;
InternetSetOption(hInet, INTERNET_OPTION_CONNECT_TIMEOUT, @Option,
SizeOf(Option));
InternetSetOption(hInet, INTERNET_OPTION_RECEIVE_TIMEOUT, @Option,
SizeOf(Option));
hConnect := InternetOpenUrl(hInet, PChar(trim(sUrl)), nil, 0,
INTERNET_FLAG_NO_UI, 0);
if Assigned(hConnect) then
try
dummy := 0;
bufLen := SizeOf(StatusCode);
if HttpQueryInfo(hConnect, HTTP_QUERY_STATUS_CODE or
HTTP_QUERY_FLAG_NUMBER, @StatusCode, bufLen, dummy) then
Result := StatusCode;
finally
InternetCloseHandle(hConnect);
end;
finally
InternetCloseHandle(hInet);
end;
end;
function htcodes(mycode: Integer): string;
begin
case mycode of
200: Result := 'succès';
301: Result := 'Adresse déplacée';
400: Result := 'Demande incorrecte';
401: Result := 'pas d''authentification';
403: Result := 'pas de permission';
404: Result := 'Pas de réponse';
408: Result := 'Timeout';
else
Result := 'erreur inconnue';
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var stc: Integer;
begin
stc:=urlcheck(memo1.Text);
Showmessage(htcodes(stc));
end;
end.