home *** CD-ROM | disk | FTP | other *** search
/ QBasic & Borland Pascal & C / Delphi5.iso / Pascal / BPASCAL.700 / D12 / PAINT.ZIP / BITMAPS.PAS next >
Encoding:
Pascal/Delphi Source File  |  1992-10-01  |  7.4 KB  |  256 lines
  1. {************************************************}
  2. {                                                }
  3. {   ObjectWindows Paint demo                     }
  4. {   Copyright (c) 1992 by Borland International  }
  5. {                                                }
  6. {************************************************}
  7.  
  8. unit Bitmaps;
  9.  
  10. { This unit augments the HBitmap type by implementing load and store of the
  11.   bitmap to a file.
  12.  
  13.   Presently operates only on Windows format for bitmaps.
  14. }
  15. {$S-,R-}
  16.  
  17. interface
  18.  
  19. uses WinTypes, WinProcs;
  20.  
  21. { Read a bitmap from file (full pathname).
  22.   Returns 0 if error or HBitmap.
  23. }
  24. function LoadBitmapFile(FileName: PChar): HBitmap;
  25.  
  26. { Write a bitmap to file (full pathname).
  27.   Returns 0 if error else non-zero.
  28. }
  29. function StoreBitmapFile(FileName: PChar; HBM: HBitmap): Integer;
  30.  
  31. implementation
  32.  
  33. procedure AHIncr; far; external 'KERNEL' index 114;
  34.  
  35. const
  36.   MaxIO = 65534;    { Max number bytes handled in single IO operation }
  37.   OneIO = 32768;  { Number bytes handled per huge IO operation }
  38.   BMType = $4D42;  { = 'BM' }
  39.  
  40. type
  41.   PtrRec = record
  42.     Lo, Hi: Word
  43.   end;
  44.   IOFunction = function(FP: integer; Buf: PChar; Size: Integer): Word;
  45.  
  46. { Perform IO operation in chunks to avoid memory segment crossings.
  47.   Returns 0 if error else non-zero.
  48. }
  49. function HugeIO(IOFunc: IOFunction; F: Integer; P: Pointer; Size: Longint)
  50.                : Word;
  51. var
  52.   L, N: Longint;                { L maintains total bytes }
  53. begin                { N maintains bytes for current pass }
  54.   HugeIO := 1;
  55.   L := 0;
  56.   while L < Size do
  57.   begin
  58.     N := Size - L;
  59.     if N > OneIO then N := OneIO;
  60.     if IOFunc(F,
  61.     { Compute the segment and offset reached.
  62.       The Hi word of P contains the initial segment.
  63.       Think of the following as performing arithmetic
  64.         modulo segment-size, since the size of a segment
  65.         fills one word:
  66.       The Hi word of L contains the number of segments crossed
  67.         (the size of one segment fills the Lo word, so Hi word
  68.         will roll over as segments are filled).
  69.         Multiply by Ofs(AHIncr) to obtain the number used to
  70.         indicate this number of segments.
  71.       The Lo word of L contains the number of bytes already
  72.         passed in the present segment.
  73.      }
  74.            Ptr(PtrRec(P).Hi + PtrRec(L).Hi * Ofs(AHIncr),
  75.                PtrRec(L).Lo),
  76.                Integer(N))     { Guaranteed to be in Integer range }
  77.        <> N then
  78.     begin
  79.       HugeIO := 0;
  80.       Exit; { abnormal termination }
  81.     end; 
  82.     Inc(L, N);
  83.   end;
  84. end;
  85.  
  86. function _LFileSize(F : integer) : longint;        
  87. {- an equivalent to TP's FileSize() function }     
  88. var                                                
  89.   CurPos : longint;                                
  90. begin                                               
  91.   CurPos := _llseek(F,0,1);                    
  92.   _LFileSize := _llseek(F,0,2);                
  93.   _llseek(F,CurPos,0);                         
  94. end;                                           
  95.  
  96. { Read a bitmap from file (full pathname).
  97.   Returns 0 if error or HBitmap.
  98. }
  99. function LoadBitmapFile(FileName: PChar): HBitmap;
  100. var
  101.   F: Integer;            { File Handle for Windows file functions }
  102.   H: THandle;            { Handle to memory for bitmap }
  103.   DC: HDC;            { Drawing context for application }
  104.   Size, N: Longint;        { Size of bitmap, Size of color spec }
  105.   P: PBitmapInfo;        { Windows bitmap format info header }
  106.   Header: TBitmapFileHeader;    { Bitmap file header }
  107.  
  108. begin
  109.   LoadBitmapFile := 0;
  110.   F := _LOpen(FileName, of_Read);
  111.   if F = -1 then Exit;
  112.  
  113.   { read in the Bitmap file header }
  114.   if (_LRead(F, @Header, SizeOf(Header)) <> SizeOf(Header)) or
  115.     (Header.bfType <> BMType) then
  116.   begin
  117.     _LClose(F);
  118.     Exit;
  119.   end;
  120.  
  121.   { read the rest of the file }
  122.   Size := _LFileSize(F) - SizeOf(TBitmapFileHeader);     
  123.   H := GlobalAlloc(gmem_Moveable, Size);    { Allocate the memory }
  124.   if H = 0 then
  125.   begin
  126.     _LClose(F);
  127.     Exit;
  128.   end;
  129.  
  130.   P := GlobalLock(H);                { Lock it down }
  131.  
  132.   if (HugeIO(_LRead, F, P, Size) <> 0) and
  133.     (P^.bmiHeader.biSize = SizeOf(TBitmapInfoHeader)) then
  134.   begin
  135.     { Compute the offset from the beginning of P^ }      
  136.     { where the actual image begins }                    
  137.     N := Header.bfOffBits - SizeOf(TBitmapFileHeader);
  138.  
  139.     { actually create the Bitmap }
  140.     DC := GetDC(0);
  141.     LoadBitmapFile := CreateDIBitmap(DC, P^.bmiHeader,
  142.       cbm_Init, Ptr(PtrRec(P).Hi,N),P^, dib_RGB_Colors); 
  143.  
  144.     { clean up }
  145.     ReleaseDC(0, DC);
  146.   end;
  147.  
  148.   GlobalUnlock(H);
  149.   GlobalFree(H);
  150.   _LClose(F);
  151. end;
  152.  
  153.  
  154. { Write a bitmap to file (full pathname).
  155.   Returns 0 if error else non-zero.
  156. }
  157. function StoreBitmapFile(FileName: PChar; HBM: HBitmap): Integer;
  158.   var
  159.     BM:   TBitmap;        { Bitmap information }
  160.     BFH:  TBitmapFileHeader;    { Bitmap file information }
  161.     BIP:  PBitmapInfo;        { Part of bitmap file information }
  162.     DC:   HDC;            { Drawing context }
  163.  
  164.     HMem: THandle;        { Handle to memory for bitmap }
  165.     Buf:  Pointer;        { Memory for bitmap }
  166.  
  167.     ColorSize, DataSize: Longint; { Size needed to store Color/Data }
  168.     BitCount: Word;        { Number of bits per pixel }
  169.     FP: Integer;        { File }
  170.  
  171.   { Takes the size in bits and returns the (aligned) size in bytes.
  172.     Bitmap data format requires word alignment.
  173.   }
  174.   function bmAlignDouble(Size: Longint): Longint;
  175.   begin
  176.     bmAlignDouble := (Size + 31) div 32 * 4;
  177.   end;
  178.  
  179. begin
  180.    StoreBitmapFile := 0;
  181.    { Get the information about the Bitmap }
  182.    if GetObject(HBM, SizeOf(TBitmap), @BM) = 0 then Exit;
  183.  
  184.    BitCount := bm.bmPlanes * bm.bmBitsPixel;
  185.    if (BitCount <> 24) then
  186.      ColorSize := SizeOf(TRGBQuad) * (1 shl BitCount)
  187.    else
  188.      ColorSize := 0;
  189.    DataSize := bmAlignDouble(bm.bmWidth * BitCount) * bm.bmHeight;
  190.  
  191.    { Create the file }
  192.    FP := _lcreat(FileName, 0);
  193.    if FP = -1 then Exit;
  194.  
  195.    { Allocate memory for the bitmap info structure }
  196.    GetMem(BIP, SizeOf(TBitmapInfoHeader) + ColorSize);
  197.    if BIP <> nil then
  198.    begin
  199.      { Fill in the Bitmap info header }
  200.      with BIP^.bmiHeader do
  201.      begin
  202.        biSize := SizeOf(TBitmapInfoHeader);
  203.        biWidth := bm.bmWidth;
  204.        biHeight := bm.bmHeight;
  205.        biPlanes := 1;
  206.        biBitCount := BitCount;
  207.        biCompression := 0;
  208.        biSizeImage := DataSize;
  209.        biXPelsPerMeter := 0;
  210.        biYPelsPerMeter := 0;
  211.        biClrUsed := 0;
  212.        biClrImportant := 0;
  213.      end;
  214.  
  215.      { Fill in the file header }
  216.      with BFH do
  217.      begin
  218.        bfOffBits := SizeOf(BFH) + SizeOf(TBitmapInfo) + ColorSize;
  219.        bfReserved1 := 0;
  220.        bfReserved2 := 0;
  221.        bfSize :=  bfOffBits + DataSize;
  222.        bfType := BMType;
  223.      end;
  224.  
  225.      { Create the memory Bitmap }
  226.      HMem := GlobalAlloc(gmem_Fixed, DataSize);
  227.      if HMem <> 0 then
  228.      begin
  229.        Buf := GlobalLock(HMem);
  230.  
  231.        { Get the bitmap bits in device independent format }
  232.        DC := GetDC(0);
  233.        if GetDIBits(DC, hbm, 0, DataSize, Buf, BIP^, dib_RGB_Colors) <> 0 then
  234.        begin
  235.          ReleaseDC(0, DC);
  236.          { Write to file }
  237.          _lwrite(FP, @BFH, SizeOf(BFH));
  238.          _lwrite(FP, PChar(BIP), SizeOf(TBitmapInfo) + ColorSize);
  239.          HugeIO(_lwrite, FP, Buf, DataSize);
  240.          StoreBitmapFile := 1;
  241.        end;
  242.  
  243.        { Clean up }
  244.        GlobalUnlock(HMem);
  245.        GlobalFree(HMem);
  246.      end;
  247.  
  248.      FreeMem(BIP, SizeOf(TBitmapInfoHeader) + ColorSize);
  249.    end;
  250.  
  251.    _lclose(FP);
  252.  
  253. end;
  254.  
  255. end.
  256.