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.8 - (hide annotations) (download) (as text)
Sun May 13 17:38:44 2007 UTC (16 years, 11 months ago) by h677
Branch: bRESPOPUP
CVS Tags: v1_56_0_705
Changes since 1.1.2.7: +33 -4 lines
File MIME type: text/x-pascal
レスポップアップ中のメニューのアクションを、そのスレッドで動作するように拡張

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

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