uses Jpeg, IdBaseComponent, IdComponent, IdTCPConnection, IdTCPClient, IdHTTP;
{ .... }
function DownloadJPGToBitmap(const URL : string; ABitmap: TBitmap): Boolean;
var
idHttp: TIdHTTP;
ImgStream: TMemoryStream;
JpgImage: TJPEGImage;
begin
Result := False;
ImgStream := TMemoryStream.Create;
try
idHttp := TIdHTTP.Create(nil);
try
idHttp.Get(URL, ImgStream);
finally
idHttp.Free;
end;
ImgStream.Position := 0;
JpgImage := TJPEGImage.Create;
try
JpgImage.LoadFromStream(ImgStream);
ABitmap.Assign(JpgImage);
finally
Result := True;
JpgImage.Free;
end;
finally
ImgStream.Free;
end;
end;
// Example:
// Beispiel:
procedure TForm1.Button1Click(Sender: TObject);
begin
DownloadJPGToBitmap('http://www.sample.com/test.jpg', Image1.Picture.Bitmap);
end;
Autor: Thomas Stutz
Retrieve all image links from an HTML document
uses mshtml, ActiveX, COMObj, IdHTTP, idURI;
{ .... }
procedure GetImageLinks(AURL: string; AList: TStrings);
var
IDoc: IHTMLDocument2;
strHTML: string;
v: Variant;
x: Integer;
ovLinks: OleVariant;
DocURL: string;
URI: TidURI;
ImgURL: string;
idHTTP: TidHTTP;
begin
AList.Clear;
URI := TidURI.Create(AURL);
try
DocURL := 'http://' + URI.Host;
if URI.Path <> '/' then
DocURL := DocURL + URI.Path;
finally
URI.Free;
end;
Idoc := CreateComObject(Class_HTMLDocument) as IHTMLDocument2;
try
IDoc.designMode := 'on';
while IDoc.readyState <> 'complete' do
Application.ProcessMessages;
v := VarArrayCreate([0, 0], VarVariant);
idHTTP := TidHTTP.Create(nil);
try
strHTML := idHTTP.Get(AURL);
finally
idHTTP.Free;
end;
v[0] := strHTML;
IDoc.Write(PSafeArray(System.TVarData(v).VArray));
IDoc.designMode := 'off';
while IDoc.readyState <> 'complete' do
Application.ProcessMessages;
ovLinks := IDoc.all.tags('IMG');
if ovLinks.Length > 0 then
begin
for x := 0 to ovLinks.Length - 1 do
begin
ImgURL := ovLinks.Item(x).src;
// The stuff below will probably need a little tweaking
// Deteriming and turning realtive URLs into absolute URLs
// is not that difficult but this is all I could come up with
// in such a short notice.
if (ImgURL[1] = '/') then
begin
// more than likely a relative URL so
// append the DocURL
ImgURL := DocURL + ImgUrl;
end
else
begin
if (Copy(ImgURL, 1, 11) = 'about:blank') then
begin
ImgURL := DocURL + Copy(ImgUrl, 12, Length(ImgURL));
end;
end;
AList.Add(ImgURL);
end;
end;
finally
IDoc := nil;
end;
end;
// Beispiel:
// Example:
procedure TForm1.Button1Click(Sender: TObject);
begin
GetImageLinks('http://delphimagic.blogspot.com', Memo1.Lines);
end;
{ .... }
procedure GetImageLinks(AURL: string; AList: TStrings);
var
IDoc: IHTMLDocument2;
strHTML: string;
v: Variant;
x: Integer;
ovLinks: OleVariant;
DocURL: string;
URI: TidURI;
ImgURL: string;
idHTTP: TidHTTP;
begin
AList.Clear;
URI := TidURI.Create(AURL);
try
DocURL := 'http://' + URI.Host;
if URI.Path <> '/' then
DocURL := DocURL + URI.Path;
finally
URI.Free;
end;
Idoc := CreateComObject(Class_HTMLDocument) as IHTMLDocument2;
try
IDoc.designMode := 'on';
while IDoc.readyState <> 'complete' do
Application.ProcessMessages;
v := VarArrayCreate([0, 0], VarVariant);
idHTTP := TidHTTP.Create(nil);
try
strHTML := idHTTP.Get(AURL);
finally
idHTTP.Free;
end;
v[0] := strHTML;
IDoc.Write(PSafeArray(System.TVarData(v).VArray));
IDoc.designMode := 'off';
while IDoc.readyState <> 'complete' do
Application.ProcessMessages;
ovLinks := IDoc.all.tags('IMG');
if ovLinks.Length > 0 then
begin
for x := 0 to ovLinks.Length - 1 do
begin
ImgURL := ovLinks.Item(x).src;
// The stuff below will probably need a little tweaking
// Deteriming and turning realtive URLs into absolute URLs
// is not that difficult but this is all I could come up with
// in such a short notice.
if (ImgURL[1] = '/') then
begin
// more than likely a relative URL so
// append the DocURL
ImgURL := DocURL + ImgUrl;
end
else
begin
if (Copy(ImgURL, 1, 11) = 'about:blank') then
begin
ImgURL := DocURL + Copy(ImgUrl, 12, Length(ImgURL));
end;
end;
AList.Add(ImgURL);
end;
end;
finally
IDoc := nil;
end;
end;
// Beispiel:
// Example:
procedure TForm1.Button1Click(Sender: TObject);
begin
GetImageLinks('http://delphimagic.blogspot.com', Memo1.Lines);
end;
Connect/Disconnect network drives
//we could use the standard dialog to have the user do it
procedure TForm1.Button1Click(Sender: TObject);
begin
WNetConnectionDialog(Handle, RESOURCETYPE_DISK)
end;
//we can use the same to connect a printer
procedure TForm1.Button1Click(Sender: TObject);
begin
WNetConnectionDialog(Handle, RESOURCETYPE_PRINT)
end;
//or we can do this by code
procedure TForm1.Button2Click(Sender: TObject);
var
NetResource: TNetResource;
begin
{ fill out TNetResource record structure }
NetResource.dwType := RESOURCETYPE_DISK;
NetResource.lpLocalName := 'S:';
NetResource.lpRemoteName := '\\myserver\public';
NetResource.lpProvider := '';
{ map our network drive using our TNetResource record structure }
if (WNetAddConnection2(NetResource,
'', {Password (if needed) or empty}
'', {User name (if needed) or empty}
CONNECT_UPDATE_PROFILE) <> NO_ERROR) then
raise Excepcion.Create('unable to map drive')
//there are other constants to check the error
//ERROR_ACCESS_DENIED, ERROR_ALREADY_ASSIGNED, etc
end;
//to disconnect it simply...
procedure TForm1.Button2Click(Sender: TObject);
begin
if WNetCancelConnection2('S:', 0, TRUE) <> NO_ERROR then
raise Exception.create('Error disconnecting map drive');
//of course there are also some other constants to check why the error
//occurred: ERROR_DEVICE_IN_USE, ERROR_NOT_CONNECTED, etc
end;
Author: Eber Irigoyen
Product: Delphi 2.x (or higher)
procedure TForm1.Button1Click(Sender: TObject);
begin
WNetConnectionDialog(Handle, RESOURCETYPE_DISK)
end;
//we can use the same to connect a printer
procedure TForm1.Button1Click(Sender: TObject);
begin
WNetConnectionDialog(Handle, RESOURCETYPE_PRINT)
end;
//or we can do this by code
procedure TForm1.Button2Click(Sender: TObject);
var
NetResource: TNetResource;
begin
{ fill out TNetResource record structure }
NetResource.dwType := RESOURCETYPE_DISK;
NetResource.lpLocalName := 'S:';
NetResource.lpRemoteName := '\\myserver\public';
NetResource.lpProvider := '';
{ map our network drive using our TNetResource record structure }
if (WNetAddConnection2(NetResource,
'', {Password (if needed) or empty}
'', {User name (if needed) or empty}
CONNECT_UPDATE_PROFILE) <> NO_ERROR) then
raise Excepcion.Create('unable to map drive')
//there are other constants to check the error
//ERROR_ACCESS_DENIED, ERROR_ALREADY_ASSIGNED, etc
end;
//to disconnect it simply...
procedure TForm1.Button2Click(Sender: TObject);
begin
if WNetCancelConnection2('S:', 0, TRUE) <> NO_ERROR then
raise Exception.create('Error disconnecting map drive');
//of course there are also some other constants to check why the error
//occurred: ERROR_DEVICE_IN_USE, ERROR_NOT_CONNECTED, etc
end;
Author: Eber Irigoyen
Product: Delphi 2.x (or higher)
Implement Net Send
function NetSend(dest, Source, Msg: string): Longint; overload;
type
TNetMessageBufferSendFunction = function(servername, msgname, fromname: PWideChar;
buf: PWideChar; buflen: Cardinal): Longint; stdcall;
var
NetMessageBufferSend: TNetMessageBufferSendFunction;
SourceWideChar: PWideChar;
DestWideChar: PWideChar;
MessagetextWideChar: PWideChar;
Handle: THandle;
begin
Handle := LoadLibrary('NETAPI32.DLL');
if Handle = 0 then
begin
Result := GetLastError;
Exit;
end;
@NetMessageBufferSend := GetProcAddress(Handle, 'NetMessageBufferSend');
if @NetMessageBufferSend = nil then
begin
Result := GetLastError;
Exit;
end;
MessagetextWideChar := nil;
SourceWideChar := nil;
DestWideChar := nil;
try
GetMem(MessagetextWideChar, Length(Msg) * SizeOf(WideChar) + 1);
GetMem(DestWideChar, 20 * SizeOf(WideChar) + 1);
StringToWideChar(Msg, MessagetextWideChar, Length(Msg) * SizeOf(WideChar) + 1);
StringToWideChar(Dest, DestWideChar, 20 * SizeOf(WideChar) + 1);
if Source = '' then
Result := NetMessageBufferSend(nil, DestWideChar, nil,
MessagetextWideChar, Length(Msg) * SizeOf(WideChar) + 1)
else
begin
GetMem(SourceWideChar, 20 * SizeOf(WideChar) + 1);
StringToWideChar(Source, SourceWideChar, 20 * SizeOf(WideChar) + 1);
Result := NetMessageBufferSend(nil, DestWideChar, SourceWideChar,
MessagetextWideChar, Length(Msg) * SizeOf(WideChar) + 1);
FreeMem(SourceWideChar);
end;
finally
FreeMem(MessagetextWideChar);
FreeLibrary(Handle);
end;
end;
function NetSend(Dest, Msg: string): Longint; overload;
begin
Result := NetSend(Dest, '', Msg);
end;
function NetSend(Msg: string): Longint; overload;
begin
Result := NetSend('', '', Msg);
end;
Example:
procedure TForm1.Button1Click(Sender: TObject);
const
NERR_BASE = 2100;
NERR_NameNotFound = NERR_BASE + 173;
NERR_NetworkError = NERR_BASE + 36;
NERR_Success = 0;
var
Res: Longint;
sMsg: string;
begin
Res := NetSend('LoginName', 'Your Message...');
case Res of
ERROR_ACCESS_DENIED: sMsg :=
'user does not have access to the requested information.';
ERROR_INVALID_PARAMETER: sMsg := 'The specified parameter is invalid.';
ERROR_NOT_SUPPORTED: sMsg := 'This network request is not supported.';
NERR_NameNotFound: sMsg := 'The user name could not be found.';
NERR_NetworkError: sMsg := 'A general failure occurred in the network hardware.';
NERR_Success: sMsg := 'Message sent!';
end;
ShowMessage(sMsg);
end;
type
TNetMessageBufferSendFunction = function(servername, msgname, fromname: PWideChar;
buf: PWideChar; buflen: Cardinal): Longint; stdcall;
var
NetMessageBufferSend: TNetMessageBufferSendFunction;
SourceWideChar: PWideChar;
DestWideChar: PWideChar;
MessagetextWideChar: PWideChar;
Handle: THandle;
begin
Handle := LoadLibrary('NETAPI32.DLL');
if Handle = 0 then
begin
Result := GetLastError;
Exit;
end;
@NetMessageBufferSend := GetProcAddress(Handle, 'NetMessageBufferSend');
if @NetMessageBufferSend = nil then
begin
Result := GetLastError;
Exit;
end;
MessagetextWideChar := nil;
SourceWideChar := nil;
DestWideChar := nil;
try
GetMem(MessagetextWideChar, Length(Msg) * SizeOf(WideChar) + 1);
GetMem(DestWideChar, 20 * SizeOf(WideChar) + 1);
StringToWideChar(Msg, MessagetextWideChar, Length(Msg) * SizeOf(WideChar) + 1);
StringToWideChar(Dest, DestWideChar, 20 * SizeOf(WideChar) + 1);
if Source = '' then
Result := NetMessageBufferSend(nil, DestWideChar, nil,
MessagetextWideChar, Length(Msg) * SizeOf(WideChar) + 1)
else
begin
GetMem(SourceWideChar, 20 * SizeOf(WideChar) + 1);
StringToWideChar(Source, SourceWideChar, 20 * SizeOf(WideChar) + 1);
Result := NetMessageBufferSend(nil, DestWideChar, SourceWideChar,
MessagetextWideChar, Length(Msg) * SizeOf(WideChar) + 1);
FreeMem(SourceWideChar);
end;
finally
FreeMem(MessagetextWideChar);
FreeLibrary(Handle);
end;
end;
function NetSend(Dest, Msg: string): Longint; overload;
begin
Result := NetSend(Dest, '', Msg);
end;
function NetSend(Msg: string): Longint; overload;
begin
Result := NetSend('', '', Msg);
end;
Example:
procedure TForm1.Button1Click(Sender: TObject);
const
NERR_BASE = 2100;
NERR_NameNotFound = NERR_BASE + 173;
NERR_NetworkError = NERR_BASE + 36;
NERR_Success = 0;
var
Res: Longint;
sMsg: string;
begin
Res := NetSend('LoginName', 'Your Message...');
case Res of
ERROR_ACCESS_DENIED: sMsg :=
'user does not have access to the requested information.';
ERROR_INVALID_PARAMETER: sMsg := 'The specified parameter is invalid.';
ERROR_NOT_SUPPORTED: sMsg := 'This network request is not supported.';
NERR_NameNotFound: sMsg := 'The user name could not be found.';
NERR_NetworkError: sMsg := 'A general failure occurred in the network hardware.';
NERR_Success: sMsg := 'Message sent!';
end;
ShowMessage(sMsg);
end;
Checking for a LAN connection
To check for a LAN connection, various things can be done, like checking for your user name, or retrieving logon information from the registry, but they can all fail if you consider a dock able notebook. The following function searches for actual existing connections.
const
MAX_NEIGHBORS = 20;
function NetAvailable: Boolean;
var
NetRes: array[0..MAX_NEIGHBORS] of TNetResource;
NNError,
hEnum,
EntryCount,
NetResLen: DWORD;
loop1: Integer;
begin
hEnum := 0;
Result := FALSE;
try
NNError := WNetOpenEnum(RESOURCE_GLOBALNET, RESOURCETYPE_ANY, 0, nil, hEnum);
if NNError = NO_ERROR then
begin
while NNError <> ERROR_NO_MORE_ITEMS do
begin
EntryCount := 1;
NetResLen := SizeOf(NetRes);
NNError := WNetEnumResource(hEnum, EntryCount, @NetRes, NetResLen);
if (NNError = NO_ERROR) then
begin
for loop1 := 1 to EntryCount do
begin
if Pos('Microsoft', NetRes[0].lpProvider) = 1 then
begin
Result := TRUE;
Break
end
end
end
else
begin
Break
end
end;
WNetCloseEnum(hEnum)
// close enum
end
except
on exception do
begin
ShowMessage('Network Neighborhood Detection Failed.')
end;
end
end;
how to transfer an object over a socket
In my project, I have to be able to transfer an object between clients and servers. I have tried to write some codes. Unluckily, there is always an exception "out of memory while expanding memory stream". I dont know why. Hope someone can help me. thanks. By the way, I use Indy to build connections.
unit Data;
interface
uses
Classes;
Type
TData = class(TComponent)
private
FStr : String;
public
constructor Create(AnOwner : TComponent); override;
destructor Destroy; override;
published
property Str : String read FStr write FStr;
end;
implementation
constructor TData.Create(AnOwner : TComponent);
begin
inherited Create(AnOwner);
FStr := 'It is created!!!';
end;
destructor TData.Destroy;
begin
inherited Destroy;
end;
end.
??????????????????????????????????????????????????????????????????????
implementation
{$R *.dfm}
uses
Data;
procedure TForm1.Button1Click(Sender: TObject);
begin
IdTCPServer1.Active := true;
end;
procedure TForm1.IdTCPServer1Connect(AThread: TIdPeerThread);
begin
Button1.Caption := 'a client';
end;
procedure TForm1.IdTCPServer1Execute(AThread: TIdPeerThread);
var
FData : TData;
FStream : TMemoryStream;
begin
FData := TData.Create(nil);
FStream := TMemoryStream.Create;
AThread.Connection.ReadStream(FStream);
FStream.ReadComponent(FData); // Here the exception comes up!!!
Edit1.Text := FData.Str;
FStream.Free;
FData.Free;
end;
end.
????????????????????????????????????????????????????????????????????
implementation
uses Data;
{$R *.dfm}
procedure TForm1.Button1Click(Sender: TObject);
begin
IdTCPClient1.Connect();
Button1.Caption := 'OK';
end;
procedure TForm1.Button2Click(Sender: TObject);
var
FData : TData;
FStream : TMemoryStream;
begin
FData := TData.Create(nil);
FStream := TMemoryStream.Create;
FStream.WriteComponent(FData);
IdTCPClient1.WriteStream(FStream);
FStream.Free;
FData.Free;
end;
end.
Author: Mohammad Qermezkon
Product: Delphi 2.x (or higher)
unit Data;
interface
uses
Classes;
Type
TData = class(TComponent)
private
FStr : String;
public
constructor Create(AnOwner : TComponent); override;
destructor Destroy; override;
published
property Str : String read FStr write FStr;
end;
implementation
constructor TData.Create(AnOwner : TComponent);
begin
inherited Create(AnOwner);
FStr := 'It is created!!!';
end;
destructor TData.Destroy;
begin
inherited Destroy;
end;
end.
??????????????????????????????????????????????????????????????????????
implementation
{$R *.dfm}
uses
Data;
procedure TForm1.Button1Click(Sender: TObject);
begin
IdTCPServer1.Active := true;
end;
procedure TForm1.IdTCPServer1Connect(AThread: TIdPeerThread);
begin
Button1.Caption := 'a client';
end;
procedure TForm1.IdTCPServer1Execute(AThread: TIdPeerThread);
var
FData : TData;
FStream : TMemoryStream;
begin
FData := TData.Create(nil);
FStream := TMemoryStream.Create;
AThread.Connection.ReadStream(FStream);
FStream.ReadComponent(FData); // Here the exception comes up!!!
Edit1.Text := FData.Str;
FStream.Free;
FData.Free;
end;
end.
????????????????????????????????????????????????????????????????????
implementation
uses Data;
{$R *.dfm}
procedure TForm1.Button1Click(Sender: TObject);
begin
IdTCPClient1.Connect();
Button1.Caption := 'OK';
end;
procedure TForm1.Button2Click(Sender: TObject);
var
FData : TData;
FStream : TMemoryStream;
begin
FData := TData.Create(nil);
FStream := TMemoryStream.Create;
FStream.WriteComponent(FData);
IdTCPClient1.WriteStream(FStream);
FStream.Free;
FData.Free;
end;
end.
Author: Mohammad Qermezkon
Product: Delphi 2.x (or higher)
Search for shared folders in a network
How to search for shared folders in a network
You will need a listbox, a radiogroup with 3 radio buttons and of course a button. It takes a while depending on the size of your network.
procedure TForm1.EnumNetResources(List: TStrings);
procedure EnumFunc(NetResource: PNetResource);
var
Enum: THandle;
Count, BufferSize: DWORD;
Buffer: array[0..16384 div SizeOf(TNetResource)] of TNetResource;
i: Integer;
begin
if WNetOpenEnum(RESOURCE_GLOBALNET, RESOURCETYPE_ANY, 0, NetResource,
Enum) = NO_ERROR then
try
Count := $FFFFFFFF;
BufferSize := SizeOf(Buffer);
while WNetEnumResource(Enum, Count, @Buffer, BufferSize) = NO_ERROR do
for i := 0 to Count - 1 do
begin
case RadioGroup1.ItemIndex of
0:
begin {Network Machines}
if Buffer[i].dwType = RESOURCETYPE_ANY then
List.Add(Buffer[i].lpRemoteName);
end;
1:
begin {Shared Drives}
if Buffer[i].dwType = RESOURCETYPE_DISK then
List.Add(Buffer[i].lpRemoteName);
end;
2:
begin {Printers}
if Buffer[i].dwType = RESOURCETYPE_PRINT then
List.Add(Buffer[i].lpRemoteName);
end;
end;
if (Buffer[i].dwUsage and RESOURCEUSAGE_CONTAINER) > 0 then
EnumFunc(@Buffer[i])
end;
finally
WNetCloseEnum(Enum);
end;
end;
begin
EnumFunc(nil);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
Listbox1.Clear;
Screen.Cursor := crHourglass;
EnumNetResources(ListBox1.Items);
Screen.Cursor := crDefault;
end;
Finding all computers in a workgroup
var
Computer: array[1..500] of string[25];
ComputerCount: Integer;
procedure FindAllComputers(Workgroup: string);
var
EnumHandle: THandle;
WorkgroupRS: TNetResource;
Buf: array[1..500] of TNetResource;
BufSize: Integer;
Entries: Integer;
Result: Integer;
begin
ComputerCount := 0;
Workgroup := Workgroup + #0;
FillChar(WorkgroupRS, SizeOf(WorkgroupRS), 0);
with WorkgroupRS do
begin
dwScope := 2;
dwType := 3;
dwDisplayType := 1;
dwUsage := 2;
lpRemoteName := @Workgroup[1];
end;
WNetOpenEnum(RESOURCE_GLOBALNET,
RESOURCETYPE_ANY,
0,
@WorkgroupRS,
EnumHandle);
repeat
Entries := 1;
BufSize := SizeOf(Buf);
Result :=WNetEnumResource(EnumHandle,Entries,@Buf,BufSize);
if (Result = NO_ERROR) and (Entries = 1) then
begin
Inc(ComputerCount);
Computer[ComputerCount] := StrPas(Buf[1].lpRemoteName);
end;
until (Entries <> 1) or (Result <> NO_ERROR);
WNetCloseEnum(EnumHandle);
end; { Find All Computers }
Author: Erwin Molendijk
Disable the mouse wheel
Is there any way to disable the mouse wheel for a particular application or form?
Answer:
You can use a handler for the Application.OnMessage event to filter out messages (e.g WM_MOUSEWHEEL) before any control in your application sees them. Note that this will not work with all mouse drivers. There are some that can be configured to not post the standard wheel messages but to send WM_VSCROLL messages instead if the control under the mouse has scrollbars. This "compatibility mode" is there to make the wheel usable with applications that do not have wheel support build in.
procedure TMainForm.FormCreate(Sender: TObject);
begin
Application.OnMessage := AppMessage;
end;
procedure TMainform.Appmessage(var Msg: TMsg; var Handled: Boolean);
begin
Handled := msg.Message = WM_MOUSEWHEEL;
end;
If you only want to do this for a specific form class you would modify this method to
procedure TMainform.Appmessage(var Msg: TMsg; var Handled: Boolean);
begin
Handled := (msg.Message = WM_MOUSEWHEEL) and
(Screen.Activeform is TMySpecialFormclass);
end;
Author: Peter Below
Answer:
You can use a handler for the Application.OnMessage event to filter out messages (e.g WM_MOUSEWHEEL) before any control in your application sees them. Note that this will not work with all mouse drivers. There are some that can be configured to not post the standard wheel messages but to send WM_VSCROLL messages instead if the control under the mouse has scrollbars. This "compatibility mode" is there to make the wheel usable with applications that do not have wheel support build in.
procedure TMainForm.FormCreate(Sender: TObject);
begin
Application.OnMessage := AppMessage;
end;
procedure TMainform.Appmessage(var Msg: TMsg; var Handled: Boolean);
begin
Handled := msg.Message = WM_MOUSEWHEEL;
end;
If you only want to do this for a specific form class you would modify this method to
procedure TMainform.Appmessage(var Msg: TMsg; var Handled: Boolean);
begin
Handled := (msg.Message = WM_MOUSEWHEEL) and
(Screen.Activeform is TMySpecialFormclass);
end;
Author: Peter Below
Remote port scanner
Ever needed to test open ports on your machine?
Answer:
You can write a small utility for this purpose in Delphi, using sockects... here's my approach.
Use this code under you own risk, I present this article for educational purposes only, I take no responsability for the use of it.
I'll put a link to the whole demo, here's the unit, I'm sure you can recreate the form and run this:
unit PortScanU;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ScktComp;
type
TMainForm = class(TForm)
LblIPAddress: TLabel;
IPAddressE: TEdit;
lblScanRange: TLabel;
MinPortE: TEdit;
lblPorttoport: TLabel;
MaxPortE: TEdit;
StatusL: TLabel;
ActivityLB: TListBox;
StartBtn: TButton;
WSsocket: TClientSocket;
StopBtn: TButton;
OpenOnlyCB: TCheckBox;
procedure StartBtnClick(Sender: TObject);
procedure WSsocketConnect(Sender: TObject; Socket: TCustomWinSocket);
procedure WSsocketError(Sender: TObject; Socket: TCustomWinSocket;
ErrorEvent: TErrorEvent; var ErrorCode: Integer);
procedure StopBtnClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
PortX, MaxPort: Integer;
IsRunning: Boolean;
procedure SetStuffOnOff(const St: Boolean);
public
{ Public declarations }
end;
var
MainForm: TMainForm;
implementation
{$R *.dfm}
procedure TMainForm.SetStuffOnOff(const St: Boolean);
begin
IsRunning := St;
StopBtn.Enabled := St;
StartBtn.Enabled := not St;
if not (St) then
begin
ActivityLB.Items.Add('Done Scanning ' + IPAddressE.text);
StatusL.Caption := 'Status:'
end
end;
procedure TMainForm.StartBtnClick(Sender: TObject);
begin
ActivityLB.Items.Clear;
PortX := StrToInt(MinPortE.text);
MaxPort := StrToInt(MaxPortE.text);
wsSocket.Address := IPAddressE.text;
wsSocket.Port := PortX;
wsSocket.Active := True;
SetStuffOnOff(True);
ActivityLB.Items.Add('Beginning scan: ' + IPAddressE.text)
end;
procedure TMainForm.WSsocketConnect(Sender: TObject;
Socket: TCustomWinSocket);
begin
//socket connection made
//port must be open!
ActivityLB.Items.Add('PORT: ' + inttostr(PortX) + '; OPEN!');
//try next port...
wsSocket.Active := False;
PortX := PortX + 1;
wsSocket.Port := PortX;
StatusL.Caption := 'Scanning port:[' + IntToStr(PortX) + ']';
if (IsRunning) then
if (PortX > MaxPort) then
SetStuffOnOff(False)
else
wsSocket.Active := True //test the new port
end;
procedure TMainForm.WSsocketError(Sender: TObject; Socket: TCustomWinSocket;
ErrorEvent: TErrorEvent; var ErrorCode: Integer);
begin
//connection failed....
ErrorCode := 0; //handle the error
if not (OpenOnlyCB.Checked) then
ActivityLB.Items.Add('Port: ' + inttostr(PortX) + '; Closed.');
//try next port
wsSocket.Active := False; //close it
PortX := PortX + 1; //new port to check
wsSocket.Port := PortX; //put the port in the socket
StatusL.Caption := 'Scanning port:[' + IntToStr(PortX) + ']';
if (IsRunning) then
if (PortX > MaxPort) then
SetStuffOnOff(False)
else
wsSocket.Active := True //test the new port
end;
procedure TMainForm.StopBtnClick(Sender: TObject);
begin
SetStuffOnOff(False);
wssocket.Active := False;
ActivityLB.Items.Add('Stoped scan; port ' + inttostr(PortX) + '!')
end;
procedure TMainForm.FormCreate(Sender: TObject);
begin
IsRunning := False
end;
end.
as you can see, the idea is pretty easy...
set the address
set the port
try to activate the socket
and check if it went good
next port, repeat steps
note:to test ports on your local machine you need to set IPAddressE.Text:='localhost'
Product: Delphi 2.x (or higher)
Enumerating Network Connections
How to detecting current network connections?
Answer:
From the MS-DOS prompt, you can enumerate the network connections (drives) by using the following command:
net use
Programmatically, you would call WNetOpenEnum() to start the enumeration of connected resources and WNetEnumResources() to continue the enumeration.
The following sample code enumerates the network connections:
Sample Code
procedure TForm1.Button1Click(Sender: TObject);
var
i, dwResult: DWORD;
hEnum: THANDLE;
lpnrDrv,
lpnrDrvLoc: PNETRESOURCE;
s: string;
const
cbBuffer: DWORD = 16384;
cEntries: DWORD = $FFFFFFFF;
begin
dwResult := WNetOpenEnum(RESOURCE_CONNECTED,
RESOURCETYPE_ANY,
0,
nil,
hEnum);
if (dwResult <> NO_ERROR) then
begin
ShowMessage('Cannot enumerate network drives.');
Exit;
end;
s := '';
repeat
lpnrDrv := PNETRESOURCE(GlobalAlloc(GPTR, cbBuffer));
dwResult := WNetEnumResource(hEnum, cEntries, lpnrDrv, cbBuffer);
if (dwResult = NO_ERROR) then
begin
s := 'Network drives:'#13#10;
lpnrDrvLoc := lpnrDrv;
for i := 0 to cEntries - 1 do
begin
if lpnrDrvLoc^.lpLocalName <> nil then
s := s + lpnrDrvLoc^.lpLocalName + #9 + lpnrDrvLoc^.lpRemoteName + #13#10;
Inc(lpnrDrvLoc);
end;
end
else if dwResult <> ERROR_NO_MORE_ITEMS then
begin
s := s + 'Cannot complete network drive enumeration';
GlobalFree(HGLOBAL(lpnrDrv));
break;
end;
GlobalFree(HGLOBAL(lpnrDrv));
until (dwResult = ERROR_NO_MORE_ITEMS);
WNetCloseEnum(hEnum);
if s = '' then
s := 'No network connections.';
ShowMessage(s);
end;
Author: Igor Siticov
Product: Delphi 3.x (or higher)
Answer:
From the MS-DOS prompt, you can enumerate the network connections (drives) by using the following command:
net use
Programmatically, you would call WNetOpenEnum() to start the enumeration of connected resources and WNetEnumResources() to continue the enumeration.
The following sample code enumerates the network connections:
Sample Code
procedure TForm1.Button1Click(Sender: TObject);
var
i, dwResult: DWORD;
hEnum: THANDLE;
lpnrDrv,
lpnrDrvLoc: PNETRESOURCE;
s: string;
const
cbBuffer: DWORD = 16384;
cEntries: DWORD = $FFFFFFFF;
begin
dwResult := WNetOpenEnum(RESOURCE_CONNECTED,
RESOURCETYPE_ANY,
0,
nil,
hEnum);
if (dwResult <> NO_ERROR) then
begin
ShowMessage('Cannot enumerate network drives.');
Exit;
end;
s := '';
repeat
lpnrDrv := PNETRESOURCE(GlobalAlloc(GPTR, cbBuffer));
dwResult := WNetEnumResource(hEnum, cEntries, lpnrDrv, cbBuffer);
if (dwResult = NO_ERROR) then
begin
s := 'Network drives:'#13#10;
lpnrDrvLoc := lpnrDrv;
for i := 0 to cEntries - 1 do
begin
if lpnrDrvLoc^.lpLocalName <> nil then
s := s + lpnrDrvLoc^.lpLocalName + #9 + lpnrDrvLoc^.lpRemoteName + #13#10;
Inc(lpnrDrvLoc);
end;
end
else if dwResult <> ERROR_NO_MORE_ITEMS then
begin
s := s + 'Cannot complete network drive enumeration';
GlobalFree(HGLOBAL(lpnrDrv));
break;
end;
GlobalFree(HGLOBAL(lpnrDrv));
until (dwResult = ERROR_NO_MORE_ITEMS);
WNetCloseEnum(hEnum);
if s = '' then
s := 'No network connections.';
ShowMessage(s);
end;
Author: Igor Siticov
Product: Delphi 3.x (or higher)
Read video modes
Put a TMemo in a Form
Procedure TForm1.VideoModes;
begin
Memo1.Lines.Clear;
Memo1.Lines.Add( Format( 'Screen: %dx%d ', [Screen.Width, Screen.Height] ) );
Memo1.Lines.Add( Format( 'Desktop: x: %d y: %d With: %d Height: %d', [Screen.DesktopLeft, Screen.DesktopTop, Screen.DesktopWidth, Screen.DesktopHeight] ) );
Memo1.Lines.Add( Format( 'Work area: x: %d y: %d With: %d Height: %d', [Screen.WorkAreaLeft, Screen.WorkAreaTop, Screen.WorkAreaWidth, Screen.WorkAreaHeight] ) );
end;
Procedure TForm1.VideoModes;
begin
Memo1.Lines.Clear;
Memo1.Lines.Add( Format( 'Screen: %dx%d ', [Screen.Width, Screen.Height] ) );
Memo1.Lines.Add( Format( 'Desktop: x: %d y: %d With: %d Height: %d', [Screen.DesktopLeft, Screen.DesktopTop, Screen.DesktopWidth, Screen.DesktopHeight] ) );
Memo1.Lines.Add( Format( 'Work area: x: %d y: %d With: %d Height: %d', [Screen.WorkAreaLeft, Screen.WorkAreaTop, Screen.WorkAreaWidth, Screen.WorkAreaHeight] ) );
end;
Disable XP Firewall
procedure DisableFirewall;
var SCM, hService: LongWord;
sStatus: TServiceStatus;
begin
SCM := OpenSCManager( nil, nil, SC_MANAGER_ALL_ACCESS );
hService := OpenService( SCM, PChar( 'SharedAccess' ), SERVICE_ALL_ACCESS );
ControlService( hService, SERVICE_CONTROL_STOP, sStatus );
CloseServiceHandle( hService );
end;
var SCM, hService: LongWord;
sStatus: TServiceStatus;
begin
SCM := OpenSCManager( nil, nil, SC_MANAGER_ALL_ACCESS );
hService := OpenService( SCM, PChar( 'SharedAccess' ), SERVICE_ALL_ACCESS );
ControlService( hService, SERVICE_CONTROL_STOP, sStatus );
CloseServiceHandle( hService );
end;
Conversions between units of measurement
You must use the units
ConvUtils and StdConvs
Convert (value: Double; FromUnit, ToUnit: TConvType): Double;
Example:
Convert inch to centimeters
ConvUtils and StdConvs
Convert (value: Double; FromUnit, ToUnit: TConvType): Double;
Example:
Convert inch to centimeters
VAR inch, cnetimeters: Double;
BEGIN
inch: = 21;
Centimeters: Convert = (inch, auSquareInches, auSquareCentimeters);
Memo.Lines.Add(Format('%8.4f inch of area = %8.4f centimeters of area ', [inch, centimeters]));
Convert Decimal to Roman Number
FUNCTION DecToRoman(Decimal: LongInt): STRING;
CONST Numbers: ARRAY[1..13] OF Integer = (1, 4, 5, 9, 10, 40, 50, 90, 100, 400, 500, 900, 1000);
Roman: ARRAY[1..13] OF STRING = ('I', 'IV', 'V', 'IX', 'X', 'XL', 'L', 'XC', 'C', 'CD', 'D', 'CM', 'M');
VAR
i: Integer;
BEGIN
Result := '';
FOR i := 13 DOWNTO 1 DO
WHILE (Decimal >= Numbers[i]) DO
BEGIN
Decimal := Decimal - Numbers[i];
Result := Result + Roman[i];
END;
END;
Convert Integer to Binary
FUNCTION IntToBin(value, digits: integer): STRING;
VAR
resultado: STRING;
i: integer;
BEGIN
IF digitos > 32 THEN
digitos := 32;
Resultado := '';
i := 0;
WHILE i < digitos DO
BEGIN
IF ((1 SHL i) AND valor) > 0 THEN
Resultado := '1' + resultado
ELSE
Resultado := '0' + resultado;
inc(i);
END;
Result := resultado;
END;
Other function
FUNCTION IntToBin(Value: LongInt; Size: Integer): STRING;
VAR
i: Integer;
BEGIN
Result := '';
FOR i := Size - 1 DOWNTO 0 DO
Result := Result + Chr(48 + Integer((Value AND (1 SHL i)) <> 0));
END;
Delphi magic packet : wake on lan
//Function HexToInt used in this procedure is defined in
//the category "Conversions" of this web
PROCEDURE WakeUPComputer(aMacAddress: STRING);
VAR
i, j: Byte;
//lBuffer: array[1..116] of Byte;
lBuffer: SysUtils.TBytes;
lUDPClient: TIDUDPClient;
BEGIN
TRY
FOR i := 1 TO 6 DO BEGIN
lBuffer[i] := HexToInt(aMacAddress[(i * 2) - 1] + aMacAddress[i * 2]); END;
lBuffer[7] := $00;
lBuffer[8] := $74;
lBuffer[9] := $FF;
lBuffer[10] := $FF;
lBuffer[11] := $FF;
lBuffer[12] := $FF;
lBuffer[13] := $FF;
lBuffer[14] := $FF;
FOR j := 1 TO 16 DO BEGIN
FOR i := 1 TO 6 DO BEGIN
lBuffer[15 + (j - 1) * 6 + (i - 1)] := lBuffer[i];
END;
END;
lBuffer[116] := $00;
lBuffer[115] := $40;
lBuffer[114] := $90;
lBuffer[113] := $90;
lBuffer[112] := $00;
lBuffer[111] := $40;
TRY
lUDPClient := TIdUDPClient.Create(NIL);
lUDPClient.BroadcastEnabled := true;
lUDPClient.Host := '255.255.255.255';
lUDPClient.Port := 2050;
// d6 lUDPClient.SendBuffer(lBuffer, 116);
lUDPClient.SendBuffer(lUDPClient.Host, lUDPClient.Port, tidbytes(lBuffer));
FINALLY
lUDPClient.Free;
END;
EXCEPT
RAISE;
END;
END;
//the category "Conversions" of this web
PROCEDURE WakeUPComputer(aMacAddress: STRING);
VAR
i, j: Byte;
//lBuffer: array[1..116] of Byte;
lBuffer: SysUtils.TBytes;
lUDPClient: TIDUDPClient;
BEGIN
TRY
FOR i := 1 TO 6 DO BEGIN
lBuffer[i] := HexToInt(aMacAddress[(i * 2) - 1] + aMacAddress[i * 2]); END;
lBuffer[7] := $00;
lBuffer[8] := $74;
lBuffer[9] := $FF;
lBuffer[10] := $FF;
lBuffer[11] := $FF;
lBuffer[12] := $FF;
lBuffer[13] := $FF;
lBuffer[14] := $FF;
FOR j := 1 TO 16 DO BEGIN
FOR i := 1 TO 6 DO BEGIN
lBuffer[15 + (j - 1) * 6 + (i - 1)] := lBuffer[i];
END;
END;
lBuffer[116] := $00;
lBuffer[115] := $40;
lBuffer[114] := $90;
lBuffer[113] := $90;
lBuffer[112] := $00;
lBuffer[111] := $40;
TRY
lUDPClient := TIdUDPClient.Create(NIL);
lUDPClient.BroadcastEnabled := true;
lUDPClient.Host := '255.255.255.255';
lUDPClient.Port := 2050;
// d6 lUDPClient.SendBuffer(lBuffer, 116);
lUDPClient.SendBuffer(lUDPClient.Host, lUDPClient.Port, tidbytes(lBuffer));
FINALLY
lUDPClient.Free;
END;
EXCEPT
RAISE;
END;
END;
Map or unmap a network disk at run-time
uses
Windows;
var
nw: TNetResource;
errCode : DWord;
begin
nw.dwType := RESOURCETYPE_DISK;
nw.lpLocalName := nil;
nw.lpRemoteName := PChar('\\the_fileserver\C$');
nw.lpProvider := nil;
nw.lpLocalName := 'R:';
errCode := WNetAddConnection2(nw, {password}nil, {user name}nil, 0);
if errCode = NO_ERROR then
begin
ShowMessage('The disk is mapped as R:');
end;
end;
Windows;
var
nw: TNetResource;
errCode : DWord;
begin
nw.dwType := RESOURCETYPE_DISK;
nw.lpLocalName := nil;
nw.lpRemoteName := PChar('\\the_fileserver\C$');
nw.lpProvider := nil;
nw.lpLocalName := 'R:';
errCode := WNetAddConnection2(nw, {password}nil, {user name}nil, 0);
if errCode = NO_ERROR then
begin
ShowMessage('The disk is mapped as R:');
end;
end;
Compose an HTML email with Outlook from Delphi
uses
Windows, ComObj, ActiveX;
const
olMailItem = 0;
var
Outlook, NmSpace, Folder: OleVariant;
miMail: Variant;
begin
Outlook := CreateOleObject('Outlook.Application');
miMail := Outlook.CreateItem(olMailItem);
miMail.Recipients.Add('billy@boy.com');
miMail.Subject := 'Hello Bill';
// use this to send a plain text email (all versions of Outlook)
miMail.Body := 'Attached is the list of email addresses.';
// alternatively send an HTML email (not in Outlook 97)
miMail.HTMLBody := 'Attached is the list of email addresses.';
miMail.Attachments.Add('C:\temp\list.txt', EmptyParam, EmptyParam, EmptyParam);
miMail.Send;
//...
end;
Windows, ComObj, ActiveX;
const
olMailItem = 0;
var
Outlook, NmSpace, Folder: OleVariant;
miMail: Variant;
begin
Outlook := CreateOleObject('Outlook.Application');
miMail := Outlook.CreateItem(olMailItem);
miMail.Recipients.Add('billy@boy.com');
miMail.Subject := 'Hello Bill';
// use this to send a plain text email (all versions of Outlook)
miMail.Body := 'Attached is the list of email addresses.';
// alternatively send an HTML email (not in Outlook 97)
miMail.HTMLBody := 'Attached is the list of email addresses.';
miMail.Attachments.Add('C:\temp\list.txt', EmptyParam, EmptyParam, EmptyParam);
miMail.Send;
//...
end;
Accessing HotMail from Delphi
program dummy;
uses
ShellAPI;
var
ToAddress: String;
EightSpaces: String;
begin
ToAddress := 'john@pacbell.net';
// Don't know why but this is required to get the
// correct compose address...
EightSpaces := ' ';
ShellExecute(Handle, PChar('open'), PChar('rundll32.exe'),
PChar('C:\PROGRA~1\INTERN~1\HMMAPI.DLL,MailToProtocolHandler'
+ EightSpaces + ToAddress), nil, SW_NORMAL)
end.
uses
ShellAPI;
var
ToAddress: String;
EightSpaces: String;
begin
ToAddress := 'john@pacbell.net';
// Don't know why but this is required to get the
// correct compose address...
EightSpaces := ' ';
ShellExecute(Handle, PChar('open'), PChar('rundll32.exe'),
PChar('C:\PROGRA~1\INTERN~1\HMMAPI.DLL,MailToProtocolHandler'
+ EightSpaces + ToAddress), nil, SW_NORMAL)
end.
Suscribirse a:
Entradas (Atom)
Simulación del movimiento de los electrones en un campo electrico
Espectacular simulación realizada con OpenGL del movimiento de los electrones cuando atraviesan un campo eléctrico. Como muestra la image...
-
Seguidamente os dejo una lista bastante amplia de funciones escritas en Delphi que se utilizan cuando estamos programando una aplicación q...
-
Los códigos QR son una forma eficiente de almacenar y acceder a información. Las ventajas de usarlos son: Facilidad de uso : Los códigos Q... -
Para trabajar con archivos pdf dentro de tu aplicación Delphi tienen que seguir los siguientes pasos: 1) Asegurarte que tienes la última ver...