Develop and Download Open Source Software

Browse CVS Repository

Contents of /gikonavigoeson/gikonavi/BrowserRecord.pas

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


Revision 1.9 - (show annotations) (download) (as text)
Sun Apr 13 04:20:24 2008 UTC (16 years ago) by eggcake
Branch: MAIN
CVS Tags: v1_59_0_771, v1_59_0_770, v1_59_0_773, v1_59_0_772, v1_59_0_775, v1_59_0_774, v1_59_0_777, v1_59_0_776, v1_59_0_778, v1_63_1_819, v1_62_0_812, v1_59_1_765, v1_60_0_788, v1_60_0_789, v1_60_0_781, v1_60_0_782, v1_60_0_784, v1_60_0_786, v1_60_0_787, v1_59_0_767, v1_59_1_778, v1_59_0_768, v1_59_0_769, v1_58_0_752, v1_58_0_756, v1_58_0_757, v1_58_0_754, v1_58_0_755, v1_58_0_759, v1_61_0_796, v1_61_0_797, v1_61_0_795, v1_61_0_798, v1_61_0_799, v1_63_0_818, v1_63_0_817, v1_63_0_816, v1_63_0_815, v1_62_0_805, v1_62_0_804, v1_62_0_807, v1_62_0_806, v1_62_0_803, v1_62_0_802, v1_62_0_809, v1_60_0_780, v1_60_0_779, v1_62_0_810, v1_62_0_811, v1_60_0_783, v1_59_2_785, v1_60_1_793, v1_58_0_763, v1_58_0_762, v1_58_0_761, v1_58_0_760, v1_62_1_813, v1_61_0_800, v1_60_0_793, v1_60_0_792, v1_60_0_791, v1_60_0_790, v1_60_2_794, v1_61_1_801, HEAD
Branch point for: Bb62, Bb63, Bb60, Bb61, Bb59, Bb58
Changes since 1.8: +77 -67 lines
File MIME type: text/x-pascal
TWebBrowserの参照カウントが正しくなるように修正

1 unit BrowserRecord;
2
3 interface
4
5 uses
6 Windows, OleCtrls, ActiveX,
7 {$IF Defined(DELPRO) }
8 SHDocVw,
9 MSHTML,
10 {$ELSE}
11 SHDocVw_TLB,
12 MSHTML_TLB,
13 {$IFEND}
14 BoardGroup, HTMLDocumentEvent;
15
16 type
17 TBrowserRecord = class( TObject )
18 private
19 FBrowser : TWebBrowser;
20 FEvent: THTMLDocumentEventSink; ///< ???????吟?????ャ?<?潟???ゃ???潟??
21 FThread : TThreadItem;
22 FLastSize : Integer;
23 FRepaint : Boolean;
24 //FMovement : string; ///< ?鴻?????若?????≪?潟????/span>
25 public
26 destructor Destroy; override;
27 property Event : THTMLDocumentEventSink read FEvent write FEvent;
28 property Browser : TWebBrowser read FBrowser write FBrowser;
29 property Thread : TThreadItem read FThread write FThread;
30 property LastSize : Integer read FLastSize write FLastSize;
31 property Repaint : Boolean read FRepaint write FRepaint;
32 //property Movement : string read FMovement write FMovement;
33 procedure Move(const AName: string); overload;
34 procedure Move(scroll: Integer); overload;
35 procedure IDAnchorPopup(Abody :string);
36 procedure OpenFindDialog;
37 end;
38 // BrowserRecord???ゃ????????FBrowser??紊???
39 procedure ReleaseBrowser( BRecord: TBrowserRecord);
40
41 implementation
42
43 uses
44 Forms, SysUtils;
45
46 // *************************************************************************
47 //! BrowserRecord???ゃ????????FBrowser??紊???
48 // *************************************************************************
49 procedure ReleaseBrowser( BRecord: TBrowserRecord);
50 begin
51 if BRecord <> nil then begin
52 BRecord.Browser := nil;
53 if BRecord.Event <> nil then begin
54 BRecord.Event.Free;
55 BRecord.Event := nil;
56 end;
57 BRecord.Repaint := true;
58 end;
59 end;
60 // *************************************************************************
61 //! BrowserRecord?????鴻????????/span>
62 // *************************************************************************
63 destructor TBrowserRecord.Destroy;
64 var
65 doc :IHTMLDocument2;
66 begin
67 if Self.FEvent <> nil then
68 Self.FEvent.Free;
69
70 if Self.FBrowser <> nil then begin
71 if Self.Thread <> nil then begin
72 //?帥????奨???у奨?????????鴻????????祉??????????????????????????/span>
73 //???????????鴻?????若?????篆?絖????????障?????????????祉?c?????障????
74
75 try
76 doc := Self.FBrowser.ControlInterface.Document as IHTMLDocument2;
77 if Assigned(doc) then begin
78 if (doc as IHTMLDocument3).documentElement.innerText <> '' then begin
79 Self.Thread.ScrollTop := (doc.body as IHTMLElement2).scrollTop;
80 end;
81 end;
82 except
83 end;
84 end;
85 ShowWindow(Self.FBrowser.Handle, SW_HIDE);
86 end;
87
88 end;
89 // *************************************************************************
90 //! ???????吟???鴻?????若????????
91 // *************************************************************************
92 procedure TBrowserRecord.Move(const AName: string);
93 var
94 top: Integer;
95 item: OleVariant;
96 doc : OleVariant;
97 begin
98 //???????吟??篁???????????????????????
99 if not Assigned(Self.Browser) then
100 Exit;
101
102 //???????吟?????若?帥????粋昭?推賢????????粋昭?帥??緇???/span>
103 while (Self.Browser.ReadyState <> READYSTATE_COMPLETE) and
104 (Self.Browser.ReadyState <> READYSTATE_INTERACTIVE) do begin
105 Sleep(1);
106 Application.ProcessMessages;
107 end;
108
109 try
110 doc := Self.Browser.OleObject.Document;
111 top := 0;
112 item := doc.anchors.item(OleVariant(AName));
113 item.focus();
114 repeat
115 top := top + item.offsetTop;
116 item := item.offsetParent;
117 until AnsiCompareText(item.tagName, 'body' ) = 0;
118 doc.body.scrollTop := top;
119 except
120 end;
121 end;
122 // *************************************************************************
123 //! ???????吟???鴻?????若????????
124 // *************************************************************************
125 procedure TBrowserRecord.Move(scroll: Integer);
126 var
127 doc: IHTMLDocument2;
128 begin
129 //???????吟??篁???????????????????????
130 if not Assigned(Self.Browser) then
131 Exit;
132
133 //???????吟?????若?帥????粋昭?推賢????????粋昭?帥??緇???/span>
134 while (Self.Browser.ReadyState <> READYSTATE_COMPLETE) and
135 (Self.Browser.ReadyState <> READYSTATE_INTERACTIVE) do begin
136 Sleep(1);
137 Application.ProcessMessages;
138 end;
139
140 try
141 doc := Self.Browser.ControlInterface.Document as IHTMLDocument2;
142 (doc.body as IHTMLElement2).scrollTop := (doc.body as IHTMLElement2).scrollTop + scroll;
143 except
144 end;
145 end;
146
147 //ID?≪?潟???取申??
148 procedure TBrowserRecord.IDAnchorPopup(Abody :string);
149 const
150 OUTER_HTML = '<p id="idSearch"></p>';
151 HIDDEN = 'hidden';
152 var
153 firstElement: IHTMLElement;
154 doc : IHTMLDocument2;
155 nCSS : string;
156 begin
157 if not Assigned(Self.Browser) then
158 Exit;
159
160 try
161 doc := Self.Browser.ControlInterface.Document as IHTMLDocument2;
162 if not Assigned(doc) then
163 Exit;
164
165 firstElement := doc.all.item('idSearch', 0) as IHTMLElement;
166 if not Assigned(firstElement) then
167 Exit;
168
169 try
170 if Length(Abody) > 0 then begin
171 nCSS := '<p id="idSearch" style="position:absolute;top:' + IntToStr((doc.body as IHTMLElement2).ScrollTop + 10) + 'px;right:5px;' //
172 + 'background-color:window; border:outset 1px infobackground; z-index:10; overflow-y:auto; border-top:none">'
173 + Abody + '</p>';
174 firstElement.outerHTML := nCSS;
175 firstElement.style.visibility := 'visible';
176 end else begin
177 firstElement.outerHTML := OUTER_HTML;
178 firstElement.style.visibility := HIDDEN;
179 end;
180 except
181 firstElement.outerHTML := OUTER_HTML;
182 firstElement.style.visibility := HIDDEN;
183 end;
184
185 except
186 end;
187 end;
188 {
189 \brief 罎?膣≪???ゃ?≪???医?若?喝?冴??
190 }
191 procedure TBrowserRecord.OpenFindDialog();
192 const
193 CGID_WebBrowser: TGUID = '{ED016940-BD5B-11cf-BA4E-00C04FD70816}';
194 HTMLID_FIND = 1;
195 var
196 CmdTarget : IOleCommandTarget;
197 vaIn, vaOut: OleVariant;
198 begin
199 if Assigned(Self.Browser) then begin
200 try
201 CmdTarget := Self.Browser.ControlInterface.Document as IOleCommandTarget;
202 if Assigned(CmdTarget) then begin
203 CmdTarget.Exec(@CGID_WebBrowser, HTMLID_FIND, 0, vaIn, vaOut);
204 end;
205 except
206 end;
207 end;
208 end;
209
210 end.

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