Develop and Download Open Source Software

Browse CVS Repository

Annotation of /gikonavigoeson/gikonavi/ResPopupBrowser.pas

Parent Directory Parent Directory | Revision Log Revision Log | View Revision Graph Revision Graph


Revision 1.2 - (hide annotations) (download) (as text)
Sun Jun 10 14:46:32 2007 UTC (16 years, 10 months ago) by h677
Branch: MAIN
CVS Tags: v1_56_0_715, v1_57_0_723, v1_57_0_725, v1_57_0_720, v1_57_0_722, v1_57_0_719, v1_57_0_718, v1_56_0_716, v1_56_1_717, v1_56_1_716, v1_56_2_724, v1_56_2_722, v1_56_0_714, v1_56_0_713, v1_56_0_721, marged_bRESPOPUP
Branch point for: Bb56
Changes since 1.1: +450 -0 lines
File MIME type: text/x-pascal
多段ポップアップ対応をブランチ(bRESPOPUP)からマージ

1 h677 1.2 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