Net Send Ganti ID Pengirim « Dani Amarullah

Net Send Ganti ID Pengirim

Ok jumpa lagi,wakakakakakaka….

sekarang sigw mau ngasih tips buat yang suka kirim2 pesan antar LAN pake Command “Net Send”, artikel disini akan bahas buat mengganti ID pengirimnya… Ok langsung aja..
Buat New Aplikasi terus nama unitnya NetSend.pas

unit NetSend;

interface

uses
  Windows, Messages, Classes, Dialogs, Forms,
  IdIPWatch, BtnCtrls,
  XPMan, Controls, StdCtrls, IdBaseComponent, IdComponent;

type
  TForm1 = class(TForm)
  IdIPWatch1: TIdIPWatch;
  Memo1: TMemo;
  Label8: TLabel;
  Label7: TLabel;
  Label6: TLabel;
  Label5: TLabel;
  Label3: TLabel;
  Label2: TLabel;
  Label1: TLabel;
  Edit1: TEdit;
  ComboBox1: TComboBox;
  ImageButton1: TImageButton;
  XPManifest1: TXPManifest;
  ImageButton2: TImageButton;
  procedure FormCreate(Sender: TObject);
  procedure CaptionBox1Close(Sender: TObject);
  procedure ImageButton2Click(Sender: TObject);
  procedure ImageButton1Click(Sender: TObject);
  procedure Memo1Change(Sender: TObject);
  procedure Memo1KeyPress(Sender: TObject; var Key: Char);
  private
  { Private declarations }
  public
  { Public declarations }
  end;

var
  Form1: TForm1;
  fromsaha: string;

implementation

{$R *.dfm}

type
  PNetResourceArray = ^TNetResourceArray;
  TNetResourceArray = array[0..100] of TNetResource;
function CreateNetResourceList(ResourceType: DWord;
        NetResource: PNetResource;
        out Entries: DWord;
        out List: PNetResourceArray): Boolean;
var
  EnumHandle: THandle;
  BufSize: DWord;
  Res: DWord;
begin
  Result := False;
  List := Nil;
  Entries := 0;
  if WNetOpenEnum(RESOURCE_GLOBALNET,
      ResourceType,
      0,
      NetResource,
      EnumHandle) = NO_ERROR then begin
  try
  BufSize := $4000;  // 16 kByte
  GetMem(List, BufSize);
  try
  repeat
    Entries := DWord(-1);
    FillChar(List^, BufSize, 0);
    Res := WNetEnumResource(EnumHandle, Entries, List, BufSize);
    if Res = ERROR_MORE_DATA then
    begin
    ReAllocMem(List, BufSize);
    end;
  until Res  ERROR_MORE_DATA;
  Result := Res = NO_ERROR;
  if not Result then
  begin
    FreeMem(List);
    List := Nil;
    Entries := 0;
  end;
  except
  FreeMem(List);
  raise;
  end;
  finally
  WNetCloseEnum(EnumHandle);
  end;
  end;
end;

procedure ScanNetworkResources(ResourceType, DisplayType:
   DWord; List: TStrings);
procedure ScanLevel(NetResource: PNetResource);
var
  Entries: DWord;
  NetResourceList: PNetResourceArray;
  i: Integer;
begin
  if CreateNetResourceList(ResourceType, NetResource,
   Entries, NetResourceList) then
  try
  for i := 0 to Integer(Entries) - 1 do
  begin
  if (DisplayType = RESOURCEDISPLAYTYPE_GENERIC) or
  (NetResourceList[i].dwDisplayType = DisplayType) then begin
  List.AddObject(NetResourceList[i].lpRemoteName,
      Pointer(NetResourceList[i].dwDisplayType));
  end;
  if (NetResourceList[i].dwUsage and RESOURCEUSAGE_CONTAINER)  0 then
  ScanLevel(@NetResourceList[i]);
  end;
  finally
  FreeMem(NetResourceList);
  end;
end;
begin
  ScanLevel(Nil);
end;

function NetMessageBufferSendSubstA(ServerName, MsgName,
  FromName, Msg: AnsiString): Boolean;
{.$DEFINE SYNCHRONOUS}
const
  szService = '\\mailslot\\messngr';
  MaxBufLen = $700;
var

  hFile: THandle;
  WrittenBytes: DWORD;
{$IFNDEF SYNCHRONOUS}
  ovs: OVERLAPPED;
  EventName: AnsiString;
{$ENDIF}
begin
  Result := False;
  if Length(Msg) * sizeof(AnsiChar) > MaxBufLen then
  SetLength(Msg, MaxBufLen div sizeof(AnsiChar));
{$IFNDEF SYNCHRONOUS}
  EventName := 'NetSendEvent_' + ServerName;
{$ENDIF}
  ServerName := '\\\\' + Servername + szService;
  hFile := CreateFileA(
  @ServerName[1], GENERIC_WRITE, FILE_SHARE_READ, nil, OPEN_EXISTING,
  FILE_ATTRIBUTE_NORMAL or FILE_FLAG_NO_BUFFERING or FILE_FLAG_OVERLAPPED, 0);
  if hFile  INVALID_HANDLE_VALUE then
  try
  Msg := FromName + #0 + MsgName + #0 + Msg;
{$IFNDEF SYNCHRONOUS}
  ovs.hEvent := CreateEventA(nil, True, False, @EventName[1]);
  WriteFile(hFile, Pointer(Msg)^, Length(Msg), WrittenBytes, @ovs);
{$ELSE}
  WriteFile(hFile, Pointer(Msg)^, Length(Msg), WrittenBytes, nil);
{$ENDIF}
  Result := GetLastError = ERROR_IO_PENDING;
  finally
{$IFNDEF SYNCHRONOUS}
  if WaitForSingleObject(ovs.hEvent, INFINITE)  WAIT_TIMEOUT then
{$ENDIF}
    CloseHandle(hFile);
  end;
end;

function NetMessageBufferSendSubstW(ServerName, MsgName,
  FromName, Msg: WideString): Boolean;
begin
  result := NetMessageBufferSendSubstA(ServerName, MsgName,
   FromName, Msg);
end;

function NetSendMsg(name_, text_: string): DWORD;
{$IFDEF USENORMALNETSEND}
var
  msgname: WideString;
  msgtext: WideString;
{$ENDIF}
begin
  while name_[1] = '\\' do delete(name_, 1, 1);
{$IFDEF USENORMALNETSEND}
  msgname := WideString(name_);
  msgtext := WideString(text_);
  Result := NetMessageBufferSend(nil, PWideChar(msgname), nil,
     PWideChar(msgtext), sizeof(WideChar) * Length(msgtext));
{$ELSE}
  case NetMessageBufferSendSubstA(name_ , name_, fromsaha, text_) of
  True: result := ERROR_SUCCESS;
  else
  result := ERROR_ACCESS_DENIED;
  end;
{$ENDIF}
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
  Label7.Caption := IdIPWatch1.LocalName;
  Label8.Caption := IdIPWatch1.LocalIP;
  ComboBox1.Text := Label7.Caption;
  ScanNetworkResources(RESOURCETYPE_DISK, RESOURCEDISPLAYTYPE_SERVER,
     ComboBox1.Items);
end;

procedure TForm1.CaptionBox1Close(Sender: TObject);
begin
  Application.Terminate;
end;

procedure TForm1.ImageButton2Click(Sender: TObject);
begin
  Memo1.Clear;
  Memo1.SetFocus;
end;

procedure TForm1.ImageButton1Click(Sender: TObject);
begin
  if Memo1.Text='' then
  begin
  ShowMessage('Isi dulu pesannya bozzz....');
  Memo1.Clear;
  end
  else
  begin
  Fromsaha:=Edit1.Text;
  NetSendMsg(ComBobox1.Text, Memo1.Text);
  ImageButton1.Enabled:=False;
  Edit1.Text := 'Dhanie';
  Memo1.SetFocus;
  Memo1.Clear;
  end;
end;

procedure TForm1.Memo1Change(Sender: TObject);
begin
  If Memo1.Text='' then
  ImageButton1.Enabled:=False
  else
  ImageButton1.Enabled:=True;
end;

procedure TForm1.Memo1KeyPress(Sender: TObject; var Key: Char);
begin
  If key=#13 then
  ImageButton1.Click;
end;
end.

Syntax Highlighted with http://delphi-id.org/syntax

Ok sekarang buat unit barudengan nama kirim.pas

unit kirim;

interface

uses
  Windows;

implementation

uses NetSend;

type

  PNetResourceArray = ^TNetResourceArray;
  TNetResourceArray = array[0..100] of TNetResource;
function CreateNetResourceList(ResourceType: DWord;
        NetResource: PNetResource;
        out Entries: DWord;
        out List: PNetResourceArray): Boolean;
var
  EnumHandle: THandle;
  BufSize: DWord;
  Res: DWord;
begin
  Result := False;
  List := Nil;
  Entries := 0;
  if WNetOpenEnum(RESOURCE_GLOBALNET,
      ResourceType,
      0,
      NetResource,
      EnumHandle) = NO_ERROR then begin
  try
  BufSize := $4000;  // 16 kByte
  GetMem(List, BufSize);
  try
  repeat
    Entries := DWord(-1);
    FillChar(List^, BufSize, 0);
    Res := WNetEnumResource(EnumHandle, Entries, List, BufSize);
    if Res = ERROR_MORE_DATA then
    begin
    ReAllocMem(List, BufSize);
    end;
  until Res  ERROR_MORE_DATA;
  Result := Res = NO_ERROR;
  if not Result then
  begin
    FreeMem(List);
    List := Nil;
    Entries := 0;
  end;
  except
  FreeMem(List);
  raise;
  end;
  finally
  WNetCloseEnum(EnumHandle);
  end;
  end;
end;

procedure ScanNetworkResources(ResourceType, DisplayType:
      DWord; List: TStrings);
procedure ScanLevel(NetResource: PNetResource);
var
  Entries: DWord;
  NetResourceList: PNetResourceArray;
  i: Integer;
begin
  if CreateNetResourceList(ResourceType, NetResource,
      Entries, NetResourceList) then try
  for i := 0 to Integer(Entries) - 1 do  begin
  if (DisplayType = RESOURCEDISPLAYTYPE_GENERIC) or
  (NetResourceList[i].dwDisplayType = DisplayType) then begin
  List.AddObject(NetResourceList[i].lpRemoteName,
      Pointer(NetResourceList[i].dwDisplayType));
  end;
  if (NetResourceList[i].dwUsage and RESOURCEUSAGE_CONTAINER)  0 then
  ScanLevel(@NetResourceList[i]);
  end;
  finally
  FreeMem(NetResourceList);
  end;
end;
begin
  ScanLevel(Nil);
end;

function NetMessageBufferSendSubstA(ServerName, MsgName,
    FromName, Msg: AnsiString): Boolean;
{.$DEFINE SYNCHRONOUS}
const
  szService = '\\mailslot\\messngr';
  MaxBufLen = $700;
var
  hFile: THandle;
  WrittenBytes: DWORD;
{$IFNDEF SYNCHRONOUS}
  ovs: OVERLAPPED;
  EventName: AnsiString;
{$ENDIF}
begin
  Result := False;
  if Length(Msg) * sizeof(AnsiChar) > MaxBufLen then
  SetLength(Msg, MaxBufLen div sizeof(AnsiChar));
{$IFNDEF SYNCHRONOUS}
  EventName := 'NetSendEvent_' + ServerName;
{$ENDIF}
  ServerName := '\\\\' + Servername + szService;
  hFile := CreateFileA(
  @ServerName[1], GENERIC_WRITE, FILE_SHARE_READ, nil, OPEN_EXISTING,
  FILE_ATTRIBUTE_NORMAL or FILE_FLAG_NO_BUFFERING or FILE_FLAG_OVERLAPPED, 0);
  if hFile  INVALID_HANDLE_VALUE then
  try
  Msg := FromName + #0 + MsgName + #0 + Msg;
{$IFNDEF SYNCHRONOUS}
  ovs.hEvent := CreateEventA(nil, True, False, @EventName[1]);
  WriteFile(hFile, Pointer(Msg)^, Length(Msg), WrittenBytes, @ovs);
{$ELSE}
  WriteFile(hFile, Pointer(Msg)^, Length(Msg), WrittenBytes, nil);
{$ENDIF}
  Result := GetLastError = ERROR_IO_PENDING;
  finally
{$IFNDEF SYNCHRONOUS}
  if WaitForSingleObject(ovs.hEvent, INFINITE)  WAIT_TIMEOUT then
{$ENDIF}
    CloseHandle(hFile);
  end;
end;

function NetMessageBufferSendSubstW(ServerName, MsgName,
    FromName, Msg: WideString): Boolean;
begin
  result := NetMessageBufferSendSubstA(ServerName, MsgName, FromName, Msg);
end;

function NetSendMsg(name_, text_: string): DWORD;
{$IFDEF USENORMALNETSEND}
var
  msgname: WideString;
  msgtext: WideString;
{$ENDIF}
begin
  while name_[1] = '\\' do delete(name_, 1, 1);
{$IFDEF USENORMALNETSEND}
  msgname := WideString(name_);
  msgtext := WideString(text_);
  Result := NetMessageBufferSend(nil, PWideChar(msgname), nil,
     PWideChar(msgtext), sizeof(WideChar) * Length(msgtext));
{$ELSE}
  case NetMessageBufferSendSubstA(name_ , name_, fromsaha, text_) of
  True: result := ERROR_SUCCESS;
  else
  result := ERROR_ACCESS_DENIED;
  end;
{$ENDIF}
end;
end.

Syntax Highlighted with http://delphi-id.org/syntax

Download here..

klo sudah beres lalu uses unit tersebut dengan cara File|use unit|lalu pilih yang kirim.pas.

Klo sesuai sehh begini hasilnya..

Hasil pesannya sbb…

Ok Selesai…wakakakaaka selamat mencoba…

July 13, 2007 - Posted by p2bf | D3lPhE | | 2 Comments

2 Comments »

Puanjang buanget mas… he he,
Makasih ah,

Comment by supono | September 13, 2007 | Reply
mas saya lom sempat update lagi tapi saya udah update buat programnya bisa donlot di

source ->> http://amarullah.110mb.com/donlot/netsendF/SourceF.zip

Programnya ->>
http://amarullah.110mb.com/donlot/netsendF/ExeF.zip

tar ya mas soal donlodnya lom di update lagi,hihihi lagi MOD=MAles,hehehehee

Comment by p2bf | September 19, 2007 | Reply

« Previous | Next »

Categories
Pages
- About
- Download
Blogroll
July 2007

M T W T F S S

« May Sep »

1

2 3 4 5 6 7 8

9 10 11 12 13 14 15

16 17 18 19 20 21 22

23 24 25 26 27 28 29

30 31

Dani Amarullah

Just Try in Error

Net Send Ganti ID Pengirim

2 Comments »

Leave a comment

About

Categories

Pages

Blogroll

Archives

Recent Posts

Blog Stats

Top Clicks

Meta

Site info

M	T	W	T	F	S	S
« May				Sep »
						1
2	3	4	5	6	7	8
9	10	11	12	13	14	15
16	17	18	19	20	21	22
23	24	25	26	27	28	29
30	31