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