procedure TVideoForm.SampleGrabberBuffer(sender: TObject;
  SampleTime: Double; pBuffer: Pointer; BufferLen: Integer);
var
r: TRect;
begin
  if CallBack.Checked then
  begin

    //Image.Canvas.Lock;
    try
      SampleGrabber.GetBitmap(bmp , pBuffer, BufferLen);

      //Image.Picture.Assign(bmp);

      try
        BmpPreview.Width := 1000;
        BmpPreview.Height := 1000;

        r.Left := 0;
        r.Top := 0;
        r.Right := 1000;
        r.Bottom := 1000;

        BmpPreview.Canvas.StretchDraw(r, bmp);

        Image.Picture.Assign(BmpPreview);
      except
        on e: Exception do
          Caption := e.Message;
      end;

    finally
      //Image.Canvas.Unlock;
    end;
  end;
end;

function TSampleGrabber.GetBitmap(Bitmap: TBitmap; Buffer: Pointer; BufferLen: Integer): Boolean;
  var
    hr: HRESULT;
    BIHeaderPtr: PBitmapInfoHeader;
    MediaType: TAMMediaType;
    BitmapHandle: HBitmap;
    DIBPtr: Pointer;
    DIBSize: LongInt;
  begin
    Result := False;
    if not Assigned(Bitmap) then
      Exit;
    if Assigned(Buffer) and (BufferLen = 0) then
      Exit;
    hr := SampleGrabber.GetConnectedMediaType(MediaType);
    if hr <> S_OK then
      Exit;
    try
      if IsEqualGUID(MediaType.majortype, MEDIATYPE_Video) then
      begin
        BIHeaderPtr := Nil;
        if IsEqualGUID(MediaType.formattype, FORMAT_VideoInfo) then
        begin
          if MediaType.cbFormat = SizeOf(TVideoInfoHeader) then  // check size
            BIHeaderPtr := @(PVideoInfoHeader(MediaType.pbFormat)^.bmiHeader);
        end
        else if IsEqualGUID(MediaType.formattype, FORMAT_VideoInfo2) then
        begin
          if MediaType.cbFormat = SizeOf(TVideoInfoHeader2) then  // check size
            BIHeaderPtr := @(PVideoInfoHeader2(MediaType.pbFormat)^.bmiHeader);
        end;
        // check, whether format is supported by TSampleGrabber
        if not Assigned(BIHeaderPtr) then
          Exit;
        BitmapHandle := CreateDIBSection(0, PBitmapInfo(BIHeaderPtr)^,
                                         DIB_RGB_COLORS, DIBPtr, 0, 0);
        if BitmapHandle <> 0 then
        begin
          try
            if DIBPtr = Nil then
              Exit;
            // get DIB size
            DIBSize := BIHeaderPtr^.biSizeImage;
            if DIBSize = 0 then
            begin
              with BIHeaderPtr^ do
                DIBSize := GetDIBLineSize(biBitCount, biWidth) * biHeight * biPlanes;
            end;
            // copy DIB
            if not Assigned(Buffer) then
            begin
              // get buffer size
              BufferLen := 0;
              hr := SampleGrabber.GetCurrentBuffer(BufferLen, Nil);
              if (hr <> S_OK) or (BufferLen <= 0) then
                Exit;
              // copy buffer to DIB
              if BufferLen > DIBSize then  // copy Min(BufferLen, DIBSize)
                BufferLen := DIBSize;
              hr := SampleGrabber.GetCurrentBuffer(BufferLen, DIBPtr);
              if hr <> S_OK then
                Exit;
            end
            else
            begin
              if BufferLen > DIBSize then  // copy Min(BufferLen, DIBSize)
                BufferLen := DIBSize;
              Move(Buffer^, DIBPtr^, BufferLen);
            end;
            Bitmap.Handle := BitmapHandle;
            Result := True;
          finally
            if Bitmap.Handle <> BitmapHandle then  // preserve for any changes in Graphics.pas
              DeleteObject(BitmapHandle);
          end;
        end;
      end;
    finally
      FreeMediaType(@MediaType);
    end;
  end;

function TSampleGrabber.BufferCB(SampleTime: Double; pBuffer: PByte;
    BufferLen: Integer): HResult;
  begin
    if assigned(FOnBuffer) then
    begin
      FCriticalSection.Enter;
      try
        FOnBuffer(self, SampleTime, pBuffer, BufferLen);
      finally
        FCriticalSection.Leave;
      end;
    end;
    result := S_OK;
  end;

Move(Buffer^, DIBPtr^, BufferLen);