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.4 - (hide 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 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 h677 1.3 uses MojuUtils, GikoSystem, Setting, Giko, GikoDataModule, Preview;
57 h677 1.2
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 h677 1.4 ARect: TRect;
160 h677 1.2 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 h677 1.4 DIV_X, DIV_Y: Integer;
264 h677 1.2 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 h677 1.4 DIV_X := GikoSys.Setting.RespopupDeltaX;
276     DIV_Y := GikoSys.Setting.RespopupDeltaY;
277    
278 h677 1.2 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 h677 1.3 dx1 := 0; dx2 := + DIV_X;
286     dy1 := -h; dy2 := - DIV_Y;
287 h677 1.2 end;
288     gppRight:
289     begin
290 h677 1.3 dx1 := 0; dx2 := + DIV_X;
291 h677 1.2 dy1 := - (h div 2); dy2 := 0;
292     end;
293     gppRightBottom:
294     begin
295 h677 1.3 dx1 := 0; dx2 := + DIV_X;
296     dy1 := 0; dy2 := + DIV_Y;
297 h677 1.2 end;
298     gppTop:
299     begin
300     dx1 := - (w div 2); dx2 := 0;
301 h677 1.3 dy1 := -h; dy2 := - DIV_Y;
302 h677 1.2 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 h677 1.3 dy1 := 0; dy2 := + DIV_Y;
308 h677 1.2 end;
309     gppLeftTop:
310     begin
311 h677 1.3 dx1 := -w; dx2 := - DIV_X ;
312     dy1 := -h; dy2 := - DIV_Y;
313 h677 1.2 end;
314     gppLeft:
315     begin
316 h677 1.3 dx1 := -w; dx2 := - DIV_X;
317 h677 1.2 dy1 := - (h div 2); dy2 := 0;
318     end;
319     gppLeftBottom:
320     begin
321 h677 1.3 dx1 := -w; dx2 := - DIV_X;
322     dy1 := 0; dy2 := + DIV_Y;
323 h677 1.2 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