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.10 - (show annotations) (download) (as text)
Tue May 15 16:38:20 2007 UTC (16 years, 11 months ago) by h677
Branch: bRESPOPUP
CVS Tags: v1_56_0_707
Changes since 1.1.2.9: +16 -27 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;
49 property PopupType: TGikoPopupType read FPopupType write FPopupType;
50 procedure TitlePopup;
51 procedure Popup;
52 end;
53
54 implementation
55 uses MojuUtils, GikoSystem, Setting, Giko, GikoDataModule;
56
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.OnEnter := nil;
73 Self.OnBeforeNavigate2 := nil;
74 Self.OnStatusTextChange := nil;
75 Self.OnNewWindow2 := nil;
76 if (FChild <> nil) then begin
77 FChild.Free;
78 FChild := nil;
79 end;
80 if (FEvent <> nil) then begin
81 FEvent.Free;
82 FEvent := nil;
83 end;
84 FThread := nil;
85 inherited Destroy;
86 end;
87
88 procedure TResPopupBrowser.CreateParams(var Params: TCreateParams);
89 begin
90 inherited;
91 Params.Style := Params.Style or WS_EX_TOOLWINDOW;
92
93 end;
94 function TResPopupBrowser.CreateNewBrowser: TResPopupBrowser;
95 begin
96 if (Self.Visible) then begin
97 if (FChild <> nil) then begin
98 if (FChild.Visible) then begin
99 Result := FChild.CreateNewBrowser;
100 end else begin
101 Result := FChild;
102 end;
103 end else begin
104 FChild := TResPopupBrowser.Create(Self);
105 FChild.ParentBrowser := Self;
106 FChild.NavigateBlank;
107 FChild.OnBeforeNavigate2 := GikoForm.BrowserBeforeNavigate2;
108 FChild.OnStatusTextChange := GikoForm.BrowserStatusTextChange;
109 FChild.OnNewWindow2 := GikoForm.BrowserNewWindow2;
110 SetWindowPos(FChild.Handle, HWND_BOTTOM,
111 0, 0, 0 , 0,
112 SWP_NOSIZE or SWP_NOMOVE or SWP_NOACTIVATE or SWP_HIDEWINDOW);
113 Result := FChild;
114 end;
115 end else begin
116 FParentBrowser := nil;
117 Self.NavigateBlank;
118 Self.OnBeforeNavigate2 := GikoForm.BrowserBeforeNavigate2;
119 Self.OnStatusTextChange := GikoForm.BrowserStatusTextChange;
120 Self.OnNewWindow2 := GikoForm.BrowserNewWindow2;
121 SetWindowPos(Self.Handle, HWND_BOTTOM,
122 0, 0, 0 , 0,
123 SWP_NOSIZE or SWP_NOMOVE or SWP_NOACTIVATE or SWP_HIDEWINDOW);
124 Result := Self;
125 end;
126 end;
127 function TResPopupBrowser.CurrentBrowser: TResPopupBrowser;
128 begin
129 Result := Self.CreateNewBrowser;
130 if (Result.ParentBrowser <> nil) then
131 Result := Result.ParentBrowser;
132 end;
133 procedure TResPopupBrowser.NavigateBlank;
134 begin
135 if (not Assigned(Self.Document)) then begin
136 Self.Navigate('about:blank');
137 end;
138 while (Self.ReadyState <> READYSTATE_COMPLETE) and
139 (Self.ReadyState <> READYSTATE_INTERACTIVE) do begin
140 Forms.Application.ProcessMessages;
141 end;
142 end;
143 procedure TResPopupBrowser.TitlePopup;
144 begin
145 Write('', True);
146 end;
147 procedure TResPopupBrowser.Popup;
148 begin
149 Write(Self.RawDocument, false);
150 end;
151 procedure TResPopupBrowser.Write(ADocument: String; OnlyTitle: Boolean = False);
152 var
153 p: TPoint;
154 doc: Variant;
155 ARect: TRect;
156 FDispHtmlDocument: DispHTMLDocument;
157 mainActive: Boolean;
158 begin
159 try
160 mainActive := GikoForm.Active;
161
162 // ?帥?鴻?????若????羔???
163 SetWindowLongA(Self.Handle, GWL_EXSTYLE, WS_EX_TOOLWINDOW);
164 GetCursorpos(p);
165 // ???c????膰??
166 SetWindowPos(Self.Handle, HWND_BOTTOM,
167 p.X, p.Y, 50 , 50,
168 SWP_NOACTIVATE or SWP_HIDEWINDOW);
169 doc := Idispatch( olevariant(Self.ControlInterface).Document) as IHTMLDocument2;
170 doc.open;
171 doc.charset := 'Shift_JIS';
172 doc.Write('<html><head>'#13#10 +
173 '<meta http-equiv="Content-type" content="text/html; charset=Shift_JIS">'#13#10
174 + GetBodyStyle(OnlyTitle) + '</head><body>'
175 + GetTitle(OnlyTitle)
176 + ADocument + '<a name="bottom"></a></body></html>');
177
178 doc.Close;
179
180
181 ARect := CalcRect(Screen.WorkAreaHeight, Screen.WorkAreaWidth,
182 not OnlyTitle);
183
184 FDispHtmlDocument := Idispatch(OleVariant(Self.ControlInterface).Document) as DispHTMLDocument;
185 FEvent := THTMLDocumentEventSink.Create(Self, FDispHtmlDocument, HTMLDocumentEvents2);
186 FEvent.OnClick := ResPopupBrowserClick;
187
188 Self.Visible := True;
189 SetWindowPos(Self.Handle, HWND_TOPMOST,
190 ARect.Left, ARect.Top,
191 (ARect.Right - ARect.Left) ,
192 (ARect.Bottom - ARect.Top),
193 SWP_NOACTIVATE or SWP_HIDEWINDOW);
194
195 ShowWindow(Self.Handle, SW_SHOWNOACTIVATE);
196 if mainActive <> GikoForm.Active then begin
197 GikoForm.SetFocus;
198 end;
199 except
200 end;
201 end;
202 function TResPopupBrowser.GetTitle(OnlyTitle: Boolean): string;
203 begin
204 Result := '<span id="hTitle">' + Title +'</span>';
205 if OnlyTitle then Result := Result + '<BR>';
206 end;
207 function TResPopupBrowser.GetBodyStyle(OnlyTitle: Boolean = False): string;
208 var
209 i : Integer;
210 begin
211
212 Result := '<style type="text/css">' +
213 'dl { margin :0px; padding :0px}'#13#10 +
214 'body { ' +
215 'border-width: 1px; border-style: solid;white-space: nowrap; ' +
216 'margin: 2px 4px 0px 0px; padding: 0px 4px 0px 0px; ';
217
218 if Length( GikoSys.Setting.HintFontName ) > 0 then
219 Result := Result + 'font-family:"' + GikoSys.Setting.HintFontName + '";';
220 if GikoSys.Setting.HintFontSize <> 0 then
221 Result := Result + 'font-size:' + IntToStr( GikoSys.Setting.HintFontSize ) + 'pt;';
222 if GikoSys.Setting.HintFontColor <> -1 then
223 Result := Result + 'color:#' + IntToHex( GikoSys.Setting.HintFontColor, 6 ) + ';';
224 if GikoSys.Setting.HintBackColor <> -1 then begin
225 i := ColorToRGB( GikoSys.Setting.HintBackColor );
226 Result := Result + 'background-color:#' +
227 IntToHex( (i shr 16) or (i and $ff00) or ((i and $ff) shl 16), 6 ) + ';';
228 end;
229 if OnlyTitle then
230 Result := Result + 'overflow: hidden; ';
231
232 Result := Result + '}';
233 if GikoSys.Setting.ResPopupHeaderBold then begin
234 Result := Result + #13#10'span#hTitle{font-weight: bold; }';
235 end;
236 Result := Result + '</style>';
237 end;
238
239 procedure TResPopupBrowser.Clear;
240 begin
241 ChildClear;
242 if (Self.Visible) then begin
243 Self.Title := '';
244 Self.RawDocument := '';
245 Self.FThread := nil;
246 FEvent.Free;
247 FEvent := nil;
248 NavigateBlank;
249 ShowWindow(Self.Handle, SW_HIDE);
250 Self.Visible := False;
251 end;
252 end;
253 procedure TResPopupBrowser.ChildClear;
254 begin
255 if (FChild <> nil) then begin
256 FChild.Clear;
257 end;
258 end;
259
260 function TResPopupBrowser.CalcRect(MaxHeight: Integer; MaxWidth: Integer; Scroll: Boolean): TRect;
261 var
262 p: TPoint;
263 ele: IHTMLElement2;
264 h, w: Integer;
265 begin
266 GetCursorpos(p);
267 ele := ((Self.Document as IHTMLDocument2).body as IHTMLElement2);
268 if Scroll then begin
269 h := GetWindowHeight + 10;
270 w := ele.scrollWidth + 25
271 end else begin
272 h := GetWindowHeight + 5;
273 w := ele.scrollWidth + 10;
274 end;
275 Result := Rect(0, 0, w, h);
276 case GikoSys.Setting.PopupPosition of
277 gppRightTop: OffsetRect(Result, p.x - w - 2, p.y - h - 2);
278 gppRight: OffsetRect(Result, p.x - w - 2, p.y - (h div 2));
279 gppRightBottom: OffsetRect(Result, p.x - w -2, p.y + 2);
280 gppTop: OffsetRect(Result, p.x - (w div 2), p.y - h - 2);
281 gppCenter: OffsetRect(Result, p.x - (w div 2), p.y - (h div 2));
282 gppBottom: OffsetRect(Result, p.x - (w div 2), p.y + 2);
283 gppLeftTop: OffsetRect(Result, p.x + 2, p.y - h - 2);
284 gppLeft: OffsetRect(Result, p.x + 2, p.y - (h div 2));
285 gppLeftBottom: OffsetRect(Result, p.x + 2, p.y + 2);
286 end;
287 if (Result.Left < 0) then begin
288 OffsetRect(Result, -Result.Left, 0);
289 end;
290 if (Result.Top < 0) then begin
291 OffsetRect(Result, 0, -Result.Top);
292 end;
293 if (Result.Right > MaxWidth) then begin
294 OffsetRect(Result, - (Result.Right - MaxWidth), 0);
295 end;
296 if (Result.Bottom > MaxHeight) then begin
297 OffsetRect(Result, 0, - (Result.Bottom - MaxHeight));
298 end;
299
300 // ?????у??綺?窪?????腆肴???????喝?冴???????????脂?≪?泣?ゃ?冴??絨???????
301 if (Result.Left < 0) then begin
302 Result := Rect(0, Result.Top,
303 Result.Right, Result.Bottom);
304 end;
305 if (Result.Top < 0) then begin
306 Result := Rect(Result.Left, 0,
307 Result.Right, Result.Bottom);
308 end;
309 end;
310 function TResPopupBrowser.GetWindowHeight : Integer;
311 var
312 top: Integer;
313 item: OleVariant;
314 begin
315 Result := 0;
316 //???????吟?????若?帥????粋昭?推賢????????粋昭?帥??緇???/span>
317 while (Self.ReadyState <> READYSTATE_COMPLETE) and
318 (Self.ReadyState <> READYSTATE_INTERACTIVE) do begin
319 Sleep(1);
320 Forms.Application.ProcessMessages;
321 end;
322
323 try
324 top := 0;
325 item := OleVariant( Self.Document as IHTMLDocument2)
326 .anchors.item(OleVariant('bottom'));
327 item.focus();
328 repeat
329 top := top + item.offsetTop;
330 item := item.offsetParent;
331 until AnsiCompareText(item.tagName, 'body' ) = 0;
332 Result := top;
333 except
334 end;
335 end;
336 function TResPopupBrowser.ResPopupBrowserClick(Sender: TObject): WordBool;
337 begin
338 if (not GikoSys.Setting.UnActivePopup) then begin
339 // ???潟???????????若???鴻??絅??c???????с?????若?????∞??????菴???
340 GikoForm.SetFocus;
341 end;
342 Result := True;
343 end;
344 function TResPopupBrowser.GetThread: TThreadItem;
345 begin
346 Result := nil;
347 if (FThread <> nil) then begin
348 try
349 // ?≦?鴻?????ゃ?潟?炊???/span>
350 if (FThread.ParentBoard <> nil) then begin
351 Result := FThread
352 end;
353 except
354 //?≦?鴻?????ゃ?潟?帥???c??
355 Result := nil;
356 end;
357 end;
358 end;
359 end.

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