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

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