Develop and Download Open Source Software

Browse CVS Repository

Diff of /gikonavigoeson/gikonavi/ResPopupBrowser.pas

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

revision 1.1 by h677, Mon May 7 17:55:59 2007 UTC revision 1.1.2.11 by h677, Fri May 18 22:43:35 2007 UTC
# Line 0  Line 1 
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(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.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);
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_NOZORDER or
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_NOZORDER or
128                SWP_NOSIZE or SWP_NOMOVE or  SWP_NOACTIVATE or SWP_HIDEWINDOW);
129            Result := Self;
130        end;
131    end;
132    function TResPopupBrowser.CurrentBrowser: TResPopupBrowser;
133    begin
134        Result := Self.CreateNewBrowser;
135        if (Result.ParentBrowser <> nil) then
136            Result := Result.ParentBrowser;
137    end;
138    procedure TResPopupBrowser.NavigateBlank(Forced: Boolean);
139    begin
140        if (not Assigned(Self.Document)) or (Forced) then begin
141            Self.Navigate('about:blank');
142        end;
143        while (Self.ReadyState <> READYSTATE_COMPLETE) and
144                (Self.ReadyState <> READYSTATE_INTERACTIVE) do begin
145            Sleep(1);
146            Forms.Application.ProcessMessages;
147        end;
148    end;
149    procedure TResPopupBrowser.TitlePopup;
150    begin
151        Write('', True);
152    end;
153    procedure TResPopupBrowser.Popup;
154    begin
155        Write(Self.RawDocument, false);
156    end;
157    procedure TResPopupBrowser.Write(ADocument: String; OnlyTitle: Boolean = False);
158    var
159            p: TPoint;
160        doc: Variant;
161            ARect, rect: TRect;
162        FDispHtmlDocument: DispHTMLDocument;
163    begin
164        try
165            // タスクバーから消す
166            SetWindowLongA(Self.Handle, GWL_EXSTYLE, WS_EX_TOOLWINDOW);
167            GetCursorpos(p);
168            // いったん縮小
169            SetWindowPos(Self.Handle, HWND_BOTTOM,
170                p.X, p.Y, 50 , 50,
171                SWP_NOACTIVATE or SWP_HIDEWINDOW);
172            doc := Idispatch( olevariant(Self.ControlInterface).Document) as IHTMLDocument2;
173            doc.open;
174            doc.charset := 'Shift_JIS';
175            doc.Write('<html><head>'#13#10 +
176                    '<meta http-equiv="Content-type" content="text/html; charset=Shift_JIS">'#13#10 +
177                    '<meta http-equiv="Pragma" content="no-cache">'#13#10 +
178                    '<meta http-equiv="Cache-Control" content="no-cache">'#13#10
179                    + GetBodyStyle(OnlyTitle) + '</head><body>'
180                    + GetTitle(OnlyTitle)
181                    + ADocument + '<a name="bottom"></a></body></html>');
182    
183            doc.Close;
184    
185            ARect := CalcRect(Screen.WorkAreaHeight, Screen.WorkAreaWidth,
186                 not OnlyTitle);
187    
188            FDispHtmlDocument := Idispatch(OleVariant(Self.ControlInterface).Document) as DispHTMLDocument;
189            FEvent := THTMLDocumentEventSink.Create(Self, FDispHtmlDocument, HTMLDocumentEvents2);
190            FEvent.OnClick := ResPopupBrowserClick;
191    
192            Self.Visible := True;
193            SetWindowPos(Self.Handle, HWND_TOPMOST,
194                ARect.Left, ARect.Top,
195                (ARect.Right - ARect.Left) ,
196                (ARect.Bottom - ARect.Top),
197                SWP_NOACTIVATE or SWP_HIDEWINDOW);
198            ShowWindow(Self.Handle, SW_SHOWNOACTIVATE);
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    var
241        rect: TRect;
242    begin
243        ChildClear;
244        if (Self.Visible) then begin
245            Self.Title := '';
246            Self.RawDocument := '';
247            Self.FThread := nil;
248            Self.FEvent.Free;
249            Self.FEvent := nil;
250            Self.Blur;
251            ShowWindow(Self.Handle, SW_HIDE);
252            Self.Visible := False;
253        end;
254    end;
255    procedure TResPopupBrowser.ChildClear;
256    begin
257        if (FChild <> nil) then begin
258            FChild.Clear;
259        end;
260    end;
261    
262    function TResPopupBrowser.CalcRect(MaxHeight: Integer; MaxWidth: Integer; Scroll: Boolean): TRect;
263    var
264            p: TPoint;
265        ele: IHTMLElement2;
266        h, w: Integer;
267    begin
268            GetCursorpos(p);
269        ele := ((Self.Document as IHTMLDocument2).body as IHTMLElement2);
270        if Scroll then begin
271            h := GetWindowHeight + 10;
272            w := ele.scrollWidth + 25
273        end else begin
274            h := GetWindowHeight + 5;
275            w := ele.scrollWidth + 10;
276        end;
277            Result := Rect(0, 0, w, h);
278        case GikoSys.Setting.PopupPosition of
279            gppRightTop:            OffsetRect(Result, p.x - w - 2, p.y - h - 2);
280            gppRight:                       OffsetRect(Result, p.x - w - 2, p.y - (h div 2));
281            gppRightBottom: OffsetRect(Result, p.x - w -2, p.y + 2);
282            gppTop:                                 OffsetRect(Result, p.x - (w div 2), p.y - h - 2);
283            gppCenter:                      OffsetRect(Result, p.x - (w div 2), p.y - (h div 2));
284            gppBottom:                      OffsetRect(Result, p.x - (w div 2), p.y + 2);
285            gppLeftTop:                     OffsetRect(Result, p.x + 2, p.y - h - 2);
286            gppLeft:                                OffsetRect(Result, p.x + 2, p.y - (h div 2));
287            gppLeftBottom:  OffsetRect(Result, p.x + 2, p.y + 2);
288        end;
289        if (Result.Left < 0) then begin
290            OffsetRect(Result, -Result.Left, 0);
291        end;
292        if (Result.Top < 0) then begin
293            OffsetRect(Result, 0, -Result.Top);
294        end;
295        if (Result.Right > MaxWidth) then begin
296            OffsetRect(Result, - (Result.Right - MaxWidth), 0);
297        end;
298        if (Result.Bottom > MaxHeight) then begin
299            OffsetRect(Result, 0, - (Result.Bottom - MaxHeight));
300        end;
301    
302        // ここで再度左と上を確認して飛び出してたら、画面サイズを小さくする
303        if (Result.Left < 0) then begin
304            Result := Rect(0, Result.Top,
305                Result.Right, Result.Bottom);
306        end;
307        if (Result.Top < 0) then begin
308            Result := Rect(Result.Left, 0,
309                Result.Right, Result.Bottom);
310        end;
311    end;
312    function TResPopupBrowser.GetWindowHeight : Integer;
313    var
314            top: Integer;
315            item: OleVariant;
316    begin
317        Result := 0;
318        //ブラウザがデータの読み込み中の時は読み込みを待つ
319        while (Self.ReadyState <> READYSTATE_COMPLETE) and
320                    (Self.ReadyState <> READYSTATE_INTERACTIVE) do begin
321            Sleep(1);
322            Forms.Application.ProcessMessages;
323        end;
324    
325        try
326            top := 0;
327            item := OleVariant( Self.Document as IHTMLDocument2)
328                    .anchors.item(OleVariant('bottom'));
329            item.focus();
330            repeat
331                top := top + item.offsetTop;
332                item := item.offsetParent;
333            until AnsiCompareText(item.tagName, 'body' ) = 0;
334            Result := top;
335        except
336        end;
337    end;
338    function TResPopupBrowser.ResPopupBrowserClick(Sender: TObject): WordBool;
339    begin
340        // ギコナビのフォーカスを奪ってるのでフォームに無理やり返す
341        Blur;
342        Result := True;
343    end;
344    function TResPopupBrowser.GetThread: TThreadItem;
345    begin
346        Result := nil;
347        if (FThread <> nil) then begin
348            try
349                // 無効なポインタ検査
350                if (FThread.ParentBoard <> nil) then begin
351                    Result := FThread
352                end;
353            except
354                //無効なポインタだった
355                Result := nil;
356            end;
357        end;
358    end;
359    procedure TResPopupBrowser.Blur;
360    var
361        rect: TRect;
362    begin
363        if ((Self.Document as IHTMLDocument2).activeElement <> nil) then begin
364            // フォーカス外し
365            Windows.GetClientRect(Self.Handle, rect);
366            if (Self.ParentBrowser <> nil) then begin
367                (Self.Application as IOleObject).DoVerb(OLEIVERB_DISCARDUNDOSTATE, (* iVerb *)
368                                               nil,                 (* lpMsg *)
369                                               Self,             (* pActiveSite *)
370                                               0,                   (* lindex - reserved *)
371                                               Self.ParentBrowser.Handle,      (* hwndParent *)
372                                               rect);               (* display rectangle *)
373                Self.ParentBrowser.Blur;
374            end else begin
375                (Self.Application as IOleObject).DoVerb(OLEIVERB_DISCARDUNDOSTATE, (* iVerb *)
376                                               nil,                 (* lpMsg *)
377                                               Self,             (* pActiveSite *)
378                                               0,                   (* lindex - reserved *)
379                                               GikoForm.ActiveContent.Browser.Handle,      (* hwndParent *)
380                                               rect);               (* display rectangle *)
381            end;
382        end;
383    end;
384    
385    initialization
386        OleInitialize(nil);
387    
388    finalization
389        OleUninitialize;
390    
391    end.

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.1.2.11

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