Mega Code Archive
Internet
<![CDATA[
Kaynak: 7
TCP Listesi
{
Loading Delphi apps without a browser and on Win as Linux as well needs a
decision once.
With a loader on the client side, no further installation is in charge.
We had the requirement starting different Delphi apps from a
linux or windows server, wherever you are.
We call it Delphi Web Start (DWS).
The dws-client gets a list and after clicking on it, the app is
loading from server to client with just a stream.
First we had to choose between a ftp and a tcp solution. The
advantage of tcp is the freedom to define a separate port, which
was "services, port 9010 - DelphiWebStart".
You will need indy. Because it is simple to use and very fast.
The tcp-server comes from indy which has one great advantage:
CommandHandlers is a collection of text commands that will be
processed by the server. This property greatly simplify the
process of building servers based on text protocols.
First we start with DWS_Server,
so we define two command handlers:
}
CTR_LIST = 'return_list';
CTR_FILE = 'return_file';
{
By starting the tcp-server it returns with the first command
handler "CTR_LIST" a list of the apps:
}
procedure TForm1.IdTCPServer1Execute(AThread: TIdPeerThread);
...
// comes with writeline from client
if sRequest = CTR_LIST then begin
for idx:= 0 to meData.Lines.Count - 1 do
athread.Connection.WriteLn(ExtractFileName(meData.Lines[idx]));
aThread.Connection.WriteLn('::END::');
aThread.Connection.Disconnect;
{
One word concerning the thread:
In the internal architecture there are 2 threads categories.
First is a listener thread that "listen" and waits for a
connection. So we don't have to worry about threads, the built in
thread will be served by indy though parameter:
}
IdTCPServer1Execute(AThread: TIdPeerThread)
{
When our dws-client is connected, this thread transfer all the
communication operations to another thread.
This technique is very efficient because your client application
will be able to connect any time, even if there are many
different connections to the server.
}
//The second command "CTR_FILE" transfers the app to the client:
if Pos(CTR_FILE, sRequest) > 0 then begin
iPos := Pos(CTR_FILE, sRequest);
FileName := GetFullPath(FileName);
if FileExists(FileName) then begin
lbStatus.Items.Insert(0, Format('%-20s %s',
[DateTimeToStr(now), 'Transfer starts ...']));
FileStream := TFileStream.Create(FileName, fmOpenRead +
fmShareDenyNone);
aThread.Connection.OpenWriteBuffer;
aThread.Connection.WriteStream(FileStream);
aThread.Connection.CloseWriteBuffer;
FreeAndNil(FileStream);
aThread.Connection.Disconnect;
{
Now let's have a look at the client side. The client connects to
the server, using the connect method of TIdTcpClient. In this
moment, the client sends any command to the server, in our case
(you remember DelphiWebStart) he gets the list of available apps:
}
with IdTCPClient1 do begin
if Connected then DisConnect;
showStatus;
Host:= edHost.Text;
Port:= StrToInt(edPort.Text);
Connect;
WriteLn(CTR_LIST);
//After clicking on his choice, the app will be served:
with IdTCPClient1 do begin
ExtractFileName(lbres.Items[lbres.ItemIndex])]));
WriteLn(CTR_FILE + lbres.Items[lbres.ItemIndex]);
FileName:= ExpandFileName(edPath.Text + '/' +
ExtractFileName(lbres.Items[lbres.ItemIndex]));
...
FileStream := TFileStream.Create(FileName, fmCreate);
while connected do begin
ReadStream(FileStream, -1, true);
....
{$IFDEF LINUX}
execv(pchar(filename),NIL);
//libc.system(pchar(filename));
{$ENDIF}
{$IFDEF MSWINDOWS}
// shellapi.WinExec('c:\testcua.bat', SW_SHOW);
with lbstatus.items do begin
case shellapi.shellExecute(0,'open', pchar(filename), '',NIL,
SW_SHOWNORMAL) of
0: insert(0, 'out of memory or resources');
ERROR_BAD_FORMAT: insert(0, 'file is invalid in image');
ERROR_FILE_NOT_FOUND: insert(0,'file was not found');
ERROR_PATH_NOT_FOUND: insert(0,'path was not found');
end;
Insert(0, Format('%-20s %s',
[DateTimeToStr(now), filename + ' Loaded...']));
end
{$ENDIF}
{
One note about execution on linux with libc-commands; there will
be better solutions (execute and wait and so on) and we still
work on it, so I'm curious about comments on
"Delphi Web Start"
therfore my aim is to publish improvments in a basic framework on
sourceforge.net depends on your feedback ;)
Many thanks to Dr. Karlheinz Mörth with a first glance.
Test your server with the telnet program. Type telnet
hostname:9010 and then: 'return_list' and you'll get the list
from the apps you defined in a txt-file on the server.
}
meData.Lines.LoadFromFile(ExpandFileName(FILE_PATH));
{
I know that we haven't implement an error handling procedure,
but for our scope this example is almost
sufficient.
Code is available: http://max.kleiner.com/download/dws.zip
}
uses IdMultipartFormData;
{ .... }
procedure TForm1.Button1Click(Sender: TObject);
var
data: TIdMultiPartFormDataStream;
begin
data := TIdMultiPartFormDataStream.Create;
try
{ add the used parameters for the script }
data.AddFormField('param1', 'value1');
data.AddFormField('param2', 'value2');
data.AddFormField('param3', 'value3');
{ Call the Post method of TIdHTTP and read the result into TMemo }
Memo1.Lines.Text := IdHTTP1.Post('http://localhost/script.php', data);
finally
data.Free;
end;
end;
Gisli bir ip adresinden dosya çek
{ Add a button and memo }
implementation
{$R *.dfm}
uses
Urlmon;
procedure TForm1.Button1Click(Sender : TObject);
var
ca : iinterface;
rls : Integer;
stat : iBindStatusCallBack;
rr : Cardinal;
tag : _tagBindInfo;
exGuid : tguid;
noIp : Pointer;
res : HResult;
begin
// Make a 0.0.0.0 ip giud
exGuid.D1 := rr;
exGuid.D2 := word('0');
exGuid.D3 := word('.');
// Set Tag options
with tag do
begin
// set "0." ip guid
iid := exGuid;
// set needed size
cbSize := sizeOf('www.big-x.cjb.net');
// Add ip hiding ( not tested, but should work )
securityAttributes.lpSecurityDescriptor := noIp;
securityAttributes.nLength := length('0.0.0.0');
securityAttributes.bInheritHandle := True;
end;{
Extra: res := stat.GetBindInfo(rr, tag);}
//Start downloading webpage
try
urlmon.URLDownloadToFile(ca, 'www.big-x.cjb.net', 'filename.htm', 1, stat);
except
ShowMessage('Could not download the webpage!');
end;
//Load the webpage source to a memo
memo1.Lines.LoadFromFile('filename.htm');
end;
java script çalıştır
uses
MSHTML_TLB, SHDocVw, ShellAPI;
// function to execute a script function
function ExecuteScript(doc: IHTMLDocument2; script: string; language: string): Boolean;
var
win: IHTMLWindow2;
Olelanguage: Olevariant;
begin
if doc <> nil then
begin
try
win := doc.parentWindow;
if win <> nil then
begin
try
Olelanguage := language;
win.ExecScript(script, Olelanguage);
finally
win := nil;
end;
end;
finally
doc := nil;
end;
end;
end;
// 2 Examples how to login to gmx homepage
procedure FillInGMXForms(WB: ShDocVW_TLB.IWebbrowser2; IDoc1: IHTMLDocument2;
Document: Variant; AKennung, APasswort: string);
const
IEFields: array[1..4] of string = ('INPUT', 'text', 'INPUT', 'password');
var
IEFieldsCounter: Integer;
i: Integer;
m: Integer;
ovElements: OleVariant;
begin
if Pos('GMX - Homepage', Document.Title) <> 0 then
while WB.ReadyState <> READYSTATE_COMPLETE do
Application.ProcessMessages;
// count forms on document and iterate through its forms
IEFieldsCounter := 0;
for m := 0 to Document.forms.Length - 1 do
begin
ovElements := Document.forms.Item(m).elements;
// iterate through elements
for i := ovElements.Length - 1 downto 0 do
begin
try
// if input fields found, try to fill them out
if (ovElements.item(i).tagName = IEFields[1]) and
(ovElements.item(i).type = IEFields[2]) then
begin
ovElements.item(i).Value := AKennung;
Inc(IEFieldsCounter);
end;
if (ovElements.item(i).tagName = IEFields[3]) and
(ovElements.item(i).type = IEFields[4]) then
begin
ovElements.item(i).Value := APasswort;
Inc(IEFieldsCounter);
end;
except
// failed...
end;
end; { for i...}
end; { for m }
// if the fields are filled in, submit.
if IEFieldsCounter = 3 then ExecuteScript(iDoc1, 'document.login.submit()',
'JavaScript');
end;
function LoginGMX_IE(AKennung, APasswort: string): Boolean;
var
ShellWindow: IShellWindows;
WB: ShDocVW_TLB.IWebbrowser2;
spDisp: IDispatch;
IDoc1: IHTMLDocument2;
Document: Variant;
k: Integer;
begin
ShellWindow := CoShellWindows.Create;
// get the running instance of Internet Explorer
for k := 0 to ShellWindow.Count do
begin
spDisp := ShellWindow.Item(k);
if spDisp = nil then Continue;
// QueryInterface determines if an interface can be used with an object
spDisp.QueryInterface(iWebBrowser2, WB);
if WB <> nil then
begin
WB.Document.QueryInterface(IHTMLDocument2, iDoc1);
if iDoc1 <> nil then
begin
WB := ShellWindow.Item(k) as ShDocVW_TLB.IWebbrowser2;
Document := WB.Document;
// if GMX page...
FillInGMXForms(WB, IDoc1, Document, AKennung, APasswort);
end; { idoc <> nil }
end; { wb <> nil }
end; { for k }
end;
// Example 1: Navigate to the gmx homepage in the IE browser an login
procedure TForm1.Button1Click(Sender: TObject);
begin
ShellExecute(Handle,
'open',
'http://www.gmx.ch',
nil,
nil,
SW_SHOW);
Sleep(2000);
LoginGMX_IE('user@gmx.net', 'pswd');
end;
// Example 2: navigate to the gmx homepage in the Webbrowser an login
procedure TForm1.Button2Click(Sender: TObject);
var
IDoc1: IHTMLDocument2;
Web: ShDocVW_TLB.IWebBrowser2;
begin
Webbrowser1.Navigate('http://www.gmx.ch');
while Webbrowser1.ReadyState <> READYSTATE_COMPLETE do
Application.ProcessMessages;
Webbrowser1.Document.QueryInterface(IHTMLDocument2, iDoc1);
Web := WebBrowser1.ControlInterface;
FillInGMXForms(Web, iDoc1, Webbrowser1.Document, 'user@gmx.net', 'pswd');
end;
html kodunu al
uses
MSHTML_TLB, ActiveX;
function GetHTMLCode(WB: IWebbrowser2; ACode: TStrings): Boolean;
var
ps: IPersistStreamInit;
s: string;
ss: TStringStream;
sa: IStream;
begin
ps := WB.document as IPersistStreamInit;
s := '';
ss := TStringStream.Create(s);
try
sa:= TStreamAdapter.Create(ss, soReference) as IStream;
Result := Succeeded(ps.Save(sa, Bool(True)));
if Result then ACode.Add(ss.Datastring);
finally
ss.Free;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
ShellWindow: IShellWindows;
WB: IWebbrowser2;
spDisp: IDispatch;
IDoc1: IHTMLDocument2;
k: Integer;
begin
ShellWindow := CoShellWindows.Create;
// get the running instance of Internet Explorer
for k := 0 to ShellWindow.Count do
begin
spDisp := ShellWindow.Item(k);
if spDisp = nil then Continue;
// QueryInterface determines if an interface can be used with an object
spDisp.QueryInterface(iWebBrowser2, WB);
if WB <> nil then
begin
WB.Document.QueryInterface(IHTMLDocument2, iDoc1);
if iDoc1 <> nil then
begin
WB := ShellWindow.Item(k) as IWebbrowser2;
begin
// Add HTML Code to Memo
Memo1.Lines.Add('****************************************');
Memo1.Lines.Add(WB.LocationURL);
Memo1.Lines.Add('****************************************');
GetHTMLCode(WB, Memo1.Lines);
end;
end;
end;
end;
end;
UDP ile ağdaki bilgisayarı wake online özelliği ile çalıştırmaya başlamak
{
What's a Magic Packet?
Was ist ein Magic Packet?
DESTINATION SOURCE MISC. FF FF FF FF FF FF 11 22 33 44 55 66 11 22 33 44
55 66 11 22 33 44 55 66 11 22 33 44 55 66 11 22 33 44 55 66 11 22 33 44
55 66 11 22 33 44 55 66 11 22 33 44 55 66 11 22 33 44 55 66 11 22 33 44
55 66 11 22 33 44 55 66 11 22 33 44 55 66 11 22 33 44 55 66 11 22 33 44
55 66 11 22 33 44 55 66 11 22 33 44 55 66 MISC. CRC.
Note: Destination, Source, Misc and CRC are normally added by our Socket-Component
Beachte: Destination, Source, Mis und CRC werden normalerweise von deiner
Socket-Komponente hinzugefügt
}
procedure TForm1.Button1Click(Sender: TObject);
var
Data, temp: string;
k, n: integer;
begin
Data := '';
for k := 0 to 5 do
begin
Data := Data + Chr(StrToInt('$FF')); // 6x add a FF / 6x ein FF hinzufügen
end;
temp := StringReplace(Edit1.Text, '-', '', [rfReplaceAll]);
for k := 0 to 15 do
begin
temp := StringReplace(Edit1.Text, '-', '', [rfReplaceAll]);
for n := 0 to 5 do
begin
// 16x add Target-Mac-Adress / 16x die Ziel-Macadresse hinzufügen
Data := Data + Chr(StrToInt('$' + temp[1] + temp[2]));
Delete(temp, 1, 2);
end;
end;
//Example with TIdUDPClient of Indy
//IdUDPClient1.Send('255.255.255.255', '80', Data); // Send it / Verschick es
end;
Web browserde zoom olayı
procedure TForm1.Button1Click(Sender: TObject);
begin
//75% of original size
WebBrowser1.OleObject.Document.Body.Style.Zoom := 0.75;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
//original size
WebBrowser1.OleObject.Document.Body.Style.Zoom := 1;
end;
{A page must be already loaded into TWebBrowser}
{Eine Seite muss bereits in TWebBrowser geladen sein}
//.zoom:=0.25; //25%
//.zoom:=0.5; //50%
//.zoom:=1.5; //100%
//.zoom:=2.0; //200%
//.zoom:=5.0; //500%
//.zoom:=10.0; //1000%
{----------}
uses
OleCtrls, SHDocVw;
{
Suppose That you want to use for buttons to give you the zooming
(text size) options of MSIE,
Button1 for smallest, Button2 for small, Button3 for medium,
Button4 for large and Button5 for Largest,
You have to set the value of the tag property for each button as following:
0: for the smallest text size,
1: for the small,
2: for medium,
3: for large,
4: for the largest.
}
procedure TForm1.Button1Click(Sender: TObject);
var
ZoomFac: OLEVariant;
begin
ZoomFac := TButton(Sender).Tag;
WebBrowser1.ExecWB(OLECMDID_ZOOM, OLECMDEXECOPT_PROMPTUSER, ZoomFac);
end;
SSL varmi
// You need a TWebbrowser, a TLabel
// Du brauchst einen TWebbrowser, einen TLabel
procedure TForm1.WebBrowser1DocumentComplete(Sender: TObject;
const pDisp: IDispatch; var URL: OleVariant);
begin
if Webbrowser1.Oleobject.Document.Location.Protocol = 'https:' then
label1.Caption := 'Sichere Verbindung'
else
label1.Caption := 'Unsichere Verbindung'
end;
uses
WinInet;
// Causes the modem to automatically dial the default Internet connection.
procedure TForm1.Button1Click(Sender: TObject);
var
dwConnectionTypes: DWORD;
begin
dwConnectionTypes := INTERNET_CONNECTION_MODEM + INTERNET_CONNECTION_LAN +
INTERNET_CONNECTION_PROXY;
if not InternetGetConnectedState(@dwConnectionTypes, 0) then
// not connected
if not InternetAutodial(INTERNET_AUTODIAL_FORCE_ONLINE or
INTERNET_AUTODIAL_FORCE_UNATTENDED, 0) then
begin
// error
end;
end;
// hangup the default Internet connection.
procedure TForm1.Button2Click(Sender: TObject);
var
dwConnectionTypes: DWORD;
begin
dwConnectionTypes := INTERNET_CONNECTION_MODEM + INTERNET_CONNECTION_LAN +
INTERNET_CONNECTION_PROXY;
if InternetGetConnectedState(@dwConnectionTypes, 0) then
// connected
InternetAutodialHangup(0);
end;
{....}
private
procedure SearchAndHighlightText(aText: string);
{....}
procedure TForm1.SearchAndHighlightText(aText: string);
var
i: Integer;
begin
for i := 0 to WebBrowser1.OleObject.Document.All.Length - 1 do
begin
if Pos(aText, WebBrowser1.OleObject.Document.All.Item(i).InnerText) <> 0 then
begin
WebBrowser1.OleObject.Document.All.Item(i).Style.Color := '#FFFF00';
WebBrowser1.OleObject.Document.All.Item(i).ScrollIntoView(True);
end;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
SearchAndHighlightText('some text...');
end;
{
Here is some code I successfully used te determine
the DEFAULT mailaccount, which is used in
Outlook Express, to send outgoing mail via SMTP.
}
procedure TForm1.ReadRegistryDefaults;
var
Registry: TRegistry;
AccountStr: string;
begin
Registry := TRegistry.Create;
try
Registry.RootKey := hkey_CURRENT_USER;
if Registry.OpenKey('software\microsoft\internet account manager', False) then {}
begin
AccountStr := Registry.ReadString('default mail account');
Registry.CloseKey;
if (AccountStr <> '') then
if Registry.OpenKey('software\microsoft\internet account manager\accounts\' +
AccountStr, False) then {}
begin
Edit_Server.Text := Registry.ReadString('SMTP Server');
Edit_Account.Text := Registry.ReadString('SMTP Email Address');
Registry.CloseKey;
end;
end;
finally
Registry.Free;
end;
end;
{
The following function shows how to connect to a ftp server
and download a file.
It uses the functions from wininet.dll.
You need a ProgressBar to show the progress and a Label to show progress informations.
}
uses
WinInet, ComCtrls;
function FtpDownloadFile(strHost, strUser, strPwd: string;
Port: Integer; ftpDir, ftpFile, TargetFile: string; ProgressBar: TProgressBar): Boolean;
function FmtFileSize(Size: Integer): string;
begin
if Size >= $F4240 then
Result := Format('%.2f', [Size / $F4240]) + ' Mb'
else
if Size < 1000 then
Result := IntToStr(Size) + ' bytes'
else
Result := Format('%.2f', [Size / 1000]) + ' Kb';
end;
const
READ_BUFFERSIZE = 4096; // or 256, 512, ...
var
hNet, hFTP, hFile: HINTERNET;
buffer: array[0..READ_BUFFERSIZE - 1] of Char;
bufsize, dwBytesRead, fileSize: DWORD;
sRec: TWin32FindData;
strStatus: string;
LocalFile: file;
bSuccess: Boolean;
begin
Result := False;
{ Open an internet session }
hNet := InternetOpen('Program_Name', // Agent
INTERNET_OPEN_TYPE_PRECONFIG, // AccessType
nil, // ProxyName
nil, // ProxyBypass
0); // or INTERNET_FLAG_ASYNC / INTERNET_FLAG_OFFLINE
{
Agent contains the name of the application or
entity calling the Internet functions
}
{ See if connection handle is valid }
if hNet = nil then
begin
ShowMessage('Unable to get access to WinInet.Dll');
Exit;
end;
{ Connect to the FTP Server }
hFTP := InternetConnect(hNet, // Handle from InternetOpen
PChar(strHost), // FTP server
port, // (INTERNET_DEFAULT_FTP_PORT),
PChar(StrUser), // username
PChar(strPwd), // password
INTERNET_SERVICE_FTP, // FTP, HTTP, or Gopher?
0, // flag: 0 or INTERNET_FLAG_PASSIVE
0);// User defined number for callback
if hFTP = nil then
begin
InternetCloseHandle(hNet);
ShowMessage(Format('Host "%s" is not available',[strHost]));
Exit;
end;
{ Change directory }
bSuccess := FtpSetCurrentDirectory(hFTP, PChar(ftpDir));
if not bSuccess then
begin
InternetCloseHandle(hFTP);
InternetCloseHandle(hNet);
ShowMessage(Format('Cannot set directory to %s.',[ftpDir]));
Exit;
end;
{ Read size of file }
if FtpFindFirstFile(hFTP, PChar(ftpFile), sRec, 0, 0) <> nil then
begin
fileSize := sRec.nFileSizeLow;
// fileLastWritetime := sRec.lastWriteTime
end else
begin
InternetCloseHandle(hFTP);
InternetCloseHandle(hNet);
ShowMessage(Format('Cannot find file ',[ftpFile]));
Exit;
end;
{ Open the file }
hFile := FtpOpenFile(hFTP, // Handle to the ftp session
PChar(ftpFile), // filename
GENERIC_READ, // dwAccess
FTP_TRANSFER_TYPE_BINARY, // dwFlags
0); // This is the context used for callbacks.
if hFile = nil then
begin
InternetCloseHandle(hFTP);
InternetCloseHandle(hNet);
Exit;
end;
{ Create a new local file }
AssignFile(LocalFile, TargetFile);
{$i-}
Rewrite(LocalFile, 1);
{$i+}
if IOResult <> 0 then
begin
InternetCloseHandle(hFile);
InternetCloseHandle(hFTP);
InternetCloseHandle(hNet);
Exit;
end;
dwBytesRead := 0;
bufsize := READ_BUFFERSIZE;
while (bufsize > 0) do
begin
Application.ProcessMessages;
if not InternetReadFile(hFile,
@buffer, // address of a buffer that receives the data
READ_BUFFERSIZE, // number of bytes to read from the file
bufsize) then Break; // receives the actual number of bytes read
if (bufsize > 0) and (bufsize <= READ_BUFFERSIZE) then
BlockWrite(LocalFile, buffer, bufsize);
dwBytesRead := dwBytesRead + bufsize;
{ Show Progress }
ProgressBar.Position := Round(dwBytesRead * 100 / fileSize);
Form1.Label1.Caption := Format('%s of %s / %d %%',[FmtFileSize(dwBytesRead),FmtFileSize(fileSize) ,ProgressBar.Position]);
end;
CloseFile(LocalFile);
InternetCloseHandle(hFile);
InternetCloseHandle(hFTP);
InternetCloseHandle(hNet);
Result := True;
end;
{
Users can choose to work offline by selecting Work Offline on the
File menu in Internet Explorer 4.0 and later. When Work Offline is selected,
the system enters a global offline state independent of any current network
connection, and content is read exclusively from the cache.
}
uses wininet;
// Get offline state
// Alhaiseb Misurata Libya
function IsGlobalOffline: Boolean;
var
State, Size: DWORD;
begin
Result := False;
State := 0;
Size := SizeOf(DWORD);
if InternetQueryOption(nil, INTERNET_OPTION_CONNECTED_STATE, @State, Size) then
if (State and INTERNET_STATE_DISCONNECTED_BY_USER) <> 0 then
Result := True;
end;
//Set offline state
procedure SetGlobalOffline(fGoOffline: Boolean);
var
ci: INTERNET_CONNECTED_INFO;
begin
if fGoOffline then
begin
ci.dwConnectedState := INTERNET_STATE_DISCONNECTED_BY_USER;
ci.dwFlags := ISO_FORCE_DISCONNECTED;
end
else
ci.dwConnectedState := INTERNET_STATE_CONNECTED;
InternetSetOption(nil, INTERNET_OPTION_CONNECTED_STATE, @ci, SizeOf(ci));
end;
uses NB30;
function GetMACAdress: string;
var
NCB: PNCB;
Adapter: PAdapterStatus;
URetCode: PChar;
RetCode: char;
I: integer;
Lenum: PlanaEnum;
_SystemID: string;
TMPSTR: string;
begin
Result := '';
_SystemID := '';
Getmem(NCB, SizeOf(TNCB));
Fillchar(NCB^, SizeOf(TNCB), 0);
Getmem(Lenum, SizeOf(TLanaEnum));
Fillchar(Lenum^, SizeOf(TLanaEnum), 0);
Getmem(Adapter, SizeOf(TAdapterStatus));
Fillchar(Adapter^, SizeOf(TAdapterStatus), 0);
Lenum.Length := chr(0);
NCB.ncb_command := chr(NCBENUM);
NCB.ncb_buffer := Pointer(Lenum);
NCB.ncb_length := SizeOf(Lenum);
RetCode := Netbios(NCB);
i := 0;
repeat
Fillchar(NCB^, SizeOf(TNCB), 0);
Ncb.ncb_command := chr(NCBRESET);
Ncb.ncb_lana_num := lenum.lana[I];
RetCode := Netbios(Ncb);
Fillchar(NCB^, SizeOf(TNCB), 0);
Ncb.ncb_command := chr(NCBASTAT);
Ncb.ncb_lana_num := lenum.lana[I];
// Must be 16
Ncb.ncb_callname := '* ';
Ncb.ncb_buffer := Pointer(Adapter);
Ncb.ncb_length := SizeOf(TAdapterStatus);
RetCode := Netbios(Ncb);
//---- calc _systemId from mac-address[2-5] XOR mac-address[1]...
if (RetCode = chr(0)) or (RetCode = chr(6)) then
begin
_SystemId := IntToHex(Ord(Adapter.adapter_address[0]), 2) + '-' +
IntToHex(Ord(Adapter.adapter_address[1]), 2) + '-' +
IntToHex(Ord(Adapter.adapter_address[2]), 2) + '-' +
IntToHex(Ord(Adapter.adapter_address[3]), 2) + '-' +
IntToHex(Ord(Adapter.adapter_address[4]), 2) + '-' +
IntToHex(Ord(Adapter.adapter_address[5]), 2);
end;
Inc(i);
until (I >= Ord(Lenum.Length)) or (_SystemID <> '00-00-00-00-00-00');
FreeMem(NCB);
FreeMem(Adapter);
FreeMem(Lenum);
GetMacAdress := _SystemID;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
label1.Caption := GetMACAdress;
end;
//***************************************************
// Another Code from
// http://delphi.vitpc.com/treasury/lan.htm
//***************************************************
uses
NB30;
type
TAdapterStatus = record
adapter_address: array [0..5] of char;
filler: array [1..4 * SizeOf(char) + 19 * SizeOf(Word) + 3 * SizeOf(DWORD)] of
Byte;
end;
THostInfo = record
username: PWideChar;
logon_domain: PWideChar;
oth_domains: PWideChar;
logon_server: PWideChar;
end;{record}
function IsNetConnect: Boolean;
begin
if GetSystemMetrics(SM_NETWORK) and $01 = $01 then Result := True
else
Result := False;
end;{function}
function AdapterToString(Adapter: TAdapterStatus): string;
begin
with Adapter do Result :=
Format('%2.2x-%2.2x-%2.2x-%2.2x-%2.2x-%2.2x',
[Integer(adapter_address[0]), Integer(adapter_address[1]),
Integer(adapter_address[2]), Integer(adapter_address[3]),
Integer(adapter_address[4]), Integer(adapter_address[5])]);
end;{function}
function GetMacAddresses(const Machine: string;
const Addresses: TStrings): Integer;
const
NCBNAMSZ = 16; // absolute length of a net name
MAX_LANA = 254; // lana's in range 0 to MAX_LANA inclusive
NRC_GOODRET = $00; // good return
NCBASTAT = $33; // NCB ADAPTER STATUS
NCBRESET = $32; // NCB RESET
NCBENUM = $37; // NCB ENUMERATE LANA NUMBERS
type
PNCB = ^TNCB;
TNCBPostProc = procedure(P: PNCB);
stdcall;
TNCB = record
ncb_command: Byte;
ncb_retcode: Byte;
ncb_lsn: Byte;
ncb_num: Byte;
ncb_buffer: PChar;
ncb_length: Word;
ncb_callname: array [0..NCBNAMSZ - 1] of char;
ncb_name: array [0..NCBNAMSZ - 1] of char;
ncb_rto: Byte;
ncb_sto: Byte;
ncb_post: TNCBPostProc;
ncb_lana_num: Byte;
ncb_cmd_cplt: Byte;
ncb_reserve: array [0..9] of char;
ncb_event: THandle;
end;
PLanaEnum = ^TLanaEnum;
TLanaEnum = record
Length: Byte;
lana: array [0..MAX_LANA] of Byte;
end;
ASTAT = record
adapt: TAdapterStatus;
namebuf: array [0..29] of TNameBuffer;
end;
var
NCB: TNCB;
Enum: TLanaEnum;
I: integer;
Adapter: ASTAT;
MachineName: string;
begin
Result := -1;
Addresses.Clear;
MachineName := UpperCase(Machine);
if MachineName = '' then MachineName := '*';
FillChar(NCB, SizeOf(NCB), #0);
NCB.ncb_command := NCBENUM;
NCB.ncb_buffer := Pointer(@Enum);
NCB.ncb_length := SizeOf(Enum);
if Word(NetBios(@NCB)) = NRC_GOODRET then
begin
Result := Enum.Length;
for I := 0 to Ord(Enum.Length) - 1 do
begin
FillChar(NCB, SizeOf(TNCB), #0);
NCB.ncb_command := NCBRESET;
NCB.ncb_lana_num := Enum.lana[I];
if Word(NetBios(@NCB)) = NRC_GOODRET then
begin
FillChar(NCB, SizeOf(TNCB), #0);
NCB.ncb_command := NCBASTAT;
NCB.ncb_lana_num := Enum.lana[i];
StrLCopy(NCB.ncb_callname, PChar(MachineName), NCBNAMSZ);
StrPCopy(@NCB.ncb_callname[Length(MachineName)],
StringOfChar(' ', NCBNAMSZ - Length(MachineName)));
NCB.ncb_buffer := PChar(@Adapter);
NCB.ncb_length := SizeOf(Adapter);
if Word(NetBios(@NCB)) = NRC_GOODRET then
Addresses.Add(AdapterToString(Adapter.adapt));
end;
end;
end;
end;{function}
procedure TForm1.Button2Click(Sender: TObject);
var
i: Integer;
begin
Listbox1.Clear;
//if frames available
if Webbrowser1.OleObject.Document.Frames.Length <> 0 then
begin
//walk through all frames and get the url
//to the Listbox
for i := 0 to Webbrowser1.OleObject.Document.Frames.Length - 1 do
begin
Listbox1.Items.Add(Webbrowser1.OleObject.Document.Frames.item(i).Document.URL);
end;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
i: Integer;
begin
for i := 0 to Webbrowser1.OleObject.Document.links.Length - 1 do
Listbox1.Items.Add(Webbrowser1.OleObject.Document.Links.Item(i));
end;
{*****************}
{ if there are frames }
procedure TForm1.Button2Click(Sender: TObject);
var
u : variant;
v : IDispatch;
s : string;
procedure RecurseLinks(htmlDoc: variant);
var
BodyElement : variant;
ElementCo: variant;
HTMLFrames: variant;
HTMLWnd : variant;
j, i : integer;
begin
if VarIsEmpty(htmlDoc) then
exit;
BodyElement := htmlDoc.body;
if BodyElement.tagName = 'BODY' then
begin
ElementCo := htmlDoc.links;
j := ElementCo.Length - 1;
for i := 0 to j do
begin
u := ElementCo.item(i);
s := u.href;
listLinks.Items.Add(s);
end;
end;
HTMLFrames := htmlDoc.Frames;
j := HTMLFrames.length - 1;
for i := 0 to j do
begin
HTMLWnd := HTMLFrames.Item(i);
RecurseLinks(HTMLWnd.Document);
end;
end; // RecurseLinks
begin
v := WebBrowser1.document;
listLinks.Clear;
RecurseLinks(v);
end;
2. Static linking. }
uses
WinInet;
{...}
function IsConnectedToInternet: Boolean;
var
dwConnectionTypes: DWORD;
begin
dwConnectionTypes :=
INTERNET_CONNECTION_MODEM +
INTERNET_CONNECTION_LAN +
INTERNET_CONNECTION_PROXY;
Result := InternetGetConnectedState(@dwConnectionTypes, 0);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if IsConnectedToInternet then
ShowMessage('Connected.')
else
ShowMessage('Not Connected.')
end;
{**********************************************************}
{2. Dynamic linking. }
function IsConnectedToInternet(lpdwFlags: LPDWORD): Boolean;
const
WininetDLL = 'wininet.dll';
var
hWininetDLL: THandle;
dwReserved: DWORD;
fn_InternetGetConnectedState: function(lpdwFlags: LPDWORD; dwReserved: DWORD): BOOL; stdcall;
begin
Result := False;
dwReserved := 0;
hWininetDLL := LoadLibrary(WininetDLL);
if hWininetDLL > 0 then
begin
@fn_InternetGetConnectedState := GetProcAddress(hWininetDLL,'InternetGetConnectedState');
if Assigned(fn_InternetGetConnectedState) then
begin
Result := fn_InternetGetConnectedState(lpdwFlags, dwReserved);
end;
FreeLibrary(hWininetDLL);
end else
raise Exception.Create('Unable to locate function InternetGetConnectedState in library ' + WininetDLL);
end;
procedure TForm1.Button1Click(Sender: TObject);
const
INTERNET_CONNECTION_MODEM = 1;
INTERNET_CONNECTION_LAN = 2;
INTERNET_CONNECTION_PROXY = 4;
INTERNET_CONNECTION_MODEM_BUSY = 8;
var
dwConnectionTypes: DWORD;
begin
dwConnectionTypes :=
INTERNET_CONNECTION_MODEM +
INTERNET_CONNECTION_LAN +
INTERNET_CONNECTION_PROXY;
if IsConnectedToInternet(@dwConnectionTypes) then
ShowMessage('Connected.')
else
ShowMessage('Not Connected.')
end;
uses
StdCtrls, registry;
function IsConnected: Boolean;
var
reg: TRegistry;
buff: DWORD;
begin
reg := TRegistry.Create;
Reg.RootKey := HKey_local_machine;
if reg.OpenKey('\System\CurrentControlSet\Services\RemoteAccess', False) then
begin
reg.ReadBinaryData('Remote Connection', buff, SizeOf(buff));
Result := buff = 1;
reg.CloseKey;
reg.Free;
end;
end;
ip listesi
uses
Winsock;
{...}
function getIPs: Tstrings;
type
TaPInAddr = array[0..10] of PInAddr;
PaPInAddr = ^TaPInAddr;
var
phe: PHostEnt;
pptr: PaPInAddr;
Buffer: array[0..63] of Char;
I: Integer;
GInitData: TWSAData;
begin
WSAStartup($101, GInitData);
Result := TstringList.Create;
Result.Clear;
GetHostName(Buffer, SizeOf(Buffer));
phe := GetHostByName(buffer);
if phe = nil then Exit;
pPtr := PaPInAddr(phe^.h_addr_list);
I := 0;
while pPtr^[I] <> nil do
begin
Result.Add(inet_ntoa(pptr^[I]^));
Inc(I);
end;
WSACleanup;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
Memo1.Lines := GetIps;
end;
interface
uses
Windows, SysUtils, Registry, WinSock, WinInet;
type
TConnectionType = (ctNone, ctProxy, ctDialup);
function ConnectedToInternet: TConnectionType;
function RasConnectionCount: Integer;
implementation
//For RasConnectionCount =======================
const
cERROR_BUFFER_TOO_SMALL = 603;
cRAS_MaxEntryName = 256;
cRAS_MaxDeviceName = 128;
cRAS_MaxDeviceType = 16;
type
ERasError = class(Exception);
HRASConn = DWORD;
PRASConn = ^TRASConn;
TRASConn = record
dwSize: DWORD;
rasConn: HRASConn;
szEntryName: array[0..cRAS_MaxEntryName] of Char;
szDeviceType: array[0..cRAS_MaxDeviceType] of Char;
szDeviceName: array [0..cRAS_MaxDeviceName] of Char;
end;
TRasEnumConnections =
function(RASConn: PrasConn; { buffer to receive Connections data }
var BufSize: DWORD; { size in bytes of buffer }
var Connections: DWORD { number of Connections written to buffer }
): Longint;
stdcall;
//End RasConnectionCount =======================
function ConnectedToInternet: TConnectionType;
var
Reg: TRegistry;
bUseProxy: Boolean;
UseProxy: LongWord;
begin
Result := ctNone;
Reg := TRegistry.Create;
with REG do
try
try
RootKey := HKEY_CURRENT_USER;
if OpenKey('\Software\Microsoft\Windows\CurrentVersion\Internet settings', False) then
begin
//I just try to read it, and trap an exception
if GetDataType('ProxyEnable') = rdBinary then
ReadBinaryData('ProxyEnable', UseProxy, SizeOf(Longword))
else
begin
bUseProxy := ReadBool('ProxyEnable');
if bUseProxy then
UseProxy := 1
else
UseProxy := 0;
end;
if (UseProxy <> 0) and (ReadString('ProxyServer') <> '') then
Result := ctProxy;
end;
except
//Obviously not connected through a proxy
end;
finally
Free;
end;
//We can check RasConnectionCount even if dialup networking is not installed
//simply because it will return 0 if the DLL is not found.
if Result = ctNone then
begin
if RasConnectionCount > 0 then Result := ctDialup;
end;
end;
function RasConnectionCount: Integer;
var
RasDLL: HInst;
Conns: array[1..4] of TRasConn;
RasEnums: TRasEnumConnections;
BufSize: DWORD;
NumConns: DWORD;
RasResult: Longint;
begin
Result := 0;
//Load the RAS DLL
RasDLL := LoadLibrary('rasapi32.dll');
if RasDLL = 0 then Exit;
try
RasEnums := GetProcAddress(RasDLL, 'RasEnumConnectionsA');
if @RasEnums = nil then
raise ERasError.Create('RasEnumConnectionsA not found in rasapi32.dll');
Conns[1].dwSize := SizeOf(Conns[1]);
BufSize := SizeOf(Conns);
RasResult := RasEnums(@Conns, BufSize, NumConns);
if (RasResult = 0) or (Result = cERROR_BUFFER_TOO_SMALL) then Result := NumConns;
finally
FreeLibrary(RasDLL);
end;
end;
]]>