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 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     if (GetAsyncKeyState(VK_SHIFT) = Smallint($8001)) then begin
 155         // \83V\83t\83g\89\9f\82µ\82Ä\82é\8fê\8d\87\82Í\82»\82Ì\82Ü\82Ü\8fo\82·
 156         Write(Self.RawDocument, false);
 157     end else begin
 158         // é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é
 159         Write(
 160             MojuUtils.CustomStringReplace(
 161                 Self.RawDocument, '  ', '&nbsp;&nbsp;'),
 162             false);
 163     end;
 164 end;
 165 procedure TResPopupBrowser.Write(ADocument: String; OnlyTitle: Boolean = False);
 166 var
 167         p: TPoint;
 168     doc: Variant;
 169         ARect: TRect;
 170     FDispHtmlDocument: DispHTMLDocument;
 171 begin
 172     try
 173         // \83^\83X\83N\83o\81[\82©\82ç\8fÁ\82·
 174         SetWindowLongA(Self.Handle, GWL_EXSTYLE, WS_EX_TOOLWINDOW);
 175         GetCursorpos(p);
 176         // \82¢\82Á\82½\82ñ\8fk\8f¬
 177         SetWindowPos(Self.Handle, HWND_BOTTOM,
 178             p.X, p.Y, 50 , 50,
 179             SWP_NOACTIVATE or SWP_HIDEWINDOW);
 180         doc := Idispatch( olevariant(Self.ControlInterface).Document) as IHTMLDocument2;
 181         doc.open;
 182         doc.charset := 'Shift_JIS';
 183         doc.Write('<html><head>'#13#10 +
 184                 '<meta http-equiv="Content-type" content="text/html; charset=Shift_JIS">'#13#10 +
 185                 '<meta http-equiv="Pragma" content="no-cache">'#13#10 +
 186                 '<meta http-equiv="Cache-Control" content="no-cache">'#13#10 +
 187                 GetBodyStyle(OnlyTitle) + '</head><body>'
 188                 + GetTitle(OnlyTitle)
 189                 + ADocument + '<a name="bottom"></a></body></html>');
 190
 191         doc.Close;
 192         // \83}\83\8b\83`\83\82\83j\83^\91Î\89\9e
 193         ARect := CalcRect(Screen.MonitorFromPoint(p).WorkareaRect,
 194                         not OnlyTitle);
 195
 196         FDispHtmlDocument := Idispatch(OleVariant(Self.ControlInterface).Document) as DispHTMLDocument;
 197         FEvent := THTMLDocumentEventSink.Create(Self, FDispHtmlDocument, HTMLDocumentEvents2);
 198         FEvent.OnClick := ResPopupBrowserClick;
 199         FEvent.OnDoubleClick := ResPopupBrowserDbClick;
 200         Self.Visible := True;
 201         SetWindowPos(Self.Handle, HWND_TOPMOST,
 202             ARect.Left, ARect.Top,
 203             (ARect.Right - ARect.Left) ,
 204             (ARect.Bottom - ARect.Top),
 205             SWP_NOACTIVATE or SWP_HIDEWINDOW);
 206         ShowWindow(Self.Handle, SW_SHOWNOACTIVATE);
 207     except
 208     end;
 209 end;
 210 function TResPopupBrowser.GetTitle(OnlyTitle: Boolean): string;
 211 begin
 212     Result := '<span id="hTitle">' + Title +'</span>';
 213     if OnlyTitle then Result := Result + '<BR>';
 214 end;
 215 function TResPopupBrowser.GetBodyStyle(OnlyTitle: Boolean = False): string;
 216 var
 217     i : Integer;
 218 begin
 219
 220     Result := '<style type="text/css">' +
 221             'dl { margin :0px; padding :0px}'#13#10 +
 222             'body { ' +
 223             'border-width: 1px; border-style: solid;white-space: nowrap; ' +
 224             'margin: 2px 4px 0px 0px; padding: 0px 4px 0px 0px; ';
 225
 226         if Length( GikoSys.Setting.HintFontName ) > 0 then
 227                 Result := Result + 'font-family:"' + GikoSys.Setting.HintFontName + '";';
 228         if GikoSys.Setting.HintFontSize <> 0 then
 229                 Result := Result + 'font-size:' + IntToStr( GikoSys.Setting.HintFontSize ) + 'pt;';
 230         if GikoSys.Setting.HintFontColor <> -1 then
 231                 Result := Result + 'color:#' + IntToHex( GikoSys.Setting.HintFontColor, 6 ) + ';';
 232         if GikoSys.Setting.HintBackColor <> -1 then begin
 233                 i := ColorToRGB( GikoSys.Setting.HintBackColor );
 234                 Result := Result + 'background-color:#' +
 235             IntToHex( (i shr 16) or (i and $ff00) or ((i and $ff) shl 16), 6 ) + ';';
 236     end;
 237     if OnlyTitle then
 238         Result := Result + 'overflow: hidden; ';
 239
 240     Result := Result + '}';
 241     if GikoSys.Setting.ResPopupHeaderBold then begin
 242         Result := Result + #13#10'span#hTitle{font-weight: bold; }';
 243     end;
 244     Result := Result + '</style>';
 245 end;
 246
 247 procedure TResPopupBrowser.Clear;
 248 begin
 249     ChildClear;
 250     if (Self.Visible) then begin
 251         Self.Title := '';
 252         Self.RawDocument := '';
 253         Self.FThread := nil;
 254         Self.FEvent.Free;
 255         Self.FEvent := nil;
 256         Self.Blur;
 257         ShowWindow(Self.Handle, SW_HIDE);
 258         Self.Visible := False;
 259     end;
 260 end;
 261 procedure TResPopupBrowser.ChildClear;
 262 begin
 263     if (FChild <> nil) then begin
 264         FChild.Clear;
 265     end;
 266 end;
 267
 268 function TResPopupBrowser.CalcRect(WorkArea: TRect; Scroll: Boolean): TRect;
 269 var
 270         p: TPoint;
 271     ele: IHTMLElement2;
 272     h, w, dx1, dx2, dy1, dy2: Integer;
 273     MaxWidth, MaxHeight: Integer;
 274     DIV_X, DIV_Y: Integer;
 275 begin
 276         GetCursorpos(p);
 277     ele := ((Self.Document as IHTMLDocument2).body as IHTMLElement2);
 278     if Scroll then begin
 279         h := GetWindowHeight + 10;
 280         w := ele.scrollWidth + 25
 281     end else begin
 282         h := GetWindowHeight + 5;
 283         w := ele.scrollWidth + 10;
 284     end;
 285
 286     DIV_X := GikoSys.Setting.RespopupDeltaX;
 287     DIV_Y := GikoSys.Setting.RespopupDeltaY;
 288
 289     dx1 := 0; dx2 := 0;
 290     dy1 := 0; dy2 := 0;
 291
 292         Result := Rect(0, 0, w, h);
 293     case GikoSys.Setting.PopupPosition of
 294         gppRightTop:
 295         begin
 296             dx1 := 0; dx2 := + DIV_X;
 297             dy1 := -h; dy2 := - DIV_Y;
 298         end;
 299         gppRight:
 300         begin
 301             dx1 := 0; dx2 := + DIV_X;
 302             dy1 := - (h div 2); dy2 := 0;
 303         end;
 304         gppRightBottom:
 305         begin
 306             dx1 := 0; dx2 := + DIV_X;
 307             dy1 := 0; dy2 := + DIV_Y;
 308         end;
 309         gppTop:
 310         begin
 311             dx1 := - (w div 2); dx2 := 0;
 312             dy1 := -h; dy2 := - DIV_Y;
 313         end;
 314         // \94p\8e~ gppCenter: OffsetRect(Result, p.x - (w div 2), p.y - (h div 2));
 315         gppBottom:
 316         begin
 317             dx1 := - (w div 2); dx2 := 0;
 318             dy1 := 0; dy2 := + DIV_Y;
 319         end;
 320         gppLeftTop:
 321         begin
 322             dx1 := -w; dx2 := - DIV_X ;
 323             dy1 := -h; dy2 := - DIV_Y;
 324         end;
 325         gppLeft:
 326         begin
 327             dx1 := -w; dx2 := - DIV_X;
 328             dy1 := - (h div 2); dy2 := 0;
 329         end;
 330         gppLeftBottom:
 331         begin
 332             dx1 := -w; dx2 := - DIV_X;
 333             dy1 := 0; dy2 := + DIV_Y;
 334         end;
 335     end;
 336     // \8f\89\8aú\88Ê\92u\82É\88Ú\93®
 337     OffsetRect(Result, p.x + dx1 + dx2, p.y + dy1 + dy2);
 338
 339     MaxWidth := WorkArea.Right - WorkArea.Left;
 340     MaxHeight := WorkArea.Bottom - WorkArea.Top;
 341     // \88È\89º\81A\8f\89\8aú\88Ê\92u\82É\96â\91è\82ª\82 \82é\82Æ\82«\82Ì\88Ú\93®
 342     if (Result.Left < WorkArea.Left) then begin
 343         // \8bt\83T\83C\83h\82É\97]\97T\82ª\82 \82ê\82Î\81A\8fo\97Í\88Ê\92u\82Ì\8d¶\89E\93]\8a·
 344         if ((p.X - WorkArea.Left) * 2 < MaxWidth) then begin
 345             if ( (GikoSys.Setting.PopupPosition = gppTop) or
 346                 (GikoSys.Setting.PopupPosition = gppBottom)) then begin
 347                 OffsetRect(Result, -Result.Left, 0);
 348             end else begin
 349                 OffsetRect(Result, - (dx1 + 2 * dx2), 0);
 350             end;
 351         end else begin
 352             // \89æ\96Ê\92[\82Ü\82Å\89æ\96Ê\95\9d\82ð\8f¬\82³\82\82·\82é
 353             Result := Rect(WorkArea.Left, Result.Top,
 354                 Result.Right, Result.Bottom);
 355         end;
 356     end;
 357     if (Result.Top < WorkArea.Top) then begin
 358         // \92ê\91¤\82É\97]\97T\82ª\82 \82ê\82Î\81A\8fo\97Í\88Ê\92u\82Ì\8fã\89º\93]\8a·
 359         if ((p.Y - WorkArea.Top) * 2 < MaxHeight) then begin
 360             OffsetRect(Result, 0, - (dy1 + 2 * dy2));
 361         end else begin
 362             // \89æ\96Ê\92[\82Ü\82Å\89æ\96Ê\8d\82\82ð\8f¬\82³\82\82·\82é
 363             Result := Rect(Result.Left, WorkArea.Top,
 364                 Result.Right, Result.Bottom);
 365         end;
 366     end;
 367     if (Result.Right > WorkArea.Right) then begin
 368         // \8bt\83T\83C\83h\82É\97]\97T\82ª\82 \82ê\82Î\81A\8fo\97Í\88Ê\92u\82Ì\8d¶\89E\93]\8a·
 369         if ((p.X - WorkArea.Left) * 2 > WorkArea.Right) then begin
 370             if( (GikoSys.Setting.PopupPosition = gppTop) or
 371                 (GikoSys.Setting.PopupPosition = gppBottom)) then begin
 372                 OffsetRect(Result, -(Result.Right - WorkArea.Right), 0);
 373             end else begin
 374                 OffsetRect(Result, -w - (dx1 + 2 * dx2), 0);
 375             end;
 376             // \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é
 377             if (Result.Left < WorkArea.Left) then begin
 378                 Result := Rect(WorkArea.Left, Result.Top,
 379                     Result.Right, Result.Bottom);
 380             end;
 381         end else begin
 382             // \89æ\96Ê\92[\82Ü\82Å\89æ\96Ê\95\9d\82ð\8f¬\82³\82\82·\82é
 383             Result := Rect(Result.Left, Result.Top,
 384                 WorkArea.Right, Result.Bottom);
 385         end;
 386     end;
 387     if (Result.Bottom > WorkArea.Bottom) then begin
 388         // \8fã\91¤\82É\97]\97T\82ª\82 \82ê\82Î\81A\8fo\97Í\88Ê\92u\82Ì\8fã\89º\93]\8a·
 389         if ((p.Y - WorkArea.Top) * 2 > WorkArea.Bottom) then begin
 390             OffsetRect(Result, 0, -h - (dy1 + 2 * dy2));
 391             // \8fã\82É\8aÑ\82¢\82½\8fê\8d\87\82Í\81A
 392             if (Result.Top < WorkArea.Top) then begin
 393                 Result := Rect(Result.Left, WorkArea.Top,
 394                     Result.Right, Result.Bottom);
 395             end;
 396         end else begin
 397             // \89æ\96Ê\92[\82Ü\82Å\89æ\96Ê\8d\82\82ð\8f¬\82³\82\82·\82é
 398             Result := Rect(Result.Left, Result.Top,
 399                 Result.Right, WorkArea.Bottom);
 400         end;
 401     end;
 402 end;
 403 function TResPopupBrowser.GetWindowHeight : Integer;
 404 var
 405         top: Integer;
 406         item: OleVariant;
 407 begin
 408     Result := 0;
 409     //\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Â
 410     while (Self.ReadyState <> READYSTATE_COMPLETE) and
 411                 (Self.ReadyState <> READYSTATE_INTERACTIVE) do begin
 412         Sleep(1);
 413         Forms.Application.ProcessMessages;
 414     end;
 415
 416     try
 417         top := 0;
 418         item := OleVariant( Self.Document as IHTMLDocument2)
 419                 .anchors.item(OleVariant('bottom'));
 420         item.focus();
 421         repeat
 422             top := top + item.offsetTop;
 423             item := item.offsetParent;
 424         until AnsiCompareText(item.tagName, 'body' ) = 0;
 425         Result := top;
 426     except
 427     end;
 428 end;
 429 function TResPopupBrowser.ResPopupBrowserClick(Sender: TObject): WordBool;
 430 begin
 431     // \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·
 432     Blur;
 433     Result := True;
 434 end;
 435 function TResPopupBrowser.GetThread: TThreadItem;
 436 begin
 437     Result := nil;
 438     if (FThread <> nil) then begin
 439         try
 440             // \96³\8cø\82È\83|\83C\83\93\83^\8c\9f\8d¸
 441             if (FThread.ParentBoard <> nil) then begin
 442                 Result := FThread
 443             end;
 444         except
 445             //\96³\8cø\82È\83|\83C\83\93\83^\82¾\82Á\82½
 446             Result := nil;
 447         end;
 448     end;
 449 end;
 450 procedure TResPopupBrowser.Blur;
 451 var
 452     FOleInPlaceActiveObject: IOleInPlaceActiveObject;
 453 begin
 454     FOleInPlaceActiveObject := Self.ControlInterface as IOleInPlaceActiveObject;
 455     FOleInPlaceActiveObject.OnFrameWindowActivate(False);
 456 end;
 457 function TResPopupBrowser.ResPopupBrowserDbClick(Sender: TObject): WordBool;
 458 begin
 459     // \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·
 460     Blur;
 461     // \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¤
 462     PostMessage( GikoForm.Handle , USER_RESPOPUPCLEAR, Integer( Self ), 0 );
 463     Result := True;
 464 end;
 465 initialization
 466     OleInitialize(nil);
 467
 468 finalization
 469     OleUninitialize;
 470
 471 end.