Develop and Download Open Source Software

Browse CVS Repository

Contents of /gikonavigoeson/gikonavi/ResPopupBrowser.pas

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


Revision 1.1.2.7 - (show annotations) (download) (as text)
Sun May 13 14:49:06 2007 UTC (16 years, 11 months ago) by h677
Branch: bRESPOPUP
Changes since 1.1.2.6: +28 -13 lines
File MIME type: text/x-pascal
レスポップアップのメソッドを新設
ポップアップ中でメル欄のポップアップが利かない不具合の修正

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

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