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.12 by h677, Sat May 19 05:06:06 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.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_NOZORDER or
116                    SWP_NOSIZE or SWP_NOMOVE or  SWP_NOACTIVATE or SWP_HIDEWINDOW);
117                Result := FChild;
118            end;
119        end else begin
120            FParentBrowser := nil;
121            Self.NavigateBlank(False);
122            Self.OnEnter := GikoForm.BrowserEnter;
123            Self.OnBeforeNavigate2 := GikoForm.BrowserBeforeNavigate2;
124            Self.OnStatusTextChange := GikoForm.BrowserStatusTextChange;
125            Self.OnNewWindow2 := GikoForm.BrowserNewWindow2;
126            SetWindowPos(Self.Handle, HWND_BOTTOM,
127                0, 0, 0 , 0,
128    //            SWP_NOZORDER or
129                SWP_NOSIZE or SWP_NOMOVE or  SWP_NOACTIVATE or SWP_HIDEWINDOW);
130            Result := Self;
131        end;
132    end;
133    function TResPopupBrowser.CurrentBrowser: TResPopupBrowser;
134    begin
135        Result := Self.CreateNewBrowser;
136        if (Result.ParentBrowser <> nil) then
137            Result := Result.ParentBrowser;
138    end;
139    procedure TResPopupBrowser.NavigateBlank(Forced: Boolean);
140    begin
141        if (not Assigned(Self.Document)) or (Forced) then begin
142            Self.Navigate('about:blank');
143        end;
144        while (Self.ReadyState <> READYSTATE_COMPLETE) and
145                (Self.ReadyState <> READYSTATE_INTERACTIVE) do begin
146            Sleep(1);
147            Forms.Application.ProcessMessages;
148        end;
149    end;
150    procedure TResPopupBrowser.TitlePopup;
151    begin
152        Write('', True);
153    end;
154    procedure TResPopupBrowser.Popup;
155    begin
156        Write(Self.RawDocument, false);
157    end;
158    procedure TResPopupBrowser.Write(ADocument: String; OnlyTitle: Boolean = False);
159    var
160            p: TPoint;
161        doc: Variant;
162            ARect, rect: TRect;
163        FDispHtmlDocument: DispHTMLDocument;
164    begin
165        try
166            // タスクバーから消す
167            SetWindowLongA(Self.Handle, GWL_EXSTYLE, WS_EX_TOOLWINDOW);
168            GetCursorpos(p);
169            // いったん縮小
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                    '<meta http-equiv="Content-type" content="text/html; charset=Shift_JIS">'#13#10 +
178                    '<meta http-equiv="Pragma" content="no-cache">'#13#10 +
179                    '<meta http-equiv="Cache-Control" content="no-cache">'#13#10 +
180                    GetBodyStyle(OnlyTitle) + '</head><body>'
181                    + GetTitle(OnlyTitle)
182                    + ADocument + '<a name="bottom"></a></body></html>');
183    
184            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            SetWindowPos(Self.Handle, HWND_TOPMOST,
195                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    end;
203    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    var
210        i : Integer;
211    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                'margin: 2px 4px 0px 0px; padding: 0px 4px 0px 0px; ';
218    
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            if GikoSys.Setting.HintBackColor <> -1 then begin
226                    i := ColorToRGB( GikoSys.Setting.HintBackColor );
227                    Result := Result + 'background-color:#' +
228                IntToHex( (i shr 16) or (i and $ff00) or ((i and $ff) shl 16), 6 ) + ';';
229        end;
230        if OnlyTitle then
231            Result := Result + 'overflow: hidden; ';
232    
233        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    end;
239    
240    procedure TResPopupBrowser.Clear;
241    begin
242        ChildClear;
243        if (Self.Visible) then begin
244            Self.Title := '';
245            Self.RawDocument := '';
246            Self.FThread := nil;
247            Self.FEvent.Free;
248            Self.FEvent := nil;
249            Self.Blur;
250            ShowWindow(Self.Handle, SW_HIDE);
251            Self.Visible := False;
252        end;
253    end;
254    procedure TResPopupBrowser.ChildClear;
255    begin
256        if (FChild <> nil) then begin
257            FChild.Clear;
258        end;
259    end;
260    
261    function TResPopupBrowser.CalcRect(MaxHeight: Integer; MaxWidth: Integer; Scroll: Boolean): TRect;
262    var
263            p: TPoint;
264        ele: IHTMLElement2;
265        h, w: Integer;
266    begin
267            GetCursorpos(p);
268        ele := ((Self.Document as IHTMLDocument2).body as IHTMLElement2);
269        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            Result := Rect(0, 0, w, h);
277        case GikoSys.Setting.PopupPosition of
278            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            gppLeftBottom:  OffsetRect(Result, p.x + 2, p.y + 2);
287        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        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    
301        // ここで再度左と上を確認して飛び出してたら、画面サイズを小さくする
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    end;
311    function TResPopupBrowser.GetWindowHeight : Integer;
312    var
313            top: Integer;
314            item: OleVariant;
315    begin
316        Result := 0;
317        //ブラウザがデータの読み込み中の時は読み込みを待つ
318        while (Self.ReadyState <> READYSTATE_COMPLETE) and
319                    (Self.ReadyState <> READYSTATE_INTERACTIVE) do begin
320            Sleep(1);
321            Forms.Application.ProcessMessages;
322        end;
323    
324        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    function TResPopupBrowser.ResPopupBrowserClick(Sender: TObject): WordBool;
338    begin
339        // ギコナビのフォーカスを奪ってるのでフォームに無理やり返す
340        Blur;
341        Result := True;
342    end;
343    function TResPopupBrowser.GetThread: TThreadItem;
344    begin
345        Result := nil;
346        if (FThread <> nil) then begin
347            try
348                // 無効なポインタ検査
349                if (FThread.ParentBoard <> nil) then begin
350                    Result := FThread
351                end;
352            except
353                //無効なポインタだった
354                Result := nil;
355            end;
356        end;
357    end;
358    procedure TResPopupBrowser.Blur;
359    var
360        FOleInPlaceActiveObject: IOleInPlaceActiveObject;
361    begin
362        FOleInPlaceActiveObject := Self.ControlInterface as IOleInPlaceActiveObject;
363        FOleInPlaceActiveObject.OnFrameWindowActivate(False);
364    end;
365    
366    initialization
367        OleInitialize(nil);
368    
369    finalization
370        OleUninitialize;
371    
372    end.

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

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