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.1.2.12 - (hide annotations) (download) (as text)
Sat May 19 05:06:06 2007 UTC (16 years, 11 months ago) by h677
Branch: bRESPOPUP
CVS Tags: v1_56_0_709, v1_56_0_708
Changes since 1.1.2.11: +7 -26 lines
File MIME type: text/x-pascal
フォーカスの外し方をきちんとすることによって、レスポップアップとレスアンカーの問題解消

1 h677 1.1.2.1 unit ResPopupBrowser;
2     interface
3     uses
4     Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
5 h677 1.1.2.8 ActiveX, OleCtrls, {HintWindow,} HTMLDocumentEvent, BoardGroup,
6 h677 1.1.2.1 {$IF Defined(DELPRO) }
7     SHDocVw,
8     MSHTML
9     {$ELSE}
10     SHDocVw_TLB,
11     MSHTML_TLB
12     {$IFEND}
13     ;
14    
15     type
16 h677 1.1.2.6 TGikoPopupType = (gptRaw, gptThread);
17    
18 h677 1.1.2.1 TResPopupBrowser = class(TWebBrowser)
19     private
20     FChild :TResPopupBrowser;
21 h677 1.1.2.7 FParentBrowser :TResPopupBrowser;
22 h677 1.1.2.1 FTitle :String;
23 h677 1.1.2.7 FRawDocument: String;
24 h677 1.1.2.1 FPopupType: TGikoPopupType;
25 h677 1.1.2.8 FEvent: THTMLDocumentEventSink;//???????吟?????ャ?<?潟???ゃ???潟??
26     FThread: TThreadItem;
27 h677 1.1.2.6 function GetBodyStyle(OnlyTitle: Boolean = False): string;
28 h677 1.1.2.4 function GetWindowHeight : Integer;
29 h677 1.1.2.6 function GetTitle(OnlyTitle: Boolean): string;
30     function CalcRect(MaxHeight: Integer; MaxWidth: Integer; Scroll: Boolean): TRect;
31 h677 1.1.2.8 function ResPopupBrowserClick(Sender: TObject): WordBool;
32     function GetThread: TThreadItem;
33 h677 1.1.2.1 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 h677 1.1.2.7 property ParentBrowser:TResPopupBrowser read FParentBrowser write FParentBrowser;
40 h677 1.1.2.1 property Title: String read FTitle write FTitle;
41 h677 1.1.2.7 property RawDocument: String read FRawDocument write FRawDocument;
42 h677 1.1.2.8 property Thread: TThreadItem read GetThread write FThread;
43 h677 1.1.2.1 function CreateNewBrowser: TResPopupBrowser;
44 h677 1.1.2.7 function CurrentBrowser: TResPopupBrowser;
45 h677 1.1.2.6 procedure Write(ADocument: String; OnlyTitle: Boolean = False);
46 h677 1.1.2.1 procedure Clear;
47     procedure ChildClear;
48 h677 1.1.2.11 procedure NavigateBlank(Forced: Boolean);
49 h677 1.1.2.6 property PopupType: TGikoPopupType read FPopupType write FPopupType;
50     procedure TitlePopup;
51 h677 1.1.2.7 procedure Popup;
52 h677 1.1.2.11 procedure Blur;
53 h677 1.1.2.1 end;
54    
55     implementation
56 h677 1.1.2.8 uses MojuUtils, GikoSystem, Setting, Giko, GikoDataModule;
57 h677 1.1.2.1
58    
59     constructor TResPopupBrowser.Create(AOwner: TComponent);
60     begin
61     inherited Create(AOwner);
62 h677 1.1.2.10 TOleControl(Self).Parent := nil;
63 h677 1.1.2.1 Visible := False;
64 h677 1.1.2.10 FChild := nil;
65 h677 1.1.2.2 Title := '';
66 h677 1.1.2.7 RawDocument := '';
67 h677 1.1.2.9 FEvent := nil;
68 h677 1.1.2.10 ShowWindow(Self.Handle, SW_HIDE);
69 h677 1.1.2.1 end;
70    
71     destructor TResPopupBrowser.Destroy;
72     begin
73 h677 1.1.2.12 Self.Blur;
74 h677 1.1.2.9 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 h677 1.1.2.1 inherited Destroy;
88     end;
89    
90     procedure TResPopupBrowser.CreateParams(var Params: TCreateParams);
91     begin
92 h677 1.1.2.9 inherited;
93     Params.Style := Params.Style or WS_EX_TOOLWINDOW;
94    
95 h677 1.1.2.1 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 h677 1.1.2.12 FChild := TResPopupBrowser.Create(Self.Owner);
107 h677 1.1.2.7 FChild.ParentBrowser := Self;
108 h677 1.1.2.11 FChild.NavigateBlank(False);
109     FChild.OnEnter := GikoForm.BrowserEnter;
110 h677 1.1.2.7 FChild.OnBeforeNavigate2 := GikoForm.BrowserBeforeNavigate2;
111     FChild.OnStatusTextChange := GikoForm.BrowserStatusTextChange;
112     FChild.OnNewWindow2 := GikoForm.BrowserNewWindow2;
113 h677 1.1.2.9 SetWindowPos(FChild.Handle, HWND_BOTTOM,
114     0, 0, 0 , 0,
115 h677 1.1.2.11 // SWP_NOZORDER or
116 h677 1.1.2.9 SWP_NOSIZE or SWP_NOMOVE or SWP_NOACTIVATE or SWP_HIDEWINDOW);
117 h677 1.1.2.1 Result := FChild;
118     end;
119     end else begin
120 h677 1.1.2.7 FParentBrowser := nil;
121 h677 1.1.2.11 Self.NavigateBlank(False);
122     Self.OnEnter := GikoForm.BrowserEnter;
123 h677 1.1.2.3 Self.OnBeforeNavigate2 := GikoForm.BrowserBeforeNavigate2;
124 h677 1.1.2.1 Self.OnStatusTextChange := GikoForm.BrowserStatusTextChange;
125 h677 1.1.2.2 Self.OnNewWindow2 := GikoForm.BrowserNewWindow2;
126 h677 1.1.2.9 SetWindowPos(Self.Handle, HWND_BOTTOM,
127     0, 0, 0 , 0,
128 h677 1.1.2.11 // SWP_NOZORDER or
129 h677 1.1.2.9 SWP_NOSIZE or SWP_NOMOVE or SWP_NOACTIVATE or SWP_HIDEWINDOW);
130 h677 1.1.2.1 Result := Self;
131     end;
132 h677 1.1.2.7 end;
133     function TResPopupBrowser.CurrentBrowser: TResPopupBrowser;
134     begin
135     Result := Self.CreateNewBrowser;
136 h677 1.1.2.8 if (Result.ParentBrowser <> nil) then
137 h677 1.1.2.7 Result := Result.ParentBrowser;
138 h677 1.1.2.1 end;
139 h677 1.1.2.11 procedure TResPopupBrowser.NavigateBlank(Forced: Boolean);
140 h677 1.1.2.1 begin
141 h677 1.1.2.11 if (not Assigned(Self.Document)) or (Forced) then begin
142 h677 1.1.2.1 Self.Navigate('about:blank');
143     end;
144     while (Self.ReadyState <> READYSTATE_COMPLETE) and
145     (Self.ReadyState <> READYSTATE_INTERACTIVE) do begin
146 h677 1.1.2.11 Sleep(1);
147 h677 1.1.2.1 Forms.Application.ProcessMessages;
148     end;
149     end;
150 h677 1.1.2.6 procedure TResPopupBrowser.TitlePopup;
151     begin
152     Write('', True);
153     end;
154 h677 1.1.2.7 procedure TResPopupBrowser.Popup;
155     begin
156     Write(Self.RawDocument, false);
157     end;
158 h677 1.1.2.6 procedure TResPopupBrowser.Write(ADocument: String; OnlyTitle: Boolean = False);
159 h677 1.1.2.1 var
160 h677 1.1.2.9 p: TPoint;
161 h677 1.1.2.1 doc: Variant;
162 h677 1.1.2.11 ARect, rect: TRect;
163 h677 1.1.2.8 FDispHtmlDocument: DispHTMLDocument;
164 h677 1.1.2.1 begin
165     try
166 h677 1.1.2.9 // ?帥?鴻?????若????羔???
167     SetWindowLongA(Self.Handle, GWL_EXSTYLE, WS_EX_TOOLWINDOW);
168     GetCursorpos(p);
169     // ???c????膰??
170     SetWindowPos(Self.Handle, HWND_BOTTOM,
171     p.X, p.Y, 50 , 50,
172     SWP_NOACTIVATE or SWP_HIDEWINDOW);
173     doc := Idispatch( olevariant(Self.ControlInterface).Document) as IHTMLDocument2;
174     doc.open;
175     doc.charset := 'Shift_JIS';
176     doc.Write('<html><head>'#13#10 +
177 h677 1.1.2.11 '<meta http-equiv="Content-type" content="text/html; charset=Shift_JIS">'#13#10 +
178     '<meta http-equiv="Pragma" content="no-cache">'#13#10 +
179 h677 1.1.2.12 '<meta http-equiv="Cache-Control" content="no-cache">'#13#10 +
180     GetBodyStyle(OnlyTitle) + '</head><body>'
181 h677 1.1.2.9 + GetTitle(OnlyTitle)
182     + ADocument + '<a name="bottom"></a></body></html>');
183 h677 1.1.2.10
184 h677 1.1.2.9 doc.Close;
185    
186     ARect := CalcRect(Screen.WorkAreaHeight, Screen.WorkAreaWidth,
187     not OnlyTitle);
188    
189     FDispHtmlDocument := Idispatch(OleVariant(Self.ControlInterface).Document) as DispHTMLDocument;
190     FEvent := THTMLDocumentEventSink.Create(Self, FDispHtmlDocument, HTMLDocumentEvents2);
191     FEvent.OnClick := ResPopupBrowserClick;
192    
193     Self.Visible := True;
194 h677 1.1.2.10 SetWindowPos(Self.Handle, HWND_TOPMOST,
195 h677 1.1.2.9 ARect.Left, ARect.Top,
196     (ARect.Right - ARect.Left) ,
197     (ARect.Bottom - ARect.Top),
198     SWP_NOACTIVATE or SWP_HIDEWINDOW);
199     ShowWindow(Self.Handle, SW_SHOWNOACTIVATE);
200     except
201     end;
202 h677 1.1.2.2 end;
203 h677 1.1.2.6 function TResPopupBrowser.GetTitle(OnlyTitle: Boolean): string;
204     begin
205     Result := '<span id="hTitle">' + Title +'</span>';
206     if OnlyTitle then Result := Result + '<BR>';
207     end;
208     function TResPopupBrowser.GetBodyStyle(OnlyTitle: Boolean = False): string;
209 h677 1.1.2.4 var
210     i : Integer;
211 h677 1.1.2.2 begin
212    
213     Result := '<style type="text/css">' +
214     'dl { margin :0px; padding :0px}'#13#10 +
215     'body { ' +
216     'border-width: 1px; border-style: solid;white-space: nowrap; ' +
217 h677 1.1.2.4 'margin: 2px 4px 0px 0px; padding: 0px 4px 0px 0px; ';
218 h677 1.1.2.2
219     if Length( GikoSys.Setting.HintFontName ) > 0 then
220     Result := Result + 'font-family:"' + GikoSys.Setting.HintFontName + '";';
221     if GikoSys.Setting.HintFontSize <> 0 then
222     Result := Result + 'font-size:' + IntToStr( GikoSys.Setting.HintFontSize ) + 'pt;';
223     if GikoSys.Setting.HintFontColor <> -1 then
224     Result := Result + 'color:#' + IntToHex( GikoSys.Setting.HintFontColor, 6 ) + ';';
225 h677 1.1.2.4 if GikoSys.Setting.HintBackColor <> -1 then begin
226     i := ColorToRGB( GikoSys.Setting.HintBackColor );
227 h677 1.1.2.2 Result := Result + 'background-color:#' +
228 h677 1.1.2.4 IntToHex( (i shr 16) or (i and $ff00) or ((i and $ff) shl 16), 6 ) + ';';
229     end;
230 h677 1.1.2.6 if OnlyTitle then
231     Result := Result + 'overflow: hidden; ';
232 h677 1.1.2.2
233 h677 1.1.2.5 Result := Result + '}';
234     if GikoSys.Setting.ResPopupHeaderBold then begin
235     Result := Result + #13#10'span#hTitle{font-weight: bold; }';
236     end;
237     Result := Result + '</style>';
238 h677 1.1.2.1 end;
239 h677 1.1.2.2
240 h677 1.1.2.1 procedure TResPopupBrowser.Clear;
241     begin
242     ChildClear;
243     if (Self.Visible) then begin
244 h677 1.1.2.2 Self.Title := '';
245 h677 1.1.2.7 Self.RawDocument := '';
246 h677 1.1.2.8 Self.FThread := nil;
247 h677 1.1.2.11 Self.FEvent.Free;
248     Self.FEvent := nil;
249     Self.Blur;
250 h677 1.1.2.1 ShowWindow(Self.Handle, SW_HIDE);
251 h677 1.1.2.5 Self.Visible := False;
252 h677 1.1.2.1 end;
253     end;
254     procedure TResPopupBrowser.ChildClear;
255     begin
256     if (FChild <> nil) then begin
257     FChild.Clear;
258     end;
259     end;
260    
261 h677 1.1.2.6 function TResPopupBrowser.CalcRect(MaxHeight: Integer; MaxWidth: Integer; Scroll: Boolean): TRect;
262 h677 1.1.2.1 var
263     p: TPoint;
264 h677 1.1.2.2 ele: IHTMLElement2;
265 h677 1.1.2.4 h, w: Integer;
266 h677 1.1.2.1 begin
267     GetCursorpos(p);
268 h677 1.1.2.2 ele := ((Self.Document as IHTMLDocument2).body as IHTMLElement2);
269 h677 1.1.2.6 if Scroll then begin
270     h := GetWindowHeight + 10;
271     w := ele.scrollWidth + 25
272     end else begin
273     h := GetWindowHeight + 5;
274     w := ele.scrollWidth + 10;
275     end;
276 h677 1.1.2.4 Result := Rect(0, 0, w, h);
277 h677 1.1.2.1 case GikoSys.Setting.PopupPosition of
278 h677 1.1.2.4 gppRightTop: OffsetRect(Result, p.x - w - 2, p.y - h - 2);
279     gppRight: OffsetRect(Result, p.x - w - 2, p.y - (h div 2));
280     gppRightBottom: OffsetRect(Result, p.x - w -2, p.y + 2);
281     gppTop: OffsetRect(Result, p.x - (w div 2), p.y - h - 2);
282     gppCenter: OffsetRect(Result, p.x - (w div 2), p.y - (h div 2));
283     gppBottom: OffsetRect(Result, p.x - (w div 2), p.y + 2);
284     gppLeftTop: OffsetRect(Result, p.x + 2, p.y - h - 2);
285     gppLeft: OffsetRect(Result, p.x + 2, p.y - (h div 2));
286 h677 1.1.2.3 gppLeftBottom: OffsetRect(Result, p.x + 2, p.y + 2);
287 h677 1.1.2.1 end;
288     if (Result.Left < 0) then begin
289     OffsetRect(Result, -Result.Left, 0);
290     end;
291     if (Result.Top < 0) then begin
292     OffsetRect(Result, 0, -Result.Top);
293     end;
294 h677 1.1.2.4 if (Result.Right > MaxWidth) then begin
295     OffsetRect(Result, - (Result.Right - MaxWidth), 0);
296     end;
297     if (Result.Bottom > MaxHeight) then begin
298     OffsetRect(Result, 0, - (Result.Bottom - MaxHeight));
299     end;
300 h677 1.1.2.11
301 h677 1.1.2.4 // ?????у??綺?窪?????腆肴???????喝?冴???????????脂?≪?泣?ゃ?冴??絨???????
302     if (Result.Left < 0) then begin
303     Result := Rect(0, Result.Top,
304     Result.Right, Result.Bottom);
305     end;
306     if (Result.Top < 0) then begin
307     Result := Rect(Result.Left, 0,
308     Result.Right, Result.Bottom);
309     end;
310 h677 1.1.2.1 end;
311 h677 1.1.2.4 function TResPopupBrowser.GetWindowHeight : Integer;
312     var
313     top: Integer;
314     item: OleVariant;
315     begin
316 h677 1.1.2.5 Result := 0;
317 h677 1.1.2.4 //???????吟?????若?帥????粋昭?推賢????????粋昭?帥??緇???/span>
318     while (Self.ReadyState <> READYSTATE_COMPLETE) and
319     (Self.ReadyState <> READYSTATE_INTERACTIVE) do begin
320     Sleep(1);
321     Forms.Application.ProcessMessages;
322     end;
323 h677 1.1.2.1
324 h677 1.1.2.4 try
325     top := 0;
326     item := OleVariant( Self.Document as IHTMLDocument2)
327     .anchors.item(OleVariant('bottom'));
328     item.focus();
329     repeat
330     top := top + item.offsetTop;
331     item := item.offsetParent;
332     until AnsiCompareText(item.tagName, 'body' ) = 0;
333     Result := top;
334     except
335     end;
336     end;
337 h677 1.1.2.8 function TResPopupBrowser.ResPopupBrowserClick(Sender: TObject): WordBool;
338     begin
339 h677 1.1.2.11 // ???潟???????????若???鴻??絅??c???????с?????若?????∞??????菴???
340     Blur;
341 h677 1.1.2.8 Result := True;
342     end;
343     function TResPopupBrowser.GetThread: TThreadItem;
344     begin
345     Result := nil;
346     if (FThread <> nil) then begin
347     try
348     // ?≦?鴻?????ゃ?潟?炊???/span>
349     if (FThread.ParentBoard <> nil) then begin
350     Result := FThread
351     end;
352     except
353     //?≦?鴻?????ゃ?潟?帥???c??
354     Result := nil;
355     end;
356     end;
357     end;
358 h677 1.1.2.11 procedure TResPopupBrowser.Blur;
359     var
360 h677 1.1.2.12 FOleInPlaceActiveObject: IOleInPlaceActiveObject;
361 h677 1.1.2.11 begin
362 h677 1.1.2.12 FOleInPlaceActiveObject := Self.ControlInterface as IOleInPlaceActiveObject;
363     FOleInPlaceActiveObject.OnFrameWindowActivate(False);
364 h677 1.1.2.11 end;
365    
366     initialization
367     OleInitialize(nil);
368    
369     finalization
370     OleUninitialize;
371    
372 h677 1.1.2.1 end.

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