将一个局域网的AD0的mis程序升级到互联网的方法(散分 前 6 人 50分 ，感兴趣 的 问我要测试程序) ( 积分: 300 )

如果是三层架构做的程序，那么改为B/S就要方便一些。

偶来晚了 5555555555555555555

to lich
就是 sconnect.pas 加一句话 而已， 很多人 都改过

不错的

good[]

我也想要测试程序
skylan1977@163.com

还要请教一下，修改的是哪行代码？

http://www.delphibbs.com/delphibbs/dispq.asp?lid=1053633

http://distribucon.com/midasbug/results.asp?DelphiVersion=11

borland 公司 找到的
http://codecentral.borland.com/codecentral/ccweb.exe/listing?id=18265

强烈支持开源和感谢那些愿意把自己代码公开的好朋友们。[]

呵呵，非常感谢啊

unit U_Fun_Net_ADO;
// hfghfghfg qq:105204912 鸽子（郝峰鸽）
interface
uses Windows, SysUtils, Classes, WinInet, comobj, adoint, zlib;

procedure makeUpstream(s: TMemoryStream; action, sql, memo1, memo2: string);
procedure getRS_stream(ms_Down: TMemoryStream; var errmsg: string; ms_rs: TMemoryStream);


function HttpPutStram(url: string; s_up, s_down: TMemoryStream): Boolean;
function RecordsetFromMS(Stream: TMemoryStream): _Recordset;
function RecordsetFromHttp(Host, sql: string): _Recordset;
function ExecFromHttp(Host, sql: string; NoRecords: boolean; var c: integer): _Recordset;
function HttpConnect(host: string): boolean;
function Http_GetFieldNames(host, tb: string; ss: TStrings): boolean;
function Http_GetTableNames(host: string; sys: boolean; ss: TStrings): boolean;


implementation

procedure makeUpstream(s: TMemoryStream; action, sql, memo1, memo2: string);
var
c: integer;
procedure w(v: string);
var
i: integer;
begin
i := length(v);
s.Write(i, sizeof(i));
s.Write(v[1], i);


end;

begin
s.Clear;
c := 4;
s.Write(c, sizeof(c));

w(action);
w(sql);
w(memo1);
w(memo2);
end;

procedure getRS_stream(ms_Down: TMemoryStream; var errmsg: string; ms_rs: TMemoryStream);
var
isCompress: Byte;
myUNCompression: TDecompressionStream;
BuffSize, BuffSize_UnCompress: integer;
i: integer;
begin
errmsg := '';
ms_Down.Position := 0;
ms_Down.ReadBuffer(isCompress, 1);
ms_Down.ReadBuffer(BuffSize, sizeof(BuffSize));
if isCompress > 0 then
begin
ms_Down.ReadBuffer(BuffSize_UnCompress, sizeof(BuffSize_UnCompress));
myUNCompression := TDecompressionStream.Create(ms_Down);
ms_rs.CopyFrom(myUNCompression, BuffSize_UnCompress);

ms_Down.Position := 1 + 2 * sizeof(BuffSize) + BuffSize;
ms_Down.ReadBuffer(i, sizeof(i));
if i > 0 then
begin
SetLength(errmsg, i);
ms_Down.ReadBuffer(errmsg[1], i);
end;
end
else
begin

if BuffSize > 0 then
ms_rs.CopyFrom(ms_Down, BuffSize);

ms_Down.ReadBuffer(i, sizeof(i));
if i > 0 then
begin
SetLength(errmsg, i);
ms_Down.ReadBuffer(errmsg[1], i);
end;


end;
end;

function HttpPutStram(url: string; s_up, s_down: TMemoryStream): Boolean;
var
buf: array[0..32768 - 1] of char;
bufsize: dword;
FUrl, fsrvr: string;
fsize, totsize: int64;
NetHandle: hinternet;

hconnect: hinternet;
hintfile: hinternet;
lpdword: Dword;
bufferin: INTERNET_BUFFERS;


// ErrCode: Integer;
wsize: int64;
NowP, i: integer;
lpdwlen, lpdwidx, BytesRead, HaveRead: DWord;


function ExtractServer(url: string): string;
begin
if Pos('://', UpperCase(url)) > 0 then
Delete(url, 1, Pos('://', url) + 2);

if Pos('@', UpperCase(url)) > 0 then
Delete(url, 1, Pos('@', url) + 1);

if Pos('/', url) > 0 then
url := Copy(url, 1, Pos('/', url) - 1);

Result := url;
end;

function RemoveServer(url: string): string;
begin
if Pos('://', UpperCase(url)) > 0 then
Delete(url, 1, Pos('://', url) + 2);

if Pos('@', UpperCase(url)) > 0 then
Delete(url, 1, Pos('@', url) + 1);

if Pos('/', url) > 0 then
Delete(url, 1, Pos('/', url) - 1);

Result := url;
end;

begin
Result := False;

FUrl := url;


TotSize := s_up.Size;

if TotSize <= 0 then
Exit;
s_up.Position := 0;
s_down.Clear;

fsrvr := ExtractServer(url);
url := RemoveServer(url);

NetHandle := InternetOpen('sql for ADO', INTERNET_OPEN_TYPE_PRECONFIG {or INTERNET_FLAG_ASYNC}, nil, nil, 0);
if assigned(NetHandle) then
begin
hconnect := InternetConnect(NetHandle, PChar(fsrvr), INTERNET_DEFAULT_HTTP_PORT, nil, nil, INTERNET_SERVICE_HTTP, 0, 0);

hintfile := HttpOpenRequest(HConnect, 'POST', PChar(url), nil, nil, nil, INTERNET_FLAG_NO_CACHE_WRITE, 0);

if hintfile = nil then
begin
Exit;
end;

if hintfile <> nil then
begin


bufsize := 32768;
FSize := 0;
FillChar(bufferin, SizeOf(bufferin), 0);
bufferin.dwStructSize := SizeOf(INTERNET_BUFFERS);
bufferin.dwBufferTotal := TotSize;

if HttpSendRequestEx(hintfile, @bufferin, nil, HSR_INITIATE, 0) then
begin
while (bufsize = 32768) do
begin

bufsize := s_up.Read(buf[0], 32768);

if not InternetWriteFile(hintfile, @buf, bufsize, lpdword) then
begin



InternetCloseHandle(hintfile);
InternetCloseHandle(hconnect);
InternetCloseHandle(NetHandle);
// hintProgress('', 0);
exit;

end;

wsize := wsize + lpdword;
FSize := FSize + bufsize;

if lpdword > 0 then
begin
NowP := Round(100 * FSize / totsize);
if NowP <> i then
begin
i := NowP;
end;

end;

end;






HttpEndRequest(hintfile, nil, 0, 0);



/////////////////////////////////////

lpdwidx := 0;
lpdword := 0;
lpdwlen := 4;
if HttpQueryInfo(hintfile, HTTP_QUERY_CONTENT_LENGTH or
HTTP_QUERY_FLAG_NUMBER, @lpdword, lpdwlen, lpdwidx) then
begin



repeat

InternetReadFile(hintfile, @Buf, 32768, BytesRead);
s_down.Write(Buf[0], bytesread);
HaveRead := HaveRead + bytesread;

{
if assigned(PrintProcess) then

PrintProcess(round(HaveRead * 100 / lpdword), 100);
}
until BytesRead = 0;

result := lpdword = HaveRead;

end;

end;



///



InternetCloseHandle(hintfile);
InternetCloseHandle(hconnect);
Result := true;
end;

InternetCloseHandle(NetHandle);
// hintProgress('', 0);

end;

end;

function RecordsetToMS(const Recordset: _Recordset; Stream: TMemoryStream): boolean;
var
RS: Variant;
begin
Result := false;
if Recordset = nil then Exit;

try
RS := CreateOleObject('ADODB.Recordset');
RS := Recordset;
RS.Save(TStreamAdapter.Create(stream) as IUnknown, adPersistADTG);
Stream.Position := 0;
Result := true;
finally
;
end;
end;


function RecordsetFromMS(Stream: TMemoryStream): _Recordset;
var
RS: Variant;
begin
Result := nil;
if Stream.Size < 1 then Exit;
try
Stream.Position := 0;
RS := CreateOleObject('ADODB.Recordset');
RS.Open(TStreamAdapter.Create(Stream) as IUnknown);
Result := IUnknown(RS) as _Recordset;
finally
;
end;
end;


function RecordsetFromHttp(Host, sql: string): _Recordset;
var
s_up, s_down: TMemoryStream;
e: string;

begin

s_up := TMemoryStream.Create;
s_down := TMemoryStream.Create;

makeUpstream(s_up, 'open', sql, '', '');

HttpPutStram(host, s_up, s_down);
s_up.Clear;
getRS_stream(s_down, e, s_up);

if e = '' then
begin
Result := RecordsetFromMS(s_up);

FreeAndNil(s_up);
FreeAndNil(s_down);
end
else
begin

FreeAndNil(s_up);
FreeAndNil(s_down);
raise Exception.Create(e);

end;
end;

function ExecFromHttp(Host, sql: string; NoRecords: boolean; var c: integer): _Recordset;
var
s_up, s_down: TMemoryStream;
e: string;

begin

c := 0;
s_up := TMemoryStream.Create;
s_down := TMemoryStream.Create;

if NoRecords then
makeUpstream(s_up, 'exec', sql, 'NoRecords', '')
else
makeUpstream(s_up, 'exec', sql, '', '');

HttpPutStram(host, s_up, s_down);

s_up.Clear;
getRS_stream(s_down, e, s_up);

if e = '' then
begin
s_up.Position := 0;
if s_up.Size = sizeof(c) then
s_up.ReadBuffer(c, sizeof(c))
else
begin
Result := RecordsetFromMS(s_up);
end;

FreeAndNil(s_up);
FreeAndNil(s_down);
end
else
begin

FreeAndNil(s_up);
FreeAndNil(s_down);
raise Exception.Create(e);

end;
end;

function HttpConnect(host: string): boolean;
var
s_up, s_down: TMemoryStream;
e: string;
i: integer;
begin
Result := false;
s_up := TMemoryStream.Create;
s_down := TMemoryStream.Create;


makeUpstream(s_up, 'connect', '', '', '');

HttpPutStram(host, s_up, s_down);

Result := s_down.Size = sizeof(i);

FreeAndNil(s_up);
FreeAndNil(s_down);

end;

function Http_GetFieldNames(host, tb: string; ss: TStrings): boolean;
var
s_up, s_down: TMemoryStream;
e: string;

begin
Result := false;
s_up := TMemoryStream.Create;
s_down := TMemoryStream.Create;


makeUpstream(s_up, 'GetFieldNames', tb, '', '');

HttpPutStram(host, s_up, s_down);

s_up.clear;
getRS_stream(s_down, e, s_up);
s_up.SaveToFile('c:/2.dd');
if e = '' then
begin
s_up.Position := 0;
ss.LoadFromStream(s_up);
Result := true;
FreeAndNil(s_up);
FreeAndNil(s_down);
end
else
begin

FreeAndNil(s_up);
FreeAndNil(s_down);
raise Exception.Create(e);

end;


end;

function Http_GetTableNames(host: string; sys: boolean; ss: TStrings): boolean;
var
s_up, s_down: TMemoryStream;
e: string;

begin
Result := false;
s_up := TMemoryStream.Create;
s_down := TMemoryStream.Create;


if sys then
makeUpstream(s_up, 'GetTableNames', '1', '', '')
else
makeUpstream(s_up, 'GetTableNames', '', '', '');

HttpPutStram(host, s_up, s_down);

s_up.clear;

getRS_stream(s_down, e, s_up);

if e = '' then
begin
s_up.Position := 0;
ss.LoadFromStream(s_up);
Result := true;
FreeAndNil(s_up);
FreeAndNil(s_down);
end
else
begin

FreeAndNil(s_up);
FreeAndNil(s_down);
raise Exception.Create(e);

end;


end;
end.

不错呀。我正在想如何将我所做的局域网程序升级到INTERNET，恰看到这个，好呀

我也来顶，祝大富翁们圣诞节快乐。

老大，我永远支持你
你的小弟，哈哈哈哈
看来离老大的水平相差太远啊

还没看懂