本文整理自网络，侵删。
Type THTTPHead = (nHead, nGet, nPost); PWebHead = ^TWebHead; TWebHead = Record uCode :Word; szSer :Array [0..64] Of AnsiChar; End; PDomain = ^TDomain; TDomain = Record szUrl :Array [0..255] Of AnsiChar; szHost :Array [0..255] Of AnsiChar; szFile :Array [0..255] Of AnsiChar; bSSL :Boolean; nPort :Word; End; Const UserAgent:PAnsiChar = 'Mozilla/5.0 (Windows NT 6.1; WOW64; Trident/7.0; rv:11.0) like Gecko'; Header :PAnsiChar = 'Content-Type: application/x-www-form-urlencoded'#13#10#$0; Function StrStrIA(lpFirst, lpSrch: PAnsiChar): PAnsiChar; stdcall; external 'shlwapi.dll' name 'StrStrIA';Function StrNCatA(lpFirst, lpSrch:PAnsiChar; cchMax:Integer): PAnsiChar; stdcall; external 'shlwapi.dll' name 'StrNCatA';Function StrToIntA(lpSrch: PAnsiChar): Integer; stdcall; external 'shlwapi.dll' name 'StrToIntA'; Function StrPosA(lpSrch, lpFirst:PAnsiChar):Integer;Var Cmp :PAnsiChar;begin Result := 0; if (lpSrch = Nil) Or (lpFirst = Nil) then Exit; if DWORD(lpSrch) = DWORD(lpFirst) then begin Result := 1; Exit; end; Cmp := StrStrIA(lpFirst, lpSrch); if Cmp <> Nil then begin Result := DWORD(Cmp) - DWORD(lpFirst) + 1; end;end; Procedure DeleteA(lpszStr:PAnsiChar; Index, Count:Integer);Var uSize :Integer;begin uSize := lstrlenA(lpszStr); if uSize = Count then begin lstrcpyA(@lpszStr[index - 1], @lpszStr[Index + Count -1]); ZeroMemory(@lpszStr[index -1], Index + Count); end else begin lpszStr[Index - 1] := #0; StrNCatA(lpszStr, @lpszStr[Index + Count - 1], uSize); end;end; Function CopyA(lpszStr:PAnsiChar; Index, Count:Integer):PAnsiChar;begin Result := GetMemory(Count - Index + 1); lstrcpynA(Result, @lpszStr[Index -1], Count);end; Function ParseURL(szUrl:PAnsiChar):PDomain;Var nSize :DWORD; szSeek :PAnsiChar; szCmp :PAnsiChar;begin Result := GetMemory(SizeOf(TDomain)); ZeroMemory(Result, SizeOf(TDomain)); if StrStrIA(szUrl, 's://') <> Nil then Result^.bSSL := True; nSize := StrPosA('://', szUrl); if nSize > 0 then begin szSeek := @szUrl[nSize + 2]; lstrcpyA(@Result^.szUrl, szUrl); end else begin szSeek := szUrl; lstrcpyA(@Result^.szUrl, 'http://'); lstrcatA(@Result^.szUrl, szUrl); end; nSize := StrPosA(':', szSeek); if nSize > 0 then begin lstrcpynA(@Result^.szHost, szSeek, nSize); szSeek := @szSeek[nSize]; nSize := StrPosA('/', szSeek); if nSize > 0 then begin lstrcpynA(@Result^.szFile, szSeek, nSize); Result^.nPort := StrToIntA(Result^.szFile); ZeroMemory(@Result^.szFile, 256); szSeek := @szSeek[nSize - 1]; end; end Else begin nSize := StrPosA('/', szSeek); if nSize > 0 then lstrcpynA(@Result^.szHost, szSeek, nSize) Else lstrcpyA(@Result^.szHost, szSeek); szCmp := StrStrIA(szUrl, 's://'); if szCmp <> Nil then begin nSize := DWORD(szCmp) - DWORD(szUrl); if nSize > 0 then Result^.nPort := 443; End Else Result^.nPort := 80; end; nSize := StrPosA('/', szSeek); if nSize > 0 then lstrcpynA(@Result^.szFile, @szSeek[nSize], 255); if lstrlenA(@Result^.szFile) = 0 then lstrcpyA(@Result^.szFile, '/');end; Function GetCode(szHead:PAnsiChar):Integer;Var szSeek :PAnsiChar; uRet :Integer;begin Result := 0; szSeek := szHead; uRet := StrPosA(' ', szSeek); if uRet > 0 then begin Inc(szSeek, uRet); uRet := StrPosA(' ', szSeek); if uRet > 0 then begin szSeek[uRet-1] := #$0; Result := StrToIntA(szSeek); szSeek[uRet-1] := ' '; end; end;end; Function GetWebSer(szHead:PAnsiChar):PAnsiChar;Var szSeek :PAnsiChar; uRet :Integer;begin Result := Nil; szSeek := szHead; uRet := StrPosA('Server:', szSeek); if uRet > 0 then begin Inc(szSeek, uRet + 7); uRet := StrPosA(#13, szSeek)-1; if uRet > 0 then begin szSeek[uRet] := #$0; Result := GetMemory(lstrlenA(szSeek) + 6); lstrcpyA(Result, szSeek); szSeek[uRet] := #13; end; end;end; Function GetPowered(szHead:PAnsiChar):PAnsiChar;Var szSeek :PAnsiChar; uRet :Integer;begin Result := Nil; szSeek := szHead; uRet := StrPosA('x-powered-by:', szSeek); if uRet > 0 then begin Inc(szSeek, uRet + 13); uRet := StrPosA(#13, szSeek)-1; if uRet > 0 then begin szSeek[uRet] := #$0; Result := GetMemory(lstrlenA(szSeek) + 6); lstrcpyA(Result, szSeek); szSeek[uRet] := #13; end; end;end; Function HTTP_Exec(lpHead:THTTPHead; szUrl:PAnsiChar; Data:Pointer; dSize:DWORD; Cookies:PAnsiChar; Var uCode:DWORD):PByte;Const IntBufSize = 8192;Var Session :HINTERNET; Connect :HINTERNET; Resource :HINTERNET; dwFlags :DWORD; Buffer :Array[0..IntBufSize-1] of AnsiChar; uSize :DWORD; uRecv :DWORD; dwDomain :PDomain; Stream :TMemoryStream;begin Result := Nil; uCode := 0; Stream := TMemoryStream.Create; dwDomain := ParseURL(szUrl); if dwDomain = Nil then Exit; if dwDomain^.bSSL then dwFlags := INTERNET_FLAG_SECURE Else dwFlags := 0; if Cookies <> Nil then InternetSetCookieA(szUrl, Nil, Cookies); Session := InternetOpenA(UserAgent, INTERNET_OPEN_TYPE_PRECONFIG, Nil, Nil, 0); if Session <> Nil then begin Connect := InternetConnectA(Session, @dwDomain^.szHost, dwDomain^.nPort, Nil, Nil, INTERNET_SERVICE_HTTP, 0, 0); if Connect <> Nil then begin case lpHead of nHead : begin Resource := HttpOpenRequestA(Connect, 'HEAD', @dwDomain^.szFile, Nil, Nil, Nil, dwFlags Or INTERNET_FLAG_NO_CACHE_WRITE Or INTERNET_FLAG_RELOAD, 0); if Resource <> Nil then begin if HttpSendRequestA(Resource, Nil, 0, Nil, 0) then begin uSize := SizeOf(Buffer); ZeroMemory(@Buffer, uSize); uRecv := 0; if HttpQueryInfoA(Resource, HTTP_QUERY_RAW_HEADERS_CRLF, @Buffer, uSize, uRecv) then begin Stream.WriteBuffer(Buffer, lstrlenA(@Buffer)); uCode := GetCode(@Buffer); end; end; end; end; nGet : begin Resource := HttpOpenRequestA(Connect, 'GET', @dwDomain^.szFile, Nil, Nil, Nil, dwFlags Or INTERNET_FLAG_NO_CACHE_WRITE Or INTERNET_FLAG_RELOAD, 0); if Resource <> Nil then begin if HttpSendRequestA(Resource, Nil, 0, Nil, 0) then begin uSize := SizeOf(DWORD); uRecv := 0; if HttpQueryInfoA(Resource, HTTP_QUERY_STATUS_CODE Or HTTP_QUERY_FLAG_NUMBER, @uCode, uSize, uRecv) then begin repeat if InternetReadFile(Resource, @Buffer, IntBufSize, uRecv) then begin Stream.WriteBuffer(Buffer, uRecv); end; until uRecv = 0; end; end; end; end; nPost : begin Resource := HttpOpenRequestA(Connect, 'POST', @dwDomain^.szFile, Nil, Nil, Nil, dwFlags Or INTERNET_FLAG_NO_CACHE_WRITE Or INTERNET_FLAG_RELOAD, 0); if Resource <> Nil then begin If HttpAddRequestHeadersA(Resource, Header, lstrlenA(Header), dwFlags Or HTTP_ADDREQ_FLAG_ADD Or HTTP_ADDREQ_FLAG_REPLACE) Then begin if HttpSendRequestA(Resource, Nil, 0, Data, dSize) then begin uSize := SizeOf(DWORD); uRecv := 0; if HttpQueryInfoA(Resource, HTTP_QUERY_STATUS_CODE Or HTTP_QUERY_FLAG_NUMBER, @uCode, uSize, uRecv) then begin repeat if InternetReadFile(Resource, @Buffer, IntBufSize, uRecv) then begin Stream.WriteBuffer(Buffer, uRecv); end; until uRecv = 0; end; end; end; end; end; end; InternetCloseHandle(Connect); end; InternetCloseHandle(Session); end; if Stream.Size > 0 then begin Result := GetMemory(Stream.Size); CopyMemory(Result, Stream.Memory, Stream.Size); end; Stream.Free;end;
来源:https://www.7xcode.com/archives/91.html 相关阅读 >>
Delphi中使用词霸2005的动态库xdictgrb.dll实现屏幕取词
Delphi 调用浏览文件夹 selectdirectory
更多相关阅读请进入《Delphi》频道 >>
