Delphi控件源码

开发平台：
Delphi

MMRiff.pas：源码内容
							{========================================================================}
{=                (c) 1995-98 SwiftSoft Ronald Dittrich                 =}
{========================================================================}
{=                          All Rights Reserved                         =}
{========================================================================}
{=  D 01099 Dresden             = Tel.: +0351-8012255                   =}
{=  Loewenstr.7a                = info@swiftsoft.de                     =}
{========================================================================}
{=  Actual versions on http://www.swiftsoft.de/mmtools.html             =}
{========================================================================}
{=  This code is for reference purposes only and may not be copied or   =}
{=  distributed in any format electronic or otherwise except one copy   =}
{=  for backup purposes.                                                =}
{=                                                                      =}
{=  No Delphi Component Kit or Component individually or in a collection=}
{=  subclassed or otherwise from the code in this unit, or associated   =}
{=  .pas, .dfm, .dcu, .asm or .obj files may be sold or distributed     =}
{=  without express permission from SwiftSoft.                          =}
{=                                                                      =}
{=  For more licence informations please refer to the associated        =}
{=  HelpFile.                                                           =}
{========================================================================}
{=  $Date: 20.01.1998 - 18:00:00 $                                      =}
{========================================================================}
Unit MMRIFF;
{$I COMPILER.INC}
interface
uses
{$IFDEF WIN32}
    Windows,
{$ELSE}
    WinTypes,
    WinProcs,
{$ENDIF}
    SysUtils,
    MMSystem,
    MMUtils,
    MMDIB,
    MMAbout;
const
     CHUNK_MODIFIED = 1;    { chunk was modified                      }
     CHUNK_REVERT   = 2;    { command to revert to original text      }
{$IFDEF WIN32}
type
    THMMIO = HMMIO;             { whats that BORLAND !? }
{$ENDIF}
type
    PChunk = ^TChunk;
    TChunk = packed record
       fcc: FOURCC;
       cksize: Longint;
       data: array[0..0] of Byte;
    end;
    PInfoData = ^TInfoData;
    TInfoData = packed record
       index       : Word;      { index into aINFO                        }
       wFlags      : Word;      { flags for chunk                         }
       dwINFOOffset: Longint;   { offset in file to INFO chunk            }
       lpText      : PChar;     { text of modified chunk. None if NULL.   }
       pNext       : PInfoData; { next read sub-chunk                     }
    end;
    PInfoChunk = ^TInfoChunk;
    TInfoChunk = packed record
       lpChunk     : PChar;     { complete chunk in memory (GlobalPtr)    }
       cksize      : Longint;   { size of chunk data                      }
       pHead       : PInfoData; { first sub-chunk data                    }
    end;
    TInfo = packed record
      pFOURCC: PChar;
      pShort : PChar;
      pLong  : PChar;
    end;
    PDisp = ^TDisp;
    TDisp = packed record
       cfid   : Longint;        { Clipboard id of data                    }
       wFlags : Word;           { flags for chunk                         }
       lpChunk: PChar;          { ptr to original file data               }
       lpData : PChar;          { ptr to modified data                    }
       pNext  : PDISP;          { next in list                            }
    end;
    PDispList = ^TDispList;
    TDispList = packed record
       pHead : PDisp;           { first 'DISP' chunk                      }
    end;
const
     aINFO: array[0..23] of TInfo = (
(pFOURCC: 'IARL';
 pShort: 'Archival Location';
 pLong: 'Indicates where the subject of the file is archived.'),
(pFOURCC: 'IART';
 pShort: 'Artist'; 
 pLong: 'Lists the artist of the original subject of the file. For example,'
        +' "Michaelangelo."'),
(pFOURCC: 'ICMS'; 
 pShort: 'Commissioned'; 
 pLong: 'Lists the name of the person or organization that commissioned '
         +'the subject of the file. For example, "Pope Julian II."'),
(pFOURCC: 'ICMT';
 pShort: 'Comments';
 pLong: 'Provides general comments about the file or the subject of the '
        +'file. If the comment is several sentences long, end each sentence '
        +'with a period. Do not include newline characters.'),
(pFOURCC: 'ICOP';
 pShort: 'Copyright';
 pLong: 'Records the copyright information for the file. For example, '
       +'"Copyright Encyclopedia International 1991." If there are multiple '
       +'copyrights, separate them by a semicolon followed by a space.'),
(pFOURCC: 'ICRD'; 
 pShort: 'Creation date';
 pLong: 'Specifies the date the subject of the file was created. List dates '
       +'in year-month-day format, padding one-digit months and days with a'
       +' zero on the left. For example, "1553-05-03" for May 3), 1553.'),
(pFOURCC: 'ICRP'; 
 pShort: 'Cropped'; 
 pLong: 'Describes whether an image has been cropped and, if so, how it was '
       +'cropped. For example, "lower right corner."'),
(pFOURCC: 'IDIM';
 pShort: 'Dimensions';
 pLong: 'Specifies the size of the original subject of the file. For example, '
       +'"8.5 in h, 11 in w."'),
(pFOURCC: 'IDPI'; 
 pShort: 'Dots Per Inch';
 pLong: 'Stores dots per inch setting of the digitizer used to produce the '
       +'file, such as "300."'),
(pFOURCC: 'IENG'; 
 pShort: 'Engineer';
 pLong: 'Stores the name of the engineer who worked on the file. If there '
       +'are multiple engineers, separate the names by a semicolon and a '
       +'blank. For example, "Smith, John; Adams, Joe."'),
(pFOURCC: 'IGNR'; 
 pShort: 'Genre'; 
 pLong: 'Describes the original work, such as, "landscape," "portrait," '
       +'"still life," etc.'),
(pFOURCC: 'IKEY'; 
 pShort: 'Keywords';
 pLong: 'Provides a list of keywords that refer to the file or subject of '
       +'the file. Separate multiple keywords with a semicolon and a blank. For example, "Seattle; aerial view; scenery."'),
(pFOURCC: 'ILGT';
 pShort: 'Lightness'; 
 pLong: 'Describes the changes in lightness settings on the digitizer required '
       +'to produce the file. Note that the format of this information depends on hardware used.'),
(pFOURCC: 'IMED'; 
 pShort: 'Medium'; 
 pLong: 'Describes the original subject of the file, such as, "computer image," '
       +'"drawing," "lithograph," and so forth.'),
(pFOURCC: 'INAM'; 
 pShort: 'Name';
 pLong: 'Stores the title of the subject of the file, such as, "Seattle From '
       +'Above."'),
(pFOURCC: 'IPLT'; 
 pShort: 'Palette Setting';
 pLong: 'Specifies the number of colors requested when digitizing an image, '
       +'such as "256."'),
(pFOURCC: 'IPRD';
 pShort: 'Product';
 pLong: 'Specifies the name of the title the file was originally intended '
       +'for, such as "Encyclopedia of Pacific Northwest Geography."'),
(pFOURCC: 'ISBJ'; 
 pShort: 'Subject';
 pLong: 'Describes the contents of the file, such as "Aerial view of Seattle."'),
(pFOURCC: 'ISFT'; 
 pShort: 'Software';
 pLong: 'Identifies the name of the software package used to create the file, '
       +'such as "Microsoft WaveEdit."'),
(pFOURCC: 'ISHP'; 
 pShort: 'Sharpness';
 pLong: 'Identifies the changes in sharpness for the digitizer required to '
       +'produce the file (the format depends on the hardware used).'),
(pFOURCC: 'ISRC'; 
 pShort: 'Source';
 pLong: 'Identifies the name of the person or organization who supplied the '
       +'original subject of the file. For example, "Trey Research."'),
(pFOURCC: 'ISRF';
 pShort: 'Source Form';
 pLong: 'Identifies the original form of the material that was digitized, '
       +'such as "slide," "paper," "map," and so forth. This is not necessarily '
       +'the same as IMED.'),
(pFOURCC: 'ITCH'; 
 pShort: 'Technician'; 
 pLong: 'Identifies the technician who digitized the subject file. For '
       +'example, "Smith, John."'),
(pFOURCC: NIL;
 pShort: NIL;
 pLong: NIL));
{*************************************************************************}
{ error returns from RIFF functions                                       }
{*************************************************************************}
const
     RIFFERR_BASE      = 0;
     RIFFERR_NOERROR   = 0;
     RIFFERR_ERROR     = RIFFERR_BASE+1;
     RIFFERR_BADPARAM  = RIFFERR_BASE+2;
     RIFFERR_FILEERROR = RIFFERR_BASE+3;
     RIFFERR_NOMEM     = RIFFERR_BASE+4;
     RIFFERR_BADFILE   = RIFFERR_BASE+5;
(************************************************************************)
function  mmioFourCC(ch0,ch1,ch2,ch3: Char): FourCC;
function  RiffCopyChunk(hmmioSrc,hmmioDst: THMMIO; lpck: PMMCKINFO): Boolean;
function  RiffCopyList(hmmioSrc,hmmioDst: THMMIO; lpck: PMMCKINFO): Boolean;
(************************************************************************)
function  RiffInitINFO(Var lpInfo: PInfoChunk): integer;
function  RiffCopyInfo(Var lpInfoDst: PInfoChunk; lpInfoSrc: PInfoChunk): integer;
function  RiffFreeINFO(Var lpInfo: PInfoChunk): integer;
function  RiffReadINFO(hmmio: THMMIO; lpck: PMMCKINFO; lpInfo: PInfoChunk): integer;
function  RiffWriteINFO(hmmio: THMMIO; lpInfo: PInfoChunk): integer;
function  RiffCreateINFO(wFlags, id: Word; dwInfoOffset: Longint; lpText: PChar): PInfoData;
procedure RiffInsertINFO(lpInfo: PInfoChunk; pInfo: PInfoData);
function  RiffFindPIINFO(lpInfo: PInfoChunk; fcc: FOURCC): PInfoData;
procedure RiffModifyINFO(lpInfo: PInfoChunk; pi: PInfoData;
                         wFlags: Word; dw: Longint; lpText: PChar);
function  RiffFindaINFO(fcc: FOURCC): integer;
function  RiffParseINFO(lpInfo: PInfoChunk): integer;
(************************************************************************)
function  RiffInitDISP(Var lpDisp: PDispList): integer;
function  RiffCopyDISP(lpDispDst, lpDispSrc: PDISPList): integer;
function  RiffFreeDISP(Var lpDisp: PDispList; FreeList: Boolean): integer;
function  RiffReadDISP(hmmio: THMMIO; lpck: PMMCKINFO; Var lpDisp: PDispList): integer;
function  RiffWriteDISP(hmmio: THMMIO; lpDisp: PDispList): integer;
function  RiffCreateDISP(wFlags: Word; id: Longint; lpChunk, lpData: PChar): PDisp;
procedure RiffInsertDISP(lpDisp: PDispList; pd: PDisp);
procedure RiffModifyDISP(lpDisp: PDispList; pd: PDisp;
                         wFlags: Word; lpData: PChar);
implementation
{**************************************************************************}
function mmioFourCC(ch0,ch1,ch2,ch3: Char): FourCC;
begin
     Result := Longint(ch0) OR
               (Longint(ch1) shl 8) OR
               (Longint(ch2) shl 16) OR
               (Longint(ch3) shl 24);
end;
{**************************************************************************}
function RiffCopyChunk(hmmioSrc, hmmioDst: THMMIO; lpck: PMMCKINFO): Boolean;
Label rscc_Error;
var
   ck: TMMCKINFO;
   pBuf: PChar;
begin
     Result := False;
     pBuf := GlobalAllocPtr(GHND, lpck^.cksize);
     if (pBuf = NIL) then
        goto rscc_Error;
     ck.ckid   := lpck^.ckid;
     ck.cksize := lpck^.cksize;
     if mmioCreateChunk(hmmioDst, @ck, 0) <> 0 then
        goto rscc_Error;
     if mmioRead(hmmioSrc, pBuf, lpck^.cksize) <> Longint(lpck^.cksize) then
        goto rscc_Error;
     if mmioWrite(hmmioDst, pBuf, lpck^.cksize) <> Longint(lpck^.cksize) then
        goto rscc_Error;
     if mmioAscend(hmmioDst, @ck, 0) <> 0 then
        goto rscc_Error;
     Result := True;
rscc_Error:
     if (pBuf <> NIL) then GlobalFreePtr(pBuf);
end;
{**************************************************************************}
function RiffCopyList(hmmioSrc,hmmioDst: THMMIO; lpck: PMMCKINFO): Boolean;
Label
   rscl_Error;
Var
   ck: TMMCKINFO;
   pBuf: PChar;
   dwCopySize: Longint;
begin
     Result := False;
     pBuf := GlobalAllocPtr(GHND,lpck^.cksize);
     if (pBuf = NIL ) then
        goto rscl_Error;
     dwCopySize := lpck^.cksize;
     { mmio leaves us after LIST ID }
     ck.ckid    := lpck^.ckid;
     ck.cksize  := dwCopySize;
     ck.fccType := lpck^.fccType;
     if mmioCreateChunk(hmmioDst, @ck, MMIO_CREATELIST) <> 0 then
	goto rscl_Error;
     { we already wrote 'LIST' ID, so reduce byte count }
     dec(dwCopySize, sizeof(FOURCC));
     if mmioRead(hmmioSrc, pBuf, dwCopySize) <> dwCopySize then
        goto rscl_Error;
     if mmioWrite(hmmioDst, pBuf, dwCopySize) <> dwCopySize then
        goto rscl_Error;
     if mmioAscend(hmmioDst, @ck, 0) <> 0 then
        goto rscl_Error;
     Result := True;
rscl_Error:
    if (pBuf <> NIL) then GlobalFreePtr(pBuf);
End;
{**************************************************************************}
function RiffInitINFO(Var lpInfo: PInfoChunk): integer;
Var
   id: Word;
   pi: PInfoData;
begin
    lpInfo := GlobalAllocPtr(GHND,sizeof(TInfoChunk));
    if (lpInfo <> Nil) then
    begin
         id := 0;
         while (aINFO[id].pFOURCC <> NIL) do
         begin
	      pI := RiffCreateINFO(0, id, 0, NIL);   { create empty INFO }
	      RiffInsertINFO(lpInfo, pI);
              inc(id);
         end;
         Result := RIFFERR_NOERROR;
    end
    else Result := RIFFERR_NOMEM;
end;
{**************************************************************************}
function RiffReadINFO(hmmio: THMMIO; lpck: PMMCKINFO; lpInfo: PInfoChunk): integer;
Var
   dwInfoSize: Longint;
begin
     Result := RIFFERR_NOERROR;
     
     dwInfoSize := lpck^.cksize - sizeof(FOURCC); { take out 'INFO' }
     if dwInfoSize > 0 then
     begin
        lpInfo^.cksize := dwInfoSize;
        lpInfo^.lpChunk := GlobalAllocPtr(GHND,dwInfoSize);
        if (lpInfo^.lpChunk <> NIL) then
        begin
           if mmioRead(hmmio, PChar(lpInfo^.lpChunk), dwInfoSize) <> dwInfoSize then
              Result := RIFFERR_FILEERROR
           else
              Result := RiffParseINFO(lpInfo);
        end
        else Result := RIFFERR_NOMEM;
     end;
end;
{**************************************************************************}
function RiffWriteINFO(hmmio: THMMIO; lpInfo: PInfoChunk): integer;
Var
   ck: TMMCKINFO;
   ckInfo: TMMCKINFO;
   pi: PInfoData;
   lpstr: PChar;
   fList: Boolean;
begin
     fList := False;
     Result := RIFFERR_BADPARAM;
     if (hmmio = 0) OR (lpInfo = Nil) then exit;
     Result := RIFFERR_FILEERROR;
     ckINFO.ckid   := mmioFOURCC('L', 'I', 'S', 'T');
     ckINFO.cksize := 0;  { mmio fill it in later }
     ckINFO.fccType:= mmioFOURCC('I', 'N', 'F', 'O');
     pI := lpInfo^.pHead;
     while (pI <> Nil) do
     begin
	  if (pI^.lpText <> Nil) then
             { Modified text }
	     lpstr := pi^.lpText
          else if (pi^.dwINFOOffset <> 0) then
	     { default text }
	     lpstr := (lpInfo^.lpChunk+pI^.dwINFOOffset)
          else
	     { no text }
	     lpstr := Nil;
          if (lpstr <> Nil) and (lpstr^ <> #0) then
          begin
	     if (Not fList) then
             begin
	        { only create if needed... }
	        if mmioCreateChunk(hmmio, @ckINFO, MMIO_CREATELIST) <> 0 then
                   exit;
		fList := True;
             end;
	     ck.ckid := mmioStringToFOURCC(aINFO[pI^.index].pFOURCC,0);
	     ck.cksize := StrLen(lpstr)+1;
	     ck.fccType := 0;
	     if mmioCreateChunk(hmmio, @ck, 0) <> 0 then
		exit;
	     if mmioWrite(hmmio, lpstr, ck.cksize) <> Longint(ck.cksize) then
		exit;
             if mmioAscend(hmmio, @ck, 0) <> 0 then
		exit;
          end;
	  pi := pi^.pnext;
     end;
     if fList then
     begin
	  if mmioAscend(hmmio, @ckINFO, 0) <> 0 then
	     exit;
     end;
     Result := RIFFERR_NOERROR;
end;
{**************************************************************************}
function RiffCopyINFO(Var lpInfoDst: PInfoChunk; lpInfoSrc: PInfoChunk): integer;
Var
   pISrc,pIDst: PInfoData;
   lpStr,pBuf: PChar;
begin
     Result := RIFFERR_BADPARAM;
     if (lpInfoSrc = Nil) or (lpInfoDst = Nil) then exit;
     pISrc := lpInfoSrc^.pHead;
     while (pISrc <> Nil) do
     begin              
	  if (pISrc^.lpText <> Nil) then
             { Modified text }
	     lpStr := piSrc^.lpText
          else if (pISrc^.wFlags <> CHUNK_MODIFIED) and (pISrc^.dwINFOOffset <> 0) then
	     { default text }
	     lpStr := (lpInfoSrc^.lpChunk+pISrc^.dwINFOOffset)
          else
	     { no text }
	     lpStr := nil;
          if (lpStr <> Nil) and (lpStr^ <> #0) then
          begin
             { the new text MUST allocated with GlobalAlloc }
             pBuf := GlobalAllocPtr(GHND,StrLen(lpStr)+1);
             piDst := RiffFindPIINFO(lpInfoDst, mmioStringToFOURCC(aINFO[pISrc^.index].pFOURCC,0));
	     RiffModifyINFO(lpInfoDst, piDst, CHUNK_MODIFIED, 0, StrCopy(pBuf,lpStr));
         end;
	 piSrc := piSrc^.pNext;
     end;
     Result := RIFFERR_NOERROR;
end;
{**************************************************************************}
procedure RiffInsertINFO(lpInfo: PInfoChunk; pInfo: PInfoData);
Var
   pi: PInfoData;
begin
     if (lpInfo = NIL) then exit;
     if (lpInfo^.pHead = NIL) then
     begin
          lpInfo^.pHead := pInfo;
	  exit;
     end;
     pi := lpInfo^.pHead;
     while (pi^.pnext <> NIL) do pi := pi^.pnext;
     { insert at end }
     pI^.pnext := pInfo;
end;
{**************************************************************************}
function RiffCreateINFO(wFlags, id: Word; dwInfoOffset: Longint; lpText: PChar): PInfoData;
Var
   pi: PInfoData;
begin
     pI := GlobalAllocPtr(GHND,sizeof(TInfoData));
     if (pI <> Nil) then
     begin
          pI^.index := id;
          pI^.wFlags := wFlags;
          pI^.dwINFOOffset := dwInfoOffset;
          pI^.lpText := lpText;
          Result := pi;
     end
     else Result := Nil;
end;
{**************************************************************************}
function RiffFindPIINFO(lpInfo: PInfoChunk; fcc: FOURCC): PInfoData;
Var
   pi: PInfoData;
begin
     pi := lpInfo^.pHead;
     while (pI <> Nil) do
     begin
	  if mmioStringToFOURCC(aINFO[pI^.index].pFOURCC,0) = fcc then
          begin
	       Result := pi;
               exit;
          end;
          pi := pi^.pnext;
     end;
     Result := Nil;
end;
{**************************************************************************}
procedure RiffModifyINFO(lpInfo: PInfoChunk;
                         pi: PInfoData;
                         wFlags: Word; dw: Longint; lpText: PChar);
begin
     if (pI = Nil) then exit;
     if (wFlags and CHUNK_MODIFIED = 0) and
        (wFlags and CHUNK_REVERT = 0) then pi^.dwINFOOffset := dw;
     if (pi^.lpText <> Nil) then
     begin
     	  if (lpText <> Nil) then
	  begin
	       if StrComp(lpText,pi^.lpText) = 0 then
               begin
	           { they are the same, don't bother changing... }
	           GlobalFreePtr(lpText);
               end
	       else
	       begin
		   GlobalFreePtr(pi^.lpText);
                   if (lpText^ <> #0) then
                   begin
                      { new text... }
                      pi^.lpText := lpText;
                      pi^.wFlags := wFlags;
                   end
                   else
                   begin
                      { new is blank, do nothing... }
                      GlobalFreePtr(lpText);
                      pi^.lpText := nil;
                      pi^.wFlags := CHUNK_REVERT;
                   end;
               end;
          end
	  else if (wFlags AND CHUNK_REVERT <> 0) then
	  begin
	       GlobalFreePtr(pi^.lpText);
	       pi^.lpText := Nil;
               pi^.wFlags := wFlags;
          end;
     end
     else if (lpText <> Nil) then
     begin
	  { if no read data, don't bother to check.... }
	  if (lpInfo^.lpChunk = Nil) or (pi^.dwINFOOffset = 0) then
	  begin
               if (lpText^ <> #0) then
               begin
                  { new text... }
                  pi^.lpText := lpText;
                  pi^.wFlags := wFlags;
               end
               else
               begin
                  { new is blank, do nothing... }
                  GlobalFreePtr(lpText);
               end;
          end
	  else if StrComp(lpText, PChar(lpInfo^.lpChunk+pI^.dwINFOOffset)) <> 0 then
	  begin
             if (lpText^ <> #0) then
             begin
                { new text... }
             	pi^.lpText := lpText;
                pi^.wFlags := wFlags;
             end
             else
             begin
                { new is blank }
                if PChar(lpInfo^.lpChunk+pI^.dwINFOOffset)^ <> #0 then
                begin
                   { original was not blank }
                   pi^.lpText := lpText;
                   pi^.wFlags := wFlags;
                end
                else
                begin
                   { do nothing }
                   GlobalFreePtr(lpText);
                end;
             end;
          end
	  else
          begin
	     { the same, don't bother... }
	     GlobalFreePtr(lpText);
          end;
     end;
end;
{**************************************************************************}
function RiffFindaINFO(fcc: FOURCC): integer;
Var
   id: Word;
begin
     id := 0;
     while aINFO[id].pFOURCC <> nil do
     begin
	  if mmioStringToFOURCC(aINFO[id].pFOURCC, 0) = fcc then
          begin
               Result := id;
               exit;
          end;
          inc(id);
     end;
     Result := -1;
end;
{**************************************************************************}
function RiffParseINFO(lpInfo: PInfoChunk): integer;
Var
   pBuf: PChar;
   dwCurInfoOffset: Longint;
   pi: PInfoData;
   lpck: PChunk;
begin
     pBuf := lpInfo^.lpChunk;
     dwCurInfoOffset := 0;
     while dwCurInfoOffset < lpInfo^.cksize do
     begin
	  lpck := PChunk(PChar(pBuf+dwCurInfoOffset));
          { dwCurInfoOffset is offset of data }
	  inc(dwCurInfoOffset, sizeof(TChunk)-1);
	  pi := RiffFindPIINFO(lpInfo, lpck^.fcc);
	  if (pi <> Nil) then
          begin
	       { modify entry to show text (data) from file... }
	       RiffModifyINFO(lpInfo, pi, 0, dwCurInfoOffset, NIL);
          end;
          { skip past data }
	  inc(dwCurInfoOffset, lpck^.cksize+(lpck^.cksize AND 1));
     end;
     Result := RIFFERR_NOERROR;
end;
{**************************************************************************}
function RiffFreeINFO(Var lpInfo: PInfoChunk): integer;
Var
    pi, pit:  PInfoData;
begin
     Result := RIFFERR_BADPARAM;
     if (lpInfo = Nil) then exit;
     if (lpInfo^.lpChunk <> Nil) then
     	GlobalFreePtr(lpInfo^.lpChunk);
     pi := lpInfo^.pHead;
     while (pi <> Nil) do
     begin
	  pit := pi;
	  pi := pi^.pnext;
          if (pit^.lpText <> nil) then GlobalFreePtr(pit^.lpText);
	  GlobalFreePtr(pit);
     end;
     GlobalFreePtr(lpInfo);
     lpInfo := NIL;
     Result := RIFFERR_NOERROR;
end;
{**************************************************************************}
function RiffInitDISP(Var lpDisp: PDispList): integer;
begin
    lpDisp := GlobalAllocPtr(GHND,sizeof(TDispList));
    if (lpDisp <> Nil) then
        Result := RIFFERR_NOERROR
    else
        Result := RIFFERR_NOMEM;
end;
{**************************************************************************}
function RiffCopyDISP(lpDispDst, lpDispSrc: PDISPList): integer;
Label
   riff_DI_Error;
var
   pdSrc,pdDst: PDisp;
   lpData: PChar;
   dwSize: Longint;
begin
   Result := RIFFERR_BADPARAM;
   if (lpDispDst = nil) or (lpDispSrc = nil) then exit;
   Result := RIFFERR_ERROR;
   pdDst := nil;
   { first remove all old 'DISP' chunks }
   if RiffFreeDISP(lpDispDst,False) <> 0 then
      goto riff_DI_Error;
   Result := RIFFERR_NOMEM;
   pdSrc := lpDispSrc^.pHead;
   while pdSrc <> nil do
   begin
      if (pdSrc^.cfid <> 0) then
      begin
         if (pdSrc^.lpChunk <> nil) or (pdSrc^.lpData <> nil) then
         begin
            if (pdSrc^.lpData <> nil) then
                { modified Data }
                lpData := pdSrc^.lpData
            else if (pdSrc^.wFlags <> CHUNK_MODIFIED) then
                { original file Data }
                lpData := pdSrc^.lpChunk
            else
                lpData := nil;
            if (lpData <> nil) and (lpData^ <> #0) then
            begin
               pdDst := RiffCreateDISP(0, pdSrc^.cfid, nil, nil);
               if (pdDst = nil) then
                   goto riff_DI_Error;
               dwSize := GlobalMemSize(lpData);
               pdDst^.lpData := GlobalAllocPtr(GHND,dwSize);
               if (pdDst^.lpData = nil) then
                  goto riff_DI_Error;
               GlobalMoveMem(lpData^,pdDst^.lpData^,dwSize);
               RiffInsertDISP(lpDispDst, pdDst);
            end;
         end;
      end;
      pdSrc := pdSrc^.pNext;
   end;
   Result := RIFFERR_NOERROR;
   exit;
riff_DI_Error:
   if (pdDst <> nil) then
   begin
      if (pdDst^.lpData <> nil) then GlobalFreePtr(pdDst^.lpData);
      GlobalFreePtr(pdDst);
   end;
end;
{**************************************************************************}
function RiffReadDISP(hmmio: THMMIO; lpck: PMMCKINFO; Var lpDisp: PDispList): integer;
Label
   riff_DI_Error;
Var
   pd: PDisp;
   dwDispSize: Longint;
begin
     Result := RIFFERR_BADPARAM;
     if (lpDisp = nil) then exit;
     Result := RIFFERR_NOMEM;
     { create empty 'DISP' }
     pd := RiffCreateDISP(0, 0, nil, nil);
     if (pd = nil) then
        goto riff_DI_Error;
     dwDispSize := lpck^.cksize - sizeof(pd^.cfid);{ take out id of Data }
     if (dwDispSize > 0) then
     begin
        pd^.lpChunk := GlobalAllocPtr(GHND,dwDispSize);
        if (pd^.lpChunk = nil) then
           goto riff_DI_Error;
        Result := RIFFERR_FILEERROR;
        if mmioRead(hmmio, PChar(@pd^.cfid), sizeof(pd^.cfid)) <> sizeof(pd^.cfid) then
           goto riff_DI_Error;
        if mmioRead(hmmio, pd^.lpChunk, dwDispSize) <> dwDispSize then
           goto riff_DI_Error;
        RiffInsertDISP(lpDisp, pd);
        Result := RIFFERR_NOERROR;
        exit;
     end;
     Result := RIFFERR_NOERROR;
riff_DI_Error:
     if (pd <> nil) then
     begin
        if (pd^.lpChunk <> nil) then GlobalFreePtr(pd^.lpChunk);
        GlobalFreePtr(pd);
     end;
end;
{**************************************************************************}
function RiffWriteDISP(hmmio: THMMIO; lpDisp: PDispList): integer;
Var
   ckDISP: TMMCKINFO;
   pData : PChar;
   pd    : PDisp;
   dwSize: Longint;
begin
     Result := RIFFERR_BADPARAM;
     if (hmmio = 0) or (lpDisp = nil) then exit;
     Result := RIFFERR_FILEERROR;
     pd := lpDisp^.pHead;
     while (pd <> nil) do
     with pd^ do
     begin
	if ((cfid = CF_DIB) or (cfid = CF_TEXT)) then
        begin
           if (lpChunk <> nil) or (lpData <> nil) then
           begin
              if (lpData <> nil) then
                  { modified Data }
                  pData := lpData
              else if (wFlags <> CHUNK_MODIFIED) then
                  { original file Data }
                  pData := lpChunk
              else
                  pData := nil;
              if (pData <> nil) and (pData^ <> #0) then
              begin
                 ckDISP.ckid   := mmioFOURCC('D', 'I', 'S', 'P');
                 ckDISP.cksize := 0;  { mmio fill it in later }
	         { create new 'DISP' chunk }
	         if mmioCreateChunk(hmmio, @ckDISP, 0) <> 0 then
                    exit;
                 dwSize := sizeOf(cfid);
                 if mmioWrite(hmmio, @cfid, dwSize) <> dwSize then
                    exit;
                 case cfid of
                   CF_TEXT: dwSize := StrLen(pData)+1;
                   CF_DIB : dwSize := DIB_SIZE(PDIB(pData));
                 end;
                 if mmioWrite(hmmio, pData, dwSize) <> dwSize then
                    exit;
                 if mmioAscend(hmmio, @ckDISP, 0) <> 0 then
		    exit;
              end;
           end;
        end;
        pd := pd^.pNext;
     end;
     Result := RIFFERR_NOERROR;
end;
{**************************************************************************}
function RiffCreateDISP(wFlags: Word; id: Longint; lpChunk, lpData: PChar): PDisp;
Var
   pd: PDisp;
begin
     pd := GlobalAllocPtr(GHND,sizeof(TDisp));
     if (pd <> Nil) then
     begin
          pd^.cfid := id;
          pd^.wFlags := wFlags;
          pd^.lpChunk := lpChunk;
          pd^.lpData := lpData;
          Result := pd;
     end
     else Result := nil;
end;
{**************************************************************************}
procedure RiffInsertDISP(lpDisp: PDispList; pd: PDisp);
Var
   pdi: PDisp;
begin
     if (lpDisp = nil) then exit;
     if (lpDisp^.pHead = nil) then
     begin
          lpDisp^.pHead := pd;
	  exit;
     end;
     pdi := lpDisp^.pHead;
     while (pdi^.pNext <> NIL) do pdi := pdi^.pNext;
     { insert at end }
     pdi^.pNext := pd;
end;
{**************************************************************************}
procedure RiffModifyDISP(lpDisp: PDispList; pd: PDisp;
                         wFlags: Word; lpData: PChar);
var
   Size: Longint;
begin
     if (pd = Nil) then exit;
     if (pd^.lpData <> Nil) then
     begin
     	  if (lpData <> Nil) then
	  begin
               Size := GlobalMemSize(lpData);
               if (Size = GlobalMemSize(pd^.lpData)) and
                   (GlobalCmpMem(lpData^,pd^.lpData^,Size) = True) then
               begin
	           { they are the same, don't bother changing... }
	           GlobalFreePtr(lpData);
               end
	       else
	       begin
		   GlobalFreePtr(pd^.lpData);
                   if (lpData^ <> #0) then
                   begin
                      { new data... }
                      pd^.lpData := lpData;
                      pd^.wFlags := wFlags;
                   end
                   else
                   begin
                      { new is blank, do nothing... }
                      GlobalFreePtr(lpData);
                      pd^.lpData := nil;
                      pd^.wFlags := CHUNK_REVERT;
                   end;
               end;
          end
	  else
          begin
	       GlobalFreePtr(pd^.lpData);
	       pd^.lpData := Nil;
               pd^.wFlags := CHUNK_REVERT;
        end;
     end
     else if (lpData <> Nil) then
     begin
	  { if no read data, don't bother to check.... }
	  if (pd^.lpChunk = Nil) then
	  begin
               if (lpData^ <> #0) then
               begin
                  { new text... }
                  pd^.lpData := lpData;
                  pd^.wFlags := wFlags;
               end
               else
               begin
                  { new is blank, do nothing... }
                  GlobalFreePtr(lpData);
               end;
          end
	  else
          begin
             Size := GlobalMemSize(lpData);
             if IsBadReadPtr(pd^.lpChunk,Size) or
                (GlobalCmpMem(lpData^, pd^.lpChunk^, Size) = False) then
	     begin
                if (lpData^ <> #0) then
                begin
                   { new data... }
                   pd^.lpData := lpData;
                   pd^.wFlags := wFlags;
                end
                else
                begin
                   { new is blank }
                   if pd^.lpChunk^ <> #0 then
                   begin
                      { original was not blank }
                      pd^.lpData := lpData;
                      pd^.wFlags := wFlags;
                   end
                   else
                   begin
                      { do nothing }
                      GlobalFreePtr(lpData);
                   end;
                end;
             end
	     else
             begin
	          { the same, don't bother... }
	          GlobalFreePtr(lpData);
             end;
          end;
     end
     else pd^.wFlags := wFlags;
end;
{**************************************************************************}
function RiffFreeDISP(Var lpDisp: PDispList; FreeList: Boolean): integer;
Var
   p,pd:  PDisp;
begin
   Result := RIFFERR_BADPARAM;
   if (lpDisp = nil) then exit;
   pd := lpDisp^.pHead;
   while (pd <> nil) do
   begin
      p := pd;
      pd := pd^.pNext;
      if (p^.lpChunk <> nil) then
      begin
         GlobalFreePtr(p^.lpChunk);
         p^.lpChunk := nil;
      end;
      if (p^.lpData <> nil) then
      begin
         GlobalFreePtr(p^.lpData);
         p^.lpData := nil;
      end;
      GlobalFreePtr(p);
   end;
   lpDisp^.pHead := nil;
   if FreeList then
   begin
      GlobalFreePtr(lpDisp);
      lpDisp := nil;
   end;
   Result := RIFFERR_NOERROR;
end;
end.

						