/[projects]/dao/DelphiScanner/Components/tpsystools_4.04/source/StNetCon.pas
ViewVC logotype

Contents of /dao/DelphiScanner/Components/tpsystools_4.04/source/StNetCon.pas

Parent Directory Parent Directory | Revision Log Revision Log


Revision 2671 - (show annotations) (download)
Tue Aug 25 18:15:15 2015 UTC (8 years, 9 months ago) by torben
File size: 11684 byte(s)
Added tpsystools component
1 // Upgraded to Delphi 2009: Sebastian Zierer
2
3 (* ***** BEGIN LICENSE BLOCK *****
4 * Version: MPL 1.1
5 *
6 * The contents of this file are subject to the Mozilla Public License Version
7 * 1.1 (the "License"); you may not use this file except in compliance with
8 * the License. You may obtain a copy of the License at
9 * http://www.mozilla.org/MPL/
10 *
11 * Software distributed under the License is distributed on an "AS IS" basis,
12 * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
13 * for the specific language governing rights and limitations under the
14 * License.
15 *
16 * The Original Code is TurboPower SysTools
17 *
18 * The Initial Developer of the Original Code is
19 * TurboPower Software
20 *
21 * Portions created by the Initial Developer are Copyright (C) 1996-2002
22 * the Initial Developer. All Rights Reserved.
23 *
24 * Contributor(s):
25 *
26 * ***** END LICENSE BLOCK ***** *)
27
28 {*********************************************************}
29 {* SysTools: StNetCon.pas 4.04 *}
30 {*********************************************************}
31 {* SysTools: Net Connection Class *}
32 {*********************************************************}
33
34 {$I STDEFINE.INC}
35
36 {$H+} {Huge strings}
37
38 unit StNetCon;
39
40 interface
41
42 uses
43 Windows, Classes, StBase;
44
45 type
46 TStNetConnectOptions = (coUseConnectDialog, coPersistentConnection,
47 coReadOnlyPath, coUseMRU, coHideRestoreBox,
48 coPromptForAccount, coAlwaysPromptForAccount,
49 coRedirectIfNeeded);
50 TStNetDisconnectOptions = (doUseDisconnectDialog, doUpdateProfile,
51 doForceFilesClosed, doPromptToForceFilesClosed);
52
53 TStNetConnectOptionsSet = set of TStNetConnectOptions;
54 TStNetDisconnectOptionsSet = set of TStNetDisconnectOptions;
55
56 TOnConnectFailEvent = procedure(Sender: TObject; ErrorCode: DWord) of object;
57 TOnConnectCancelEvent = procedure(Sender: TObject; ErrorCode: DWord) of object;
58
59 TOnDisconnectFailEvent = procedure(Sender: TObject; ErrorCode: DWord) of object;
60 TOnDisconnectCancelEvent = procedure(Sender: TObject; ErrorCode: DWord) of object;
61
62
63 TStNetConnection = class(TStComponent)
64 protected { Protected declarations }
65 FLocalDevice : String;
66 FPassword : String;
67 FServerName : String;
68 FShareName : String;
69 FUserName : String;
70 FConnectOptions : TStNetConnectOptionsSet;
71 FDisconnectOptions : TStNetDisconnectOptionsSet;
72
73 FOnConnect : TNotifyEvent;
74 FOnConnectFail : TOnConnectFailEvent;
75 FOnConnectCancel : TOnConnectCancelEvent;
76 FOnDisconnect : TNotifyEvent;
77 FOnDisconnectFail : TOnDisconnectFailEvent;
78 FOnDisconnectCancel: TOnDisconnectCancelEvent;
79 private { Private declarations }
80 function GetServerName: string;
81 procedure SetServerName(Value: string);
82 public { Public declarations }
83 constructor Create(AOwner: TComponent); override;
84 destructor Destroy; override;
85
86 function Connect: DWord;
87 function Disconnect: DWord;
88
89 property Password: String read FPassword write FPassword;
90 property UserName: String read FUserName write FUserName;
91 published { Published declarations }
92 property ConnectOptions : TStNetConnectOptionsSet
93 read FConnectOptions write FConnectOptions;
94 property DisconnectOptions : TStNetDisconnectOptionsSet
95 read FDisconnectOptions write FDisconnectOptions;
96
97 property LocalDevice: String
98 read FLocalDevice write FLocalDevice;
99 property ServerName : String
100 read GetServerName write SetServerName;
101 property ShareName : String
102 read FShareName write FShareName;
103
104 property OnConnect: TNotifyEvent
105 read FOnConnect write FOnConnect;
106 property OnConnectFail: TOnConnectFailEvent
107 read FOnConnectFail write FOnConnectFail;
108 property OnConnectCancel: TOnConnectCancelEvent
109 read FOnConnectCancel write FOnConnectCancel;
110 property OnDisconnect: TNotifyEvent
111 read FOnDisconnect write FOnDisconnect;
112 property OnDisconnectFail: TOnDisconnectFailEvent
113 read FOnDisconnectFail write FOnDisconnectFail;
114 property OnDisconnectCancel: TOnDisconnectCancelEvent
115 read FOnDisconnectCancel write FOnDisconnectCancel;
116 end;
117
118 implementation
119
120 uses StStrL,
121 SysUtils;
122
123 constructor TStNetConnection.Create(AOwner: TComponent);
124 begin
125 inherited Create(AOwner);
126 FConnectOptions := [coUseConnectDialog, coUseMRU, coPromptForAccount];
127 FDisconnectOptions := [doUseDisconnectDialog, doPromptToForceFilesClosed];
128 end;
129
130 destructor TStNetConnection.Destroy;
131 begin
132 inherited Destroy;
133 end;
134
135 function TStNetConnection.GetServerName: string;
136 begin
137 { don't return any UNC notation }
138 Result := FilterL(FServerName, '\');
139 end;
140
141 procedure TStNetConnection.SetServerName(Value : string);
142 begin
143 { get rid of any UNC notation or trailing marks }
144 Value := FilterL(Value, '\');
145
146 { do we have a valid server name? }
147 if (Length(Value) > 0) then
148 FServerName := '\\' + Value
149 else
150 FServerName := Value;
151 end;
152
153 function TStNetConnection.Connect: DWord;
154 var
155 CDS : TConnectDlgStruct;
156 NR : TNetResource;
157 ServerAndShare : String;
158 DevRedirect : Pointer;
159 DevRedirectSize: DWord;
160 COFlags : DWord;
161 LDResult : DWord;
162 UN, PW : PChar;
163 X : string;
164 begin
165 { Fill in the structures with 'nil' values as the default }
166 FillChar(CDS, SizeOf(CDS), 0);
167 FillChar(NR, SizeOf(NR), 0);
168
169 { we can only connect to DISK resources }
170 NR.dwType := RESOURCETYPE_DISK;
171
172 { fill in the default server and share names }
173 if (Length(FServerName) > 0) then begin
174 ServerAndShare := FServerName;
175 if (Length(FShareName) > 0) then
176 ServerAndShare := ServerAndShare + '\' + FShareName;
177 NR.lpRemoteName := PChar(ServerAndShare);
178 end;
179
180 { Get the needed memory for any device redirections that occur .. 20 seems like a good buffer }
181 DevRedirectSize := Length(NR.lpRemoteName) + 20;
182 GetMem(DevRedirect, DevRedirectSize * SizeOf(Char));
183 LDResult := 0;
184
185 { do we have a LocalDevice name to use? }
186 if Length(FLocalDevice) > 0 then
187 NR.lpLocalName := PChar(FLocalDevice);
188
189
190 if (coUseConnectDialog in FConnectOptions) then begin
191 { always set the size of the record structure }
192 CDS.cbStructure := SizeOf(CDS);
193
194 { what options, if any, do we need to display? }
195 if (coReadOnlyPath in FConnectOptions) and (Length(NR.lpRemoteName) > 1) and
196 (not (coUseMRU in FConnectOptions)) then
197 CDS.dwFlags := CDS.dwFlags + CONNDLG_RO_PATH;
198 if (coUseMRU in FConnectOptions) then
199 CDS.dwFlags := CDS.dwFlags + CONNDLG_USE_MRU;
200 if (coHideRestoreBox in FConnectOptions) then
201 CDS.dwFlags := CDS.dwFlags + CONNDLG_HIDE_BOX;
202 if (coPersistentConnection in FConnectOptions) then
203 CDS.dwFlags := CDS.dwFlags + CONNDLG_PERSIST
204 else
205 CDS.dwFlags := CDS.dwFlags + CONNDLG_NOT_PERSIST;
206
207 { set the netresource information of the connect structure }
208 CDS.lpConnRes := @NR;
209
210 { call the API and display the dialog }
211 Result := WNetConnectionDialog1(CDS);
212 if (Result = NO_ERROR) and (CDS.dwDevNum > 0) then begin
213 LDResult := CONNECT_LOCALDRIVE;
214 X := Char(Ord('A') + CDS.dwDevNum - 1) + ':';
215 StrCopy(DevRedirect, PChar(X));
216 end;
217 end else begin
218 { fill in the necessary NetResource information }
219 COFlags := 0;
220 if (coAlwaysPromptForAccount in FConnectOptions) then
221 COFlags := COFlags + CONNECT_INTERACTIVE + CONNECT_PROMPT
222 else if (coPromptForAccount in FConnectOptions) then
223 COFlags := COFlags + CONNECT_INTERACTIVE;
224 if (coRedirectIfNeeded in FConnectOptions) then
225 COFlags := COFlags + CONNECT_REDIRECT;
226 if (coPersistentConnection in FConnectOptions) then
227 COFLags := COFlags + CONNECT_UPDATE_PROFILE;
228
229 { Set up the Username and password }
230 UN := nil;
231 PW := nil;
232 if Length(FUserName) > 0 then
233 UN := PChar(FUserName);
234 if Length(FPassword) > 0 then
235 PW := PChar(FPassword);
236
237 { Call the API .. the Parameter order is different for NT and 9x }
238
239 if (Win32Platform = VER_PLATFORM_WIN32_NT) then
240 Result := WNetUseConnection(0, NR, UN, PW, COFlags, DevRedirect,
241 DevRedirectSize, LDResult)
242 else
243 Result := WNetUseConnection(0, NR, PW, UN, COFlags, DevRedirect,
244 DevRedirectSize, LDResult);
245
246 {
247 Result := WNetUseConnection(0, NR, UN, PW, COFlags, DevRedirect,
248 DevRedirectSize, LDResult);
249 if Result = ERROR_INVALID_PASSWORD then
250 Result := WNetUseConnection(0, NR, PW, UN, COFlags, DevRedirect,
251 DevRedirectSize, LDResult);
252 }
253 end;
254
255 case Result of
256 NO_ERROR :
257 if Assigned(FOnConnect) then
258 FOnConnect(Self);
259 1223, $FFFFFFFF :
260 if Assigned(FOnConnectCancel) then
261 FOnConnectCancel(Self, Result);
262 else
263 if Assigned(FOnConnectFail) then
264 FOnConnectFail(Self, Result)
265 end;
266
267 { Free up the device redirection memory }
268 FreeMem(DevRedirect);
269 end;
270
271 function TStNetConnection.Disconnect: DWord;
272 var
273 DDS : TDiscDlgStruct;
274 ServerAndShare : String;
275 UpdateProfile : DWord;
276 begin
277 if (doUseDisconnectDialog in FDisconnectOptions) then begin
278 Result := WNetDisconnectDialog(0, RESOURCETYPE_DISK);
279 end else begin
280 { fill in the default server and share names }
281 if (Length(FServerName) > 0) then begin
282 ServerAndShare := FServerName;
283 if (Length(FShareName) > 0) then
284 ServerAndShare := ServerAndShare + '\' + FShareName;
285 end;
286
287 if (doForceFilesClosed in FDisconnectOptions) and
288 (not (doPromptToForceFilesClosed in FDisconnectOptions)) then begin
289 { what options, if any, do we need? }
290 if (doUpdateProfile in FDisconnectOptions) then
291 UpdateProfile := CONNECT_UPDATE_PROFILE
292 else
293 UpdateProfile := 0;
294
295 { call the API }
296 if Length(FLocalDevice) > 0 then
297 Result := WNetCancelConnection2(PChar(FLocalDevice),
298 UpdateProfile, True)
299 else
300 Result := WNetCancelConnection2(PChar(ServerAndShare),
301 UpdateProfile, True)
302 end else begin
303 { Fill in the structure with 'nil' values as the default }
304 FillChar(DDS, SizeOf(DDS), 0);
305
306 { always set the size of the record structure }
307 DDS.cbStructure := SizeOf(DDS);
308
309 if Length(FLocalDevice) > 0 then
310 DDS.lpLocalName := PChar(FLocalDevice);
311
312 DDS.lpRemoteName := PChar(ServerAndShare);
313
314 { what options, if any, do we need to display? }
315 if (doUpdateProfile in FDisconnectOptions) then
316 DDS.dwFlags := DDS.dwFlags + DISC_UPDATE_PROFILE;
317
318 if not (doForceFilesClosed in FDisconnectOptions) then
319 DDS.dwFlags := DDS.dwFlags + DISC_NO_FORCE;
320
321 { call the API }
322 Result := WNetDisconnectDialog1(DDS);
323 end;
324 end;
325
326 case Result of
327 NO_ERROR :
328 if Assigned(FOnDisconnect) then
329 FOnDisconnect(Self);
330 $FFFFFFFF :
331 if Assigned(FOnDisconnectCancel)
332 then FOnDisconnectCancel(Self, Result);
333 else
334 if Assigned(FOnDisconnectFail) then
335 FOnDisconnectFail(Self, Result)
336 end;
337 end;
338
339 end.

  ViewVC Help
Powered by ViewVC 1.1.20