Develop and Download Open Source Software

Browse CVS Repository

Contents of /gikonavigoeson/gikonavi/ResPopupBrowser.pas

Parent Directory Parent Directory | Revision Log Revision Log | View Revision Graph Revision Graph


Revision 1.1.2.12 - (show annotations) (download) (as text)
Sat May 19 05:06:06 2007 UTC (16 years, 11 months ago) by h677
Branch: bRESPOPUP
CVS Tags: v1_56_0_709, v1_56_0_708
Changes since 1.1.2.11: +7 -26 lines
File MIME type: text/x-pascal
フォーカスの外し方をきちんとすることによって、レスポップアップとレスアンカーの問題解消

1 unit ResPopupBrowser;
2 interface
3 uses
4 Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
5 ActiveX, OleCtrls, {HintWindow,} HTMLDocumentEvent, BoardGroup,
6 {$IF Defined(DELPRO) }
7 SHDocVw,
8 MSHTML
9 {$ELSE}
10 SHDocVw_TLB,
11 MSHTML_TLB
12 {$IFEND}
13 ;
14
15 type
16 TGikoPopupType = (gptRaw, gptThread);
17
18 TResPopupBrowser = class(TWebBrowser)
19 private
20 FChild :TResPopupBrowser;
21 FParentBrowser :TResPopupBrowser;
22 FTitle :String;
23 FRawDocument: String;
24 FPopupType: TGikoPopupType;
25 FEvent: THTMLDocumentEventSink;//???????吟?????ャ?<?潟???ゃ???潟??
26 FThread: TThreadItem;
27 function GetBodyStyle(OnlyTitle: Boolean = False): string;
28 function GetWindowHeight : Integer;
29 function GetTitle(OnlyTitle: Boolean): string;
30 function CalcRect(MaxHeight: Integer; MaxWidth: Integer; Scroll: Boolean): TRect;
31 function ResPopupBrowserClick(Sender: TObject): WordBool;
32 function GetThread: TThreadItem;
33 protected
34 procedure CreateParams(var Params: TCreateParams); override;
35 public
36 constructor Create(AOwner: TComponent); override;
37 destructor Destroy; override;
38 property Child: TResPopupBrowser read FChild;
39 property ParentBrowser:TResPopupBrowser read FParentBrowser write FParentBrowser;
40 property Title: String read FTitle write FTitle;
41 property RawDocument: String read FRawDocument write FRawDocument;
42 property Thread: TThreadItem read GetThread write FThread;
43 function CreateNewBrowser: TResPopupBrowser;
44 function CurrentBrowser: TResPopupBrowser;
45 procedure Write(ADocument: String; OnlyTitle: Boolean = False);
46 procedure Clear;
47 procedure ChildClear;
48 procedure NavigateBlank(Forced: Boolean);
49 property PopupType: TGikoPopupType read FPopupType write FPopupType;
50 procedure TitlePopup;
51 procedure Popup;
52 procedure Blur;
53 end;
54
55 implementation
56 uses MojuUtils, GikoSystem, Setting, Giko, GikoDataModule;
57
58
59 constructor TResPopupBrowser.Create(AOwner: TComponent);
60 begin
61 inherited Create(AOwner);
62 TOleControl(Self).Parent := nil;
63 Visible := False;
64 FChild := nil;
65 Title := '';
66 RawDocument := '';
67 FEvent := nil;
68 ShowWindow(Self.Handle, SW_HIDE);
69 end;
70
71 destructor TResPopupBrowser.Destroy;
72 begin
73 Self.Blur;
74 Self.OnEnter := nil;
75 Self.OnBeforeNavigate2 := nil;
76 Self.OnStatusTextChange := nil;
77 Self.OnNewWindow2 := nil;
78 if (FChild <> nil) then begin
79 FChild.Free;
80 FChild := nil;
81 end;
82 if (FEvent <> nil) then begin
83 FEvent.Free;
84 FEvent := nil;
85 end;
86 FThread := nil;
87 inherited Destroy;
88 end;
89
90 procedure TResPopupBrowser.CreateParams(var Params: TCreateParams);
91 begin
92 inherited;
93 Params.Style := Params.Style or WS_EX_TOOLWINDOW;
94
95 end;
96 function TResPopupBrowser.CreateNewBrowser: TResPopupBrowser;
97 begin
98 if (Self.Visible) then begin
99 if (FChild <> nil) then begin
100 if (FChild.Visible) then begin
101 Result := FChild.CreateNewBrowser;
102 end else begin
103 Result := FChild;
104 end;
105 end else begin
106 FChild := TResPopupBrowser.Create(Self.Owner);
107 FChild.ParentBrowser := Self;
108 FChild.NavigateBlank(False);
109 FChild.OnEnter := GikoForm.BrowserEnter;
110 FChild.OnBeforeNavigate2 := GikoForm.BrowserBeforeNavigate2;
111 FChild.OnStatusTextChange := GikoForm.BrowserStatusTextChange;
112 FChild.OnNewWindow2 := GikoForm.BrowserNewWindow2;
113 SetWindowPos(FChild.Handle, HWND_BOTTOM,
114 0, 0, 0 , 0,
115 // SWP_NOZORDER or
116 SWP_NOSIZE or SWP_NOMOVE or SWP_NOACTIVATE or SWP_HIDEWINDOW);
117 Result := FChild;
118 end;
119 end else begin
120 FParentBrowser := nil;
121 Self.NavigateBlank(False);
122 Self.OnEnter := GikoForm.BrowserEnter;
123 Self.OnBeforeNavigate2 := GikoForm.BrowserBeforeNavigate2;
124 Self.OnStatusTextChange := GikoForm.BrowserStatusTextChange;
125 Self.OnNewWindow2 := GikoForm.BrowserNewWindow2;
126 SetWindowPos(Self.Handle, HWND_BOTTOM,
127 0, 0, 0 , 0,
128 // SWP_NOZORDER or
129 SWP_NOSIZE or SWP_NOMOVE or SWP_NOACTIVATE or SWP_HIDEWINDOW);
130 Result := Self;
131 end;
132 end;
133 function TResPopupBrowser.CurrentBrowser: TResPopupBrowser;
134 begin
135 Result := Self.CreateNewBrowser;
136 if (Result.ParentBrowser <> nil) then
137 Result := Result.ParentBrowser;
138 end;
139 procedure TResPopupBrowser.NavigateBlank(Forced: Boolean);
140 begin
141 if (not Assigned(Self.Document)) or (Forced) then begin
142 Self.Navigate('about:blank');
143 end;
144 while (Self.ReadyState <> READYSTATE_COMPLETE) and
145 (Self.ReadyState <> READYSTATE_INTERACTIVE) do begin
146 Sleep(1);
147 Forms.Application.ProcessMessages;
148 end;
149 end;
150 procedure TResPopupBrowser.TitlePopup;
151 begin
152 Write('', True);
153 end;
154 procedure TResPopupBrowser.Popup;
155 begin
156 Write(Self.RawDocument, false);
157 end;
158 procedure TResPopupBrowser.Write(ADocument: String; OnlyTitle: Boolean = False);
159 var
160 p: TPoint;
161 doc: Variant;
162 ARect, rect: TRect;
163 FDispHtmlDocument: DispHTMLDocument;
164 begin
165 try
166 // ?帥?鴻?????若????羔???
167 SetWindowLongA(Self.Handle, GWL_EXSTYLE, WS_EX_TOOLWINDOW);
168 GetCursorpos(p);
169 // ???c????膰??
170 SetWindowPos(Self.Handle, HWND_BOTTOM,
171 p.X, p.Y, 50 , 50,
172 SWP_NOACTIVATE or SWP_HIDEWINDOW);
173 doc := Idispatch( olevariant(Self.ControlInterface).Document) as IHTMLDocument2;
174 doc.open;
175 doc.charset := 'Shift_JIS';
176 doc.Write('<html><head>'#13#10 +
177 '<meta http-equiv="Content-type" content="text/html; charset=Shift_JIS">'#13#10 +
178 '<meta http-equiv="Pragma" content="no-cache">'#13#10 +
179 '<meta http-equiv="Cache-Control" content="no-cache">'#13#10 +
180 GetBodyStyle(OnlyTitle) + '</head><body>'
181 + GetTitle(OnlyTitle)
182 + ADocument + '<a name="bottom"></a></body></html>');
183
184 doc.Close;
185
186 ARect := CalcRect(Screen.WorkAreaHeight, Screen.WorkAreaWidth,
187 not OnlyTitle);
188
189 FDispHtmlDocument := Idispatch(OleVariant(Self.ControlInterface).Document) as DispHTMLDocument;
190 FEvent := THTMLDocumentEventSink.Create(Self, FDispHtmlDocument, HTMLDocumentEvents2);
191 FEvent.OnClick := ResPopupBrowserClick;
192
193 Self.Visible := True;
194 SetWindowPos(Self.Handle, HWND_TOPMOST,
195 ARect.Left, ARect.Top,
196 (ARect.Right - ARect.Left) ,
197 (ARect.Bottom - ARect.Top),
198 SWP_NOACTIVATE or SWP_HIDEWINDOW);
199 ShowWindow(Self.Handle, SW_SHOWNOACTIVATE);
200 except
201 end;
202 end;
203 function TResPopupBrowser.GetTitle(OnlyTitle: Boolean): string;
204 begin
205 Result := '<span id="hTitle">' + Title +'</span>';
206 if OnlyTitle then Result := Result + '<BR>';
207 end;
208 function TResPopupBrowser.GetBodyStyle(OnlyTitle: Boolean = False): string;
209 var
210 i : Integer;
211 begin
212
213 Result := '<style type="text/css">' +
214 'dl { margin :0px; padding :0px}'#13#10 +
215 'body { ' +
216 'border-width: 1px; border-style: solid;white-space: nowrap; ' +
217 'margin: 2px 4px 0px 0px; padding: 0px 4px 0px 0px; ';
218
219 if Length( GikoSys.Setting.HintFontName ) > 0 then
220 Result := Result + 'font-family:"' + GikoSys.Setting.HintFontName + '";';
221 if GikoSys.Setting.HintFontSize <> 0 then
222 Result := Result + 'font-size:' + IntToStr( GikoSys.Setting.HintFontSize ) + 'pt;';
223 if GikoSys.Setting.HintFontColor <> -1 then
224 Result := Result + 'color:#' + IntToHex( GikoSys.Setting.HintFontColor, 6 ) + ';';
225 if GikoSys.Setting.HintBackColor <> -1 then begin
226 i := ColorToRGB( GikoSys.Setting.HintBackColor );
227 Result := Result + 'background-color:#' +
228 IntToHex( (i shr 16) or (i and $ff00) or ((i and $ff) shl 16), 6 ) + ';';
229 end;
230 if OnlyTitle then
231 Result := Result + 'overflow: hidden; ';
232
233 Result := Result + '}';
234 if GikoSys.Setting.ResPopupHeaderBold then begin
235 Result := Result + #13#10'span#hTitle{font-weight: bold; }';
236 end;
237 Result := Result + '</style>';
238 end;
239
240 procedure TResPopupBrowser.Clear;
241 begin
242 ChildClear;
243 if (Self.Visible) then begin
244 Self.Title := '';
245 Self.RawDocument := '';
246 Self.FThread := nil;
247 Self.FEvent.Free;
248 Self.FEvent := nil;
249 Self.Blur;
250 ShowWindow(Self.Handle, SW_HIDE);
251 Self.Visible := False;
252 end;
253 end;
254 procedure TResPopupBrowser.ChildClear;
255 begin
256 if (FChild <> nil) then begin
257 FChild.Clear;
258 end;
259 end;
260
261 function TResPopupBrowser.CalcRect(MaxHeight: Integer; MaxWidth: Integer; Scroll: Boolean): TRect;
262 var
263 p: TPoint;
264 ele: IHTMLElement2;
265 h, w: Integer;
266 begin
267 GetCursorpos(p);
268 ele := ((Self.Document as IHTMLDocument2).body as IHTMLElement2);
269 if Scroll then begin
270 h := GetWindowHeight + 10;
271 w := ele.scrollWidth + 25
272 end else begin
273 h := GetWindowHeight + 5;
274 w := ele.scrollWidth + 10;
275 end;
276 Result := Rect(0, 0, w, h);
277 case GikoSys.Setting.PopupPosition of
278 gppRightTop: OffsetRect(Result, p.x - w - 2, p.y - h - 2);
279 gppRight: OffsetRect(Result, p.x - w - 2, p.y - (h div 2));
280 gppRightBottom: OffsetRect(Result, p.x - w -2, p.y + 2);
281 gppTop: OffsetRect(Result, p.x - (w div 2), p.y - h - 2);
282 gppCenter: OffsetRect(Result, p.x - (w div 2), p.y - (h div 2));
283 gppBottom: OffsetRect(Result, p.x - (w div 2), p.y + 2);
284 gppLeftTop: OffsetRect(Result, p.x + 2, p.y - h - 2);
285 gppLeft: OffsetRect(Result, p.x + 2, p.y - (h div 2));
286 gppLeftBottom: OffsetRect(Result, p.x + 2, p.y + 2);
287 end;
288 if (Result.Left < 0) then begin
289 OffsetRect(Result, -Result.Left, 0);
290 end;
291 if (Result.Top < 0) then begin
292 OffsetRect(Result, 0, -Result.Top);
293 end;
294 if (Result.Right > MaxWidth) then begin
295 OffsetRect(Result, - (Result.Right - MaxWidth), 0);
296 end;
297 if (Result.Bottom > MaxHeight) then begin
298 OffsetRect(Result, 0, - (Result.Bottom - MaxHeight));
299 end;
300
301 // ?????у??綺?窪?????腆肴???????喝?冴???????????脂?≪?泣?ゃ?冴??絨???????
302 if (Result.Left < 0) then begin
303 Result := Rect(0, Result.Top,
304 Result.Right, Result.Bottom);
305 end;
306 if (Result.Top < 0) then begin
307 Result := Rect(Result.Left, 0,
308 Result.Right, Result.Bottom);
309 end;
310 end;
311 function TResPopupBrowser.GetWindowHeight : Integer;
312 var
313 top: Integer;
314 item: OleVariant;
315 begin
316 Result := 0;
317 //???????吟?????若?帥????粋昭?推賢????????粋昭?帥??緇???/span>
318 while (Self.ReadyState <> READYSTATE_COMPLETE) and
319 (Self.ReadyState <> READYSTATE_INTERACTIVE) do begin
320 Sleep(1);
321 Forms.Application.ProcessMessages;
322 end;
323
324 try
325 top := 0;
326 item := OleVariant( Self.Document as IHTMLDocument2)
327 .anchors.item(OleVariant('bottom'));
328 item.focus();
329 repeat
330 top := top + item.offsetTop;
331 item := item.offsetParent;
332 until AnsiCompareText(item.tagName, 'body' ) = 0;
333 Result := top;
334 except
335 end;
336 end;
337 function TResPopupBrowser.ResPopupBrowserClick(Sender: TObject): WordBool;
338 begin
339 // ???潟???????????若???鴻??絅??c???????с?????若?????∞??????菴???
340 Blur;
341 Result := True;
342 end;
343 function TResPopupBrowser.GetThread: TThreadItem;
344 begin
345 Result := nil;
346 if (FThread <> nil) then begin
347 try
348 // ?≦?鴻?????ゃ?潟?炊???/span>
349 if (FThread.ParentBoard <> nil) then begin
350 Result := FThread
351 end;
352 except
353 //?≦?鴻?????ゃ?潟?帥???c??
354 Result := nil;
355 end;
356 end;
357 end;
358 procedure TResPopupBrowser.Blur;
359 var
360 FOleInPlaceActiveObject: IOleInPlaceActiveObject;
361 begin
362 FOleInPlaceActiveObject := Self.ControlInterface as IOleInPlaceActiveObject;
363 FOleInPlaceActiveObject.OnFrameWindowActivate(False);
364 end;
365
366 initialization
367 OleInitialize(nil);
368
369 finalization
370 OleUninitialize;
371
372 end.

Back to OSDN">Back to OSDN
ViewVC Help
Powered by ViewVC 1.1.26