(*//

标题:制作三维立体画

说明:再老也算是个函数吧

设计:Zswang

日期:2002-01-26

支持:wjhu111@21cn.com

//*)

///////Begin Source

type

 TRecordLevel = record

   rColor: TColor;

   rLevel: Byte;

 end;

procedure Picture3D(mBitmap3D, mBitmap2D, mBitmapMask: TBitmap;

 mLevelList: array of TRecordLevel); { 制作三维立体画 }

var

 X, Y, I, J, W: Integer;

 vColor: TColor;

begin

 mBitmap3D.Assign(nil);

 W := mBitmapMask.Width;

 mBitmap3D.Width := W * Succ(mBitmap2D.Width div W);

 mBitmap3D.Height := mBitmap2D.Height;

 mBitmap3D.Canvas.Draw(0, 0, mBitmapMask);

 for I := 0 to (mBitmap2D.Width div W) do begin

   for Y := 0 to mBitmapMask.Height - 1 do begin

     for X := 0 to Pred(W) do begin

       vColor := mBitmap2D.Canvas.Pixels[X + W * I, Y];

       for J := Low(mLevelList) to High(mLevelList) do

         if mLevelList[J].rColor = vColor then begin

           if X + mLevelList[J].rLevel >= W then

             mBitmapMask.Canvas.Pixels[X, Y]

               := mBitmapMask.Canvas.Pixels[X + mLevelList[J].rLevel - W, Y]

           else

             mBitmapMask.Canvas.Pixels[X, Y]

               := mBitmapMask.Canvas.Pixels[X + mLevelList[J].rLevel, Y];

           Break;

         end;

     end;

   end;

   mBitmap3D.Canvas.Draw(W * Succ(I), 0, mBitmapMask);

 end;

end; { Picture3D }

///////End Source

///////Begin Demo

const

 cLevelCount = 6;

 cLevelList: array[0 .. Pred(cLevelCount)] of TRecordLevel =

(

(rColor: clWhite;  rLevel: 0),

(rColor: clRed;    rLevel: 1),

(rColor: clBlue;   rLevel: 2),

(rColor: clYellow; rLevel: 3),

(rColor: clGreen;  rLevel: 4),

(rColor: clBlack;  rLevel: 5)

);

procedure TForm1.Button1Click(Sender: TObject);

begin

 Picture3D(Image3D.Picture.Bitmap, Image2D.Picture.Bitmap,

   ImageMask.Picture.Bitmap, cLevelList);

end;

///////End Demo

**********************************************

(*//

标题:制作红绿眼镜三维立体画

说明:算法虽然简单,但回味无穷;特别致谢Kiss2提出这个问题

设计:Zswang

日期:2002-04-05

支持:wjhu111@21cn.com

//*)

///////Begin Source

function RedGreen3D(mBitmapLeft: TBitmap; mBitmapRight: TBitmap;

 mBitmap3D: TBitmap): Boolean;

var

 vRect: TRect;

 vGreen, vRed: TColor;

begin

 Result := False;

 if not Assigned(mBitmapLeft) then Exit;

 if not Assigned(mBitmapRight) then Exit;

 if not Assigned(mBitmap3D) then Exit;

 vRed := clRed;

 vGreen := vRed xor $FFFFFF;

 try

   mBitmap3D.Width := mBitmapLeft.Width;

   mBitmap3D.Height := mBitmapLeft.Height;

   vRect := Rect(0, 0, mBitmap3D.Width, mBitmap3D.Height);

   mBitmap3D.Canvas.Brush.Color := vGreen;

   mBitmap3D.Canvas.FillRect(vRect);

   mBitmapLeft.Canvas.CopyMode := cmSrcPaint;

   mBitmapLeft.Canvas.CopyRect(vRect, mBitmap3D.Canvas, vRect);

   mBitmap3D.Canvas.Brush.Color := vRed;

   mBitmap3D.Canvas.FillRect(vRect);

   mBitmapRight.Canvas.CopyMode := cmSrcPaint;

   mBitmapRight.Canvas.CopyRect(vRect, mBitmap3D.Canvas, vRect);

   mBitmap3D.Canvas.CopyRect(vRect, mBitmapLeft.Canvas, vRect);

   mBitmap3D.Canvas.CopyMode := cmSrcAnd;

   mBitmap3D.Canvas.CopyRect(vRect, mBitmapRight.Canvas, vRect);

 except

   Exit;

 end;

 Result := True;

end; { RedGreen3D }

///////End Source

///////Begin Demo

procedure TForm1.Button1Click(Sender: TObject);

begin

//Image1左眼视角位图

//Image2右眼视角位图

//Image3三维立体位画

 RedGreen3D(Image1.Picture.Bitmap, Image2.Picture.Bitmap, Image3.Picture.Bitmap);

end;

///////End Demo