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.9 by h677, Mon May 14 22:02:43 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;
49            property PopupType: TGikoPopupType read FPopupType write FPopupType;
50            procedure TitlePopup;
51            procedure Popup;
52            end;
53    
54    implementation
55    uses MojuUtils, GikoSystem, Setting, Giko, GikoDataModule;
56    
57    
58    constructor TResPopupBrowser.Create(AOwner: TComponent);
59    begin
60            inherited Create(AOwner);
61        FChild := nil;
62        Visible := False;
63        Title := '';
64        RawDocument := '';
65        FEvent := nil;
66    end;
67    
68    destructor TResPopupBrowser.Destroy;
69    begin
70        Self.OnEnter := nil;
71        Self.OnBeforeNavigate2 := nil;
72        Self.OnStatusTextChange := nil;
73        Self.OnNewWindow2 := nil;
74        if (FChild <> nil) then begin
75            FChild.Free;
76            FChild := nil;
77        end;
78        if (FEvent <> nil) then begin
79            FEvent.Free;
80            FEvent := nil;
81        end;
82        FThread := nil;
83            inherited Destroy;
84    end;
85    
86    procedure TResPopupBrowser.CreateParams(var Params: TCreateParams);
87    begin
88            inherited;
89        Params.Style := Params.Style or WS_EX_TOOLWINDOW;
90    
91    end;
92    function TResPopupBrowser.CreateNewBrowser: TResPopupBrowser;
93    begin
94        if (Self.Visible) then begin
95            if (FChild <> nil) then begin
96                if (FChild.Visible) then begin
97                    Result := FChild.CreateNewBrowser;
98                end else begin
99                    Result := FChild;
100                end;
101            end else begin
102                FChild := TResPopupBrowser.Create(Self);
103                TOleControl(FChild).Parent := TOleControl(Self).Parent;
104                FChild.ParentBrowser := Self;
105                FChild.NavigateBlank;
106    
107                FChild.OnEnter := GikoForm.BrowserEnter;
108                FChild.OnBeforeNavigate2 := GikoForm.BrowserBeforeNavigate2;
109                FChild.OnStatusTextChange := GikoForm.BrowserStatusTextChange;
110                FChild.OnNewWindow2 := GikoForm.BrowserNewWindow2;
111                SetWindowPos(FChild.Handle, HWND_BOTTOM,
112                    0, 0, 0 , 0,
113                    SWP_NOSIZE or SWP_NOMOVE or  SWP_NOACTIVATE or SWP_HIDEWINDOW);
114                ShowWindow(FChild.Handle, SW_HIDE);
115                Result := FChild;
116            end;
117        end else begin
118            TOleControl(Self).Parent := nil;
119            FParentBrowser := nil;
120            Self.NavigateBlank;
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;
138    begin
139        if (not Assigned(Self.Document)) then begin
140            Self.Navigate('about:blank');
141        end;
142        while (Self.ReadyState <> READYSTATE_COMPLETE) and
143                (Self.ReadyState <> READYSTATE_INTERACTIVE) do begin
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            ARect: TRect;
160        FDispHtmlDocument: DispHTMLDocument;
161    begin
162        try
163            // タスクバーから消す
164            SetWindowLongA(Self.Handle, GWL_EXSTYLE, WS_EX_TOOLWINDOW);
165            GetCursorpos(p);
166            // いったん縮小
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                    + GetBodyStyle(OnlyTitle) + '</head><body>'
176                    + GetTitle(OnlyTitle)
177                    + ADocument + '<a name="bottom"></a></body></html>');
178            doc.Close;
179    
180            ARect := CalcRect(Screen.WorkAreaHeight, Screen.WorkAreaWidth,
181                 not OnlyTitle);
182    
183            FDispHtmlDocument := Idispatch(OleVariant(Self.ControlInterface).Document) as DispHTMLDocument;
184            FEvent := THTMLDocumentEventSink.Create(Self, FDispHtmlDocument, HTMLDocumentEvents2);
185            FEvent.OnClick := ResPopupBrowserClick;
186    
187            Self.Visible := True;
188            SetWindowPos(Self.Handle, HWND_TOP,
189                ARect.Left, ARect.Top,
190                (ARect.Right - ARect.Left) ,
191                (ARect.Bottom - ARect.Top),
192                SWP_NOACTIVATE or SWP_HIDEWINDOW);
193    
194            ShowWindow(Self.Handle, SW_SHOWNOACTIVATE);
195        except
196        end;
197    end;
198    function TResPopupBrowser.GetTitle(OnlyTitle: Boolean): string;
199    begin
200        Result := '<span id="hTitle">' + Title +'</span>';
201        if OnlyTitle then Result := Result + '<BR>';
202    end;
203    function TResPopupBrowser.GetBodyStyle(OnlyTitle: Boolean = False): string;
204    var
205        i : Integer;
206    begin
207    
208        Result := '<style type="text/css">' +
209                'dl { margin :0px; padding :0px}'#13#10 +
210                'body { ' +
211                'border-width: 1px; border-style: solid;white-space: nowrap; ' +
212                'margin: 2px 4px 0px 0px; padding: 0px 4px 0px 0px; ';
213    
214            if Length( GikoSys.Setting.HintFontName ) > 0 then
215                    Result := Result + 'font-family:"' + GikoSys.Setting.HintFontName + '";';
216            if GikoSys.Setting.HintFontSize <> 0 then
217                    Result := Result + 'font-size:' + IntToStr( GikoSys.Setting.HintFontSize ) + 'pt;';
218            if GikoSys.Setting.HintFontColor <> -1 then
219                    Result := Result + 'color:#' + IntToHex( GikoSys.Setting.HintFontColor, 6 ) + ';';
220            if GikoSys.Setting.HintBackColor <> -1 then begin
221                    i := ColorToRGB( GikoSys.Setting.HintBackColor );
222                    Result := Result + 'background-color:#' +
223                IntToHex( (i shr 16) or (i and $ff00) or ((i and $ff) shl 16), 6 ) + ';';
224        end;
225        if OnlyTitle then
226            Result := Result + 'overflow: hidden; ';
227    
228        Result := Result + '}';
229        if GikoSys.Setting.ResPopupHeaderBold then begin
230            Result := Result + #13#10'span#hTitle{font-weight: bold; }';
231        end;
232        Result := Result + '</style>';
233    end;
234    
235    procedure TResPopupBrowser.Clear;
236    var
237        body: IHTMLElement2;
238    begin
239        ChildClear;
240        if (Self.Visible) then begin
241            try
242                if (Self.ParentBrowser = nil) then begin
243                    body := (Idispatch( olevariant(GikoForm.ActiveContent.Browser
244                        .ControlInterface).Document) as IHTMLDocument2).body as IHTMLElement2;
245                    body.focus;
246                end;
247            except
248            end;
249            Self.Title := '';
250            Self.RawDocument := '';
251            Self.FThread := nil;
252            FEvent.Free;
253            FEvent := nil;
254            NavigateBlank;
255            ShowWindow(Self.Handle, SW_HIDE);
256            Self.Visible := False;
257        end;
258    end;
259    procedure TResPopupBrowser.ChildClear;
260    begin
261        if (FChild <> nil) then begin
262            FChild.Clear;
263        end;
264    end;
265    
266    function TResPopupBrowser.CalcRect(MaxHeight: Integer; MaxWidth: Integer; Scroll: Boolean): TRect;
267    var
268            p: TPoint;
269        ele: IHTMLElement2;
270        h, w: Integer;
271    begin
272            GetCursorpos(p);
273        ele := ((Self.Document as IHTMLDocument2).body as IHTMLElement2);
274        if Scroll then begin
275            h := GetWindowHeight + 10;
276            w := ele.scrollWidth + 25
277        end else begin
278            h := GetWindowHeight + 5;
279            w := ele.scrollWidth + 10;
280        end;
281            Result := Rect(0, 0, w, h);
282        case GikoSys.Setting.PopupPosition of
283            gppRightTop:            OffsetRect(Result, p.x - w - 2, p.y - h - 2);
284            gppRight:                       OffsetRect(Result, p.x - w - 2, p.y - (h div 2));
285            gppRightBottom: OffsetRect(Result, p.x - w -2, p.y + 2);
286            gppTop:                                 OffsetRect(Result, p.x - (w div 2), p.y - h - 2);
287            gppCenter:                      OffsetRect(Result, p.x - (w div 2), p.y - (h div 2));
288            gppBottom:                      OffsetRect(Result, p.x - (w div 2), p.y + 2);
289            gppLeftTop:                     OffsetRect(Result, p.x + 2, p.y - h - 2);
290            gppLeft:                                OffsetRect(Result, p.x + 2, p.y - (h div 2));
291            gppLeftBottom:  OffsetRect(Result, p.x + 2, p.y + 2);
292        end;
293        if (Result.Left < 0) then begin
294            OffsetRect(Result, -Result.Left, 0);
295        end;
296        if (Result.Top < 0) then begin
297            OffsetRect(Result, 0, -Result.Top);
298        end;
299        if (Result.Right > MaxWidth) then begin
300            OffsetRect(Result, - (Result.Right - MaxWidth), 0);
301        end;
302        if (Result.Bottom > MaxHeight) then begin
303            OffsetRect(Result, 0, - (Result.Bottom - MaxHeight));
304        end;
305        
306        // ここで再度左と上を確認して飛び出してたら、画面サイズを小さくする
307        if (Result.Left < 0) then begin
308            Result := Rect(0, Result.Top,
309                Result.Right, Result.Bottom);
310        end;
311        if (Result.Top < 0) then begin
312            Result := Rect(Result.Left, 0,
313                Result.Right, Result.Bottom);
314        end;
315    end;
316    function TResPopupBrowser.GetWindowHeight : Integer;
317    var
318            top: Integer;
319            item: OleVariant;
320    begin
321        Result := 0;
322        //ブラウザがデータの読み込み中の時は読み込みを待つ
323        while (Self.ReadyState <> READYSTATE_COMPLETE) and
324                    (Self.ReadyState <> READYSTATE_INTERACTIVE) do begin
325            Sleep(1);
326            Forms.Application.ProcessMessages;
327        end;
328    
329        try
330            top := 0;
331            item := OleVariant( Self.Document as IHTMLDocument2)
332                    .anchors.item(OleVariant('bottom'));
333            item.focus();
334            repeat
335                top := top + item.offsetTop;
336                item := item.offsetParent;
337            until AnsiCompareText(item.tagName, 'body' ) = 0;
338            Result := top;
339        except
340        end;
341    end;
342    function TResPopupBrowser.ResPopupBrowserClick(Sender: TObject): WordBool;
343    var
344        doc: IHTMLDocument2;
345        body: IHTMLElement2;
346    begin
347    //    doc := Idispatch( olevariant(
348    //        GikoForm.ActiveContent.Browser.ControlInterface).Document) as IHTMLDocument2;
349        doc := Idispatch( olevariant(
350            Self.ControlInterface).Document) as IHTMLDocument2;
351        body := (doc.body as IHTMLElement2);
352        body.focus;
353        Result := True;
354    end;
355    function TResPopupBrowser.GetThread: TThreadItem;
356    begin
357        Result := nil;
358        if (FThread <> nil) then begin
359            try
360                // 無効なポインタ検査
361                if (FThread.ParentBoard <> nil) then begin
362                    Result := FThread
363                end;
364            except
365                //無効なポインタだった
366                Result := nil;
367            end;
368        end;
369    end;
370    end.

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

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