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.5 by h677, Thu May 10 16:07:31 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,
6    {$IF Defined(DELPRO) }
7            SHDocVw,
8            MSHTML
9    {$ELSE}
10            SHDocVw_TLB,
11            MSHTML_TLB
12    {$IFEND}
13    ;
14    
15    type
16            TResPopupBrowser = class(TWebBrowser)
17            private
18            FChild :TResPopupBrowser;
19            FTitle :String;
20                    FPopupType: TGikoPopupType;
21            function GetBodyStyle(): string;
22            function GetWindowHeight : Integer;
23            protected
24                    procedure CreateParams(var Params: TCreateParams); override;
25            public
26                    constructor Create(AOwner: TComponent); override;
27                    destructor Destroy; override;
28            property Child: TResPopupBrowser read FChild;
29            property Title: String read FTitle write FTitle;
30            function CreateNewBrowser: TResPopupBrowser;
31            procedure Write(ADocument: String);
32            procedure Clear;
33            procedure ChildClear;
34            procedure NavigateBlank;
35                    function CalcRect(MaxHeight: Integer; MaxWidth: Integer): TRect;
36                    property PopupType: TGikoPopupType read FPopupType write FPopupType;
37            end;
38    
39    implementation
40    uses MojuUtils, GikoSystem, Setting, Giko;
41    
42    
43    constructor TResPopupBrowser.Create(AOwner: TComponent);
44    begin
45            inherited Create(AOwner);
46        FChild := nil;
47        Visible := False;
48        Title := '';
49    end;
50    
51    destructor TResPopupBrowser.Destroy;
52    begin
53            inherited Destroy;
54    end;
55    
56    procedure TResPopupBrowser.CreateParams(var Params: TCreateParams);
57    begin
58            inherited CreateParams(Params);
59    end;
60    function TResPopupBrowser.CreateNewBrowser: TResPopupBrowser;
61    begin
62        if (Self.Visible) then begin
63            if (FChild <> nil) then begin
64                if (FChild.Visible) then begin
65                    Result := FChild.CreateNewBrowser;
66                end else begin
67                    Result := FChild;
68                end;
69            end else begin
70                FChild := TResPopupBrowser.Create(Self);
71                TOleControl(FChild).Parent := nil;
72                FChild.NavigateBlank;
73                FChild.OnEnter := GikoForm.BrowserEnter;
74                FChild.OnBeforeNavigate2 := GikoForm.BrowserBeforeNavigate2;
75                FChild.OnStatusTextChange := GikoForm.BrowserStatusTextChange;
76                FChild.OnNewWindow2 := GikoForm.BrowserNewWindow2;
77                ShowWindow(FChild.Handle, SW_HIDE);
78                Result := FChild;
79            end;
80        end else begin
81            TOleControl(Self).Parent := nil;
82            Self.NavigateBlank;
83            Self.OnEnter := GikoForm.BrowserEnter;
84            Self.OnBeforeNavigate2 := GikoForm.BrowserBeforeNavigate2;
85            Self.OnStatusTextChange := GikoForm.BrowserStatusTextChange;
86            Self.OnNewWindow2 := GikoForm.BrowserNewWindow2;
87            Result := Self;
88        end;
89    
90    end;
91    procedure TResPopupBrowser.NavigateBlank;
92    begin
93        if (not Assigned(Self.Document)) then begin
94            Self.Navigate('about:blank');
95        end;
96        while (Self.ReadyState <> READYSTATE_COMPLETE) and
97                (Self.ReadyState <> READYSTATE_INTERACTIVE) do begin
98            Forms.Application.ProcessMessages;
99        end;
100    end;
101    procedure TResPopupBrowser.Write(ADocument: String);
102    var
103        doc: Variant;
104            ARect: TRect;
105    begin
106        try
107            // いったん縮小
108            SetWindowPos(Self.Handle, HWND_TOP,
109                0, 0, 50 , 50,
110                SWP_NOMOVE or SWP_NOACTIVATE or SWP_HIDEWINDOW);
111    
112            doc := Idispatch( olevariant(Self.ControlInterface).Document) as IHTMLDocument2;
113            doc.open;
114            doc.charset := 'Shift_JIS';
115            doc.Write('<html><head>'#13#10 +
116                    '<meta http-equiv="Content-type" content="text/html; charset=Shift_JIS">'#13#10 +
117                    '<span id="hTitle">' + Title +'</span>'+ GetBodyStyle + '</head><body>' +
118                    ADocument + '<a name="bottom"></a></body></html>');
119            doc.Close;
120    
121            ARect := CalcRect(Screen.Height, Screen.Width);
122            SetWindowPos(Self.Handle, HWND_TOP,
123                ARect.Left, ARect.Top,
124                (ARect.Right - ARect.Left) ,
125                (ARect.Bottom - ARect.Top),
126                SWP_NOACTIVATE or SWP_HIDEWINDOW);
127            ShowWindow(Self.Handle, SW_SHOWNOACTIVATE);
128            Self.Visible := True;
129        except
130        end;
131    
132    end;
133    
134    function TResPopupBrowser.GetBodyStyle(): string;
135    var
136        i : Integer;
137    begin
138    
139        Result := '<style type="text/css">' +
140                'dl { margin :0px; padding :0px}'#13#10 +
141                'body { ' +
142                'border-width: 1px; border-style: solid;white-space: nowrap; ' +
143                'margin: 2px 4px 0px 0px; padding: 0px 4px 0px 0px; ';
144    
145            if Length( GikoSys.Setting.HintFontName ) > 0 then
146                    Result := Result + 'font-family:"' + GikoSys.Setting.HintFontName + '";';
147            if GikoSys.Setting.HintFontSize <> 0 then
148                    Result := Result + 'font-size:' + IntToStr( GikoSys.Setting.HintFontSize ) + 'pt;';
149            if GikoSys.Setting.HintFontColor <> -1 then
150                    Result := Result + 'color:#' + IntToHex( GikoSys.Setting.HintFontColor, 6 ) + ';';
151            if GikoSys.Setting.HintBackColor <> -1 then begin
152                    i := ColorToRGB( GikoSys.Setting.HintBackColor );
153                    Result := Result + 'background-color:#' +
154                IntToHex( (i shr 16) or (i and $ff00) or ((i and $ff) shl 16), 6 ) + ';';
155        end;
156    
157        Result := Result + '}';
158        if GikoSys.Setting.ResPopupHeaderBold then begin
159            Result := Result + #13#10'span#hTitle{font-weight: bold; }';
160        end;
161        Result := Result + '</style>';
162    end;
163    
164    procedure TResPopupBrowser.Clear;
165    begin
166        ChildClear;
167        if (Self.Visible) then begin
168            Self.Title := '';
169            NavigateBlank;
170            ShowWindow(Self.Handle, SW_HIDE);
171            Self.Visible := False;
172        end;
173    end;
174    procedure TResPopupBrowser.ChildClear;
175    begin
176        if (FChild <> nil) then begin
177            FChild.Clear;
178        end;
179    end;
180    
181    function TResPopupBrowser.CalcRect(MaxHeight: Integer; MaxWidth: Integer): TRect;
182    var
183            p: TPoint;
184        ele: IHTMLElement2;
185        h, w: Integer;
186    begin
187            GetCursorpos(p);
188        ele := ((Self.Document as IHTMLDocument2).body as IHTMLElement2);
189        h := GetWindowHeight + 10;
190        w := ele.scrollWidth + 25;
191            Result := Rect(0, 0, w, h);
192        case GikoSys.Setting.PopupPosition of
193            gppRightTop:            OffsetRect(Result, p.x - w - 2, p.y - h - 2);
194            gppRight:                       OffsetRect(Result, p.x - w - 2, p.y - (h div 2));
195            gppRightBottom: OffsetRect(Result, p.x - w -2, p.y + 2);
196            gppTop:                                 OffsetRect(Result, p.x - (w div 2), p.y - h - 2);
197            gppCenter:                      OffsetRect(Result, p.x - (w div 2), p.y - (h div 2));
198            gppBottom:                      OffsetRect(Result, p.x - (w div 2), p.y + 2);
199            gppLeftTop:                     OffsetRect(Result, p.x + 2, p.y - h - 2);
200            gppLeft:                                OffsetRect(Result, p.x + 2, p.y - (h div 2));
201            gppLeftBottom:  OffsetRect(Result, p.x + 2, p.y + 2);
202        end;
203        if (Result.Left < 0) then begin
204            OffsetRect(Result, -Result.Left, 0);
205        end;
206        if (Result.Top < 0) then begin
207            OffsetRect(Result, 0, -Result.Top);
208        end;
209        if (Result.Right > MaxWidth) then begin
210            OffsetRect(Result, - (Result.Right - MaxWidth), 0);
211        end;
212        if (Result.Bottom > MaxHeight) then begin
213            OffsetRect(Result, 0, - (Result.Bottom - MaxHeight));
214        end;
215        
216        // ここで再度左と上を確認して飛び出してたら、画面サイズを小さくする
217        if (Result.Left < 0) then begin
218            Result := Rect(0, Result.Top,
219                Result.Right, Result.Bottom);
220        end;
221        if (Result.Top < 0) then begin
222            Result := Rect(Result.Left, 0,
223                Result.Right, Result.Bottom);
224        end;
225    end;
226    function TResPopupBrowser.GetWindowHeight : Integer;
227    var
228            top: Integer;
229            item: OleVariant;
230    begin
231        Result := 0;
232        //ブラウザがデータの読み込み中の時は読み込みを待つ
233        while (Self.ReadyState <> READYSTATE_COMPLETE) and
234                    (Self.ReadyState <> READYSTATE_INTERACTIVE) do begin
235            Sleep(1);
236            Forms.Application.ProcessMessages;
237        end;
238    
239        try
240            top := 0;
241            item := OleVariant( Self.Document as IHTMLDocument2)
242                    .anchors.item(OleVariant('bottom'));
243            item.focus();
244            repeat
245                top := top + item.offsetTop;
246                item := item.offsetParent;
247            until AnsiCompareText(item.tagName, 'body' ) = 0;
248            Result := top;
249        except
250        end;
251    end;
252    end.

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

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