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

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

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