source: cprs/branches/tmg-cprs/CPRS-Chart/TMG_Extra/HTMLEdit/EwbDDE.pas@ 1641

Last change on this file since 1641 was 541, checked in by Kevin Toppenberg, 15 years ago

TMG Ver 1.1 Added HTML Support, better demographics editing

File size: 7.7 KB
Line 
1//*************************************************************
2// Ewb_DDE *
3// *
4// Freeware Unit *
5// For Delphi 5 - 2009 *
6// by *
7// Eran Bodankin (bsalsa) -(bsalsa@gmail.com) *
8// Mathias Walter (mich@matze.tv) *
9// *
10// Documentation and updated versions: *
11// *
12// http://www.bsalsa.com *
13//*************************************************************
14{LICENSE:
15THIS SOFTWARE IS PROVIDED TO YOU "AS IS" WITHOUT WARRANTY OF ANY KIND,
16EITHER EXPRESSED OR IMPLIED INCLUDING BUT NOT LIMITED TO THE APPLIED
17WARRANTIES OF MERCHANTABILITY AND/OR FITNESS FOR A PARTICULAR PURPOSE.
18YOU ASSUME THE ENTIRE RISK AS TO THE ACCURACY AND THE USE OF THE SOFTWARE
19AND ALL OTHER RISK ARISING OUT OF THE USE OR PERFORMANCE OF THIS SOFTWARE
20AND DOCUMENTATION. BSALSA PRODUCTIONS DOES NOT WARRANT THAT THE SOFTWARE IS ERROR-FREE
21OR WILL OPERATE WITHOUT INTERRUPTION. THE SOFTWARE IS NOT DESIGNED, INTENDED
22OR LICENSED FOR USE IN HAZARDOUS ENVIRONMENTS REQUIRING FAIL-SAFE CONTROLS,
23INCLUDING WITHOUT LIMITATION, THE DESIGN, CONSTRUCTION, MAINTENANCE OR
24OPERATION OF NUCLEAR FACILITIES, AIRCRAFT NAVIGATION OR COMMUNICATION SYSTEMS,
25AIR TRAFFIC CONTROL, AND LIFE SUPPORT OR WEAPONS SYSTEMS. BSALSA PRODUCTIONS SPECIFICALLY
26DISCLAIMS ANY EXPRESS OR IMPLIED WARRANTY OF FITNESS FOR SUCH PURPOSE.
27
28You may use/ change/ modify the component under 4 conditions:
291. In your website, add a link to "http://www.bsalsa.com"
302. In your application, add credits to "Embedded Web Browser"
313. Mail me (bsalsa@gmail.com) any code change in the unit for the benefit
32 of the other users.
334. Please, consider donation in our web site!
34{*******************************************************************************}
35
36unit EwbDDE;
37
38interface
39
40uses
41 Windows, Classes, ShellAPI, EWBAcc, Registry, EwbTools, ShlObj, IEConst,
42 sysUtils, ActiveX, ComObj;
43
44type
45 TEwb_DDE = class(TThread)
46 end;
47
48procedure GetDDEVariables;
49function GetCommandTypeFromDDEString(szCommand: string): UINT;
50function GetPathFromDDEString(szCommand: string; var szFolder: string): Boolean;
51function GetPidlFromDDEString(const szCommand: string): PItemIDList;
52function GetShowCmdFromDDEString(szCommand: string): Integer;
53function ParseDDECommand(const szCommand: string; var szFolder: string;
54 var pidl: PItemIDList; var show: Integer): UINT;
55procedure DisposePIDL(ID: PItemIDList);
56
57implementation
58
59uses
60 EwbCoreTools;
61
62var
63 FindFolder, OpenFolder, ExploreFolder, HtmlFileApp, HtmlFileTopic: string;
64 //All DDE variables
65 FoldersApp, FoldersTopic: string;
66
67procedure DisposePIDL(ID: PItemIDList);
68var
69 Malloc: IMalloc;
70begin
71 if ID <> nil then
72 begin
73 OLECheck(SHGetMalloc(Malloc));
74 Malloc.Free(ID);
75 end;
76end;
77
78procedure GetDDEVariables;
79var
80 tmpStr: string;
81 Reg: TRegistry;
82begin
83 Reg := TRegistry.Create;
84 with Reg do
85 try
86 RootKey := HKEY_CLASSES_ROOT;
87 OpenKey('htmlfile\shell\open\ddeexec\application', False);
88 HtmlFileApp := Readstring('');
89 CloseKey;
90 OpenKey('htmlfile\shell\open\ddeexec\topic', False);
91 HtmlFileTopic := ReadString('');
92 CloseKey;
93 OpenKey('Folder\shell\open\ddeexec\application', False);
94 FoldersApp := Readstring('');
95 CloseKey;
96 OpenKey('Folder\shell\open\ddeexec\topic', False);
97 FoldersTopic := ReadString('');
98 CloseKey;
99 OpenKey('Folder\shell\open\ddeexec', False);
100 tmpStr := readString('');
101 CloseKey;
102 tmpStr := Copy(tmpStr, Pos('[', tmpStr) + 1, length(tmpStr));
103 OpenFolder := Copy(tmpStr, 1, Pos('(', tmpStr) - 1);
104 OpenKey('Folder\shell\explore\ddeexec', False);
105 tmpStr := readString('');
106 CloseKey;
107 tmpStr := Copy(tmpStr, Pos('[', tmpStr) + 1, length(tmpStr));
108 ExploreFolder := Copy(tmpStr, 1, Pos('(', tmpStr) - 1);
109 OpenKey('Directory\shell\find\ddeexec', False);
110 tmpStr := readString('');
111 CloseKey;
112 tmpStr := Copy(tmpStr, Pos('[', tmpStr) + 1, length(tmpStr));
113 FindFolder := Copy(tmpStr, 1, Pos('(', tmpStr) - 1);
114 finally
115 Free;
116 end;
117end;
118
119function GetCommandTypeFromDDEString(szCommand: string): UINT;
120begin
121 szCommand := Copy(szCommand, Pos('[', szCommand) + 1, length(szCommand));
122 szCommand := Copy(szCommand, 1, Pos('(', szCommand) - 1);
123 if szCommand = OpenFolder then
124 Result := VIEW_COMMAND
125 else if szCommand = ExploreFolder then
126 Result := EXPLORE_COMMAND
127 else if szCommand = FindFolder then
128 Result := FIND_COMMAND
129 else
130 Result := NO_COMMAND;
131end;
132
133function GetPathFromDDEString(szCommand: string; var szFolder: string): Boolean;
134begin
135 szCommand := Copy(szCommand, Pos('"', szCommand) + 1, length(szCommand));
136 szFolder := Copy(szCommand, 1, Pos('"', szCommand) - 1);
137 Result := (szFolder <> '');
138end;
139
140function GetPidlFromDDEString(const szCommand: string): PItemIDList;
141var
142 PidlShared, PidlGlobal: PItemIDList;
143 dwProcessId: Integer;
144 hShared: THandle;
145 St: string;
146 ProcessID: string;
147 i: Integer;
148begin
149 St := Copy(szCommand, Pos(',', szCommand) + 1, length(szCommand));
150 i := 1;
151 while not (CharInSet(St[i], IsDigit) and (i <= Length(St))) do
152 Inc(i);
153 ProcessID := Copy(St, i, Length(St));
154 St := Copy(St, i, length(St) - 1);
155 i := 1;
156 while CharInSet(St[i], IsDigit) and (i <= Length(St)) do
157 Inc(i);
158 St := Copy(St, 1, i - 1);
159
160 while not ((ProcessID[i] = ':') or (ProcessID[i] = ',')) and (i <=
161 Length(ProcessID)) do
162 Inc(i);
163 if ProcessID[i] = ':' then
164 begin
165 ProcessID := Copy(ProcessID, i, Length(ProcessID));
166 i := 1;
167 while not (CharInSet(ProcessID[i], IsDigit) and (i <= Length(ProcessID)))
168 do
169 Inc(i);
170 ProcessID := Copy(ProcessID, i, Length(ProcessID));
171 i := 1;
172 while (CharInSet(ProcessID[i], IsDigit)) and (i <= Length(ProcessID)) do
173 Inc(i);
174 if not (CharInSet(ProcessID[i], IsDigit)) then
175 ProcessID := Copy(ProcessID, 1, i - 1);
176 end
177 else
178 ProcessID := '0';
179 dwProcessId := StrToInt(ProcessID);
180 if dwProcessId <> 0 then
181 begin
182 hShared := StrToInt(St);
183 PidlShared := ShLockShared(hShared, dwProcessId);
184 if PidlShared <> nil then
185 begin
186 Result := CopyPidl(PidlShared);
187 ShUnlockShared(PidlShared);
188 end
189 else
190 Result := nil;
191 ShFreeShared(hShared, dwProcessId);
192 end
193 else
194 begin
195 PidlGlobal := PItemIDList(StrToInt(St));
196 Result := CopyPidl(PidlGlobal);
197 _Free(PidlGlobal);
198 end;
199end;
200
201function GetShowCmdFromDDEString(szCommand: string): Integer;
202var
203 tmpInt: Integer;
204begin
205 tmpInt := 1;
206 while szCommand[tmpInt] <> ',' do
207 Inc(tmpInt);
208 Inc(tmpInt);
209 while szCommand[tmpInt] <> ',' do
210 Inc(tmpInt);
211 szCommand := Copy(szCommand, tmpInt, Length(szCommand));
212 tmpInt := 0;
213 repeat
214 inc(tmpInt)
215 until (tmpInt > Length(szCommand)) or CharInSet(szCommand[tmpInt], IsDigit);
216 if tmpInt <= length(szCommand) then
217 Result := StrtoInt(szCommand[tmpInt])
218 else
219 Result := 1;
220end;
221
222function ParseDDECommand(const szCommand: string; var szFolder: string;
223 var pidl: PItemIDList; var show: Integer): UINT;
224begin
225 Result := GetCommandTypeFromDDEString(szCommand);
226 if Result <> NO_COMMAND then
227 begin
228 GetPathFromDDEString(szCommand, szFolder);
229 pidl := GetPidlFromDDEString(szCommand);
230 show := GetShowCmdFromDDEString(szCommand);
231 end;
232end;
233
234end.
Note: See TracBrowser for help on using the repository browser.