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.4 - (show annotations) (download) (as text)
Wed Aug 22 15:04:23 2007 UTC (16 years, 8 months ago) by h677
Branch: MAIN
CVS Tags: v1_57_0_727
Changes since 1.3: +5 -7 lines
File MIME type: text/x-pascal
レスポップアップ位置の調整を設定可能にした。
レスポップアップのアンカーはずれから消えるまでのWaitを設定可能にした。

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

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