Private Sub Command1_Click()
   Dim Img 'As ImageFile
    Dim IP 'As ImageProcess

    Set Img = CreateObject("WIA.ImageFile")
    Set IP = CreateObject("WIA.ImageProcess")

    Img.LoadFile "test.tif"

    While (IP.Filters.Count >  0 )
        IP.Filters.Remove  1 
    Wend
    IP.Filters.Add IP.FilterInfos("Convert").FilterID
    IP.Filters( 1 ).Properties("FormatID").Value = wiaFormatBMP
    Set Img = IP.Apply(Img)

    Img.SaveFile "test.bmp"
End Sub

Private Sub Command1_Click()
    Dim w As Integer, h As Integer
    Dim Img As ImageFile
    Dim IP As ImageProcess

    Set Img = CreateObject("WIA.ImageFile")
    Set IP = CreateObject("WIA.ImageProcess")

    Img.LoadFile "test.tif"
    w = Img.Width
    h = Img.Height
    MsgBox Img.PixelDepth 'дает 1
    
    While (IP.Filters.Count >  0 )
        IP.Filters.Remove  1 
    Wend
    IP.Filters.Add IP.FilterInfos("Scale").FilterID
    IP.Filters( 1 ).Properties( 1 ).Value = w 'ширина
    If Img.VerticalResolution <  110  Then '204х98
        IP.Filters( 1 ).Properties( 2 ).Value = h *  2  'высота
    Else '204х196
        IP.Filters( 1 ).Properties( 2 ).Value = h 'высота
    End If
    IP.Filters( 1 ).Properties( 3 ).Value = False
    Set Img = IP.Apply(Img)
    MsgBox Img.PixelDepth '32 о-па!!!

    While (IP.Filters.Count >  0 )
        IP.Filters.Remove  1 
    Wend
    IP.Filters.Add IP.FilterInfos("Convert").FilterID
    IP.Filters( 1 ).Properties("FormatID").Value = wiaFormatBMP
    'IP.Filters(1).Properties("FormatID").Value = wiaFormatJPEG
    'IP.Filters(1).Properties("Quality").Value = 1
    Set Img = IP.Apply(Img)

    Img.SaveFile "test.bmp"
End Sub

While (IP.Filters.Count >  0 )
 IP.Filters.Remove  1 
Wend
IP.Filters.Add IP.FilterInfos("Convert").FilterID
IP.Filters( 1 ).Properties("FormatID").Value = wiaFormatGIF
Set Img = IP.Apply(Img)

Private Sub ConvertToBMP_GDI(startFile As String, targetFileName As String)\n    Dim w As Integer, h As Integer\n    Dim Img \'As ImageFile\n    Dim Img1 \'As ImageFile\n    Dim IP \'As ImageProcess\n    Dim i As Integer\n    Dim rezult\n    Dim tmpTarget As String\n    Dim tmpTargetTemp As String\n    Dim SrcPic As StdPicture, DstPic As StdPicture\n    \n    If Len(Dir(startFile)) =  0  Then Exit Sub\n    Set Img = CreateObject("WIA.ImageFile")\n    Set IP = CreateObject("WIA.ImageProcess")\n    Img.LoadFile startFile\n    For i =  1  To Img.FrameCount\n        DoEvents\n        While (IP.Filters.Count >  0 )\n            IP.Filters.Remove  1 \n        Wend\n        IP.Filters.Add IP.FilterInfos("Convert").FilterID\n        IP.Filters( 1 ).Properties("FormatID").Value = wiaFormatBMP\n        Img.ActiveFrame = i\n        Set Img1 = IP.Apply(Img)\n        If Img.FrameCount >  1  Then\n            tmpTarget = Left(targetFileName, InStr(targetFileName, ".bmp") -  1 ) & " (page " & i & ").bmp"\n            If Len(Dir(tmpTarget)) >  0  Then\n                rezult = MsgBox("File exists. Overwrite?", vbYesNo + vbExclamation, "Warning")\n                If rezult = vbNo Then GoTo NotChangeBMP\n                DeleteFile tmpTarget\n            End If\n            On Error Resume Next\n            If Img1.VerticalResolution <  110  Then \'204х98\n                tmpTargetTemp = Left(tmpTarget, Len(tmpTarget) -  3 ) & "tmp" \'*.tmp\n                If Len(Dir(tmpTargetTemp)) >  0  Then\n                    DeleteFile tmpTargetTemp\n                End If\n                Img1.SaveFile tmpTargetTemp\n                Set SrcPic = LoadPicture(tmpTargetTemp)\n                Set DstPic = FitToSizeBitmap(SrcPic.Handle,  2 ) \'модифицирована,растягивает в 2р.по вертикали\n                SavePictureToBMP DstPic, tmpTarget\n                DeleteFile tmpTargetTemp\n            Else\n                Img1.SaveFile tmpTarget\n            End If\n        Else\n            If Len(Dir(targetFileName)) >  0  Then\n                rezult = MsgBox("File exists. Overwrite?", vbYesNo + vbExclamation, "Warning")\n                If rezult = vbNo Then GoTo NotChangeBMP\n                DeleteFile targetFileName\n            End If\n            On Error Resume Next\n            If Img1.VerticalResolution <  110  Then \'204х98\n                tmpTargetTemp = Left(targetFileName, Len(targetFileName) -  3 ) & "tmp" \'*.tmp\n                If Len(Dir(tmpTargetTemp)) >  0  Then\n                    DeleteFile tmpTargetTemp\n                End If\n                Img1.SaveFile tmpTargetTemp\n                Set SrcPic = LoadPicture(tmpTargetTemp)\n                Set DstPic = FitToSizeBitmap(SrcPic.Handle,  2 ) \'модифицирована,растягивает в 2р.по вертикали\n                SavePictureToBMP DstPic, targetFileName\n                DeleteFile tmpTargetTemp\n            Else\n                Img1.SaveFile targetFileName\n            End If\n        End If\nNotChangeBMP:\n    Next i\n    Set Img = Nothing\n    Set Img1 = Nothing\n    Set IP = Nothing\nEnd Sub

Private Sub Command1_Click()
Dim hndl As Long
 m_mfi.LoadFromFile "test.tif"
 hndl = m_mfi.Frame1bppL( 1 ,  0 ,  0 ,  2 )
 MsgBox hndl
 SaveHBitmapToBMP hndl, "new.bmp"
End Sub

Public Function SavePictureToBMP( _
   Picture As StdPicture, FileName As String) As Boolean

Public Function SaveHBitmapToBMP( _
   hImg As Long, FileName As String) As Boolean
 Dim gplRet      As Long
  Dim uEncCLSID   As CLSID
 Dim uEncParams  As EncoderParameters

 Dim GpInput As GdiplusStartupInput
 GpInput.GdiplusVersion =  1 
    GetEncoderClsID "image/bmp", uEncCLSID 'image/png","image/gif"...
    gplRet = GdipSaveImageToFile(hImg, StrPtr(FileName), uEncCLSID, Null)
    SaveHBitmapToBMP = gplRet = [OK]
    gplRet = GdipDisposeImage(hImg)
 
 GdiplusShutdown GdIHandle
End Function

Private Type CLSID 'частный вид GUID-а
   Data1         As Long
   Data2         As Integer
   Data3         As Integer
   Data4( 0  To  7 ) As Byte
End Type
Private Enum EncoderParameterValueType
   [EncoderParameterValueTypeByte] =  1 
   [EncoderParameterValueTypeASCII] =  2 
   [EncoderParameterValueTypeShort] =  3 
   [EncoderParameterValueTypeLong] =  4 
   [EncoderParameterValueTypeRational] =  5 
   [EncoderParameterValueTypeLongRange] =  6 
   [EncoderParameterValueTypeUndefined] =  7 
   [EncoderParameterValueTypeRationalRange] =  8 
End Enum

Private Type EncoderParameter
   GUID           As CLSID
   NumberOfValues As Long
   Type           As EncoderParameterValueType
   Value          As Long
End Type

Private Type EncoderParameters
   Count     As Long
   Parameter As EncoderParameter
End Type
Public Sub SaveFrameAs1bppJPEG( _
   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 JPGQuality As Long =  100 )
 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)
       
 If JPGQuality >  100  Then JPGQuality =  100 
 If JPGQuality <  1  Then JPGQuality =  1 
    'Установка качества
    uEncParams.Count =  1 
    With uEncParams.Parameter
       .NumberOfValues =  1 
       .Type = [EncoderParameterValueTypeLong]
       With .GUID
          .Data1 = &H1D5BE4B5
          .Data2 = &HFA4A
          .Data3 = &H452D
          .Data4( 0 ) = &H9C
          .Data4( 1 ) = &HDD
          .Data4( 2 ) = &H5D
          .Data4( 3 ) = &HB3
          .Data4( 4 ) = &H51
          .Data4( 5 ) = &H5
          .Data4( 6 ) = &HE7
          .Data4( 7 ) = &HEB
       End With
       'CLSIDFromString StrPtr(EncoderQuality), .GUID
       .Value = VarPtr(JPGQuality)
    End With
       
    If GetEncoderClsID("image/jpeg", 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 Sub SaveFrameAs1bppBMP( _
...
       GdipExec GdipBitmapSetResolution(nBitmap, DpiX, DpiY)
    'If GetEncoderClsID("image/bmp", EncoderCLSID) > 0 Then
    GetEncoderClsID "image/bmp", EncoderCLSID
       GdipExec GdipSaveImageToFile(nBitmap, StrPtr(FileName), EncoderCLSID, _
                                    ByVal  0 &)
...

Public Sub SaveMultiFrameAs1bppTIFF( _
   ByVal FileName As String, _
   Optional ByVal startFrame As Long =  0 , Optional ByVal endFrame 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 EncoderParameters1
 Dim paramValue As Long
 Dim i As Long
 
 Dim startF As Long
 Dim endF As Long
 If (startFrame =  0 ) Or (startFrame > FrameCount) Then
    startF =  1 
 Else
    startF = startFrame
 End If
 If (endFrame =  0 ) Or (endFrame > FrameCount) Then
    endF = FrameCount
 ElseIf (endFrame < startF) Then
    endF = startF
 Else
    endF = endFrame
 End If
 
     '// Ermitteln der CLSID vom mimeType Encoder
    Call GetEncoderClsID("image/tiff", EncoderCLSID)
    
    ' Initialisieren der Encoderparameter
    uEncParams.Count =  2 
    With uEncParams.Parameter1( 0 ) ' Tiff Kompression
        ' Setzen der Kompression GUID
        CLSIDFromString StrPtr(EncoderCompression), .GUID
        .NumberOfValues =  1 
        .Type = [EncoderParameterValueTypeLong]
        .Value = VarPtr(eTifCompression)
    End With
    
    With uEncParams.Parameter1( 1 ) ' EncoderSaveFlag
        ' Setzen der EncoderSave GUID
        CLSIDFromString StrPtr(EncoderSaveFlag), .GUID
        .NumberOfValues =  1 
        .Type = [EncoderParameterValueTypeLong]
        .Value = VarPtr(paramValue)
    End With

 ReDim nBitmap(startF To endF)
 
 For i = startF To endF
    nSrcWidth = FrameWidth(i)
    nSrcHeight = FrameHeight(i)
    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(i)
    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(i))) = OK Then
        If (DpiX >  0 ) And (DpiY >  0 ) Then _
            GdipExec GdipBitmapSetResolution(nBitmap(i), DpiX, DpiY)
            
            
             If i = startF Then
                ' erstes Bild als Tiff speichern
                paramValue = EncoderValueMultiFrame
                If GdipExec(GdipSaveImageToFile(nBitmap(startF), _
                                               StrPtr(FileName), _
                                               EncoderCLSID, _
                                               uEncParams)) <> OK Then
                    GoTo DelObj 'Exit For
                End If
            Else
                ' weitere Bilder in Tiff(lBitmap(0)) hinzufьgen
                paramValue = EncoderValueFrameDimensionPage
                If GdipExec(GdipSaveAddImage(nBitmap(startF), _
                                            nBitmap(i), _
                                            uEncParams)) <> OK Then
                    GoTo DelObj 'Exit For
                End If
            End If
    End If
DelObj:
    DeleteObject hbmDst: hbmDst =  0 : pBits =  0 
 Next i
 
    ' abschlieЯen des speicherns
    paramValue = EncoderValueFlush
    GdipExec GdipSaveAdd(nBitmap(startF), uEncParams)
    
    For i = startF To endF
        ' Destroy the bitmaps
        GdipExec GdipDisposeImage(nBitmap(i)): nBitmap(i) =  0 
    Next i

    Erase nBitmap
End Sub

tiffset.exe -s  266   1  test.tif

 TiffCompressionCCITT3 = EncoderValueConstants.EncoderValueCompressionCCITT3