source: cprs/branches/GUI-config/BDK32/Source/Rpcbedtr.pas@ 1240

Last change on this file since 1240 was 476, checked in by Kevin Toppenberg, 16 years ago

New WorldVistA Config Utility

File size: 4.4 KB
Line 
1{ **************************************************************
2 Package: XWB - Kernel RPCBroker
3 Date Created: Sept 18, 1997 (Version 1.1)
4 Site Name: Oakland, OI Field Office, Dept of Veteran Affairs
5 Developers: Danila Manapsal, Don Craven, Joel Ivey
6 Description: Property Editors for TRPCBroker component.
7 Current Release: Version 1.1 Patch 40 (January 7, 2005))
8*************************************************************** }
9
10unit RpcbEdtr;
11
12{$I IISBase.inc}
13
14interface
15
16uses
17 {Delphi standard}
18 Classes, Controls, Dialogs,
19 {$IFDEF D6_OR_HIGHER}
20 DesignIntf, DesignEditors, DesignMenus,
21 {$ELSE}
22 DsgnIntf,
23 {$ENDIF}
24 Forms, Graphics, Messages, SysUtils,
25 WinProcs, WinTypes,
26 Trpcb; //P14 -- pack split
27
28
29type
30
31{------ TRemoteProc property editor ------}
32 {This property editor gets a list of remote procedures from the API file.}
33
34TRemoteProcProperty = class(TStringProperty)
35private
36 { Private declarations }
37protected
38 { Protected declarations }
39public
40 { Public declarations }
41 function GetAttributes: TPropertyAttributes; override;
42 procedure GetValues(Proc: TGetStrProc); override;
43 procedure SetValue(const Value: string); override;
44end;
45
46
47{------ TServerProperty property editor ------}
48 {This property editor gets a list of servers from the C:\WINDOWS\HOSTS file}
49
50TServerProperty = class(TStringProperty)
51private
52 { Private declarations }
53protected
54 { Protected declarations }
55public
56 { Public declarations }
57 function GetAttributes: TPropertyAttributes; override;
58 procedure GetValues(Proc: TGetStrProc); override;
59 function GetValue: string; override;
60 procedure SetValue(const Value: string); override;
61end;
62
63
64{------ TRpcVersion property editor ------}
65 {This property editor checks to make sure that RpcVersion is not eimpty.
66 If it is, it stuffs '0' (default).}
67
68TRpcVersionProperty = class(TStringProperty)
69private
70 { Private declarations }
71protected
72 { Protected declarations }
73public
74 { Public declarations }
75 procedure SetValue(const Value: string); override;
76end;
77
78
79procedure Register;
80
81
82implementation
83
84
85uses
86 XWBut1, MFunStr, {TRPCB,} Hash, RpcbErr; //P14 -- pack split
87
88function TRemoteProcProperty.GetAttributes;
89begin
90 Result := [paAutoUpdate,paValueList];
91end;
92
93procedure TRemoteProcProperty.GetValues(Proc: TGetStrProc);
94var
95 RpcbEdited, RPCBTemp: TRPCBroker;
96 I: integer;
97begin
98 RPCBTemp := nil;
99 RpcbEdited := GetComponent(0) as TRPCBroker;
100 try
101 RPCBTemp := TRPCBroker.Create(RpcbEdited);
102 with RpcbTemp do begin
103 ShowErrorMsgs := RpcbEdited.ShowErrorMsgs;
104 Server := RpcbEdited.Server;
105 ListenerPort := RpcbEdited.ListenerPort;
106 ClearParameters := True;
107 ClearResults := True;
108 RemoteProcedure := 'XWB RPC LIST';
109 Param[0].Value := GetValue;
110 Param[0].PType := literal;
111 Call;
112 for I := 0 to Results.Count - 1 do Proc(Results[I]);
113 end;
114 finally
115 RPCBTemp.Free;
116 end;
117end;
118
119procedure TRemoteProcProperty.SetValue(const Value: string);
120begin
121 SetStrValue(UpperCase(Piece(Value,' [',1))); {convert user entry all to upper case}
122end;
123
124function TServerProperty.GetAttributes;
125begin
126 Result := [paAutoUpdate,paValueList];
127end;
128
129function TServerProperty.GetValue: string;
130begin
131 Result := Piece(GetStrValue,' [',1); {get just the name}
132end;
133
134procedure TServerProperty.GetValues(Proc: TGetStrProc);
135var
136 ServerList: TStringList;
137 I: integer;
138begin
139 ServerList := TStringList.Create;
140 GetHostList(ServerList);
141 for I := 0 to ServerList.Count - 1 do Proc(ServerList[I]);
142 ServerList.Free;
143end;
144
145procedure TServerProperty.SetValue(const Value: string);
146begin
147 SetStrValue(Piece(Value,' [',1)); {get just the name}
148end;
149
150procedure TRpcVersionProperty.SetValue(const Value: string);
151begin
152{
153 try
154 if Value = '' then NetError('Configure',XWB_NullRpcVer)
155 else SetStrValue(Value);
156 except
157 on E: EBrokerError do begin
158 ShowBrokerError(E);
159 SetStrValue('0');
160 end;
161 end;
162}
163 if Value <> '' then SetStrValue(Value)
164 else begin
165 ShowMessage('RPCVersion cannot be empty. Default is 0 (zero).');
166 SetStrValue('0');
167 end;
168end;
169
170procedure Register;
171begin
172 RegisterPropertyEditor(TypeInfo(TRemoteProc),nil,'',TRemoteProcProperty);
173 RegisterPropertyEditor(TypeInfo(TServer),nil,'',TServerProperty);
174 RegisterPropertyEditor(TypeInfo(TRpcVersion),nil,'',TRpcVersionProperty);
175end;
176
177end.
Note: See TracBrowser for help on using the repository browser.