source: cprs/branches/HealthSevak-CPRS/VA/VA508Accessibility/JAWUpdate/Message.pas@ 1695

Last change on this file since 1695 was 829, checked in by Kevin Toppenberg, 14 years ago

Upgrade to version 27
File size: 9.3 KB
Line 
1unit Message;
2
3interface
4
5uses
6 Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
7 Dialogs, StdCtrls, Registry, ActiveX, ComObj, ExtCtrls, comserv;
8
9type
10 TfrmMessage = class(TForm)
11 Label1: TLabel;
12 Panel1: TPanel;
13 Button1: TButton;
14 procedure FormCreate(Sender: TObject);
15 procedure FormShow(Sender: TObject);
16 procedure Button1Click(Sender: TObject);
17 private
18 { Private declarations }
19 public
20 Done: boolean;
21 end;
22
23var
24 frmMessage: TfrmMessage;
25
26implementation
27
28uses VAUtils, FSAPILib_TLB, VA508AccessibilityConst;
29
30{$R *.dfm}
31{$R FSAPIVER.res}
32{$R JAWSAPI.res}
33
34const
35 JAWS_INSTALL_DIRECTORY_KEY = 'SOFTWARE\Freedom Scientific\JAWS\';
36 JAWS_INSTALL_DIRECTORY_VAR = 'Target';
37 JAWS_SHARED_DIR = 'Shared\';
38 JAWS_FSAPI_DIR = 'fsapi\';
39 DLL_NAME = 'FSAPI.dll';
40 CPP_INSTALL_APP = 'vcredist_x86.exe';
41
42type
43 TDllRegisterServer = function: HResult; stdcall;
44
45const
46 DllRegisterServerName = 'DllRegisterServer';
47
48 UPDATE_VERSION_ID = 5000;
49 TARGET_DIR_ID = 5001;
50 DLL_RESOURCE_NAME = 'COMOBJECT';
51
52procedure TfrmMessage.Button1Click(Sender: TObject);
53begin
54 Close;
55end;
56
57procedure TfrmMessage.FormCreate(Sender: TObject);
58var
59 UpdateDirs: TStringList;
60 msg: string;
61 buffer: array[0..255] of char;
62
63 procedure ProcessParams;
64 var
65 data: TStringList;
66 version: string;
67
68 begin
69 if (ParamCount > 1) and FileExists(ParamStr(1)) then
70 begin
71 version := FileVersionValue(ParamStr(1), FILE_VER_FILEVERSION);
72 data := TStringList.Create;
73 try
74 data.add('STRINGTABLE');
75 data.add('{');
76 data.add(' ' + IntToStr(UPDATE_VERSION_ID) + ', "' + version + '"');
77 data.add('}');
78 data.SaveToFile(ParamStr(2));
79 finally
80 data.Free;
81 end;
82 end;
83 Done := TRUE;
84 end;
85
86 procedure GetTargetDirectories(Dirs: TStringList);
87 var
88 reg: TRegistry;
89 keys: TStringList;
90 idx, i: integer;
91 key, dir: string;
92 JFile, JFileVersion: string;
93 VerOK, Found: boolean;
94
95 begin
96 keys := TStringList.Create;
97 try
98 reg := TRegistry.Create(KEY_READ);
99 try
100 reg.RootKey := HKEY_LOCAL_MACHINE;
101 reg.OpenKeyReadOnly(JAWS_INSTALL_DIRECTORY_KEY);
102 reg.GetKeyNames(keys);
103 Found := FALSE;
104 for I := 0 to keys.Count - 1 do
105 begin
106 key := JAWS_INSTALL_DIRECTORY_KEY + keys[i] + '\';
107 reg.CloseKey;
108 if reg.OpenKeyReadOnly(key) then
109 begin
110 dir := LowerCase(reg.ReadString(JAWS_INSTALL_DIRECTORY_VAR));
111 JFile := AppendBackSlash(dir) + JAWS_APPLICATION_FILENAME;
112 if FileExists(JFile) then
113 begin
114 Found := TRUE;
115 JFileVersion := FileVersionValue(JFile, FILE_VER_FILEVERSION);
116 VerOK := VersionOK(JAWS_REQUIRED_VERSION, JFileVersion);
117 if VerOK then
118 begin
119 idx := pos('\jaws\', dir);
120 if idx > 0 then
121 begin
122 dir := copy(dir, 1, idx);
123 if dirs.IndexOf(dir) < 0 then
124 dirs.Add(dir);
125 end;
126 end;
127 end;
128 end;
129 end;
130 if found and (dirs.Count = 0) then
131 dirs.Add('');
132 finally
133 reg.Free;
134 end;
135 finally
136 keys.free;
137 end;
138 end;
139
140 function RegSvr(filename: string): boolean;
141 var
142 dll: HModule;
143 regsvr: TDllRegisterServer;
144 begin
145 Result := TRUE;
146 dll := 0;
147 try
148 dll := LoadLibrary(PChar(Filename));
149 if dll > HINSTANCE_ERROR then
150 begin
151 try
152 regsvr := GetProcAddress(dll, DllRegisterServerName);
153 if assigned(regsvr) then
154 OleCheck(regsvr);
155 finally
156 FreeLibrary(dll);
157 end;
158 end
159 else
160 Result := FALSE;
161 except
162 Result := FALSE;
163 if dll > HINSTANCE_ERROR then
164 FreeLibrary(dll);
165 end;
166 end;
167
168 procedure RegisterServer(filename: string; var msg: string);
169 var
170 api: IJawsApi;
171 oldmsg: string;
172 Registered: boolean;
173 cppInstall: string;
174
175 begin
176 try
177 try
178 api := CoJawsApi.Create;
179 except
180 oldmsg := msg;
181 msg := 'Error registering the required JAWS Component (' + DLL_NAME +
182 '). You must have admin rights on your machine to register this component. ' +
183 'Please contact your system administrator for assistance.';
184 try
185 Registered := RegSvr(filename);
186 if not Registered then
187 begin
188 cppInstall := ExtractFilePath(Application.ExeName) + CPP_INSTALL_APP;
189 if fileExists(cppInstall) then
190 begin
191 ExecuteAndWait(cppInstall);
192 Registered := RegSvr(filename);
193 end;
194 end;
195
196 if Registered then
197 begin
198 api := CoJawsApi.Create;
199
200 if oldmsg = '' then
201 msg :=''
202 else
203 msg := oldmsg + #13#10;
204 msg := msg + 'The required JAWS Component has been successfully registered.';
205 end;
206 except
207 end;
208 end;
209 finally
210 api := nil;
211 end;
212 end;
213
214 procedure UpdateCheck(UpdateDirs: TStringList; var msg: string);
215 var
216 UpdateVersion, ExistingVersion: string;
217 i: integer;
218 dirs: TStringList;
219 filename, dir, TargetDir: string;
220 update: boolean;
221
222 begin
223 LoadString(HInstance, UPDATE_VERSION_ID, @buffer, 255);
224 UpdateVersion := StrPas(buffer);
225
226 LoadString(HInstance, TARGET_DIR_ID, @buffer, 255);
227 TargetDir := StrPas(buffer);
228
229 dirs := TStringList.Create;
230 try
231 GetTargetDirectories(dirs);
232 if dirs.Count < 1 then
233 msg := 'Can not find JAWS installed on this machine';
234 if (dirs.Count = 1) and (dirs[0] = '') then
235 begin
236 dirs.Delete(0);
237 msg := 'JAWS version ' + JAWS_REQUIRED_VERSION + ' or higher is required in order to run JAWSUpdate';
238 end;
239 for I := 0 to dirs.Count - 1 do
240 begin
241 dir := dirs[i] + JAWS_SHARED_DIR + JAWS_FSAPI_DIR + TargetDir;
242 dir := AppendBackSlash(dir);
243 update := TRUE;
244 if DirectoryExists(dir) then
245 begin
246 filename := dir + DLL_NAME;
247 if FileExists(fileName) then
248 begin
249 ExistingVersion := FileVersionValue(fileName, FILE_VER_FILEVERSION);
250 update := not VersionOK(UpdateVersion, ExistingVersion);
251 if not update then
252 RegisterServer(filename, msg);
253 end;
254 end;
255 if update then
256 UpdateDirs.Add(dirs[i]);
257 end;
258 finally
259 dirs.Free;
260 end;
261 if (UpdateDirs.Count < 1) and (msg = '') then
262 msg := 'The required JAWS Component is already installed on your machine';
263 end;
264
265 function MakeDirError(dir: string; var msg: string): boolean;
266 begin
267 Result := FALSE;
268 if not DirectoryExists(dir) then
269 begin
270 if not CreateDir(dir) then
271 begin
272 msg := 'Error Creating Directory ' + dir;
273 Result := TRUE;
274 end;
275 end;
276 end;
277
278 procedure DoUpdate(UpdateDirs: TStringList; var msg: string);
279 var
280 i: integer;
281 dir, last: string;
282 TargetDir: string;
283 rs: TResourceStream;
284 fs: TFileStream;
285 filename: string;
286
287 begin
288 LoadString(HInstance, TARGET_DIR_ID, @buffer, 255);
289 TargetDir := StrPas(buffer);
290
291 for I := 0 to UpdateDirs.Count - 1 do
292 begin
293 dir := UpdateDirs[i];
294 if MakeDirError(dir, msg) then continue;
295 dir := dir + JAWS_SHARED_DIR;
296 if MakeDirError(dir, msg) then continue;
297 dir := dir + JAWS_FSAPI_DIR;
298 if MakeDirError(dir, msg) then continue;
299 dir := dir + TargetDir;
300 dir := AppendBackSlash(dir);
301 if MakeDirError(dir, msg) then continue;
302 filename := dir + DLL_NAME;
303 if FileExists(filename) then
304 DeleteFile(filename);
305 last := filename;
306 try
307 rs := TResourceStream.Create(HInstance, DLL_RESOURCE_NAME, RT_RCDATA);
308 try
309 fs := TFileStream.Create(filename, fmCreate OR fmShareExclusive);
310 try
311 fs.CopyFrom(rs, rs.Size);
312 finally
313 fs.Free;
314 end;
315 finally
316 rs.Free;
317 end;
318 except
319 on e:Exception do
320 msg := e.Message;
321 end;
322 end;
323 if msg = '' then
324 begin
325 msg := 'The required JAWS Component has been successfully installed.';
326 RegisterServer(last, msg);
327 end;
328 end;
329
330 procedure DeleteOldUpdater;
331 var
332 u8File: string;
333 begin
334 u8File := ExtractFilePath(Application.ExeName) + 'Jaws8Update.exe';
335 if fileExists(u8File) then
336 SysUtils.DeleteFile(u8File);
337 end;
338
339begin
340 if (ParamCount > 0) then
341 ProcessParams
342 else
343 begin
344 DeleteOldUpdater;
345 UpdateDirs := TStringList.Create;
346 try
347 msg := '';
348 UpdateCheck(UpdateDirs, msg);
349 if UpdateDirs.Count > 0 then
350 DoUpdate(UpdateDirs, msg);
351 label1.Caption := msg;
352 finally
353 UpdateDirs.Free;
354 end;
355 end;
356end;
357
358procedure TfrmMessage.FormShow(Sender: TObject);
359begin
360 if Done then Close;
361end;
362
363end.
Note: See TracBrowser for help on using the repository browser.