Results 1 to 3 of 3

Thread: Plaatjes manipuleren, waaronder roteren

  1. #1
    Yay: Student(je) af
    Join Date
    Jun 2003
    Location
    Harderwijk
    Posts
    2,621

    Plaatjes manipuleren, waaronder roteren

    Het komt wel eens voor dat je een bitmap moet roteren of bv. faden. Helaas heeft TBitmap hier geen method voor. Laat ik nu de volgende code op internet vinden:
    Code:
    unit Images;
    // Bron: http://www.codebase.nl/index.php/command/viewcode/id/28
    interface
    
    uses
      Windows, SysUtils, Graphics, Classes, Colors;
    
    const
      MaxPixelCount = 32768;
    
    type
      TRGBTripleArray = array[0..MaxPixelCount-1] of tagRGBTriple;
      pRGBTripleArray = ^TRGBTripleArray;
    
    procedure RotateBitmap(Bitmap: TBitmap; AngleOfRotation: Double);
    procedure DissolveBitmap(Bitmap: TBitmap; DissolvePixels: Integer);
    procedure AlphaBlendBitmaps(Bitmap: TBitmap; Bmp1, Bmp2: TBitmap; R: TRect; Opacity: Integer);
    procedure FadeText(Bitmap: TBitmap; S1, S2: String; FromCanvas: TCanvas; Opacity: Integer);
    
    implementation
    
    procedure RotateBitmap(Bitmap: TBitmap; AngleOfRotation: Double);
    var
      Theta, CosTheta, SinTheta: Extended;
      I, IOriginal, IPrime, IPrimeRotated, IRotationAxis,
      J, JOriginal, JPrime, JPrimeRotated, JRotationAxis,
      oW, oH, nW, nH: Integer;
      RowOriginal: pRGBTripleArray;
      RowRotated: pRGBTRipleArray;
      Tmp: TBitmap;
    begin
      Tmp := TBitmap.Create;
      nW := 0;
      nH := 0;
      try
        Theta := -AngleOfRotation * (Pi / 180);
        CosTheta := Cos(Theta);
        SinTheta := Sin(Theta);
        oW := Bitmap.Width;
        oH := Bitmap.Height;
        nW := Abs(Round(oW * SinTheta)) + Abs(Round(oW * CosTheta));
        nH := Abs(Round(oH * SinTheta)) + Abs(Round(oH * CosTheta));
        Tmp := TBitmap.Create;
        Tmp.Width := nW;
        Tmp.Height := nH;
        Tmp.PixelFormat := pf24bit;
        IRotationAxis := oW div 2;
        JRotationAxis := oH div 2;
        for j := nW-1 downto 0 do begin
          RowRotated  := Tmp.Scanline[J];
          JPrime := 2 * (J - (nW - oW) div 2 - JRotationAxis) + 1;
          for i := nH-1 downto 0 do begin
            IPrime := 2 * (I - (nH - oH) div 2 - IRotationAxis) + 1;
            IPrimeRotated := Round(iPrime * CosTheta - jPrime * sinTheta);
            JPrimeRotated := Round(iPrime * sinTheta + jPrime * cosTheta);
            IOriginal := (IPrimeRotated - 1) div 2 + IRotationAxis;
            JOriginal := (JPrimeRotated - 1) div 2 + JRotationAxis;
            if (IOriginal >= 0) and (IOriginal <= Bitmap.Width-1) and (JOriginal >= 0) and (JOriginal <= Bitmap.Height-1) then begin
              RowOriginal := Bitmap.Scanline[JOriginal];
              RowRotated[I] := RowOriginal[IOriginal]
            end
            else begin
              with RowRotated[I] do begin
                rgbtBlue := 255;
                rgbtGreen := 0;
                rgbtRed := 0;
              end;
            end;
          end;
        end;
      finally
        Bitmap.Width := nW;
        Bitmap.Height := nH;
        Bitmap.Canvas.Draw(0,0,Tmp);
        Tmp.Free;
      end;
    end;
    
    procedure DissolveBitmap(Bitmap: TBitmap; DissolvePixels: Integer);
    var
      C: Integer;
      T: tagRGBTriple;
      W, H: Integer;
    
      procedure DissolvePixel(X, Y: Integer);
    
        procedure SetRow(Row: Integer);
    
          function Check(Max, Int: Integer): Integer;
          begin
            if Int < 0 then Result := Max-(-Int)-1
            else if Int > Max-1 then Result := Int-Max
            else Result := Int;
          end;
    
          procedure SetCol(Col: Integer);
          begin
            with Bitmap do TRGBTripleArray(Scanline[(Check(H,(Y-Random(5))+Random(2)+Col))]^)[(Check(W,(X-Random(5))+Random(2)))+Row] := T;
          end;
    
        begin
          SetCol(0);
          SetCol(1);
          SetCol(2);
          SetCol(3);
        end;
    
      begin
        T := TRGBTripleArray(Bitmap.Scanline[Y]^)[X];
        SetRow(0);
        SetRow(1);
        SetRow(2);
        SetRow(3);
      end;
    
    var
      X, Y: Integer;
    begin
      C := 0;
      if DissolvePixels > 0 then begin
        repeat
          Inc(C);
          W := Bitmap.Width;
          H := Bitmap.Height;
          X := Random(W);
          Y := Random(H);
          if X = 0 then X := 1
          else if X = W then X := W-1;
          if Y = 0 then Y := 1
          else if Y = H then Y := H-1;
          DissolvePixel(X,Y);
        until C = DissolvePixels;
      end;
    end;
    
    procedure AlphaBlendBitmaps(Bitmap: TBitmap; Bmp1, Bmp2: TBitmap; R: TRect; Opacity: Integer);
    var
      X, Y: Integer;
      ScanLn1, ScanLn2: PRGBTripleArray;
      Tmp: TBitmap;
    begin
      Tmp := TBitmap.Create;
      try
        Bitmap.Width := R.Right - R.Left;
        Bitmap.Height := R.Bottom - R.Top;
        Bitmap.PixelFormat := pf24Bit;
        Tmp.Width := Bitmap.Width;
        Tmp.Height := Bitmap.Height;
        Tmp.PixelFormat := pf24Bit;
        Bitmap.Canvas.CopyRect(Rect(0,0,Bitmap.Width,Bitmap.Height),Bmp1.Canvas,R);
        Tmp.Canvas.CopyRect(Rect(0,0,Bitmap.Width,Bitmap.Height),Bmp2.Canvas,R);
        for Y := 0 to Bitmap.Height-1 do begin
          ScanLn1 := Bitmap.Scanline[Y];
          ScanLn2 := Tmp.Scanline[Y];
          for X := 0 to Bitmap.Width-1 do begin
            with ScanLn1[X] do begin
              rgbtBlue := ((255 - Opacity) * (rgbtBlue - ScanLn2[X].rgbtBlue)) div 255 + ScanLn2[X].rgbtBlue;
              rgbtGreen := ((255 - Opacity) * (rgbtGreen - ScanLn2[X].rgbtGreen)) div 255 + ScanLn2[X].rgbtGreen;
              rgbtRed := ((255 - Opacity) * (rgbtRed - ScanLn2[X].rgbtRed)) div 255 + ScanLn2[X].rgbtRed;
            end;
          end;
        end;
      finally
        Tmp.Free;
      end;
    end;
    
    procedure FadeText(Bitmap: TBitmap; S1, S2: String; FromCanvas: TCanvas; Opacity: Integer);
    var
      Bmp1: TBitmap;
      Bmp2: TBitmap;
      T1, T2, H: Integer;
    begin
      Bmp1 := TBitmap.Create;
      Bmp2 := TBitmap.Create;
      try
        with Bmp1.Canvas do begin
          Font.Assign(FromCanvas.Font);
          Brush.Color := FromCanvas.Brush.Color;
          Pen.Color := FromCanvas.Pen.Color;
        end;
        with Bmp2.Canvas do begin
          Font.Assign(FromCanvas.Font);
          Brush.Color := FromCanvas.Brush.Color;
          Pen.Color := FromCanvas.Pen.Color;
        end;
        T1 := Bmp1.Canvas.TextWidth(S1);
        T2 := Bmp2.Canvas.TextWidth(S2);
        H := Bmp1.Canvas.TextHeight(S1);
        Bmp1.Height := H;
        Bmp2.Height := H;
        if T1 > T2 then begin
          Bmp1.Width := T1;
          Bmp2.Width := T1;
        end
        else begin
          Bmp1.Width := T2;
          Bmp2.Width := T2;
        end;
        Bmp1.Canvas.FillRect(Rect(0,0,Bmp1.Width,Bmp1.Height));
        Bmp2.Canvas.FillRect(Rect(0,0,Bmp2.Width,Bmp2.Height));
        Bmp1.Canvas.TextOut(0,0,S1);
        Bmp2.Canvas.TextOut(0,0,S2);
        AlphaBlendBitmaps(Bitmap, Bmp1, Bmp2, Rect(0,0,Bmp1.Width,Bmp1.Height), Opacity);
      finally
        Bmp1.Free;
        Bmp2.Free;
      end;
    end;
    Gratis code
    En dit is de bron

    In de hoop dat iemand er iets aan heeft.
    My software never contains bugs. Perhaps just undocumented features.

  2. #2
    Zo zie je maar weer dat onvoldoende uitleg toch nog mooie dingen kan opleveren ...... toch
    De beste manier om te leren is door fouten te maken.
    80 procent van alle leugens die jij en ik vertellen blijft onopgemerkt

  3. #3
    Yay: Student(je) af
    Join Date
    Jun 2003
    Location
    Harderwijk
    Posts
    2,621
    Inderdaad
    My software never contains bugs. Perhaps just undocumented features.

Thread Information

Users Browsing this Thread

There are currently 1 users browsing this thread. (0 members and 1 guests)

Similar Threads

  1. Library openen en stretchen plaatjes
    By MisterE in forum Algemeen
    Replies: 5
    Last Post: 04-May-05, 08:03
  2. Plaatjes als TBitmap
    By bramdejonge in forum Algemeen
    Replies: 11
    Last Post: 31-Oct-04, 21:04
  3. probleem met aanmaken van plaatjes
    By bstienen in forum Algemeen
    Replies: 20
    Last Post: 13-May-04, 10:49
  4. Replies: 11
    Last Post: 12-Sep-03, 17:06
  5. Replies: 7
    Last Post: 19-May-02, 10:45

Bookmarks

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •