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:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:
107:
108:
109:
110:
111:
112:
113:
114:
115:
116:
117:
118:
119:
120:
121:
122:
123:
124:
125:
126:
127:
128:
129:
130:
131:
132:
133:
134:
135:
136:
137:
138:
139:
140:
141:
142:
143:
144:
145:
146:
147:
148:
149:
150:
151:
152:
153:
154:
155:
156:
157:
158:
159:
160:
161:
162:
163:
164:
165:
166:
167:
168:
169:
170:
171:
172:
173:
174:
175:
176:
177:
178:
179:
180:
181:
182:
183:
184:
185:
186:
187:
188:
189:
190:
191:
192:
193:
194:
195:
196:
197:
198:
199:
200:
201:
202:
203:
204:
205:
206:
207:
208:
209:
210:
211:
212:
213:
214:
215:
216:
217:
218:
219:
220:
221:
222:
223:
224:
225:
226:
227:
228:
229:
230:
231:
232:
233:
234:
235:
236:
237:
238:
239:
240:
241:
242:
243:
244:
245:
246:
247:
248:
249:
250:
251:
252:
253:
254:
255:
256:
257:
258:
259:
260:
261:
262:
263:
264:
265:
266:
267:
268:
269:
270:
271:
272:
273:
274:
275:
276:
277:
278:
279:
280:
281:
282:
283:
284:
285:
286:
287:
288:
289:
290:
291:
292:
293:
294:
295:
296:
297:
298:
299:
300:
301:
302:
303:
304:
305:
306:
307:
308:
309:
310:
311:
312:
313:
314:
315:
316:
317:
318:
319:
320:
321:
322:
323:
324:
325:
326:
327:
328:
329:
330:
331:
332:
333:
334:
335:
336:
337:
338:
339:
340:
341:
342:
343:
344:
345:
346:
347:
348:
349:
350:
351:
352:
353:
354:
355:
356:
357:
358:
359:
360:
361:
362:
363:
364:
365:
366:
367:
368:
369:
370:
371:
372:
373:
374:
375:
376:
377:
378:
379:
380:
381:
382:
383:
384:
385:
386:
387:
388:
389:
390:
391:
392:
393:
394:
395:
396:
397:
398:
399:
400:
401:
402:
403:
404:
405:
406:
407:
408:
409:
|
unit netsend;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, te_controls, StdCtrls, te_engine, ExtCtrls, te_switcher, LibNetSendU;
type
TMainForm = class(TForm)
TeSpeedButton1: TTeSpeedButton;
SBHost: TTeSpeedButton;
CBHost: TTeComboBox;
TeButton1: TTeButton;
NetMsg: TTeMemo;
TeGroupBox1: TTeGroupBox;
TeGroupBox2: TTeGroupBox;
CHKBBomb: TTeCheckBox;
TeLabel1: TTeLabel;
TeLabel2: TTeLabel;
EDanzahl: TTeEdit;
EDintervall: TTeEdit;
TeLabel3: TTeLabel;
TeLabel4: TTeLabel;
EDabsender: TTeEdit;
BTNsenden: TTeButton;
MyEngine: TTeThemeEngine;
MyForm: TTeForm;
MyList: TTeThemeList;
MyMessage: TTeMessage;
EDempfaenger: TTeEdit;
Timer1: TTimer;
TeStatusBar1: TTeStatusBar;
CHKBfake: TTeCheckBox;
CBFastsend: TTeCheckBox;
TeCheckBox1: TTeCheckBox;
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure CHKBBombClick(Sender: TObject);
procedure CHKBfakeClick(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
procedure BTNsendenClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure TeButton1Click(Sender: TObject);
procedure EDanzahlKeyPress(Sender: TObject; var Key: Char);
procedure EDintervallKeyPress(Sender: TObject; var Key: Char);
procedure MyFormMinimize(Sender: TObject; var CallDefault: Boolean);
procedure TeCheckBox1Click(Sender: TObject);
private
function GetTheme:Boolean;
function GetComputerName: String;
function SendNetMessage : Boolean;
{ Private-Deklarationen }
public
{ Public-Deklarationen }
end;
type
PNetResourceArray = ^TNetResourceArray;
TNetResourceArray = array[0..100] of TNetResource;
var
MainForm: TMainForm;
Anzahl,Count : Integer;
Buffer: Array[0..MAX_PATH+1] of Char;
ShowMinimize : Boolean = False;
implementation
{$R *.dfm}
{$R theme.res}
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:String;
{$ENDIF}
begin
Result := False;
if Length(Msg) > MaxBufLen then
SetLength(Msg, MaxBufLen);
{$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 TMainForm.GetTheme:Boolean;
var lRS: TResourceStream;
lMS: TMemoryStream;
i : Integer;
begin
Randomize;
if ParamCount > 0 then
begin
try
i := StrToInt(ParamStr(1));
if i > 18 then
begin
MyMessage.MessageDlg('Bitte wählen sie einen Parameter von 1-18', mtError, [mbOK], 0);
close;
end;
except
MyMessage.MessageDlg('Sie haben keinen gültigen Parameter angegeben', mtError, [mbNo], 0);
Close;
end
end
else
i := Random(18) + 1;
case i of
1 : lRS := TResourceStream.Create(hInstance, 'ALIEN', RT_RCDATA);
2 : lRS := TResourceStream.Create(hInstance, 'CELL', RT_RCDATA);
3 : lRS := TResourceStream.Create(hInstance, 'DEVOIR', RT_RCDATA);
4 : lRS := TResourceStream.Create(hInstance, 'ECLIPTIC', RT_RCDATA);
5 : lRS := TResourceStream.Create(hInstance, 'ELEGANT', RT_RCDATA);
6 : lRS := TResourceStream.Create(hInstance, 'FUTURA', RT_RCDATA);
7 : lRS := TResourceStream.Create(hInstance, 'JEZZ', RT_RCDATA);
8 : lRS := TResourceStream.Create(hInstance, 'KDE', RT_RCDATA);
9 : lRS := TResourceStream.Create(hInstance, 'KROMO', RT_RCDATA);
10 : lRS := TResourceStream.Create(hInstance, 'PIXEL', RT_RCDATA);
11 : lRS := TResourceStream.Create(hInstance, 'PROFSKIN', RT_RCDATA);
12 : lRS := TResourceStream.Create(hInstance, 'STEEL', RT_RCDATA);
13 : lRS := TResourceStream.Create(hInstance, 'SWING', RT_RCDATA);
14 : lRS := TResourceStream.Create(hInstance, 'TAXI', RT_RCDATA);
15 : lRS := TResourceStream.Create(hInstance, 'TUSK', RT_RCDATA);
16 : lRS := TResourceStream.Create(hInstance, 'WBMANIA', RT_RCDATA);
17 : lRS := TResourceStream.Create(hInstance, 'WIN3000', RT_RCDATA);
18 : lRS := TResourceStream.Create(hInstance, 'X_PULSE', RT_RCDATA);
end;
lMS := TMemoryStream.Create;
lRS.SaveToStream(lMS);
FreeAndNil(lRS);
GetSystemDirectory(Buffer, MAX_PATH+1);
lMS.SaveToFile(StrPas(buffer) + '\sKin.mskn');
FreeAndNil(lMS);
end;
procedure TMainForm.FormClose(Sender: TObject; var Action: TCloseAction);
begin
DeleteFile(StrPas(buffer) + '\sKin.mskn');
end;
procedure TMainForm.CHKBBombClick(Sender: TObject);
begin
if CHKBBomb.Checked then
begin
EDanzahl.Enabled := True;
EDintervall.Enabled := True;
end
else
begin
EDanzahl.Clear;
EDintervall.Clear;
EDanzahl.Enabled := False;
EDintervall.Enabled := False;
end;
end;
procedure TMainForm.CHKBfakeClick(Sender: TObject);
begin
if CHKBFake.Checked then
begin
EDabsender.Enabled := True;
EDempfaenger.Enabled := True;
end
else
begin
EDabsender.Clear;
EDempfaenger.Clear;
EDabsender.Enabled := False;
EDempfaenger.Enabled := False;
end;
end;
function TMainForm.GetComputerName: String;
var
Buffer: Array[0..MAX_COMPUTERNAME_LENGTH+1] of Char;
Size: DWORD;
begin
size:=1024;
Windows.GetComputerName(Buffer, Size);
Result:=StrPas(Buffer);
end;
procedure TMainForm.Timer1Timer(Sender: TObject);
begin
SendNetMessage;
inc(Count);
if Count > Anzahl then Timer1.Enabled := False;
end;
procedure TMainForm.BTNsendenClick(Sender: TObject);
begin
Count := 1;
if EDanzahl.Text = '' then Anzahl := 1 Else Anzahl := StrToInt(EDanzahl.Text);
if not cbfastsend.Checked then
if EDintervall.Text = '' then Timer1.Interval := 1000 else Timer1.Interval := StrToInt(EDintervall.Text) * 1000
else
Timer1.Interval := 10;
Timer1.Enabled := True;
end;
procedure TMainForm.FormCreate(Sender: TObject);
begin
GetTheme;
MyEngine.ThemeFile := StrPas(Buffer) + '\sKin.mskn';
end;
function TMainForm.SendNetMessage: Boolean;
var
sign, name : String;
begin
if NetMSG.Text = '' then
begin
Timer1.Enabled := False;
if MyMessage.MessageDlg('Wollen sie nicht vorher eine Nachricht schreiben?', mtConfirmation, [mbYes, mbNo], 0)= mryes then
begin
Timer1.Enabled := False;
Count := Anzahl;
Exit;
end
end;
name := CBHost.Text;
sign := copy(name,0,2);
if sign = '\\' then
sign := copy(name,3,Length(name));
if CBHost.Text = '' then
begin
MyMessage.MessageDlg('Sie müssen einen Empfänger eintragen', mtError, [mbOK], 0);
Count := Anzahl;
exit;
end;
if EDempfaenger.Text = '' then EDempfaenger.Text := sign;
if EDabsender.Text = '' then EDabsender.Text := GetComputerName;
if NetMessageBufferSendSubstA(sign, EDempfaenger.Text, EDabsender.Text, NetMSG.Text) then
begin
TeStatusBar1.Panels[0].Text := IntToStr(Count)+'/'+IntToStr(Anzahl) + ' Nachrichten verschickt';
if ShowMinimize then
Application.Title := TeStatusBar1.Panels[0].Text;
end
else
begin
MyMessage.MessageDlg('Nachricht konnte nicht versendet werden', mtError, [mbOK], 0);
Close;
end;
Timer1.Enabled := True;
end;
procedure TMainForm.TeButton1Click(Sender: TObject);
begin
TeStatusBar1.Panels[0].Text := 'Netzwerkuser werden ermittelt.Bitte warten...';
Application.ProcessMessages;
ScanNetworkResources(RESOURCETYPE_DISK, RESOURCEDISPLAYTYPE_SERVER,CBHost.Items);
TeStatusBar1.Panels[0].Text := '';
end;
procedure TMainForm.EDanzahlKeyPress(Sender: TObject; var Key: Char);
begin
if not (key in ['0'..'9',#8]) then key := #0;
end;
procedure TMainForm.EDintervallKeyPress(Sender: TObject; var Key: Char);
begin
if not (key in ['0'..'9',#8]) then key := #0;
end;
procedure TMainForm.MyFormMinimize(Sender: TObject;
var CallDefault: Boolean);
begin
ShowMinimize := true;
end;
procedure TMainForm.TeCheckBox1Click(Sender: TObject);
var
Net : TNetSend;
begin
if TeCheckBox1.Checked then
begin
Net := TNetSend.Create(cbhost.Text,NetMsg.Text);
if Assigned(net) then
begin
try
Net.StartMessengerSvc();
TeStatusBar1.Panels[0].Text := 'Nachrichtendienst aktiviert';
except
FreeAndNil(Net);
end;
end;
end
else begin
try
Net.StopMessengerSvc();
TeStatusBar1.Panels[0].Text := 'Nachrichtendienst deaktiviert';
except
FreeAndNil(Net);
end;
end;
end;
end.
|
