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

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