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.2 by h677, Sun Jun 10 14:46:32 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(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    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_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_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(Forced: Boolean);
138    begin
139        if (not Assigned(Self.Document)) or (Forced) then begin
140            Self.Navigate('about:blank');
141        end;
142        while (Self.ReadyState <> READYSTATE_COMPLETE) and
143                (Self.ReadyState <> READYSTATE_INTERACTIVE) do begin
144            Sleep(1);
145            Forms.Application.ProcessMessages;
146        end;
147    end;
148    procedure TResPopupBrowser.TitlePopup;
149    begin
150        Write('', True);
151    end;
152    procedure TResPopupBrowser.Popup;
153    begin
154        Write(Self.RawDocument, false);
155    end;
156    procedure TResPopupBrowser.Write(ADocument: String; OnlyTitle: Boolean = False);
157    var
158            p: TPoint;
159        doc: Variant;
160            ARect, rect: TRect;
161        FDispHtmlDocument: DispHTMLDocument;
162    begin
163        try
164            // タスクバーから消す
165            SetWindowLongA(Self.Handle, GWL_EXSTYLE, WS_EX_TOOLWINDOW);
166            GetCursorpos(p);
167            // いったん縮小
168            SetWindowPos(Self.Handle, HWND_BOTTOM,
169                p.X, p.Y, 50 , 50,
170                SWP_NOACTIVATE or SWP_HIDEWINDOW);
171            doc := Idispatch( olevariant(Self.ControlInterface).Document) as IHTMLDocument2;
172            doc.open;
173            doc.charset := 'Shift_JIS';
174            doc.Write('<html><head>'#13#10 +
175                    '<meta http-equiv="Content-type" content="text/html; charset=Shift_JIS">'#13#10 +
176                    '<meta http-equiv="Pragma" content="no-cache">'#13#10 +
177                    '<meta http-equiv="Cache-Control" content="no-cache">'#13#10 +
178                    GetBodyStyle(OnlyTitle) + '</head><body>'
179                    + GetTitle(OnlyTitle)
180                    + ADocument + '<a name="bottom"></a></body></html>');
181    
182            doc.Close;
183    
184            ARect := CalcRect(Screen.WorkAreaRect, not OnlyTitle);
185    
186            FDispHtmlDocument := Idispatch(OleVariant(Self.ControlInterface).Document) as DispHTMLDocument;
187            FEvent := THTMLDocumentEventSink.Create(Self, FDispHtmlDocument, HTMLDocumentEvents2);
188            FEvent.OnClick := ResPopupBrowserClick;
189    
190            Self.Visible := True;
191            SetWindowPos(Self.Handle, HWND_TOPMOST,
192                ARect.Left, ARect.Top,
193                (ARect.Right - ARect.Left) ,
194                (ARect.Bottom - ARect.Top),
195                SWP_NOACTIVATE or SWP_HIDEWINDOW);
196            ShowWindow(Self.Handle, SW_SHOWNOACTIVATE);
197        except
198        end;
199    end;
200    function TResPopupBrowser.GetTitle(OnlyTitle: Boolean): string;
201    begin
202        Result := '<span id="hTitle">' + Title +'</span>';
203        if OnlyTitle then Result := Result + '<BR>';
204    end;
205    function TResPopupBrowser.GetBodyStyle(OnlyTitle: Boolean = False): string;
206    var
207        i : Integer;
208    begin
209    
210        Result := '<style type="text/css">' +
211                'dl { margin :0px; padding :0px}'#13#10 +
212                'body { ' +
213                'border-width: 1px; border-style: solid;white-space: nowrap; ' +
214                'margin: 2px 4px 0px 0px; padding: 0px 4px 0px 0px; ';
215    
216            if Length( GikoSys.Setting.HintFontName ) > 0 then
217                    Result := Result + 'font-family:"' + GikoSys.Setting.HintFontName + '";';
218            if GikoSys.Setting.HintFontSize <> 0 then
219                    Result := Result + 'font-size:' + IntToStr( GikoSys.Setting.HintFontSize ) + 'pt;';
220            if GikoSys.Setting.HintFontColor <> -1 then
221                    Result := Result + 'color:#' + IntToHex( GikoSys.Setting.HintFontColor, 6 ) + ';';
222            if GikoSys.Setting.HintBackColor <> -1 then begin
223                    i := ColorToRGB( GikoSys.Setting.HintBackColor );
224                    Result := Result + 'background-color:#' +
225                IntToHex( (i shr 16) or (i and $ff00) or ((i and $ff) shl 16), 6 ) + ';';
226        end;
227        if OnlyTitle then
228            Result := Result + 'overflow: hidden; ';
229    
230        Result := Result + '}';
231        if GikoSys.Setting.ResPopupHeaderBold then begin
232            Result := Result + #13#10'span#hTitle{font-weight: bold; }';
233        end;
234        Result := Result + '</style>';
235    end;
236    
237    procedure TResPopupBrowser.Clear;
238    begin
239        ChildClear;
240        if (Self.Visible) then begin
241            Self.Title := '';
242            Self.RawDocument := '';
243            Self.FThread := nil;
244            Self.FEvent.Free;
245            Self.FEvent := nil;
246            Self.Blur;
247            ShowWindow(Self.Handle, SW_HIDE);
248            Self.Visible := False;
249        end;
250    end;
251    procedure TResPopupBrowser.ChildClear;
252    begin
253        if (FChild <> nil) then begin
254            FChild.Clear;
255        end;
256    end;
257    
258    function TResPopupBrowser.CalcRect(WorkArea: TRect; Scroll: Boolean): TRect;
259    var
260            p: TPoint;
261        ele: IHTMLElement2;
262        h, w, dx1, dx2, dy1, dy2: Integer;
263        MaxWidth, MaxHeight: Integer;
264    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        dx1 := 0; dx2 := 0;
276        dy1 := 0; dy2 := 0;
277    
278            Result := Rect(0, 0, w, h);
279        case GikoSys.Setting.PopupPosition of
280            gppRightTop:
281            begin
282                dx1 := 0; dx2 := -2;
283                dy1 := -h; dy2 := -2;
284            end;
285            gppRight:
286            begin
287                dx1 := 0; dx2 := -2;
288                dy1 := - (h div 2); dy2 := 0;
289            end;
290            gppRightBottom:
291            begin
292                dx1 := 0; dx2 := -2;
293                dy1 := 0; dy2 := +2;
294            end;
295            gppTop:
296            begin
297                dx1 := - (w div 2); dx2 := 0;
298                dy1 := -h; dy2 := -2;
299            end;
300            // 廃止 gppCenter: OffsetRect(Result, p.x - (w div 2), p.y - (h div 2));
301            gppBottom:
302            begin
303                dx1 := - (w div 2); dx2 := 0;
304                dy1 := 0; dy2 := +2;
305            end;
306            gppLeftTop:
307            begin
308                dx1 := -w; dx2 := +2;
309                dy1 := -h; dy2 := -2;
310            end;
311            gppLeft:
312            begin
313                dx1 := -w; dx2 := +2;
314                dy1 := - (h div 2); dy2 := 0;
315            end;
316            gppLeftBottom:
317            begin
318                dx1 := -w; dx2 := +2;
319                dy1 := 0; dy2 := +2;
320            end;
321        end;
322        // 初期位置に移動
323        OffsetRect(Result, p.x + dx1 + dx2, p.y + dy1 + dy2);
324    
325        MaxWidth := WorkArea.Right - WorkArea.Left;
326        MaxHeight := WorkArea.Bottom - WorkArea.Top;
327        // 以下、初期位置に問題があるときの移動
328        if (Result.Left < WorkArea.Left) then begin
329            // 逆サイドに余裕があれば、出力位置の左右転換
330            if (p.X * 2 < MaxWidth) then begin
331                if ( (GikoSys.Setting.PopupPosition = gppTop) or
332                    (GikoSys.Setting.PopupPosition = gppBottom)) then begin
333                    OffsetRect(Result, -Result.Left, WorkArea.Left);
334                end else begin
335                    OffsetRect(Result, - (dx1 + 2 * dx2), 0);
336                end;
337            end else begin
338                // 画面端まで画面幅を小さくする
339                Result := Rect(0, Result.Top,
340                    Result.Right, Result.Bottom);
341            end;
342        end;
343        if (Result.Top < WorkArea.Top) then begin
344            // 底側に余裕があれば、出力位置の上下転換
345            if (p.Y * 2 < MaxHeight) then begin
346                OffsetRect(Result, 0, - (dy1 + 2 * dy2));
347            end else begin
348                // 画面端まで画面高を小さくする
349                Result := Rect(Result.Left, WorkArea.Top,
350                    Result.Right, Result.Bottom);
351            end;
352        end;
353        if (Result.Right > WorkArea.Right) then begin
354            // 逆サイドに余裕があれば、出力位置の左右転換
355            if (p.X * 2 > WorkArea.Right) then begin
356                if( (GikoSys.Setting.PopupPosition = gppTop) or
357                    (GikoSys.Setting.PopupPosition = gppBottom)) then begin
358                    OffsetRect(Result, -(Result.Right - WorkArea.Right), 0);
359                end else begin
360                    OffsetRect(Result, -w - (dx1 + 2 * dx2), 0);
361                end;
362                // 逆サイドにオーバーした場合は画面端まで幅を小さくする
363                if (Result.Left < WorkArea.Left) then begin
364                    Result := Rect(WorkArea.Left, Result.Top,
365                        Result.Right, Result.Bottom);
366                end;
367            end else begin
368                // 画面端まで画面幅を小さくする
369                Result := Rect(Result.Left, Result.Top,
370                    WorkArea.Right, Result.Bottom);
371            end;
372        end;
373        if (Result.Bottom > WorkArea.Bottom) then begin
374            // 上側に余裕があれば、出力位置の上下転換
375            if (p.Y * 2 > WorkArea.Bottom) then begin
376                OffsetRect(Result, 0, -h - (dy1 + 2 * dy2));
377                // 上に貫いた場合は、
378                if (Result.Top < WorkArea.Top) then begin
379                    Result := Rect(Result.Left, WorkArea.Top,
380                        Result.Right, Result.Bottom);
381                end;
382            end else begin
383                // 画面端まで画面高を小さくする
384                Result := Rect(Result.Left, Result.Top,
385                    Result.Right, WorkArea.Bottom);
386            end;
387        end;
388    end;
389    function TResPopupBrowser.GetWindowHeight : Integer;
390    var
391            top: Integer;
392            item: OleVariant;
393    begin
394        Result := 0;
395        //ブラウザがデータの読み込み中の時は読み込みを待つ
396        while (Self.ReadyState <> READYSTATE_COMPLETE) and
397                    (Self.ReadyState <> READYSTATE_INTERACTIVE) do begin
398            Sleep(1);
399            Forms.Application.ProcessMessages;
400        end;
401    
402        try
403            top := 0;
404            item := OleVariant( Self.Document as IHTMLDocument2)
405                    .anchors.item(OleVariant('bottom'));
406            item.focus();
407            repeat
408                top := top + item.offsetTop;
409                item := item.offsetParent;
410            until AnsiCompareText(item.tagName, 'body' ) = 0;
411            Result := top;
412        except
413        end;
414    end;
415    function TResPopupBrowser.ResPopupBrowserClick(Sender: TObject): WordBool;
416    begin
417        // ギコナビのフォーカスを奪ってるのでフォームに無理やり返す
418        Blur;
419        Result := True;
420    end;
421    function TResPopupBrowser.GetThread: TThreadItem;
422    begin
423        Result := nil;
424        if (FThread <> nil) then begin
425            try
426                // 無効なポインタ検査
427                if (FThread.ParentBoard <> nil) then begin
428                    Result := FThread
429                end;
430            except
431                //無効なポインタだった
432                Result := nil;
433            end;
434        end;
435    end;
436    procedure TResPopupBrowser.Blur;
437    var
438        FOleInPlaceActiveObject: IOleInPlaceActiveObject;
439    begin
440        FOleInPlaceActiveObject := Self.ControlInterface as IOleInPlaceActiveObject;
441        FOleInPlaceActiveObject.OnFrameWindowActivate(False);
442    end;
443    
444    initialization
445        OleInitialize(nil);
446    
447    finalization
448        OleUninitialize;
449    
450    end.

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

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