home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / UCLP13.ZIP / CLIPOBJ.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1992-09-20  |  23.1 KB  |  957 lines
  1. UNIT ClipObj;
  2. Interface
  3. USES WinTypes, WinProcs, WObjects, Strings,Win31,WinDOS;
  4. {$D ClipObj Copyright (c) 1992 Doug Overmyer}
  5. const
  6.     st_OK = 1;
  7.   st_ClipFailure = 2;
  8.   st_NoMem = 3;
  9.   cc_CopyAll = 99;
  10. type
  11.  
  12. PClipItem = ^TClipItem;
  13. TClipItem = object(TObject)
  14.     CHandle:THandle;
  15.   CName:PChar;
  16.   CFormat:Word;
  17.   constructor Init(NewCHandle:THandle;NewCName:PChar;NewCFormat:Word);
  18.   destructor Done;virtual;
  19. end;
  20.  
  21. PClipObj = ^TClipObj;
  22. TClipObj = OBJECT(TObject)
  23.     constructor Init(hW:HWnd;var Stat:Word;SRect:TRect);
  24.   procedure GetClip(hW : hWnd; var Stat : Word);
  25.   destructor Done; Virtual;
  26.   procedure CopyClip(hW : hWnd;Clip:PClipItem);
  27.   procedure CopyClipS(hW : hWnd;I:PMultiSelRec);
  28.   procedure RenderSelf(DC:hDC;hWin:HWnd;IsZ:Bool);
  29.   procedure RenderSelfZ(DC:hDC;hWin:HWnd;IsZ:Bool);
  30.   procedure RedrawSelf(DC:hDC;hWin:HWnd;IsZ:Bool);
  31.   function GetStatus: Word;
  32.     function GetPal: hPalette;
  33.     function GetDIB: THandle;
  34.   function GetPICT: THandle;
  35.   function GetClips:PCollection;
  36.   procedure GetInfo(Info:PChar;Len:Integer);
  37.   procedure SetIsPrefText(Choice:Bool);
  38.   procedure ToggleIsPrefText;
  39.   procedure GetFormats(Buf:PChar);
  40.   procedure GetClipFormatName(nf:Integer; nN:PChar;Count:Word);
  41. Private
  42.   Clips     : PCollection;
  43.     name      : ARRAY[0..80] OF Char;
  44.   hDIB          : THandle;
  45.   hPal      : hPalette;
  46.   hPICT     : THandle;
  47.   hText     :THandle;
  48.   hNative   :THandle;
  49.   hBMP      :HBitmap;
  50.   hDisp     : HBitmap;
  51.   hDispZ    : hBitmap;
  52.   Status    :Word;
  53.   IsPrefText:Bool;
  54.   SR        : TRect;  {Sizing Rectangle}
  55. end;
  56. {****************************  Implementation  **********************}
  57. Implementation
  58. type
  59.   LongType = record
  60.     CASE Word OF
  61.       0: (Ptr: Pointer);
  62.       1: (Long: Longint);
  63.       2: (Lo: Word;
  64.        Hi: Word);
  65.   end;
  66. procedure AHIncr; far; external 'KERNEL' index 114;
  67. function _hRead(hFile:Integer;Buffer:PChar;dwBytes:LongInt):LongInt;far; external 'KERNEL';
  68. function _hWrite(hFile:Integer;Buffer:PChar;dwBytes:LongInt):LongInt;far; external 'KERNEL';
  69. {************************* Functions  *******************************}
  70. function LongMin(A, B: LongInt): LongInt;
  71. begin
  72.   if A < B then LongMin := A else LongMin := B;
  73. end;
  74.  
  75. function LongMax(A, B: LongInt): LongInt;
  76. begin
  77.   if A > B then LongMax := A else LongMax := B;
  78. end;
  79.  
  80. function DIBSize(Width,Height:LongInt;Res:Integer):LongInt;
  81. begin
  82.     DIBSize := (((LongInt(Width)*RES+31) div 32) * 4) * Height;
  83. end;
  84.  
  85. function CopyGHND(hGM1:THandle):THandle;
  86. var
  87.   Size:LongInt;
  88.   hGM2:THandle;
  89.   pGM2,pGM1:Pointer;
  90. begin
  91.     CopyGHND := 0;
  92.   Size :=GlobalSize(hGM1);
  93.   pGM1 := GlobalLock(hGM1);
  94.   IF pGM1 = NIL then Exit;
  95.   hGM2 :=GlobalAlloc(GHND,Size);
  96.   pGM2 := GlobalLock(hGM2);
  97.   if pGM2 <> nil then
  98.       hmemCpy(pGM2,pGM1,Size);
  99.   GlobalUnlock(hGM2);
  100.   CopyGHND := hGM2;
  101. end;
  102.  
  103. function GetDIBColorCnt(bi:PBitmapInfo):Word;
  104. begin
  105.   GetDIBColorCnt := bi^.bmiHeader.biClrUsed;
  106.   if bi^.bmiHeader.biClrUsed = 0 then
  107.         if bi^.bmiHeader.biBitCount <> 24 then
  108.             GetDIBColorCnt:= 1 shl bi^.bmiHeader.biBitCount;
  109. end;
  110.  
  111. function GetDIBBits(pDIB:Pointer):Pointer;
  112. var
  113.     bi:PBitmapInfo;
  114.     cPalColors:Word;
  115. begin
  116.     GetDIBBits := NIL;
  117.   bi := pDIB;
  118.   cPalColors := GetDIBColorCnt(bi);
  119.   GetDIBBits := Ptr(Seg(bi^),
  120.     ofs(bi^)+sizeof(TBitmapInfoHeader)+cPalColors*sizeof(TRGBQuad));
  121. end;
  122.  
  123. function GetDIBPal(bi:PBitmapInfo):HPalette;
  124. var
  125.     PalSize,N,cPalColors: Word;
  126.     pal : PLogPalette;
  127. begin
  128.     GetDIBPal := 0;
  129.     cPalColors :=GetDIBColorCnt(bi);
  130.     IF cPalColors = 0 then Exit;
  131.   PalSize := SizeOf(TLogPalette)+Pred(cPalColors)*sizeof(TPaletteEntry);
  132.   GetMem(pal, PalSize);
  133.   pal^.palVersion := $300;
  134.   pal^.palNumEntries := cPalColors;
  135.   FillChar(pal^.palPalEntry, cPalColors *sizeof(TPaletteEntry), 0);
  136.   FOR N := 0 TO pred(cPalColors) DO
  137.      WITH pal^.palPalEntry[N], bi^.bmiColors[N] DO
  138.        begin
  139.        peRed   := rgbRed;
  140.        peGreen := rgbGreen;
  141.        peBlue  := rgbBlue
  142.        end;
  143.   GetDibPal := CreatePalette(pal^);
  144.   FreeMem(pal, PalSize);
  145. end;
  146.  
  147. function CopyPal(hP:hPalette):hPalette;
  148. var
  149.  Pal : PLogPalette;
  150.  cPalColors:Word;
  151. begin
  152.   CopyPal := 0;
  153.   if hP = 0 then Exit;
  154.   GetObject(hP,2,@cPalColors);
  155.   GetMem(Pal, sizeof(TLogPalette) + pred(cPalColors)*sizeof(TPaletteEntry));
  156.   pal^.palVersion := $300;
  157.   pal^.palNumEntries := cPalColors;
  158.   GetPaletteEntries(hP, 0, cPalColors,pal^.palPalEntry);
  159.   CopyPal := CreatePalette(pal^);
  160.   FreeMem(Pal, sizeof(TLogPalette)+pred(cPalColors)*sizeof(TPaletteEntry));
  161. end;
  162.  
  163. function CopyBMP(hB1:HBitmap;DC:hDC): hBitmap;
  164. var
  165.     cBits,ret:LongInt;
  166.   hBits:THandle;
  167.   pBits:Pointer;
  168.   tb:TBitmap;
  169.   hB2:HBitmap;
  170. begin
  171.     CopyBMP := 0;
  172.   if hB1 = 0 then Exit;
  173.   GetObject(hB1,sizeof(TBitmap),@tb);
  174.   cBits := LongInt(tb.bmWidthBytes)*tb.bmHeight *tb.bmPlanes;
  175.   hbits :=GlobalAlloc(GHND,cBits);
  176.   pBits := GlobalLock(hBits);
  177.   ret :=GetBitmapBits(hB1,cBits,pBits);
  178.   hB2 := CreateCompatibleBitmap(DC,tb.bmWidth,tb.bmHeight);
  179.   ret :=SetBitmapBits(hB2,cBits,pBits);
  180.   GlobalUnlock(hBits);
  181.   GlobalFree(hBits);
  182.   CopyBMP := hB2;
  183. end;
  184.  
  185. function ScaleBMP(hB1:HBitmap;hP:HPalette;DC:hDC;SR:TRect): hBitmap;
  186. var
  187.     cBits,ret:LongInt;
  188.   Bits:THandle;
  189.   pBits:Pointer;
  190.   tb:TBitmap;
  191.   hB2,oB1,oB2:HBitmap;
  192.   RC:TRect;
  193.   MaxXY,X,Y:LongInt;
  194.   MemDC1,MemDC2:HDC;
  195.   oP:HPalette;
  196. begin
  197.     ScaleBMP := 0;
  198.   if hB1 = 0 then Exit;
  199.   GetObject(hB1,sizeof(TBitmap),@tb);
  200.   X:=tb.bmWidth;Y:=tb.bmHeight;
  201.   MaxXY:=LongMax(X,Y);
  202.   SetRect(RC,0,0,SR.Right*X div MaxXY,
  203.         SR.Bottom*Y div MaxXY);
  204.   MemDC1:= CreateCompatibleDC(DC);
  205.   MemDC2:= CreateCompatibleDC(DC);
  206.   hB2:=CreateCompatibleBitmap(DC,RC.Right,RC.Bottom);
  207.   oB2:=SelectObject(MemDC2,hB2);
  208.   oB1:=SelectObject(MemDC1,hB1);
  209.   if hP > 0 then oP := SelectPalette(memDC2,hP,False); 
  210.   RealizePalette(memDC2);           
  211.   SetStretchBltMode(memDC2,stretch_deletescans);
  212.   StretchBlt(memDC2,0,0,RC.Right,RC.Bottom,memDC1,0,0,
  213.         X,Y,SRCCopy);
  214.   if hP > 0 then SelectPalette(memDC2,oP,False);  
  215.   SelectObject(memDC1,oB1);
  216.   SelectObject(memDC2,oB2);
  217.   DeleteDC(memDC1);
  218.   DeleteDC(memDC2);
  219.   ScaleBMP :=hB2;
  220. end;
  221.  
  222. function BMPtoDIB(hB:HBitmap;hP:HPalette;DC:HDC):THandle;
  223. var
  224.     hbi:THandle;
  225.     bi:PBitmapInfo;
  226.   tb:TBitmap;
  227.   pBits:Pointer;
  228.   hBits:THandle;
  229.   cSize:LongInt;
  230.   oP:HPalette;
  231.   bRES,cColor:Integer;
  232. begin
  233.     if hP <> 0 then
  234.       begin
  235.     oP :=SelectPalette(DC,hP,false);
  236.     RealizePalette(DC);
  237.     end
  238.     else op := 0;
  239.     GetObject(hB,sizeof(TBitmap),@tb);
  240.   bRES := tb.bmPlanes*tb.bmBitsPixel;
  241.   cColor := 0;
  242.   if bRES < 24 then cColor := 1 shl bRES;
  243.   cSize :=DIBSize(tb.bmWidth,tb.bmHeight,bRes);
  244.   hbi :=GlobalAlloc(GHND,sizeof(TBitmapInfoHeader)+cColor*sizeof(TRGBQuad)+cSize);
  245.   bi := GlobalLock(hbi);
  246.   with bi^.bmiHeader do
  247.       begin
  248.         biSize:= sizeof(TBitmapInfoHeader);
  249.       biWidth :=tb.bmWidth;
  250.       biHeight := tb.bmHeight;
  251.     biPlanes := 1;
  252.     biBitCount := bRES;
  253.     biCompression := BI_RGB;
  254.     end;
  255.   pBits:=Ptr(Seg(bi^),
  256.         ofs(bi^)+sizeof(TBitmapInfoHeader)+cColor*sizeof(TRGBQuad));
  257.   GetDIBits(DC,hB,0,tb.bmHeight,pBits,bi^,DIB_RGB_Colors);
  258.   GlobalUnlock(hbi);
  259.   BMPtoDIB := hbi;
  260.   if hP > 0 then selectPalette(DC,oP,false);
  261. end;
  262.  
  263. function DIBtoBMP(H:THandle;hW:HWnd;DC1:hDC):hBitmap;
  264. var
  265.     bi:PBitmapInfo;
  266.   hP,oP:HPalette;
  267.   bits:Pointer;
  268.   DC2:hDC;
  269. begin
  270.     DIBtoBMP := 0;
  271.   if H = 0 then Exit;
  272.   bi := GlobalLock(H);
  273.   if bi = nil then Exit;
  274.   hP := GetDibPal(bi);
  275.   if DC1 = 0 then
  276.       DC2 := GetDC(hW)
  277.     else DC2 := DC1;
  278.   if hP > 0 then oP := SelectPalette(DC2,hP,False);
  279.   RealizePalette(DC2);
  280.   bits := GetDIBBits(bi);
  281.   DIBtoBMP:= CreateDIBitmap(DC2, bi^.bmiHeader,
  282.         cbm_Init, bits, bi^, dib_RGB_Colors);
  283.   GlobalUnlock(H);
  284.   if hP > 0 then SelectPalette(DC2,oP,False);
  285.   DeleteObject(hP);
  286.   if DC1 = 0 then
  287.       ReleaseDC(hW,DC2);
  288. end;
  289.  
  290. function DIBtoBMPScaled(H:THandle;hW:HWnd;SR:TRect):hBitmap;
  291. var
  292.     bi:PBitmapInfo;
  293.   hP,oP:HPalette;
  294.   bits:Pointer;
  295.   DC:hDC;
  296.   hB,oB:HBitmap;
  297.   RC:TRect;
  298.   MaxXY,X,Y:Word;
  299.   MemDC:HDC;
  300. begin
  301.     hP:= 0;
  302.     DIBtoBMPScaled := 0;
  303.   if H = 0 then Exit;
  304.   bi := GlobalLock(H);
  305.   if bi = nil then Exit;
  306.   X:=bi^.bmiheader.biWidth;Y:=bi^.bmiheader.biHeight;
  307.     MaxXY:=LongMax(X,Y);
  308.   SetRect(RC,0,0,SR.Right * X div MaxXY,SR.Bottom * Y div MaxXY);
  309.   hP := GetDibPal(bi); 
  310.   DC := GetDC(hW);
  311.   MemDC:= CreateCompatibleDC(DC);
  312.   hB:=CreateCompatibleBitmap(DC,RC.Right,RC.Bottom);
  313.   oB:=SelectObject(MemDC,hB);
  314.   if hP > 0 then oP := SelectPalette(memDC,hP,False); 
  315.   RealizePalette(memDC);             
  316.   bits := GetDIBBits(bi);
  317.   SetStretchBltMode(memDC,stretch_deletescans);
  318.   StretchDIBits(memDC,0,0,RC.Right,RC.Bottom,0,0,
  319.         X,Y,bits, bi^, dib_RGB_Colors,SRCCopy);
  320.   GlobalUnlock(H);
  321.   if hP > 0 then SelectPalette(memDC,oP,False);
  322.   if hP > 0 then DeleteObject(hP);
  323.   SelectObject(memDC,oB);
  324.   DeleteDC(memDC);
  325.   DIBtoBMPScaled :=hB;
  326.   ReleaseDC(hW,DC);
  327. end;
  328.  
  329. function CopyPICT(H:THandle):THandle;
  330. var
  331.     mi:PMetaFilePict;
  332.   hMFP:THandle;
  333.   pMFP:PMetaFilePict;
  334. begin
  335.     CopyPICT := 0;
  336.   mi := GlobalLock(H);
  337.   If mi = nil then EXIT;
  338.   hMFP := GlobalAlloc(GHND,sizeof(TMetaFilePict));
  339.   pMFP := GlobalLock(hMFP);
  340.   pMFP^.mm := mi^.mm;
  341.   pMFP^.xEXT := mi^.xEXT;
  342.   pMFP^.yEXT := mi^.yEXT;
  343.   pMFP^.hMF  := CopyMetaFile(mi^.hMF,nil);
  344.   GlobalUnlock(H);
  345.   GlobalUnlock(hMFP);
  346.   CopyPICT := hMFP;
  347. end;
  348.  
  349. procedure DelPICT(H:THandle);
  350. var
  351.   pMFP:PMetaFilePict;
  352. begin
  353.     if H = 0 then Exit;
  354.     pMFP := GlobalLock(H);
  355.   if pMFP = nil then Exit;
  356.   DeleteMetaFile(pMFP^.hMF);
  357.   GlobalUnlock(H);
  358.   GlobalFree(H);
  359. end;
  360.  
  361. procedure GetPICTSize(H:THandle;DC:HDC;HWin:HWnd;var X,Y:LongInt);
  362. var
  363.   om:Integer;
  364.   mfp:PMetaFilePict;
  365.   XP,YP:TPoint;
  366.   CR:TRect;
  367. begin
  368.     XP.X := 0;XP.Y:=0;YP.X:=0;YP.Y:= 0;
  369.   GetClientRect(HWin,CR);
  370.   if H = 0 then Exit;
  371.   mfp := GlobalLock(H);
  372.   if mfp = nil then Exit;
  373.   if (mfp^.mm = MM_ISOTROPIC) OR (mfp^.mm = MM_ANISOTROPIC) then
  374.       om := SetMapMode(DC,MM_HIMETRIC)
  375.     else
  376.         om := SetMapMode(DC,mfp^.mm);
  377.   XP.x := mfp^.xExt;
  378.     YP.y := mfp^.yExt;
  379.   SetViewportOrg(DC,0,0);
  380.   LPtoDP(DC,XP,1);LPtoDP(DC,YP,1);  {get nominal size of image}
  381.   SetMapMode(DC,om);
  382.   GlobalUnlock(H);
  383.      X:=abs(XP.x); Y:= abs(YP.Y);
  384.   if (X=0) or (Y=0) then
  385.       begin
  386.     X:=CR.Right;Y:=CR.Bottom;
  387.     end;
  388. end;
  389.  
  390. procedure RenderPICT(H:THandle;DC:HDC;HWin:HWnd;SR:TRect);
  391. var
  392.   om:Integer;
  393.   mfp:PMetaFilePict;
  394.   X,Y:LongInt;
  395.   MaxXY:LongInt;
  396. begin
  397.     if H = 0 then Exit;
  398.   X:=SR.Right;Y:=SR.Bottom;
  399.   MaxXY:=LongMax(X,Y);
  400.   mfp := GlobalLock(H);
  401.   om := SetMapMode(DC,mfp^.mm);
  402.   SetViewportOrg(DC,0,0);
  403.   SetViewPortExt(DC,X,Y);
  404.   PlayMetaFile(DC,mfp^.hMF);
  405.   GlobalUnlock(H);
  406.   SetMapMode(DC,oM);
  407. end;
  408.  
  409. function PICTtoBMP(H:THandle;DC:HDC;HWin:HWnd;SR:TRect):HBitmap;
  410. var
  411.     RC:TRect;
  412.   om:Integer;
  413.   hB,oB:HBitmap;
  414.   MemDC:hDC;
  415.   X,Y,Size:LongInt;
  416.   MaxXY:LongInt;
  417. begin
  418.     PICTtoBMP := 0;
  419.   if H = 0 then Exit;
  420.     GetPICTSize(H,DC,HWin,X,Y);
  421.   MaxXY:=LongMax(X,Y);
  422.   if SR.Right > 0 then
  423.       SetRect(RC,0,0,SR.Right * X div MaxXY,SR.Bottom * Y div MaxXY)
  424.     else
  425.         SetRect(RC,0,0,X,Y);
  426.   memDC := CreateCompatibleDC(DC);
  427.   hB := CreateCompatibleBitmap(DC,RC.Right,RC.Bottom);
  428.   oB:=SelectObject(memDC,hB);
  429.   FillRect(memDC,RC,GetStockObject(WHITE_BRUSH));
  430.   RenderPict(H,memDC,HWin,RC);
  431.   SelectObject(memDC,oB);
  432.   DeleteDC(memDC);
  433.   PICTtoBMP:= hB;
  434. end;
  435. {*************************  TClipObj  *******************************}
  436. constructor TClipObj.Init(hW:hWnd;var Stat:Word;SRect:TRect);
  437. var
  438.     hO:hWnd;
  439.   hM:THandle;
  440. begin
  441.     TObject.Init;
  442.     hText := 0;hPal := 0;hDIB := 0;hPICT := 0;hNative := 0;
  443.     hBMP := 0;hDISP:=0;hDispZ:= 0;Strcopy(Name,'');hM:=0;hO:=0;
  444.   SR:=SRect;
  445.   IsPrefText := True;
  446.   hO:=GetclipBoardOwner;
  447.   if hO <> 0 then
  448.       hM:=GetClassWord(hO,GCW_HMODULE);
  449.   if hM <> 0 then
  450.       GetModuleFileName(hM,name,sizeof(name));
  451.   filesplit(name,nil,name,nil);
  452.     GetClip(hW,Stat);
  453.     if Stat  <> id_Ok then Fail;
  454. end;
  455.  
  456. procedure TClipObj.GetClip(hW : hWnd;var Stat:Word);
  457. var
  458.     H      : THandle;
  459.   hB     : HBitmap;
  460.   DC     : hDC;
  461.   nF     :Word;
  462.   nN     :Array[0..50] of Char;
  463.   cF     :Integer;
  464.   nH     :THandle;
  465.   Indx   :Integer;
  466.   Clip   :PClipItem;
  467. begin
  468.     nF := 0;H := 0;StrCopy(nN,'');
  469.     Stat := st_ClipFailure;
  470.   if NOT OpenClipboard(hW) then EXIT;
  471.   Stat := st_OK;
  472.   Clips := New(PCollection,Init(10,10));
  473.   cF :=CountClipboardFormats;
  474.   for Indx := 0 to Pred(cF) do
  475.       begin
  476.       nF := EnumClipboardFormats(nF);
  477.       StrCopy(nN,'');
  478.     GetClipFormatName(nf,@nN,50);
  479.       H := GetClipboardData(nF);
  480.     if H = 0 then
  481.             {ignore these, usually owner-draw}
  482.     else if (StrLIComp(nN,'MGX',3) = 0) then
  483.         {lets skip this one - causes problems}
  484.         else
  485.         begin
  486.         case nF of
  487.             CF_DIB:
  488.           begin
  489.                 nH :=CopyGHND(H);
  490.         hDIB := nH;
  491.           end;
  492.       CF_PALETTE:
  493.           begin
  494.         nH := CopyPal(H);
  495.         hPAL := nH;
  496.           end;
  497.       CF_BITMAP:
  498.           begin
  499.         DC := GetDC(HW);
  500.         nH := CopyBMP(H,DC);
  501.         ReleaseDC(hW,DC);
  502.         hBMP := nH;
  503.           end;
  504.       CF_METAFILEPICT:
  505.           begin
  506.         nH := CopyPICT(H);
  507.         hPICT := nH;
  508.           end;
  509.       CF_TEXT:
  510.           begin
  511.         nH :=CopyGHND(H);
  512.         hText:= nH;
  513.           end;
  514.       else
  515.           begin
  516.         nH :=CopyGHND(H);
  517.         if StrIComp('Native',nN) = 0 then hNative := nH;
  518.           end;
  519.              end;
  520.       Clips^.Insert(New(PClipItem,Init(nH,nN,nF)));
  521.       end;
  522.     end;
  523.   CloseClipboard;
  524.   if Stat = st_OK then    {Build graphic thumbnail}
  525.       begin
  526.       if (hDIB > 0) then
  527.         hDisp:=DIBtoBMPScaled(hDIB,hW,SR)
  528.       else if (hBMP>0) then
  529.           begin
  530.         DC:=GetDC(HW);
  531.           hDISP:=ScaleBMP(hBMP,hPAL,DC,SR);
  532.         releaseDC(HW,DC);
  533.         end
  534.       else if (hPict>0) then
  535.           begin
  536.         DC:=GetDC(HW);
  537.           hDISP:= PICTtoBMP(hPICT,DC,hW,SR);
  538.         releaseDC(HW,DC);
  539.         end;
  540.     end
  541.   else       {if failure, dealloc objects}
  542.       for Indx := 0 to Pred(Clips^.Count) do
  543.           begin
  544.             Clip := Clips^.At(Indx);
  545.         case Clip^.CFormat of
  546.           CF_PALETTE:
  547.                     DeleteObject(Clip^.CHandle);
  548.                 CF_BITMAP:
  549.               DeleteObject(Clip^.CHandle);
  550.           CF_METAFILEPICT:
  551.                     DelPICT(Clip^.CHandle);
  552.           else
  553.               GlobalFree(Clip^.CHandle);
  554.                  end;
  555.         end;
  556.   Status := Stat;
  557. end;
  558.  
  559. procedure TClipObj.GetClipFormatName(nf:Integer;nN:PChar;Count:Word);
  560. begin
  561.     case nF of
  562.       cf_Text:StrCopy(nN,'Text');
  563.     cf_Bitmap:Strcopy(nN,'Bitmap');
  564.     cf_MetaFilePict:StrCopy(nN,'Picture');
  565.     cf_Sylk:StrCopy(nN,'Sylk');
  566.     cf_DIF:StrCopy(nN,'DIF');
  567.     cf_TIFF:StrCopy(nN,'TIFF');
  568.     cf_OEMText:StrCopy(nN,'OEM Text');
  569.     cf_DIB:StrCopy(nN,'DIB Bitmap');
  570.     cf_Palette:StrCopy(nN,'Palette');
  571.     cf_PenData:StrCopy(nN,'Pen Data');
  572.     cf_RIFF:StrCopy(nN,'RIFF');
  573.     cf_Wave:StrCopy(nN,'Wave');
  574.     cf_OwnerDisplay:StrCopy(nN,'Owner-Display');
  575.     cf_DspText:StrCopy(nN,'Disp Text');
  576.     cf_DSPMetaFilePict:StrCopy(nN,'Disp Picture');
  577.     cf_DSPBitmap:StrCopy(nN,'Disp Bitmap');
  578.     else
  579.             GetClipboardFormatName(nF,nN,50);
  580.     end;
  581. end;
  582.  
  583. procedure TClipObj.CopyClipS(hW : hWnd;I:PMultiSelRec);
  584. var
  585.   cSize : LongInt;
  586.   Clip:PClipItem;
  587.     Indx,Indx2:Integer;
  588.   Str:PChar;
  589. begin
  590.   Status := st_ClipFailure;
  591.   if NOT OpenClipboard(hW) then EXIT;
  592.     EmptyClipboard;
  593.   if I^.Count = cc_CopyAll then
  594.       for Indx := 0 to Pred(Clips^.Count) do
  595.         begin
  596.         Clip := Clips^.At(Indx);
  597.         CopyClip(hW,Clip);
  598.       end
  599.   else
  600.     for Indx := 1 to I^.Count do
  601.         begin
  602.         Clip:= Clips^.At(I^.Selections[Pred(Indx)]);
  603.       CopyClip(hW,Clip);
  604.         end;
  605.   CloseClipboard;
  606. end;
  607.  
  608. procedure TClipObj.CopyClip(hW : hWnd;Clip:PClipItem);
  609. var
  610.   DC : hDC;
  611.   oP : hPalette;
  612.   cSize : LongInt;
  613.     nH:THandle;
  614. begin
  615.     case Clip^.CFormat of
  616.             CF_DIB:
  617.                 nH :=CopyGHND(Clip^.CHandle);
  618.       CF_PALETTE:
  619.         nH := CopyPal(Clip^.CHandle);
  620.       CF_BITMAP:
  621.           begin
  622.         DC := GetDC(HW);
  623.         if hPAL > 0 then oP:=SelectPalette(DC,hPAL,false);
  624.         RealizePalette(DC);
  625.         nH := CopyBMP(Clip^.CHandle,DC);
  626.         if hPAL > 0 then SelectPalette(DC,oP,false);
  627.         ReleaseDC(hW,DC);
  628.           end;
  629.       CF_METAFILEPICT:
  630.         nH := CopyPICT(Clip^.CHandle);
  631.       CF_TEXT:
  632.         nH :=CopyGHND(Clip^.CHandle);
  633.       else
  634.         nH :=CopyGHND(Clip^.CHandle);
  635.          end;
  636.        SetClipboardData(Clip^.CFormat,nH);
  637. end;
  638.  
  639. destructor TClipObj.Done;
  640. var
  641.     Indx:Integer;
  642.   Clip:PClipItem;
  643. begin
  644.   for Indx := 0 to Pred(Clips^.Count) do
  645.       begin
  646.         Clip := Clips^.At(Indx);
  647.     case Clip^.CFormat of
  648.             CF_DIB:
  649.                 GlobalFree(Clip^.CHandle);
  650.       CF_PALETTE:
  651.                 DeleteObject(Clip^.CHandle);
  652.             CF_BITMAP:
  653.           DeleteObject(Clip^.CHandle);
  654.       CF_METAFILEPICT:
  655.                 DelPICT(Clip^.CHandle);
  656.             CF_TEXT:
  657.           GlobalFree(Clip^.CHandle);
  658.       else
  659.           GlobalFree(Clip^.CHandle);
  660.          end;
  661.     end;
  662.   if hDisp >0 then DeleteObject(hDISP);
  663.   if hDispZ >0 then DeleteObject(hDISPZ);
  664.     Dispose(Clips,Done);
  665.   TObject.Done;
  666. end;
  667.  
  668. procedure TClipObj.RenderSelf(DC:hDC;hWin:HWnd;IsZ:Bool);
  669. var
  670.   Clip:PClipItem;
  671.   hP,oP:hPalette;
  672.   tb:TBitmap;
  673.   oB:HBitmap;
  674.   pBits:Pointer;
  675.   bi:PBitmapInfo;
  676.   pT:Pointer;
  677.   CR:TRect;
  678.   memDC:hDC;
  679.   Indx:Integer;
  680.   Buf:PChar;
  681. begin
  682.   if Clips^.Count = 0 then Exit;
  683.     if ((hText=0) and (hDisp=0)) then
  684.     begin
  685.     GetMem(Buf,72*Clips^.Count+sizeof(name)); StrCopy(Buf,'');
  686.     StrCat(StrCat(StrCat(StrCat(Buf,'Src:'),StrLower(name)),' '),#13#10);
  687.       for Indx := 0 to Pred(Clips^.Count) do
  688.           begin
  689.             Clip := Clips^.At(Indx);
  690.         StrCat(StrCat(Buf,Clip^.CName),#13#10);
  691.         end;
  692.     GetClientRect(hWin,CR);
  693.     SetBkMode(DC,transparent);
  694.     DrawText(DC,Buf,-1,CR,DT_Left);
  695.     FreeMem(Buf,72*Clips^.Count+sizeof(name));
  696.     end
  697.     else if ((hText > 0) and IsPrefText) or
  698.         (hDisp=0) then
  699.     begin
  700.     pT := GlobalLock(hText);
  701.     GetClientRect(hWin,CR);
  702.     SetBkMode(DC,transparent);
  703.     DrawText(DC,pT,-1,CR,DT_Left);
  704.     GlobalUnlock(hText);
  705.     end
  706.     else if hDISP > 0 then
  707.       begin
  708.     if IsZ then
  709.         RenderSelfZ(DC,hWin,IsZ)
  710.     else
  711.         begin
  712.             if hPal > 0 then oP := SelectPalette(DC,hPal,False);
  713.           if hPal > 0 then RealizePalette(DC);
  714.           GetObject(hDISP,sizeof(TBitmap),@tb);
  715.         memDC:=CreateCompatibleDC(DC);
  716.         oB:=SelectObject(memDC,hDISP);
  717.              BitBlt(DC,0,0,tb.bmWidth,tb.bmHeight,memDC,0,0,SRCCOPY);
  718.             SelectObject(memDC,oB);
  719.         DeleteDC(memDC);
  720.         if hPal > 0 then SelectPalette(DC,oP,False);
  721.       end;
  722.       end;
  723. end;
  724.  
  725. procedure TClipObj.RenderSelfZ(DC:hDC;hWin:HWnd;IsZ:Bool);
  726. var
  727.   hP,oP:hPalette;
  728.   tb:TBitmap;
  729.   hB,oB:HBitmap;
  730.   pBits:Pointer;
  731.   bi:PBitmapInfo;
  732.   pT:Pointer;
  733.   CR:TRect;
  734.   memDC:hDC;
  735. begin
  736.     if hDispZ = 0 then
  737.       begin
  738.         if (hDIB > 0) then
  739.         hDispZ:=DIBtoBMP(hDIB,hWin,DC)
  740.       else if (hBMP>0) then
  741.         hDispZ:=CopyBMP(hBMP,DC)
  742.       else if (hPict>0) then
  743.           begin
  744.       SetRect(CR,0,0,0,0);
  745.           hDispZ:= PICTtoBMP(hPICT,DC,hWIN,CR);
  746.       end;
  747.     end;
  748.     if hDispZ > 0 then
  749.       begin
  750.         if hPal > 0 then oP := SelectPalette(DC,hPal,False);
  751.       if hPal > 0 then RealizePalette(DC);
  752.       GetObject(hDispZ,sizeof(TBitmap),@tb);
  753.     memDC:=CreateCompatibleDC(DC);
  754.     oB:=SelectObject(memDC,hDispZ);
  755.          BitBlt(DC,0,0,tb.bmWidth,tb.bmHeight,memDC,0,0,SRCCOPY);
  756.         SelectObject(memDC,oB);
  757.     DeleteDC(memDC);
  758.     if hPal > 0 then SelectPalette(DC,oP,False);
  759.     end;
  760. end;
  761.  
  762.  
  763. procedure TClipObj.RedrawSelf(DC:hDC;hWin:HWnd;IsZ:Bool);
  764. var
  765.   pBits:Pointer;
  766.   bi:PBitmapInfo;
  767.   pT:Pointer;
  768.   CR:TRect;
  769.   tb:TBitmap;
  770.   memDC:hDC;
  771.   oB:HBitmap;
  772.   Clip:PClipItem;
  773.   Indx:Integer;
  774.   Buf:PChar;
  775. begin
  776.     if ((hText=0) and (hDisp=0)) then
  777.     begin
  778.     GetMem(Buf,72*Clips^.Count+25); StrCopy(Buf,'');
  779.     StrCat(StrCat(StrCat(StrCat(Buf,'Src:'),StrLower(name)),' '),#13#10);
  780.       for Indx := 0 to Pred(Clips^.Count) do
  781.           begin
  782.             Clip := Clips^.At(Indx);
  783.         StrCat(StrCat(Buf,Clip^.CName),#13#10);
  784.         end;
  785.     GetClientRect(hWin,CR);
  786.     SetBkMode(DC,transparent);
  787.     DrawText(DC,Buf,-1,CR,DT_Left);
  788.     FreeMem(Buf,72*Clips^.Count+25);
  789.     end
  790.     else if ((hText > 0) and IsPrefText) or
  791.         (hDisp=0) then
  792.     begin
  793.     pT := GlobalLock(hText);
  794.     GetClientRect(hWin,CR);
  795.     SetBkMode(DC,transparent);
  796.     DrawText(DC,pT,-1,CR,DT_Left);
  797.     GlobalUnlock(hText);
  798.     end
  799.     else if hDISP > 0 then
  800.       begin
  801.     if IsZ then
  802.         RenderSelfZ(DC,hWin,IsZ)
  803.     else
  804.         begin
  805.           GetObject(hDISP,sizeof(TBitmap),@tb);
  806.         memDC:=CreateCompatibleDC(DC);
  807.         oB:=SelectObject(memDC,hDISP);
  808.              BitBlt(DC,0,0,tb.bmWidth,tb.bmHeight,memDC,0,0,SRCCOPY);
  809.             SelectObject(memDC,oB);
  810.         DeleteDC(memDC);
  811.       end;
  812.       end;
  813. end;
  814.  
  815. function TClipObj.GetStatus : Word;
  816. begin
  817.     GetStatus := Status;
  818. end;
  819.  
  820. function TClipObj.GetPal : hPalette;
  821. begin
  822.     GetPal := hPal;
  823. end;
  824.  
  825. function TClipObj.GetDIB : THandle;
  826. begin
  827.   GetDIB := hDIB;
  828. end;
  829.  
  830. function TClipObj.GetPICT : THandle;
  831. begin
  832.   GetPICT := hPICT;
  833. end;
  834.  
  835. procedure TClipObj.GetInfo(Info:PChar;Len:Integer);
  836. type
  837.   ORec = Record
  838.     Size:Word;
  839.       Width:Word;
  840.     Height:Word;
  841.     Res:Word;
  842.   end;
  843.   PRec = Record
  844.     Size:Word;
  845.   end;
  846. var
  847.   Size:LongInt;
  848.   H : THandle;
  849.   bi   : PBitmapInfo;
  850.   O    :ORec;
  851.   P    :PRec;
  852.   Buf  :Array[0..100] of Char;
  853.   pMFP :PMetaFilePict;
  854.   TB   :TBitmap;
  855. begin
  856.     fillchar(O,sizeOf(ORec),0);
  857.   fillchar(P,sizeof(PRec),0);
  858.   StrCopy(Info,''); StrCopy(Buf,'');
  859.   H := GetDIB;
  860.   if H <> 0 then
  861.       begin
  862.       bi := GlobalLock(H);
  863.       if bi <> nil then
  864.           begin
  865.           with bi^.bmiHeader, O do
  866.           if bi <> nil then
  867.             begin
  868.             width := biWidth;
  869.                 Height := biHeight;
  870.                 Res := biBitCount;
  871.           end;
  872.           GlobalUnlock(hDIB);
  873.           O.Size := GlobalSize(hDIB) div 1024;
  874.             wvsprintf(Buf,'DIB:%uK %u*%u*%u',O) ;
  875.              StrCat(Info,Buf);
  876.         end;
  877.       end;
  878.   if hPICT <> 0 then
  879.       begin
  880.          pMFP := GlobalLock(hPICT);
  881.     P.Size := GlobalSize(pMFP^.hMF) div 1024;
  882.     GlobalUnlock(hPICT);
  883.     wvsprintf(Buf,' PICT:%iK',P);
  884.          StrCat(Info,Buf);
  885.       end;
  886.     if hNative <> 0 then
  887.       begin
  888.     P.Size := GlobalSize(hNative) div 1024;
  889.     wvsprintf(Buf,' Native:%iK',P);
  890.          StrCat(Info,Buf);
  891.     end;
  892.   if hText > 0 then
  893.       begin
  894.     P.Size := GlobalSize(hText) ;
  895.     if P.Size > 1024 then
  896.         begin
  897.       P.Size := P.Size div 1024;
  898.         wvsprintf(Buf,' Text:%iK',P);
  899.       end
  900.         else
  901.             wvsprintf(Buf,' Text:%i Bytes',P);
  902.          StrCat(Info,Buf);
  903.     end;
  904.   if hBMP > 0 then
  905.       begin
  906.       GetObject(hBMP,sizeof(TBitmap),@tb);
  907.       with TB, O do
  908.             begin
  909.             width := bmWidth;
  910.                 Height := bmHeight;
  911.                 Res := bmPlanes;
  912.             Size := bmplanes*(Muldiv(height,width,1024));
  913.           end;
  914.         wvsprintf(Buf,' BMP:%uK %u*%u*%u',O) ;
  915.          StrCat(Info,Buf);
  916.     end;
  917. end;
  918.  
  919. procedure TClipObj.SetIsPrefText(Choice:Bool);
  920. begin
  921.     IsPrefText := Choice;
  922. end;
  923. procedure TClipObj.ToggleIsPrefText;
  924. begin
  925.     IsPrefText := not IsPrefText;
  926. end;
  927.  
  928. procedure TClipObj.GetFormats(Buf:PChar);
  929. begin
  930.     if Buf <> nil then
  931.       begin
  932.         if (hDisp>0) and (hText>0) then
  933.         StrCopy(Buf,'*')
  934.     else
  935.         StrCopy(Buf,'');
  936.     end;
  937. end;
  938.  
  939. function TClipObj.GetClips:PCollection;
  940. begin
  941.     GetClips := Clips;
  942. end;
  943. {********************************   TClipItem  ********************}
  944. constructor TClipItem.Init(NewCHandle:THandle;NewCName:PChar;NewCFormat:Word);
  945. begin
  946.     CHandle := NewCHandle;
  947.   CName :=StrNew(NewCName);
  948.   CFormat := NewCFormat;
  949. end;
  950.  
  951. destructor TClipItem.Done;
  952. begin
  953.     StrDispose(CName);
  954. end;
  955.  
  956. end.
  957.