ResPopupBrowser.pas

   1 unit ResPopupBrowser;
   2 interface
   3 uses
   4         Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
   5         ActiveX, OleCtrls, {HintWindow,} HTMLDocumentEvent, BoardGroup,
   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                 FEvent: THTMLDocumentEventSink;//\83u\83\89\83E\83U\83h\83L\83\85\83\81\83\93\83g\83C\83x\83\93\83g
  26         FThread: TThreadItem;
  27         function GetBodyStyle(OnlyTitle: Boolean = False): string;
  28         function GetWindowHeight : Integer;
  29         function GetTitle(OnlyTitle: Boolean): string;
  30                 function CalcRect(WorkArea: TRect; Scroll: Boolean): TRect;
  31         function ResPopupBrowserClick(Sender: TObject): WordBool;
  32         function GetThread: TThreadItem;
  33         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         property ParentBrowser:TResPopupBrowser read FParentBrowser write FParentBrowser;
  40         property Title: String read FTitle write FTitle;
  41         property RawDocument: String read FRawDocument write FRawDocument;
  42         property Thread: TThreadItem read GetThread write FThread;
  43         function CreateNewBrowser: TResPopupBrowser;
  44         function CurrentBrowser: TResPopupBrowser;
  45         procedure Write(ADocument: String; OnlyTitle: Boolean = False);
  46         procedure Clear;
  47         procedure ChildClear;
  48         procedure NavigateBlank(Forced: Boolean);
  49         property PopupType: TGikoPopupType read FPopupType write FPopupType;
  50         procedure TitlePopup;
  51         procedure Popup;
  52         procedure Blur;
  53         end;
  54
  55 implementation
  56 uses MojuUtils, GikoSystem, Setting, Giko, GikoDataModule;
  57
  58
  59 constructor TResPopupBrowser.Create(AOwner: TComponent);
  60 begin
  61         inherited Create(AOwner);
  62     TOleControl(Self).Parent := nil;
  63     Visible := False;
  64     FChild := nil;
  65     Title := '';
  66     RawDocument := '';
  67     FEvent := nil;
  68     ShowWindow(Self.Handle, SW_HIDE);
  69 end;
  70
  71 destructor TResPopupBrowser.Destroy;
  72 begin
  73     Self.Blur;
  74     Self.OnEnter := nil;
  75     Self.OnBeforeNavigate2 := nil;
  76     Self.OnStatusTextChange := nil;
  77     Self.OnNewWindow2 := nil;
  78     if (FChild <> nil) then begin
  79         FChild.Free;
  80         FChild := nil;
  81     end;
  82     if (FEvent <> nil) then begin
  83         FEvent.Free;
  84         FEvent := nil;
  85     end;
  86     FThread := nil;
  87         inherited Destroy;
  88 end;
  89
  90 procedure TResPopupBrowser.CreateParams(var Params: TCreateParams);
  91 begin
  92         inherited;
  93     Params.Style := Params.Style or WS_EX_TOOLWINDOW;
  94
  95 end;
  96 function TResPopupBrowser.CreateNewBrowser: TResPopupBrowser;
  97 begin
  98     if (Self.Visible) then begin
  99         if (FChild <> nil) then begin
 100             if (FChild.Visible) then begin
 101                 Result := FChild.CreateNewBrowser;
 102             end else begin
 103                 Result := FChild;
 104             end;
 105         end else begin
 106             FChild := TResPopupBrowser.Create(Self.Owner);
 107             FChild.ParentBrowser := Self;
 108             FChild.NavigateBlank(False);
 109             FChild.OnEnter := GikoForm.BrowserEnter;
 110             FChild.OnBeforeNavigate2 := GikoForm.BrowserBeforeNavigate2;
 111             FChild.OnStatusTextChange := GikoForm.BrowserStatusTextChange;
 112             FChild.OnNewWindow2 := GikoForm.BrowserNewWindow2;
 113             SetWindowPos(FChild.Handle, HWND_BOTTOM,
 114                 0, 0, 0 , 0,
 115                 SWP_NOSIZE or SWP_NOMOVE or  SWP_NOACTIVATE or SWP_HIDEWINDOW);
 116             Result := FChild;
 117         end;
 118     end else begin
 119         FParentBrowser := nil;
 120         Self.NavigateBlank(False);
 121         Self.OnEnter := GikoForm.BrowserEnter;
 122         Self.OnBeforeNavigate2 := GikoForm.BrowserBeforeNavigate2;
 123         Self.OnStatusTextChange := GikoForm.BrowserStatusTextChange;
 124         Self.OnNewWindow2 := GikoForm.BrowserNewWindow2;
 125         SetWindowPos(Self.Handle, HWND_BOTTOM,
 126             0, 0, 0 , 0,
 127             SWP_NOSIZE or SWP_NOMOVE or  SWP_NOACTIVATE or SWP_HIDEWINDOW);
 128         Result := Self;
 129     end;
 130 end;
 131 function TResPopupBrowser.CurrentBrowser: TResPopupBrowser;
 132 begin
 133     Result := Self.CreateNewBrowser;
 134     if (Result.ParentBrowser <> nil) then
 135         Result := Result.ParentBrowser;
 136 end;
 137 procedure TResPopupBrowser.NavigateBlank(Forced: Boolean);
 138 begin
 139     if (not Assigned(Self.Document)) or (Forced) then begin
 140         Self.Navigate('about:blank');
 141     end;
 142     while (Self.ReadyState <> READYSTATE_COMPLETE) and
 143             (Self.ReadyState <> READYSTATE_INTERACTIVE) do begin
 144         Sleep(1);
 145         Forms.Application.ProcessMessages;
 146     end;
 147 end;
 148 procedure TResPopupBrowser.TitlePopup;
 149 begin
 150     Write('', True);
 151 end;
 152 procedure TResPopupBrowser.Popup;
 153 begin
 154     Write(Self.RawDocument, false);
 155 end;
 156 procedure TResPopupBrowser.Write(ADocument: String; OnlyTitle: Boolean = False);
 157 var
 158         p: TPoint;
 159     doc: Variant;
 160         ARect, rect: TRect;
 161     FDispHtmlDocument: DispHTMLDocument;
 162 begin
 163     try
 164         // \83^\83X\83N\83o\81[\82©\82ç\8fÁ\82·
 165         SetWindowLongA(Self.Handle, GWL_EXSTYLE, WS_EX_TOOLWINDOW);
 166         GetCursorpos(p);
 167         // \82¢\82Á\82½\82ñ\8fk\8f¬
 168         SetWindowPos(Self.Handle, HWND_BOTTOM,
 169             p.X, p.Y, 50 , 50,
 170             SWP_NOACTIVATE or SWP_HIDEWINDOW);
 171         doc := Idispatch( olevariant(Self.ControlInterface).Document) as IHTMLDocument2;
 172         doc.open;
 173         doc.charset := 'Shift_JIS';
 174         doc.Write('<html><head>'#13#10 +
 175                 '<meta http-equiv="Content-type" content="text/html; charset=Shift_JIS">'#13#10 +
 176                 '<meta http-equiv="Pragma" content="no-cache">'#13#10 +
 177                 '<meta http-equiv="Cache-Control" content="no-cache">'#13#10 +
 178                 GetBodyStyle(OnlyTitle) + '</head><body>'
 179                 + GetTitle(OnlyTitle)
 180                 + ADocument + '<a name="bottom"></a></body></html>');
 181
 182         doc.Close;
 183
 184         ARect := CalcRect(Screen.WorkAreaRect, not OnlyTitle);
 185
 186         FDispHtmlDocument := Idispatch(OleVariant(Self.ControlInterface).Document) as DispHTMLDocument;
 187         FEvent := THTMLDocumentEventSink.Create(Self, FDispHtmlDocument, HTMLDocumentEvents2);
 188         FEvent.OnClick := ResPopupBrowserClick;
 189
 190         Self.Visible := True;
 191         SetWindowPos(Self.Handle, HWND_TOPMOST,
 192             ARect.Left, ARect.Top,
 193             (ARect.Right - ARect.Left) ,
 194             (ARect.Bottom - ARect.Top),
 195             SWP_NOACTIVATE or SWP_HIDEWINDOW);
 196         ShowWindow(Self.Handle, SW_SHOWNOACTIVATE);
 197     except
 198     end;
 199 end;
 200 function TResPopupBrowser.GetTitle(OnlyTitle: Boolean): string;
 201 begin
 202     Result := '<span id="hTitle">' + Title +'</span>';
 203     if OnlyTitle then Result := Result + '<BR>';
 204 end;
 205 function TResPopupBrowser.GetBodyStyle(OnlyTitle: Boolean = False): string;
 206 var
 207     i : Integer;
 208 begin
 209
 210     Result := '<style type="text/css">' +
 211             'dl { margin :0px; padding :0px}'#13#10 +
 212             'body { ' +
 213             'border-width: 1px; border-style: solid;white-space: nowrap; ' +
 214             'margin: 2px 4px 0px 0px; padding: 0px 4px 0px 0px; ';
 215
 216         if Length( GikoSys.Setting.HintFontName ) > 0 then
 217                 Result := Result + 'font-family:"' + GikoSys.Setting.HintFontName + '";';
 218         if GikoSys.Setting.HintFontSize <> 0 then
 219                 Result := Result + 'font-size:' + IntToStr( GikoSys.Setting.HintFontSize ) + 'pt;';
 220         if GikoSys.Setting.HintFontColor <> -1 then
 221                 Result := Result + 'color:#' + IntToHex( GikoSys.Setting.HintFontColor, 6 ) + ';';
 222         if GikoSys.Setting.HintBackColor <> -1 then begin
 223                 i := ColorToRGB( GikoSys.Setting.HintBackColor );
 224                 Result := Result + 'background-color:#' +
 225             IntToHex( (i shr 16) or (i and $ff00) or ((i and $ff) shl 16), 6 ) + ';';
 226     end;
 227     if OnlyTitle then
 228         Result := Result + 'overflow: hidden; ';
 229
 230     Result := Result + '}';
 231     if GikoSys.Setting.ResPopupHeaderBold then begin
 232         Result := Result + #13#10'span#hTitle{font-weight: bold; }';
 233     end;
 234     Result := Result + '</style>';
 235 end;
 236
 237 procedure TResPopupBrowser.Clear;
 238 begin
 239     ChildClear;
 240     if (Self.Visible) then begin
 241         Self.Title := '';
 242         Self.RawDocument := '';
 243         Self.FThread := nil;
 244         Self.FEvent.Free;
 245         Self.FEvent := nil;
 246         Self.Blur;
 247         ShowWindow(Self.Handle, SW_HIDE);
 248         Self.Visible := False;
 249     end;
 250 end;
 251 procedure TResPopupBrowser.ChildClear;
 252 begin
 253     if (FChild <> nil) then begin
 254         FChild.Clear;
 255     end;
 256 end;
 257
 258 function TResPopupBrowser.CalcRect(WorkArea: TRect; Scroll: Boolean): TRect;
 259 var
 260         p: TPoint;
 261     ele: IHTMLElement2;
 262     h, w, dx1, dx2, dy1, dy2: Integer;
 263     MaxWidth, MaxHeight: Integer;
 264 begin
 265         GetCursorpos(p);
 266     ele := ((Self.Document as IHTMLDocument2).body as IHTMLElement2);
 267     if Scroll then begin
 268         h := GetWindowHeight + 10;
 269         w := ele.scrollWidth + 25
 270     end else begin
 271         h := GetWindowHeight + 5;
 272         w := ele.scrollWidth + 10;
 273     end;
 274
 275     dx1 := 0; dx2 := 0;
 276     dy1 := 0; dy2 := 0;
 277
 278         Result := Rect(0, 0, w, h);
 279     case GikoSys.Setting.PopupPosition of
 280         gppRightTop:
 281         begin
 282             dx1 := 0; dx2 := -2;
 283             dy1 := -h; dy2 := -2;
 284         end;
 285         gppRight:
 286         begin
 287             dx1 := 0; dx2 := -2;
 288             dy1 := - (h div 2); dy2 := 0;
 289         end;
 290         gppRightBottom:
 291         begin
 292             dx1 := 0; dx2 := -2;
 293             dy1 := 0; dy2 := +2;
 294         end;
 295         gppTop:
 296         begin
 297             dx1 := - (w div 2); dx2 := 0;
 298             dy1 := -h; dy2 := -2;
 299         end;
 300         // \94p\8e~ gppCenter: OffsetRect(Result, p.x - (w div 2), p.y - (h div 2));
 301         gppBottom:
 302         begin
 303             dx1 := - (w div 2); dx2 := 0;
 304             dy1 := 0; dy2 := +2;
 305         end;
 306         gppLeftTop:
 307         begin
 308             dx1 := -w; dx2 := +2;
 309             dy1 := -h; dy2 := -2;
 310         end;
 311         gppLeft:
 312         begin
 313             dx1 := -w; dx2 := +2;
 314             dy1 := - (h div 2); dy2 := 0;
 315         end;
 316         gppLeftBottom:
 317         begin
 318             dx1 := -w; dx2 := +2;
 319             dy1 := 0; dy2 := +2;
 320         end;
 321     end;
 322     // \8f\89\8aú\88Ê\92u\82É\88Ú\93®
 323     OffsetRect(Result, p.x + dx1 + dx2, p.y + dy1 + dy2);
 324
 325     MaxWidth := WorkArea.Right - WorkArea.Left;
 326     MaxHeight := WorkArea.Bottom - WorkArea.Top;
 327     // \88È\89º\81A\8f\89\8aú\88Ê\92u\82É\96â\91è\82ª\82 \82é\82Æ\82«\82Ì\88Ú\93®
 328     if (Result.Left < WorkArea.Left) then begin
 329         // \8bt\83T\83C\83h\82É\97]\97T\82ª\82 \82ê\82Î\81A\8fo\97Í\88Ê\92u\82Ì\8d¶\89E\93]\8a·
 330         if (p.X * 2 < MaxWidth) then begin
 331             if ( (GikoSys.Setting.PopupPosition = gppTop) or
 332                 (GikoSys.Setting.PopupPosition = gppBottom)) then begin
 333                 OffsetRect(Result, -Result.Left, WorkArea.Left);
 334             end else begin
 335                 OffsetRect(Result, - (dx1 + 2 * dx2), 0);
 336             end;
 337         end else begin
 338             // \89æ\96Ê\92[\82Ü\82Å\89æ\96Ê\95\9d\82ð\8f¬\82³\82\82·\82é
 339             Result := Rect(0, Result.Top,
 340                 Result.Right, Result.Bottom);
 341         end;
 342     end;
 343     if (Result.Top < WorkArea.Top) then begin
 344         // \92ê\91¤\82É\97]\97T\82ª\82 \82ê\82Î\81A\8fo\97Í\88Ê\92u\82Ì\8fã\89º\93]\8a·
 345         if (p.Y * 2 < MaxHeight) then begin
 346             OffsetRect(Result, 0, - (dy1 + 2 * dy2));
 347         end else begin
 348             // \89æ\96Ê\92[\82Ü\82Å\89æ\96Ê\8d\82\82ð\8f¬\82³\82\82·\82é
 349             Result := Rect(Result.Left, WorkArea.Top,
 350                 Result.Right, Result.Bottom);
 351         end;
 352     end;
 353     if (Result.Right > WorkArea.Right) then begin
 354         // \8bt\83T\83C\83h\82É\97]\97T\82ª\82 \82ê\82Î\81A\8fo\97Í\88Ê\92u\82Ì\8d¶\89E\93]\8a·
 355         if (p.X * 2 > WorkArea.Right) then begin
 356             if( (GikoSys.Setting.PopupPosition = gppTop) or
 357                 (GikoSys.Setting.PopupPosition = gppBottom)) then begin
 358                 OffsetRect(Result, -(Result.Right - WorkArea.Right), 0);
 359             end else begin
 360                 OffsetRect(Result, -w - (dx1 + 2 * dx2), 0);
 361             end;
 362             // \8bt\83T\83C\83h\82É\83I\81[\83o\81[\82µ\82½\8fê\8d\87\82Í\89æ\96Ê\92[\82Ü\82Å\95\9d\82ð\8f¬\82³\82\82·\82é
 363             if (Result.Left < WorkArea.Left) then begin
 364                 Result := Rect(WorkArea.Left, Result.Top,
 365                     Result.Right, Result.Bottom);
 366             end;
 367         end else begin
 368             // \89æ\96Ê\92[\82Ü\82Å\89æ\96Ê\95\9d\82ð\8f¬\82³\82\82·\82é
 369             Result := Rect(Result.Left, Result.Top,
 370                 WorkArea.Right, Result.Bottom);
 371         end;
 372     end;
 373     if (Result.Bottom > WorkArea.Bottom) then begin
 374         // \8fã\91¤\82É\97]\97T\82ª\82 \82ê\82Î\81A\8fo\97Í\88Ê\92u\82Ì\8fã\89º\93]\8a·
 375         if (p.Y * 2 > WorkArea.Bottom) then begin
 376             OffsetRect(Result, 0, -h - (dy1 + 2 * dy2));
 377             // \8fã\82É\8aÑ\82¢\82½\8fê\8d\87\82Í\81A
 378             if (Result.Top < WorkArea.Top) then begin
 379                 Result := Rect(Result.Left, WorkArea.Top,
 380                     Result.Right, Result.Bottom);
 381             end;
 382         end else begin
 383             // \89æ\96Ê\92[\82Ü\82Å\89æ\96Ê\8d\82\82ð\8f¬\82³\82\82·\82é
 384             Result := Rect(Result.Left, Result.Top,
 385                 Result.Right, WorkArea.Bottom);
 386         end;
 387     end;
 388 end;
 389 function TResPopupBrowser.GetWindowHeight : Integer;
 390 var
 391         top: Integer;
 392         item: OleVariant;
 393 begin
 394     Result := 0;
 395     //\83u\83\89\83E\83U\82ª\83f\81[\83^\82Ì\93Ç\82Ý\8d\9e\82Ý\92\86\82Ì\8e\9e\82Í\93Ç\82Ý\8d\9e\82Ý\82ð\91Ò\82Â
 396     while (Self.ReadyState <> READYSTATE_COMPLETE) and
 397                 (Self.ReadyState <> READYSTATE_INTERACTIVE) do begin
 398         Sleep(1);
 399         Forms.Application.ProcessMessages;
 400     end;
 401
 402     try
 403         top := 0;
 404         item := OleVariant( Self.Document as IHTMLDocument2)
 405                 .anchors.item(OleVariant('bottom'));
 406         item.focus();
 407         repeat
 408             top := top + item.offsetTop;
 409             item := item.offsetParent;
 410         until AnsiCompareText(item.tagName, 'body' ) = 0;
 411         Result := top;
 412     except
 413     end;
 414 end;
 415 function TResPopupBrowser.ResPopupBrowserClick(Sender: TObject): WordBool;
 416 begin
 417     // \83M\83R\83i\83r\82Ì\83t\83H\81[\83J\83X\82ð\92D\82Á\82Ä\82é\82Ì\82Å\83t\83H\81[\83\80\82É\96³\97\9d\82â\82è\95Ô\82·
 418     Blur;
 419     Result := True;
 420 end;
 421 function TResPopupBrowser.GetThread: TThreadItem;
 422 begin
 423     Result := nil;
 424     if (FThread <> nil) then begin
 425         try
 426             // \96³\8cø\82È\83|\83C\83\93\83^\8c\9f\8d¸
 427             if (FThread.ParentBoard <> nil) then begin
 428                 Result := FThread
 429             end;
 430         except
 431             //\96³\8cø\82È\83|\83C\83\93\83^\82¾\82Á\82½
 432             Result := nil;
 433         end;
 434     end;
 435 end;
 436 procedure TResPopupBrowser.Blur;
 437 var
 438     FOleInPlaceActiveObject: IOleInPlaceActiveObject;
 439 begin
 440     FOleInPlaceActiveObject := Self.ControlInterface as IOleInPlaceActiveObject;
 441     FOleInPlaceActiveObject.OnFrameWindowActivate(False);
 442 end;
 443
 444 initialization
 445     OleInitialize(nil);
 446
 447 finalization
 448     OleUninitialize;
 449
 450 end.