Develop and Download Open Source Software

Browse CVS Repository

Annotation of /gikonavigoeson/gikonavi/ResPopupBrowser.pas

Parent Directory Parent Directory | Revision Log Revision Log | View Revision Graph Revision Graph


Revision 1.1.2.3 - (hide annotations) (download) (as text)
Tue May 8 22:25:45 2007 UTC (16 years, 11 months ago) by h677
Branch: bRESPOPUP
CVS Tags: v1_56_0_702
Changes since 1.1.2.2: +12 -13 lines
File MIME type: text/x-pascal
NewBrowserイベントが発生しない不具合対応

1 h677 1.1.2.1 unit ResPopupBrowser;
2     interface
3     uses
4     Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
5 h677 1.1.2.2 ActiveX, OleCtrls, HintWindow,
6 h677 1.1.2.1 {$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 h677 1.1.2.2 function GetBodyStyle(): string;
22 h677 1.1.2.1 protected
23     procedure CreateParams(var Params: TCreateParams); override;
24     public
25     constructor Create(AOwner: TComponent); override;
26     destructor Destroy; override;
27     property Child: TResPopupBrowser read FChild;
28     property Title: String read FTitle write FTitle;
29     function CreateNewBrowser: TResPopupBrowser;
30     procedure Write(ADocument: String);
31     procedure Clear;
32     procedure ChildClear;
33     procedure NavigateBlank;
34     function CalcRect(MaxWidth: Integer): TRect;
35     property PopupType: TGikoPopupType read FPopupType write FPopupType;
36     end;
37    
38     implementation
39     uses MojuUtils, GikoSystem, Setting, Giko;
40    
41    
42     constructor TResPopupBrowser.Create(AOwner: TComponent);
43     begin
44     inherited Create(AOwner);
45     FChild := nil;
46     Visible := False;
47 h677 1.1.2.2 Title := '';
48 h677 1.1.2.1 end;
49    
50     destructor TResPopupBrowser.Destroy;
51     begin
52     inherited Destroy;
53     end;
54    
55     procedure TResPopupBrowser.CreateParams(var Params: TCreateParams);
56     begin
57     inherited CreateParams(Params);
58     end;
59     function TResPopupBrowser.CreateNewBrowser: TResPopupBrowser;
60     begin
61     if (Self.Visible) then begin
62     if (FChild <> nil) then begin
63     if (FChild.Visible) then begin
64     Result := FChild.CreateNewBrowser;
65     end else begin
66     Result := FChild;
67     end;
68     end else begin
69     FChild := TResPopupBrowser.Create(Self);
70     TOleControl(FChild).Parent := nil;
71     FChild.NavigateBlank;
72     FChild.OnEnter := GikoForm.BrowserEnter;
73 h677 1.1.2.3 FChild.OnBeforeNavigate2 := GikoForm.BrowserBeforeNavigate2;
74 h677 1.1.2.1 FChild.OnStatusTextChange := GikoForm.BrowserStatusTextChange;
75 h677 1.1.2.2 FChild.OnNewWindow2 := GikoForm.BrowserNewWindow2;
76 h677 1.1.2.1 ShowWindow(FChild.Handle, SW_HIDE);
77     Result := FChild;
78     end;
79     end else begin
80     TOleControl(Self).Parent := nil;
81     Self.NavigateBlank;
82     Self.OnEnter := GikoForm.BrowserEnter;
83 h677 1.1.2.3 Self.OnBeforeNavigate2 := GikoForm.BrowserBeforeNavigate2;
84 h677 1.1.2.1 Self.OnStatusTextChange := GikoForm.BrowserStatusTextChange;
85 h677 1.1.2.2 Self.OnNewWindow2 := GikoForm.BrowserNewWindow2;
86 h677 1.1.2.1 Result := Self;
87     end;
88    
89     end;
90     procedure TResPopupBrowser.NavigateBlank;
91     begin
92     if (not Assigned(Self.Document)) then begin
93     Self.Navigate('about:blank');
94     end;
95     while (Self.ReadyState <> READYSTATE_COMPLETE) and
96     (Self.ReadyState <> READYSTATE_INTERACTIVE) do begin
97     Forms.Application.ProcessMessages;
98     end;
99     end;
100     procedure TResPopupBrowser.Write(ADocument: String);
101     var
102     doc: Variant;
103     ARect: TRect;
104     begin
105     try
106     doc := Idispatch( olevariant(Self.ControlInterface).Document) as IHTMLDocument2;
107     doc.open;
108     doc.charset := 'Shift_JIS';
109 h677 1.1.2.2 doc.Write('<html><head>'#13#10 +
110     '<meta http-equiv="Content-type" content="text/html; charset=Shift_JIS">'#13#10 +
111     Title + GetBodyStyle + '</head><body>' +
112     ADocument + '</body></html>');
113 h677 1.1.2.1 doc.Close;
114    
115 h677 1.1.2.2 while (Self.ReadyState <> READYSTATE_COMPLETE) and
116     (Self.ReadyState <> READYSTATE_INTERACTIVE) do begin
117     Sleep(1);
118     Forms.Application.ProcessMessages;
119     end;
120    
121     ARect := CalcRect(Screen.Width);
122 h677 1.1.2.3 SetWindowPos(Self.Handle, HWND_TOP,
123 h677 1.1.2.1 ARect.Left, ARect.Top,
124     (ARect.Right - ARect.Left) ,
125     (ARect.Bottom - ARect.Top),
126     SWP_NOACTIVATE or SWP_HIDEWINDOW);
127 h677 1.1.2.3 Self.Visible := True;
128 h677 1.1.2.2 ShowWindow(Self.Handle, SW_SHOWNOACTIVATE);
129    
130 h677 1.1.2.1 except
131     end;
132 h677 1.1.2.2
133     end;
134    
135     function TResPopupBrowser.GetBodyStyle(): string;
136     begin
137    
138     Result := '<style type="text/css">' +
139     'dl { margin :0px; padding :0px}'#13#10 +
140     'body { ' +
141     'border-width: 1px; border-style: solid;white-space: nowrap; ' +
142     'margin: 2px 4px 0px 0px; padding: 0px 4px 0px 0px';
143    
144     if Length( GikoSys.Setting.HintFontName ) > 0 then
145     Result := Result + 'font-family:"' + GikoSys.Setting.HintFontName + '";';
146     if GikoSys.Setting.HintFontSize <> 0 then
147     Result := Result + 'font-size:' + IntToStr( GikoSys.Setting.HintFontSize ) + 'pt;';
148     if GikoSys.Setting.HintFontColor <> -1 then
149     Result := Result + 'color:#' + IntToHex( GikoSys.Setting.HintFontColor, 6 ) + ';';
150     if GikoSys.Setting.HintBackColor <> -1 then
151     Result := Result + 'background-color:#' +
152     IntToHex(
153     (GikoSys.Setting.HintBackColor shr 16) or
154     (GikoSys.Setting.HintBackColor and $ff00) or
155     ((GikoSys.Setting.HintBackColor and $ff) shl 16), 6 ) + ';';
156    
157     Result := Result + '}</style>';
158 h677 1.1.2.1 end;
159 h677 1.1.2.2
160 h677 1.1.2.1 procedure TResPopupBrowser.Clear;
161     begin
162     ChildClear;
163     if (Self.Visible) then begin
164 h677 1.1.2.2 Self.Title := '';
165 h677 1.1.2.1 Self.Visible := False;
166     ShowWindow(Self.Handle, SW_HIDE);
167     end;
168     end;
169     procedure TResPopupBrowser.ChildClear;
170     begin
171     if (FChild <> nil) then begin
172     FChild.Clear;
173     end;
174     end;
175    
176     function TResPopupBrowser.CalcRect(MaxWidth: Integer): TRect;
177     var
178     p: TPoint;
179 h677 1.1.2.2 ele: IHTMLElement2;
180 h677 1.1.2.1 begin
181     GetCursorpos(p);
182 h677 1.1.2.2 ele := ((Self.Document as IHTMLDocument2).body as IHTMLElement2);
183     Result := Rect(0, 0,
184     ele.scrollWidth + 15,
185     ele.scrollHeight + 15);
186 h677 1.1.2.1 case GikoSys.Setting.PopupPosition of
187 h677 1.1.2.3 gppRightTop: OffsetRect(Result, p.x - (Result.Right - Result.Left) - 2, p.y - (Result.Bottom - Result.Top) - 2);
188     gppRight: OffsetRect(Result, p.x - (Result.Right - Result.Left) - 2, p.y - ((Result.Bottom - Result.Top) div 2));
189     gppRightBottom: OffsetRect(Result, p.x - (Result.Right - Result.Left) -2, p.y + 2);
190     gppTop: OffsetRect(Result, p.x - ((Result.Right - Result.Left) div 2), p.y - (Result.Bottom - Result.Top) - 2);
191 h677 1.1.2.1 gppCenter: OffsetRect(Result, p.x - ((Result.Right - Result.Left) div 2), p.y - ((Result.Bottom - Result.Top) div 2));
192 h677 1.1.2.3 gppBottom: OffsetRect(Result, p.x - ((Result.Right - Result.Left) div 2), p.y + 2);
193     gppLeftTop: OffsetRect(Result, p.x + 2, p.y - (Result.Bottom - Result.Top) - 2);
194     gppLeft: OffsetRect(Result, p.x + 2, p.y - ((Result.Bottom - Result.Top) div 2));
195     gppLeftBottom: OffsetRect(Result, p.x + 2, p.y + 2);
196 h677 1.1.2.1 end;
197     if (Result.Left < 0) then begin
198     OffsetRect(Result, -Result.Left, 0);
199     end;
200     if (Result.Top < 0) then begin
201     OffsetRect(Result, 0, -Result.Top);
202     end;
203     end;
204    
205     end.

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