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.3 - (show annotations) (download) (as text)
Tue Aug 21 15:12:36 2007 UTC (16 years, 8 months ago) by h677
Branch: MAIN
CVS Tags: v1_57_0_726
Changes since 1.2: +18 -13 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(WorkArea: TRect; 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, Preview;
57
58 const
59 // 荀????????c??????眼?с????????????????
60 // ?????鴻???若?純??????????????篏?臀?/span>
61 DIV_X = 12;
62 DIV_Y = 8;
63
64 constructor TResPopupBrowser.Create(AOwner: TComponent);
65 begin
66 inherited Create(AOwner);
67 TOleControl(Self).Parent := nil;
68 Visible := False;
69 FChild := nil;
70 Title := '';
71 RawDocument := '';
72 FEvent := nil;
73 ShowWindow(Self.Handle, SW_HIDE);
74 end;
75
76 destructor TResPopupBrowser.Destroy;
77 begin
78 Self.Blur;
79 Self.OnEnter := nil;
80 Self.OnBeforeNavigate2 := nil;
81 Self.OnStatusTextChange := nil;
82 Self.OnNewWindow2 := nil;
83 if (FChild <> nil) then begin
84 FChild.Free;
85 FChild := nil;
86 end;
87 if (FEvent <> nil) then begin
88 FEvent.Free;
89 FEvent := nil;
90 end;
91 FThread := nil;
92 inherited Destroy;
93 end;
94
95 procedure TResPopupBrowser.CreateParams(var Params: TCreateParams);
96 begin
97 inherited;
98 Params.Style := Params.Style or WS_EX_TOOLWINDOW;
99
100 end;
101 function TResPopupBrowser.CreateNewBrowser: TResPopupBrowser;
102 begin
103 if (Self.Visible) then begin
104 if (FChild <> nil) then begin
105 if (FChild.Visible) then begin
106 Result := FChild.CreateNewBrowser;
107 end else begin
108 Result := FChild;
109 end;
110 end else begin
111 FChild := TResPopupBrowser.Create(Self.Owner);
112 FChild.ParentBrowser := Self;
113 FChild.NavigateBlank(False);
114 FChild.OnEnter := GikoForm.BrowserEnter;
115 FChild.OnBeforeNavigate2 := GikoForm.BrowserBeforeNavigate2;
116 FChild.OnStatusTextChange := GikoForm.BrowserStatusTextChange;
117 FChild.OnNewWindow2 := GikoForm.BrowserNewWindow2;
118 SetWindowPos(FChild.Handle, HWND_BOTTOM,
119 0, 0, 0 , 0,
120 SWP_NOSIZE or SWP_NOMOVE or SWP_NOACTIVATE or SWP_HIDEWINDOW);
121 Result := FChild;
122 end;
123 end else begin
124 FParentBrowser := nil;
125 Self.NavigateBlank(False);
126 Self.OnEnter := GikoForm.BrowserEnter;
127 Self.OnBeforeNavigate2 := GikoForm.BrowserBeforeNavigate2;
128 Self.OnStatusTextChange := GikoForm.BrowserStatusTextChange;
129 Self.OnNewWindow2 := GikoForm.BrowserNewWindow2;
130 SetWindowPos(Self.Handle, HWND_BOTTOM,
131 0, 0, 0 , 0,
132 SWP_NOSIZE or SWP_NOMOVE or SWP_NOACTIVATE or SWP_HIDEWINDOW);
133 Result := Self;
134 end;
135 end;
136 function TResPopupBrowser.CurrentBrowser: TResPopupBrowser;
137 begin
138 Result := Self.CreateNewBrowser;
139 if (Result.ParentBrowser <> nil) then
140 Result := Result.ParentBrowser;
141 end;
142 procedure TResPopupBrowser.NavigateBlank(Forced: Boolean);
143 begin
144 if (not Assigned(Self.Document)) or (Forced) then begin
145 Self.Navigate('about:blank');
146 end;
147 while (Self.ReadyState <> READYSTATE_COMPLETE) and
148 (Self.ReadyState <> READYSTATE_INTERACTIVE) do begin
149 Sleep(1);
150 Forms.Application.ProcessMessages;
151 end;
152 end;
153 procedure TResPopupBrowser.TitlePopup;
154 begin
155 Write('', True);
156 end;
157 procedure TResPopupBrowser.Popup;
158 begin
159 Write(Self.RawDocument, false);
160 end;
161 procedure TResPopupBrowser.Write(ADocument: String; OnlyTitle: Boolean = False);
162 var
163 p: TPoint;
164 doc: Variant;
165 ARect, rect: TRect;
166 FDispHtmlDocument: DispHTMLDocument;
167 begin
168 try
169 // ?帥?鴻?????若????羔???
170 SetWindowLongA(Self.Handle, GWL_EXSTYLE, WS_EX_TOOLWINDOW);
171 GetCursorpos(p);
172 // ???c????膰??
173 SetWindowPos(Self.Handle, HWND_BOTTOM,
174 p.X, p.Y, 50 , 50,
175 SWP_NOACTIVATE or SWP_HIDEWINDOW);
176 doc := Idispatch( olevariant(Self.ControlInterface).Document) as IHTMLDocument2;
177 doc.open;
178 doc.charset := 'Shift_JIS';
179 doc.Write('<html><head>'#13#10 +
180 '<meta http-equiv="Content-type" content="text/html; charset=Shift_JIS">'#13#10 +
181 '<meta http-equiv="Pragma" content="no-cache">'#13#10 +
182 '<meta http-equiv="Cache-Control" content="no-cache">'#13#10 +
183 GetBodyStyle(OnlyTitle) + '</head><body>'
184 + GetTitle(OnlyTitle)
185 + ADocument + '<a name="bottom"></a></body></html>');
186
187 doc.Close;
188
189 ARect := CalcRect(Screen.WorkAreaRect, not OnlyTitle);
190
191 FDispHtmlDocument := Idispatch(OleVariant(Self.ControlInterface).Document) as DispHTMLDocument;
192 FEvent := THTMLDocumentEventSink.Create(Self, FDispHtmlDocument, HTMLDocumentEvents2);
193 FEvent.OnClick := ResPopupBrowserClick;
194
195 Self.Visible := True;
196 SetWindowPos(Self.Handle, HWND_TOPMOST,
197 ARect.Left, ARect.Top,
198 (ARect.Right - ARect.Left) ,
199 (ARect.Bottom - ARect.Top),
200 SWP_NOACTIVATE or SWP_HIDEWINDOW);
201 ShowWindow(Self.Handle, SW_SHOWNOACTIVATE);
202 except
203 end;
204 end;
205 function TResPopupBrowser.GetTitle(OnlyTitle: Boolean): string;
206 begin
207 Result := '<span id="hTitle">' + Title +'</span>';
208 if OnlyTitle then Result := Result + '<BR>';
209 end;
210 function TResPopupBrowser.GetBodyStyle(OnlyTitle: Boolean = False): string;
211 var
212 i : Integer;
213 begin
214
215 Result := '<style type="text/css">' +
216 'dl { margin :0px; padding :0px}'#13#10 +
217 'body { ' +
218 'border-width: 1px; border-style: solid;white-space: nowrap; ' +
219 'margin: 2px 4px 0px 0px; padding: 0px 4px 0px 0px; ';
220
221 if Length( GikoSys.Setting.HintFontName ) > 0 then
222 Result := Result + 'font-family:"' + GikoSys.Setting.HintFontName + '";';
223 if GikoSys.Setting.HintFontSize <> 0 then
224 Result := Result + 'font-size:' + IntToStr( GikoSys.Setting.HintFontSize ) + 'pt;';
225 if GikoSys.Setting.HintFontColor <> -1 then
226 Result := Result + 'color:#' + IntToHex( GikoSys.Setting.HintFontColor, 6 ) + ';';
227 if GikoSys.Setting.HintBackColor <> -1 then begin
228 i := ColorToRGB( GikoSys.Setting.HintBackColor );
229 Result := Result + 'background-color:#' +
230 IntToHex( (i shr 16) or (i and $ff00) or ((i and $ff) shl 16), 6 ) + ';';
231 end;
232 if OnlyTitle then
233 Result := Result + 'overflow: hidden; ';
234
235 Result := Result + '}';
236 if GikoSys.Setting.ResPopupHeaderBold then begin
237 Result := Result + #13#10'span#hTitle{font-weight: bold; }';
238 end;
239 Result := Result + '</style>';
240 end;
241
242 procedure TResPopupBrowser.Clear;
243 begin
244 ChildClear;
245 if (Self.Visible) then begin
246 Self.Title := '';
247 Self.RawDocument := '';
248 Self.FThread := nil;
249 Self.FEvent.Free;
250 Self.FEvent := nil;
251 Self.Blur;
252 ShowWindow(Self.Handle, SW_HIDE);
253 Self.Visible := False;
254 end;
255 end;
256 procedure TResPopupBrowser.ChildClear;
257 begin
258 if (FChild <> nil) then begin
259 FChild.Clear;
260 end;
261 end;
262
263 function TResPopupBrowser.CalcRect(WorkArea: TRect; Scroll: Boolean): TRect;
264 var
265 p: TPoint;
266 ele: IHTMLElement2;
267 h, w, dx1, dx2, dy1, dy2: Integer;
268 MaxWidth, MaxHeight: Integer;
269 begin
270 GetCursorpos(p);
271 ele := ((Self.Document as IHTMLDocument2).body as IHTMLElement2);
272 if Scroll then begin
273 h := GetWindowHeight + 10;
274 w := ele.scrollWidth + 25
275 end else begin
276 h := GetWindowHeight + 5;
277 w := ele.scrollWidth + 10;
278 end;
279
280 dx1 := 0; dx2 := 0;
281 dy1 := 0; dy2 := 0;
282
283 Result := Rect(0, 0, w, h);
284 case GikoSys.Setting.PopupPosition of
285 gppRightTop:
286 begin
287 dx1 := 0; dx2 := + DIV_X;
288 dy1 := -h; dy2 := - DIV_Y;
289 end;
290 gppRight:
291 begin
292 dx1 := 0; dx2 := + DIV_X;
293 dy1 := - (h div 2); dy2 := 0;
294 end;
295 gppRightBottom:
296 begin
297 dx1 := 0; dx2 := + DIV_X;
298 dy1 := 0; dy2 := + DIV_Y;
299 end;
300 gppTop:
301 begin
302 dx1 := - (w div 2); dx2 := 0;
303 dy1 := -h; dy2 := - DIV_Y;
304 end;
305 // 綮?罩 gppCenter: OffsetRect(Result, p.x - (w div 2), p.y - (h div 2));
306 gppBottom:
307 begin
308 dx1 := - (w div 2); dx2 := 0;
309 dy1 := 0; dy2 := + DIV_Y;
310 end;
311 gppLeftTop:
312 begin
313 dx1 := -w; dx2 := - DIV_X ;
314 dy1 := -h; dy2 := - DIV_Y;
315 end;
316 gppLeft:
317 begin
318 dx1 := -w; dx2 := - DIV_X;
319 dy1 := - (h div 2); dy2 := 0;
320 end;
321 gppLeftBottom:
322 begin
323 dx1 := -w; dx2 := - DIV_X;
324 dy1 := 0; dy2 := + DIV_Y;
325 end;
326 end;
327 // ????篏?臀???Щ??
328 OffsetRect(Result, p.x + dx1 + dx2, p.y + dy1 + dy2);
329
330 MaxWidth := WorkArea.Right - WorkArea.Left;
331 MaxHeight := WorkArea.Bottom - WorkArea.Top;
332 // 篁ヤ???????篏?臀????馹?????????????Щ??
333 if (Result.Left < WorkArea.Left) then begin
334 // ???泣?ゃ?????茖????????違???阪??篏?臀???窪?活拶??
335 if (p.X * 2 < MaxWidth) then begin
336 if ( (GikoSys.Setting.PopupPosition = gppTop) or
337 (GikoSys.Setting.PopupPosition = gppBottom)) then begin
338 OffsetRect(Result, -Result.Left, WorkArea.Left);
339 end else begin
340 OffsetRect(Result, - (dx1 + 2 * dx2), 0);
341 end;
342 end else begin
343 // ?脂?∝??障?х?脂?√???絨???????
344 Result := Rect(0, Result.Top,
345 Result.Right, Result.Bottom);
346 end;
347 end;
348 if (Result.Top < WorkArea.Top) then begin
349 // 綺??眼???茖????????違???阪??篏?臀????筝?荵∽?/span>
350 if (p.Y * 2 < MaxHeight) then begin
351 OffsetRect(Result, 0, - (dy1 + 2 * dy2));
352 end else begin
353 // ?脂?∝??障?х?脂?∫???絨???????
354 Result := Rect(Result.Left, WorkArea.Top,
355 Result.Right, Result.Bottom);
356 end;
357 end;
358 if (Result.Right > WorkArea.Right) then begin
359 // ???泣?ゃ?????茖????????違???阪??篏?臀???窪?活拶??
360 if (p.X * 2 > WorkArea.Right) then begin
361 if( (GikoSys.Setting.PopupPosition = gppTop) or
362 (GikoSys.Setting.PopupPosition = gppBottom)) then begin
363 OffsetRect(Result, -(Result.Right - WorkArea.Right), 0);
364 end else begin
365 OffsetRect(Result, -w - (dx1 + 2 * dx2), 0);
366 end;
367 // ???泣?ゃ???????若???若?????翫?????脂?∝??障?у???絨???????
368 if (Result.Left < WorkArea.Left) then begin
369 Result := Rect(WorkArea.Left, Result.Top,
370 Result.Right, Result.Bottom);
371 end;
372 end else begin
373 // ?脂?∝??障?х?脂?√???絨???????
374 Result := Rect(Result.Left, Result.Top,
375 WorkArea.Right, Result.Bottom);
376 end;
377 end;
378 if (Result.Bottom > WorkArea.Bottom) then begin
379 // 筝??眼???茖????????違???阪??篏?臀????筝?荵∽?/span>
380 if (p.Y * 2 > WorkArea.Bottom) then begin
381 OffsetRect(Result, 0, -h - (dy1 + 2 * dy2));
382 // 筝???黄?????翫??????
383 if (Result.Top < WorkArea.Top) then begin
384 Result := Rect(Result.Left, WorkArea.Top,
385 Result.Right, Result.Bottom);
386 end;
387 end else begin
388 // ?脂?∝??障?х?脂?∫???絨???????
389 Result := Rect(Result.Left, Result.Top,
390 Result.Right, WorkArea.Bottom);
391 end;
392 end;
393 end;
394 function TResPopupBrowser.GetWindowHeight : Integer;
395 var
396 top: Integer;
397 item: OleVariant;
398 begin
399 Result := 0;
400 //???????吟?????若?帥????粋昭?推賢????????粋昭?帥??緇???/span>
401 while (Self.ReadyState <> READYSTATE_COMPLETE) and
402 (Self.ReadyState <> READYSTATE_INTERACTIVE) do begin
403 Sleep(1);
404 Forms.Application.ProcessMessages;
405 end;
406
407 try
408 top := 0;
409 item := OleVariant( Self.Document as IHTMLDocument2)
410 .anchors.item(OleVariant('bottom'));
411 item.focus();
412 repeat
413 top := top + item.offsetTop;
414 item := item.offsetParent;
415 until AnsiCompareText(item.tagName, 'body' ) = 0;
416 Result := top;
417 except
418 end;
419 end;
420 function TResPopupBrowser.ResPopupBrowserClick(Sender: TObject): WordBool;
421 begin
422 // ???潟???????????若???鴻??絅??c???????с?????若?????∞??????菴???
423 Blur;
424 Result := True;
425 end;
426 function TResPopupBrowser.GetThread: TThreadItem;
427 begin
428 Result := nil;
429 if (FThread <> nil) then begin
430 try
431 // ?≦?鴻?????ゃ?潟?炊???/span>
432 if (FThread.ParentBoard <> nil) then begin
433 Result := FThread
434 end;
435 except
436 //?≦?鴻?????ゃ?潟?帥???c??
437 Result := nil;
438 end;
439 end;
440 end;
441 procedure TResPopupBrowser.Blur;
442 var
443 FOleInPlaceActiveObject: IOleInPlaceActiveObject;
444 begin
445 FOleInPlaceActiveObject := Self.ControlInterface as IOleInPlaceActiveObject;
446 FOleInPlaceActiveObject.OnFrameWindowActivate(False);
447 end;
448
449 initialization
450 OleInitialize(nil);
451
452 finalization
453 OleUninitialize;
454
455 end.

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