Public Sub SaveFrameAs1bppTIFF( _
 ByVal FileName As String, _
 Optional ByVal nFrame As Long = 0, _
 Optional ByVal DpiX As Single = 0, Optional ByVal DpiY As Single = 0, _
 Optional ByVal dHeightScale As Double = 1, Optional ByVal eTifCompression As TifCompressionType = TiffCompressionNone)
  Dim nSrcWidth As Long
  Dim nSrcHeight As Long
  Dim bmiDst As BITMAPINFO2
  Dim pBits As Long
  Dim hbmDst As Long
  Dim picSrc As IPictureDisp
  Dim hdcDst As Long
  Dim hbmOldDst As Long
  Dim nBitmap As Long
  Dim EncoderCLSID As GUID
  Dim uEncParams  As EncoderParameters
 
  nSrcWidth = FrameWidth(nFrame)
  nSrcHeight = FrameHeight(nFrame)
  With bmiDst.bmiHeader
    .biSize = LenB(bmiDst.bmiHeader)
    .biWidth = nSrcWidth
    .biHeight = nSrcHeight * dHeightScale
    .biPlanes = 1
    .biBitCount = 1
    .biCompression = BI_RGB
  End With
  With bmiDst.bmiColors(1)
    .rgbBlue = 255
    .rgbGreen = 255
    .rgbRed = 255
  End With
  hbmDst = CreateDIBSection(0, bmiDst, DIB_RGB_COLORS, pBits, 0, 0)
 
  hdcDst = CreateCompatibleDC(0)
  hbmOldDst = SelectObject(hdcDst, hbmDst)
 
  Set picSrc = Frame(nFrame)
  picSrc.Render CLng(hdcDst), 0&, CLng(nSrcHeight * dHeightScale), _
   CLng(nSrcWidth), CLng(-nSrcHeight * dHeightScale), _
   0&, 0&, CLng(picSrc.Width), CLng(picSrc.Height), ByVal 0&
  Set picSrc = Nothing
 
  SelectObject hdcDst, hbmOldDst: hbmOldDst = 0
  DeleteDC hdcDst: hdcDst = 0
 
  If GdipExec(GdipCreateBitmapFromGdiDib(bmiDst, pBits, nBitmap)) = OK Then
    If (DpiX > 0) And (DpiY > 0) Then _
     GdipExec GdipBitmapSetResolution(nBitmap, DpiX, DpiY)
       
    'Установка качества
    uEncParams.count = 1
    With uEncParams.Parameter
      ' Setzen der Kompression GUID
      CLSIDFromString StrPtr(EncoderCompression), .GUID
      .NumberOfValues = 1
      .type = [EncoderParameterValueTypeLong]
      .Value = VarPtr(eTifCompression)
    End With
       
    If GetEncoderClsid("image/tiff", EncoderCLSID) >= 0 Then _
     GdipExec GdipSaveImageToFile(nBitmap, StrPtr(FileName), EncoderCLSID, _
     uEncParams)
    GdipExec GdipDisposeImage(nBitmap): nBitmap = 0
  End If
 
  DeleteObject hbmDst: hbmDst = 0: pBits = 0
End Sub

Public Property Get Frame(Optional ByVal nFrame As Long = 0) As IPictureDisp
  Dim hBitmap As Long
  Dim nActiveFrame As Long
  If nFrame = 0 Then
    If m_nBitmap Then
      If GdipExec(GdipCreateHBITMAPFromBitmap(m_nBitmap, hBitmap, 0)) = OK Then
        Set Frame = CreateIPictureDispFromHBITMAP(hBitmap)
      End If
    End If
  ElseIf (nFrame > 0) And (nFrame <= FrameCount) Then
    nActiveFrame = frameIndex
    frameIndex = nFrame
    If GdipExec(GdipCreateHBITMAPFromBitmap(m_nBitmap, hBitmap, 0)) = OK Then
      Set Frame = CreateIPictureDispFromHBITMAP(hBitmap)
    End If
    frameIndex = nActiveFrame
  Else
    Err.Raise 9
  End If
End Property

  Public Sub SaveFrameAs1bppTIFF( _
   ByVal FileName As String, _
   Optional ByVal nFrame As Integer = 0, _
   Optional ByVal DpiX As Single = 0, Optional ByVal DpiY As Single = 0, _
   Optional ByVal dHeightScale As Double = 1, _
   Optional ByVal eTifCompression As EncoderValue = EncoderValue.CompressionNone)
    Dim nSrcWidth As Integer
    Dim nSrcHeight As Integer
    Dim bmiDst As BITMAPINFO2
    Dim pBits As Integer
    Dim hbmDst As IntPtr
    Dim bitmapSrc As Bitmap
    Dim hdcDst As IntPtr
    Dim hbmOldDst As IntPtr
    Dim nBitmap As Bitmap

    nSrcWidth = FrameWidth(nFrame)
    nSrcHeight = FrameHeight(nFrame)

    With bmiDst.bmiHeader
      .biSize = Marshal.SizeOf(bmiDst.bmiHeader)
      .biWidth = nSrcWidth
      .biHeight = CInt(nSrcHeight * dHeightScale)
      .biPlanes = 1
      .biBitCount = 1
      .biCompression = BI_RGB
    End With
    With bmiDst.bmiColors1
      .rgbBlue = 255
      .rgbGreen = 255
      .rgbRed = 255
    End With
    hbmDst = CreateDIBSection(IntPtr.Zero, bmiDst, DIB_RGB_COLORS, pBits, IntPtr.Zero, 0)

    hdcDst = CreateCompatibleDC(IntPtr.Zero)
    hbmOldDst = SelectObject(hdcDst, hbmDst)

    bitmapSrc = Frame(nFrame)
    If Not bitmapSrc Is Nothing Then
      Using gr As Graphics = Graphics.FromHdc(hdcDst)
        gr.DrawImage(bitmapSrc, 0, 0, nSrcWidth, CInt(nSrcHeight * dHeightScale))
      End Using
      bitmapSrc.Dispose()
    End If

    SelectObject(hdcDst, hbmOldDst) : hbmOldDst = IntPtr.Zero
    DeleteDC(hdcDst) : hdcDst = IntPtr.Zero

    Try
      nBitmap = Bitmap.FromHbitmap(hbmDst)
      If (DpiX > 0) And (DpiY > 0) Then nBitmap.SetResolution(DpiX, DpiY)

      'http://stackoverflow.com/questions/21169217/tiff-file-compression-with-c-sharp
      ' Get an ImageCodecInfo object that represents the TIFF codec.
      Dim myImageCodecInfo As ImageCodecInfo = GetEncoderInfo("image/tiff")
      ' Create an Encoder object based on the GUID for the Compression parameter category.
      Dim myEncoder As Encoder = Encoder.Compression
      ' Create an EncoderParameters object. An EncoderParameters object has an array of EncoderParameter 
      ' objects. In this case, there is only one EncoderParameter object in the array.
      Dim myEncoderParameters As EncoderParameters = New EncoderParameters(1)
      ' Save the bitmap as a TIFF file with eTifCompression compression.
      Dim myEncoderParameter As EncoderParameter = New EncoderParameter(myEncoder, Fix(eTifCompression))
      myEncoderParameters.Param(0) = myEncoderParameter
      nBitmap.Save(FileName, myImageCodecInfo, myEncoderParameters)
      nBitmap.Dispose() : nBitmap = Nothing
    Catch
    End Try

    DeleteObject(hbmDst) : hbmDst = IntPtr.Zero : pBits = 0
  End Sub

  Public ReadOnly Property Frame(Optional ByVal nFrame As Integer = 0) As Bitmap
    Get
      Dim nActiveFrame As Integer
      Frame = Nothing
      If nFrame = 0 Then
        If Not m_Bitmap Is Nothing Then
          Try : Frame = New Bitmap(m_Bitmap) : Catch : End Try
        End If
      ElseIf (nFrame > 0) And (nFrame <= FrameCount) Then
        nActiveFrame = frameIndex
        frameIndex = nFrame
        Try : Frame = New Bitmap(m_Bitmap) : Catch : End Try
        frameIndex = nActiveFrame
      End If
    End Get
  End Property