Public Enum TifCompressionType
    TiffCompressionLZW = 2
    TiffCompressionCCITT3 = 3
    TiffCompressionCCITT4 = 4
    TiffCompressionRle = 5
    TiffCompressionNone = 6
End Enum

Private Sub Command1_Click()
    Dim m_mfi As New CMultiFrameImage
    m_mfi.LoadFromFile "c:\111\test.tif"
    m_mfi.Frame1bpp
    Set Picture1.Picture = m_mfi.Zoom(, Picture1.ScaleWidth, 0)
End Sub

Private Declare Function VarPtrArray Lib "msvbvm60" Alias "VarPtr" ( _
   Arr() As Any) As Long
Dim mas_byte(0 To 9) As Byte

Public Function Frame1bpp( _
...
 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&
 MsgBox pBits
 CopyMemory ByVal VarPtrArray(mas_byte), pBits, 10
 Dim i As Integer
 For i = 0 To 9
    Debug.Print mas_byte(i)
 Next i
  
 Set picSrc = Nothing

Dim mas_byte(0 To 99) As Byte
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
   pvDest As Any, pvSource As Any, ByVal cBytes As Long)

 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&
 MsgBox pBits
 CopyMemory mas_byte(0), pBits, 100
 Dim i As Integer
 Dim str As String
 str = ""
 For i = 0 To 99
    str = str & i & "=" & mas_byte(i) & " "
    If Len(str) > 100 Then
        Debug.Print str
        str = ""
    End If
 Next i
 Debug.Print str
 Set picSrc = Nothing

0=0 1=0 2=193 3=3 4=40 5=0 6=0 7=0 8=192 9=6 10=0 11=0 12=35 13=9 14=0 15=0 16=1 17=0 18=1 19=0 20=0 
21=0 22=0 23=0 24=0 25=0 26=0 27=0 28=0 29=0 30=0 31=0 32=0 33=0 34=0 35=0 36=0 37=0 38=0 39=0 40=0 41=0 
42=0 43=0 44=0 45=0 46=0 47=0 48=255 49=255 50=255 51=0 52=35 53=9 54=0 55=0 56=192 57=6 58=0 59=0 60=0 
61=0 62=0 63=0 64=80 65=0 66=0 67=0 68=18 69=176 70=221 71=2 72=2 73=0 74=0 75=0 76=0 77=0 78=0 79=0 
80=0 81=0 82=0 83=0 84=28 85=0 86=0 87=0 88=221 89=246 90=255 91=255 92=255 93=255 94=255 95=255 96=0 
97=0 98=0 99=0 

Dim mas_scanline_bytes() As Byte

Public Function Frame1bpp( _
...
 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&
 Debug.Print "pBits=" & pBits
 Dim ScanLine_lenth As Long
 ScanLine_lenth = ((bmiDst.bmiHeader.biWidth + 15) \ 16) * 2
 Debug.Print "ScanLine_lenth=" & ScanLine_lenth
 ReDim mas_scanline_bytes(0 To ScanLine_lenth - 1)
 
 Dim h As Long
 Dim i As Long
 Dim j As Long
 Dim str As String
 
 For h = 0 To 1 'bmiDst.bmiHeader.biHeight - 1 'цикл по числу скан-линий
    Debug.Print "ScanLine # " & h & ":"
    CopyMemory mas_scanline_bytes(0), pBits + h * ScanLine_lenth, ScanLine_lenth
    str = ""
    For i = 0 To ScanLine_lenth - 1 Step 2
        For j = 0 To 15
            If ((i * 16 + j + 1) <= bmiDst.bmiHeader.biWidth) Then ' интересует первые 1728 бит
                str = str & CStr(GetBitXY(mas_scanline_bytes(i), mas_scanline_bytes(i + 1), j))
            End If
        Next j
        If Len(str) > 100 Then 'просто печатаем биты
            Debug.Print str
            str = ""
        End If
    Next i
    Debug.Print str 'last block of bits
 Next h
 
 Set picSrc = Nothing


Public Function GetBitXY(X As Byte, Y As Byte, Bit As Long) As Long
    'WORD - 2 байта x - первый байт (0-255) y - второй байт (0-255)
   Dim L As Long
   L = CLng(X) + CLng(Y) * 256
   GetBitXY = IIf(((L And 2 ^ Bit) > 0), 1, 0)
End Function

1728x2339
pBits=60162048
ScanLine_lenth=216
ScanLine # 0:
0000000000000000011010011100000011110000000000001010000110000000100011100010100010000000000000000010010110101011
1101100000000000011000111010100010100000111101010000000000000000011010011100000000010100000000000000000000000000
0000001101100000000000000000000011000100100100000000000000000000100000000000000010000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000001111111111111111
1111111100000000110001001001000000000000000000000000001101100000000000000000000000000000000000000000000000000000
0000101000000000000000000000000001010011111011111011101101000000010000000000000000000000000000000000000000000000
00000000000000000000000000000000000000000000000000111000000000000000000000000000
ScanLine # 1:
0001101100000000011010011100000011110000000000001010000110000000100011100010100010000000000000000010010110101011
1101100000000000011000111010100010100000111101010000000000000000011010011100000000010100000000000000000000000000
0000001101100000000000000000000011000100100100000000000000000000100000000000000010000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000001111111111111111
1111111100000000110001001001000000000000000000000000001101100000000000000000000000000000000000000000000000000000
0000101000000000000000000000000001010011111011111011101101000000010000000000000000000000000000000000000000000000
00000000000000000000000000000000000000000000000000111000000000000000000000000000

    For i = 0 To ScanLine_lenth - 1 Step 2
        For j = 0 To 15
            If ((i * 8 + j + 1) <= bmiDst.bmiHeader.biWidth) Then ' интересует первые 1728 бит
                str = str & CStr(GetBitXY(mas_scanline_bytes(i), mas_scanline_bytes(i + 1), j))
            End If
        Next j

    CopyMemory mas_scanline_bytes(0), ByVal (pBits + h * ScanLine_lenth), ScanLine_lenth

    CopyMemory mas_scanline_bytes(0), pBits + h * ScanLine_lenth, ScanLine_lenth

    CopyMemory mas_scanline_bytes(0), 0, ScanLine_lenth

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
   pvDest As Any, pvSource As Any, ByVal cBytes As Long)
   
Private Type SAFEARRAYBOUND
    cElements As Long
    lLbound As Long
End Type
Private Type SAFEARRAY2D
    cDims As Integer
    fFeatures As Integer
    cbElements As Long
    cLocks As Long
    pvData As Long
    Bounds(0 To 1) As SAFEARRAYBOUND
End Type
Private Declare Function VarPtrArray Lib "msvbvm60.dll" Alias "VarPtr" (Ptr() As Any) As Long
...

Public Function Frame1bpp( _
   Optional ByVal nFrame As Long = 0, _
   Optional ByVal nXPelsPerMeter As Long = 0, _
   Optional ByVal nYPelsPerMeter As Long = 0, _
   Optional ByVal dHeightScale As Double = 1) As IPictureDisp
 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
 
 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
    .biXPelsPerMeter = nXPelsPerMeter
    .biYPelsPerMeter = nYPelsPerMeter
 End With
 Debug.Print bmiDst.bmiHeader.biWidth & "x" & bmiDst.bmiHeader.biHeight
 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
 Set Frame1bpp = CreateIPictureDispFromHBITMAP(hbmDst)
             
               
 Debug.Print "pBits=" & pBits
 Dim ScanLine_lenth As Long
 ScanLine_lenth = ((bmiDst.bmiHeader.biWidth + 15) \ 16) * 2
 Debug.Print "ScanLine_lenth=" & ScanLine_lenth
 
 Dim tSA As SAFEARRAY2D
 Dim bDib() As Byte
 Dim X As Long, Y As Long
 Dim j As Long
 Dim str As String
    ' Get the bits in the from DIB section:
    With tSA
        .cbElements = 1
        .cDims = 2
        .Bounds(0).lLbound = 0
        .Bounds(0).cElements = bmiDst.bmiHeader.biHeight
        .Bounds(1).lLbound = 0
        .Bounds(1).cElements = ScanLine_lenth ' BytesPerScanLine()
        .pvData = pBits
    End With
    CopyMemory ByVal VarPtrArray(bDib()), VarPtr(tSA), 4

    For Y = bmiDst.bmiHeader.biHeight - 1 To 0 Step -1
    'Debug.Print "ScanLine # " & (bmiDst.bmiHeader.biHeight - 1) - Y & ":"
    str = ""
        For X = 0 To ScanLine_lenth - 1
            For j = 0 To 7
                If ((X * 8 + j + 1) <= bmiDst.bmiHeader.biWidth) Then ' интересует первые 1728 бит
                    str = str & CStr(GetBitXY(bDib(X, Y), 0, 7 - j))
                End If
            Next j
        Next X
        Debug.Print str 'last block of bits
    Next Y
    ' Clear the temporary array descriptor
    ' (This does not appear to be necessary, but
    ' for safety do it anyway)
    CopyMemory ByVal VarPtrArray(bDib), 0&, 4

End Function


Public Function GetBitXY(X As Byte, Y As Byte, Bit As Long) As Long
    'WORD - 2 байта x - первый байт (0-255) y - второй байт (0-255)
   Dim L As Long
   L = CLng(X) + CLng(Y) * 256
   GetBitXY = IIf(((L And 2 ^ Bit) > 0), 0, 1)
End Function

    For Y = bmiDst.bmiHeader.biHeight - 1 To 0 Step -1

        For X = 0 To ScanLine_lenth - 1
            For j = 0 To 7
                If ((X * 8 + j + 1) <= bmiDst.bmiHeader.biWidth) Then ' интересует первые 1728 бит
                    str = str & CStr(GetBitXY(bDib(X, Y), 0, 7 - j))
                End If
            Next j
        Next X
        Debug.Print str 'last block of bits

    CopyMemory ByVal VarPtrArray(bDib()), VarPtr(tSA), 4

Private Function DoWhite(runlen As Long) As String
Private Function DoBlack(runlen As Long) As String

Public Function termWhite(runlen As Long) As String
Public Function termBlack(runlen As Long) As String
Public Function makeUpWhite(makeup As Long) As String
Public Function makeUpBlack(makeup As Long) As String

Public Function generateByte(byteAsStr As String) As Long

Option Explicit

Public bDib() As Byte

Private Enum BITSTATE
   STATE_WHITE = 0
   STATE_BLACK = 1
End Enum


Public Function termWhite(runlen As Long) As String
    'terminating codes / White bits
    Select Case runlen:
        Case 0
            termWhite = "00110101"
        Case 1
            termWhite = "000111"
        Case 2
            termWhite = "0111"
        Case 3
            termWhite = "1000"
        Case 4
            termWhite = "1011"
        Case 5
            termWhite = "1100"
        Case 6
            termWhite = "1110"
        Case 7
            termWhite = "1111"
        Case 8
            termWhite = "10011"
        Case 9
            termWhite = "10100"
        Case 10
            termWhite = "00111"
        Case 11
            termWhite = "01000"
        Case 12
            termWhite = "001000"
        Case 13
            termWhite = "000011"
        Case 14
            termWhite = "110100"
        Case 15
            termWhite = "110101"
        Case 16
            termWhite = "101010"
        Case 17
            termWhite = "101011"
        Case 18
            termWhite = "0100111"
        Case 19
            termWhite = "0001100"
        Case 20
            termWhite = "0001000"
        Case 21
            termWhite = "0010111"
        Case 22
            termWhite = "0000011"
        Case 23
            termWhite = "0000100"
        Case 24
            termWhite = "0101000"
        Case 25
            termWhite = "0101011"
        Case 26
            termWhite = "0010011"
        Case 27
            termWhite = "0100100"
        Case 28
            termWhite = "0011000"
        Case 29
            termWhite = "00000010"
        Case 30
            termWhite = "00000011"
        Case 31
            termWhite = "00011010"
        Case 32
            termWhite = "00011011"
        Case 33
            termWhite = "00010010"
        Case 34
            termWhite = "00010011"
        Case 35
            termWhite = "00010100"
        Case 36
            termWhite = "00010101"
        Case 37
            termWhite = "00010110" '?
        Case 38
            termWhite = "00010111"
        Case 39
            termWhite = "00101000"
        Case 40
            termWhite = "00101001"
        Case 41
            termWhite = "00101010"
        Case 42
            termWhite = "00101011"
        Case 43
            termWhite = "00101100"
        Case 44
            termWhite = "00101101"
        Case 45
            termWhite = "00000100"
        Case 46
            termWhite = "00000101"
        Case 47
            termWhite = "00001010"
        Case 48
            termWhite = "00001011"
        Case 49
            termWhite = "01010010"
        Case 50
            termWhite = "01010011"
        Case 51
            termWhite = "01010100"
        Case 52
            termWhite = "01010101"
        Case 53
            termWhite = "00100100"
        Case 54
            termWhite = "00100101"
        Case 55
            termWhite = "01011000"
        Case 56
            termWhite = "01011001"
        Case 57
            termWhite = "01011010"
        Case 58
            termWhite = "01011011"
        Case 59
            termWhite = "01001010"
        Case 60
            termWhite = "01001011"
        Case 61
            termWhite = "00110010"
        Case 62
            termWhite = "00110011" '?
        Case 63
            termWhite = "00110100"
        Case Else
            termWhite = ""
    End Select
End Function

Public Function termBlack(runlen As Long) As String
    'terminating codes / Black bits
    Select Case runlen:
        Case 0
            termBlack = "0000110111"
        Case 1
            termBlack = "010"
        Case 2
            termBlack = "11"
        Case 3
            termBlack = "10"
        Case 4
            termBlack = "011"
        Case 5
            termBlack = "0011"
        Case 6
            termBlack = "0010"
        Case 7
            termBlack = "00011"
        Case 8
            termBlack = "000101"
        Case 9
            termBlack = "000100"
        Case 10
            termBlack = "0000100"
        Case 11
            termBlack = "0000101"
        Case 12
            termBlack = "0000111"
        Case 13
            termBlack = "00000100"
        Case 14
            termBlack = "00000111"
        Case 15
            termBlack = "000011000"
        Case 16
            termBlack = "0000010111"
        Case 17
            termBlack = "0000011000"
        Case 18
            termBlack = "0000001000"
        Case 19
            termBlack = "00001100111"
        Case 20
            termBlack = "00001101000"
        Case 21
            termBlack = "00001101100"
        Case 22
            termBlack = "00000110111"
        Case 23
            termBlack = "00000101000"
        Case 24
            termBlack = "00000010111"
        Case 25
            termBlack = "00000011000"
        Case 26
            termBlack = "000011001010"
        Case 27
            termBlack = "000011001011"
        Case 28
            termBlack = "000011001100"
        Case 29
            termBlack = "000011001101"
        Case 30
            termBlack = "000001101000"
        Case 31
            termBlack = "000001101001"
        Case 32
            termBlack = "000001101010"
        Case 33
            termBlack = "000001101011"
        Case 34
            termBlack = "000011010010"
        Case 35
            termBlack = "000011010011"
        Case 36
            termBlack = "000011010100"
        Case 37
            termBlack = "000011010101"
        Case 38
            termBlack = "000011010110"
        Case 39
            termBlack = "000011010111"
        Case 40
            termBlack = "000001101100"
        Case 41
            termBlack = "000001101101"
        Case 42
            termBlack = "000011011010"
        Case 43
            termBlack = "000011011011"
        Case 44
            termBlack = "000001010100"
        Case 45
            termBlack = "000001010101"
        Case 46
            termBlack = "000001010110"
        Case 47
            termBlack = "000001010111"
        Case 48
            termBlack = "000001100100"
        Case 49
            termBlack = "000001100101"
        Case 50
            termBlack = "000001010010"
        Case 51
            termBlack = "000001010011"
        Case 52
            termBlack = "000000100100"
        Case 53
            termBlack = "000000110111"
        Case 54
            termBlack = "000000111000"
        Case 55
            termBlack = "000000100111"
        Case 56
            termBlack = "000000101000"
        Case 57
            termBlack = "000001011000"
        Case 58
            termBlack = "000001011001"
        Case 59
            termBlack = "000000101011"
        Case 60
            termBlack = "000000101100"
        Case 61
            termBlack = "000001011010"
        Case 62
            termBlack = "000001100110"
        Case 63
            termBlack = "000001100111"
        Case Else
            termBlack = ""
    End Select
End Function

Public Function makeUpWhite(makeup As Long) As String
    'Makeup code words / White bits
    Select Case makeup:
        Case 64
            makeUpWhite = "11011"
        Case 128
            makeUpWhite = "10010"
        Case 192
            makeUpWhite = "010111"
        Case 256
            makeUpWhite = "0110111"
        Case 320
            makeUpWhite = "00110110"
        Case 384
            makeUpWhite = "00110111"
        Case 448
            makeUpWhite = "01100100"
        Case 512
            makeUpWhite = "01100101"
        Case 576
            makeUpWhite = "01101000"
        Case 640
            makeUpWhite = "01100111"
        Case 704
            makeUpWhite = "011001100"
        Case 768
            makeUpWhite = "011001101"
        Case 832
            makeUpWhite = "011010010"
        Case 896
            makeUpWhite = "011010011" '?
        Case 960
            makeUpWhite = "011010100"
        Case 1024
            makeUpWhite = "011010101"
        Case 1088
            makeUpWhite = "011010110"
        Case 1152
            makeUpWhite = "011010111"
        Case 1216
            makeUpWhite = "011011000"
        Case 1280
            makeUpWhite = "011011001"
        Case 1344
            makeUpWhite = "011011010"
        Case 1408
            makeUpWhite = "011011011"
        Case 1472
            makeUpWhite = "010011000"
        Case 1536
            makeUpWhite = "010011001"
        Case 1600
            makeUpWhite = "010011010"
        Case 1664
            makeUpWhite = "011000"
        Case 1728
            makeUpWhite = "010011011"
        Case 1792
            makeUpWhite = "00000001000"
        Case 1856
            makeUpWhite = "00000001100"
        Case 1920
            makeUpWhite = "00000001101"
        Case 1984
            makeUpWhite = "000000010010"
        Case 2048
            makeUpWhite = "000000010011"
        Case 2112
            makeUpWhite = "000000010100"
        Case 2176
            makeUpWhite = "000000010101"
        Case 2240
            makeUpWhite = "000000010110"
        Case 2304
            makeUpWhite = "000000010111"
        Case 2368
            makeUpWhite = "000000011100"
        Case 2432
            makeUpWhite = "000000011101"
        Case 2496
            makeUpWhite = "000000011110"
        Case 2560
            makeUpWhite = "000000011111"
        Case Else
            makeUpWhite = ""
    End Select
End Function

Public Function makeUpBlack(makeup As Long) As String
    'Makeup code words / Black bits
    Select Case makeup:
        Case 64
            makeUpBlack = "0000001111" '?
        Case 128
            makeUpBlack = "000011001000" '?
        Case 192
            makeUpBlack = "000011001001"
        Case 256
            makeUpBlack = "000001011011"
        Case 320
            makeUpBlack = "000000110011"
        Case 384
            makeUpBlack = "000000110100"
        Case 448
            makeUpBlack = "000000110101"
        Case 512
            makeUpBlack = "0000001101100"
        Case 576
            makeUpBlack = "0000001101101"
        Case 640
            makeUpBlack = "0000001001010"
        Case 704
            makeUpBlack = "0000001001011"
        Case 768
            makeUpBlack = "0000001001100"
        Case 832
            makeUpBlack = "0000001001101"
        Case 896
            makeUpBlack = "0000001110010"
        Case 960
            makeUpBlack = "0000001110011"
        Case 1024
            makeUpBlack = "0000001110100"
        Case 1088
            makeUpBlack = "0000001110101"
        Case 1152
            makeUpBlack = "0000001110110"
        Case 1216
            makeUpBlack = "0000001110111"
        Case 1280
            makeUpBlack = "0000001010010"
        Case 1344
            makeUpBlack = "0000001010011"
        Case 1408
            makeUpBlack = "0000001010100"
        Case 1472
            makeUpBlack = "0000001010101"
        Case 1536
            makeUpBlack = "0000001011010"
        Case 1600
            makeUpBlack = "0000001011011"
        Case 1664
            makeUpBlack = "0000001100100"
        Case 1728
            makeUpBlack = "0000001100101"
        Case 1792
            makeUpBlack = "00000001000"
        Case 1856
            makeUpBlack = "00000001100"
        Case 1920
            makeUpBlack = "00000001101"
        Case 1984
            makeUpBlack = "000000010010"
        Case 2048
            makeUpBlack = "000000010011"
        Case 2112
            makeUpBlack = "000000010100"
        Case 2176
            makeUpBlack = "000000010101"
        Case 2240
            makeUpBlack = "000000010110"
        Case 2304
            makeUpBlack = "000000010111"
        Case 2368
            makeUpBlack = "000000011100"
        Case 2432
            makeUpBlack = "000000011101"
        Case 2496
            makeUpBlack = "000000011110"
        Case 2560
            makeUpBlack = "000000011111"
        Case Else
            makeUpBlack = ""
    End Select
End Function

Public Sub CreateSFFFile()
    Dim sff_FileName As String
    Dim sff_FileHandle As Integer         ' file handle, from freefile()
    Dim sff_FilePos As Long               ' pointer to last byte read/written
    
    Dim sff_XPelsPerMeter As Long         ' Resolution Horizontal
    Dim sff_YPelsPerMeter As Long         ' Resolution Vertical
    Dim sff_Width As Long                 ' Width
    Dim sff_Height As Long                ' Height
    
    Dim i As Long
    Dim x As Long, y As Long
    Dim j As Long
    
    Dim runlen As Long
    Dim whiteLines As Long
    Dim ScanLine_lenth As Long
    Dim codeline As String 'Scan Line coded using MH
    
    Dim state As BITSTATE
    
    DeleteFile sff_FileName
    
    sff_FileName = "test.sff"
    sff_XPelsPerMeter = 204
    sff_YPelsPerMeter = 196
    sff_Width = 1728
    sff_Height = 2339
    ScanLine_lenth = ((sff_Width + 15) \ 16) * 2

    
    sff_FilePos = 1
    sff_FileHandle = FreeFile(0)
    Open sff_FileName For Binary Access Write Lock Write As sff_FileHandle
    
    'SFF header
    Put sff_FileHandle, sff_FilePos, "Sfff"
    Put sff_FileHandle, sff_FilePos + 4, 1 'Version
    Put sff_FileHandle, sff_FilePos + 5, 0 'reserved
    Put sff_FileHandle, sff_FilePos + 6, 0 'User Information
    Put sff_FileHandle, sff_FilePos + 7, 0
    Put sff_FileHandle, sff_FilePos + 8, 0 'Page Count
    Put sff_FileHandle, sff_FilePos + 9, 0
    Put sff_FileHandle, sff_FilePos + 10, 20 'Offset first page header
    Put sff_FileHandle, sff_FilePos + 11, 0
    Put sff_FileHandle, sff_FilePos + 12, 0 'Offset last page header
    Put sff_FileHandle, sff_FilePos + 13, 0
    Put sff_FileHandle, sff_FilePos + 14, 0
    Put sff_FileHandle, sff_FilePos + 15, 0
    Put sff_FileHandle, sff_FilePos + 16, 0 'Offset of document end
    Put sff_FileHandle, sff_FilePos + 17, 0
    Put sff_FileHandle, sff_FilePos + 18, 0
    Put sff_FileHandle, sff_FilePos + 19, 0
    sff_FilePos = sff_FilePos + 20
    
    'Page header
    Put sff_FileHandle, sff_FilePos, 254 'Page header ID
    Put sff_FileHandle, sff_FilePos + 1, 16 'Page header lenth
    Put sff_FileHandle, sff_FilePos + 2, IIf(sff_YPelsPerMeter < 100, 0, 1) 'Resolution Vertical
    Put sff_FileHandle, sff_FilePos + 3, 0 'Resolution Horizontal
    Put sff_FileHandle, sff_FilePos + 4, 0 'Coding: Modified Huffman
    Put sff_FileHandle, sff_FilePos + 5, 0 'reserved
    Put sff_FileHandle, sff_FilePos + 6, sff_Width Mod 256 'Line lenth
    Put sff_FileHandle, sff_FilePos + 7, sff_Width \ 256
    Put sff_FileHandle, sff_FilePos + 8, sff_Height Mod 256 'Page lenth
    Put sff_FileHandle, sff_FilePos + 9, sff_Height \ 256
    Put sff_FileHandle, sff_FilePos + 10, 0 'Offset Previous page
    Put sff_FileHandle, sff_FilePos + 11, 0
    Put sff_FileHandle, sff_FilePos + 12, 0
    Put sff_FileHandle, sff_FilePos + 13, 0
    Put sff_FileHandle, sff_FilePos + 14, 0 'Offset Next page
    Put sff_FileHandle, sff_FilePos + 15, 0
    Put sff_FileHandle, sff_FilePos + 16, 0
    Put sff_FileHandle, sff_FilePos + 17, 0
    sff_FilePos = sff_FilePos + 18
    
    
    'Modified Huffman
    whiteLines = 0
    For y = sff_Height - 1 To 0 Step -1
        runlen = 0
        state = STATE_WHITE
        codeline = ""
        For x = 0 To ScanLine_lenth - 1
            For j = 0 To 7
                If ((x * 8 + j + 1) <= sff_Width) Then ' интересует первые 1728 бит
                    If (GetBitX(bDib(x, y), 7 - j)) = 1 Then  'black bit
                        If (state = STATE_WHITE) Then
                            If whiteLines > 0 Then 'если предыдущие линии белые
                                'Debug.Print "whiteLines=" & whiteLines
                                sff_FilePos = writeWhiteLines(whiteLines, sff_FileHandle, sff_FilePos)
                                whiteLines = 0
                            End If
                            'кодируем предыдущие белые биты
                            codeline = codeline & DoWhite(runlen)
                            state = STATE_BLACK
                            runlen = 1
                        Else
                            runlen = runlen + 1
                        End If
                    Else 'white bit
                        If (state = STATE_BLACK) Then
                            'кодируем предыдущие черные биты
                            codeline = codeline & DoBlack(runlen)
                            state = STATE_WHITE
                            runlen = 1
                        Else
                            runlen = runlen + 1
                        End If
                    End If
                End If
            Next j
        Next x
        If (runlen = sff_Width) Then 'And (state = STATE_WHITE) Then 'все биты белые
            whiteLines = whiteLines + 1
            If y = 0 Then 'last scanline
                sff_FilePos = writeWhiteLines(whiteLines, sff_FileHandle, sff_FilePos)
                whiteLines = 0
            End If
        Else
            If state = STATE_WHITE Then
                codeline = codeline & DoWhite(runlen)
            Else
                codeline = codeline & DoBlack(runlen)
            End If
            codeline = codeline & "000000000001" '+ EOL
            'codeline = DoWhite(0) & DoBlack(763) & DoWhite(865) & DoBlack(100) & "000000000001"
            sff_FilePos = writeLine(codeline, sff_FileHandle, sff_FilePos)
        End If
    Next y

    
'    'test 2339 empty lines
'    For i = 1 To 63
'        Put sff_FileHandle, sff_FilePos, 253 '37 lines -> 2331 lines
'        sff_FilePos = sff_FilePos + 1
'    Next i
'    Put sff_FileHandle, sff_FilePos, 224 '+8 lines
'    sff_FilePos = sff_FilePos + 1
    
    'Document end
    Put sff_FileHandle, sff_FilePos, 254
    'Put sff_FileHandle, sff_FilePos + 1, 0
    
    Close sff_FileHandle
End Sub

Public Function GetBitXY(x As Byte, y As Byte, Bit As Long) As Long
    'WORD - 2 байта x - первый байт (0-255) y - второй байт (0-255)
   Dim L As Long
   L = CLng(x) + CLng(y) * 256
   GetBitXY = IIf(((L And 2 ^ Bit) > 0), 0, 1)
End Function

Public Function GetBitX(x As Byte, Bit As Long) As Long
    'x - первый байт (0-255)
   Dim L As Long
   L = CLng(x)
   GetBitX = IIf(((L And 2 ^ Bit) > 0), 0, 1)
End Function

Private Function DoWhite(runlen As Long) As String
    'coding white bits
    Dim code As String
    Dim run_len As Long
    Dim make_up As Long
    run_len = runlen
    code = ""
    Do While run_len > 2623 ' 2560+63=2623
        code = code & makeUpWhite(2560)
        run_len = run_len - 2560
    Loop
    If run_len > 63 Then ' max 2560
        make_up = (run_len \ 64) * 64
        run_len = run_len Mod 64
        code = code & makeUpWhite(make_up)
    End If
    If (run_len > 0) Or (Len(code) = 0) Then
        code = code & termWhite(run_len) ' max 63
    End If
    DoWhite = code
End Function

Private Function DoBlack(runlen As Long) As String
    'coding black bits
    Dim code As String
    Dim run_len As Long
    Dim make_up As Long
    run_len = runlen
    code = ""
    Do While run_len > 2623 ' 2560+63=2623
        code = code & makeUpBlack(2560)
        run_len = run_len - 2560
    Loop
    If run_len > 63 Then ' max 2560
        make_up = (run_len \ 64) * 64
        run_len = run_len Mod 64
        code = code & makeUpBlack(make_up)
    End If
    If (run_len > 0) Or (Len(code) = 0) Then
        code = code & termBlack(run_len) ' max 63
    End If
    DoBlack = code
End Function

Private Function writeWhiteLines(whiteLines As Long, FileHandle As Integer, start As Long) As Long
    'returns next position in file
    Dim white_Lines As Long
    Dim the_start As Long
    white_Lines = whiteLines
    the_start = start
    If (white_Lines > 0) Then
        Do While white_Lines > 37 ' max 37: 217..253
            Put FileHandle, the_start, 253
            white_Lines = white_Lines - 37
            the_start = the_start + 1
        Loop
        Put FileHandle, the_start, 216 + white_Lines
        the_start = the_start + 1
    End If
    writeWhiteLines = the_start
End Function

Private Function writeLine(codeline As String, FileHandle As Integer, start As Long) As Long
    'returns next position in file
    Dim code_Line As String
    Dim the_start As Long
    Dim the_byte As String
    Dim the_lenth As Long
    code_Line = codeline
    the_start = start
    the_lenth = (Len(code_Line) + 7) \ 8
    'Debug.Print the_lenth
    If the_lenth <= 216 Then
        Put FileHandle, the_start, the_lenth
        the_start = the_start + 1
    Else
        Put FileHandle, the_start, 0
        Put FileHandle, the_start + 1, (the_lenth Mod 256)
        Put FileHandle, the_start + 2, (the_lenth \ 256)
        the_start = the_start + 3
    End If
    Do While Len(code_Line) > 0
        If Len(code_Line) >= 8 Then
            the_byte = Left(code_Line, 8)
            code_Line = Right(code_Line, Len(code_Line) - 8)
        Else
            the_byte = code_Line & String(8 - Len(code_Line), "0")
            code_Line = ""
        End If
        Put FileHandle, the_start, generateByte(the_byte)
        the_start = the_start + 1
    Loop
    writeLine = the_start
End Function

Public Function generateByte(byteAsStr As String) As Long
    Dim i As Integer
    generateByte = 0
    If Len(byteAsStr) = 8 Then
        For i = 1 To 8
            generateByte = generateByte + CLng(Mid(byteAsStr, i, 1)) * (2 ^ (i - 1))
        Next i
    End If
End Function

Private Function DoWhite(runlen As Long) As String
    'coding white bits
    Dim code As String
    Dim run_len As Long
    Dim make_up As Long
    run_len = runlen
    code = ""
    Do While run_len > 2623 ' 2560+63=2623
        code = code & makeUpWhite(2560)
        run_len = run_len - 2560
    Loop
    If run_len > 63 Then ' max 2560
        make_up = (run_len \ 64) * 64
        run_len = run_len Mod 64
        code = code & makeUpWhite(make_up)
    End If
    code = code & termWhite(run_len) ' max 63
    DoWhite = code
End Function

Private Function DoBlack(runlen As Long) As String
    'coding black bits
    Dim code As String
    Dim run_len As Long
    Dim make_up As Long
    run_len = runlen
    code = ""
    Do While run_len > 2623 ' 2560+63=2623
        code = code & makeUpBlack(2560)
        run_len = run_len - 2560
    Loop
    If run_len > 63 Then ' max 2560
        make_up = (run_len \ 64) * 64
        run_len = run_len Mod 64
        code = code & makeUpBlack(make_up)
    End If
    code = code & termBlack(run_len) ' max 63
    DoBlack = code
End Function

    sff_YPelsPerMeter = 196
...
    Put sff_FileHandle, sff_FilePos + 2, IIf(sff_YPelsPerMeter < 100, 0, 1) 'Resolution Vertical

    sff_YPelsPerMeter = 196
...
    If sff_YPelsPerMeter < 100 Then
        Put sff_FileHandle, sff_FilePos + 2, 0 'Resolution Vertical(normal)
    Else
        Put sff_FileHandle, sff_FilePos + 2, 1 'Resolution Vertical(fine)
    End If

    Dim i As Long
    If Len(code_Line) > 0 Then
        If (Len(code_Line) Mod 8) > 0 Then
            code_Line = code_Line & String(8 - (Len(code_Line) Mod 8), "0")
        End If
        For i = 8 To Len(code_Line) Step 8
            the_byte = Mid(code_Line, i - 7, 8)
            Put FileHandle, the_start, generateByte(the_byte)
            the_start = the_start + 1
        Next
    End If
    writeLine = the_start

For i = 8 To Len(code_Line) \ 8 Step 8

                   If vaIsSetBit(bDib(x, y), 7 - j) Then 'white bit
                        If (state = STATE_BLACK) Then
                            'кодируем предыдущие черные биты

                    If (GetBitX(bDib(x, y), 7 - j)) = 1 Then  'black bit
                        If (state = STATE_WHITE) Then
                            If whiteLines > 0 Then 'если предыдущие линии белые

Function ExamineBit(x As Byte, Bit As Byte) As Boolean
    Select Case x
        Case 255:
            ExamineBit = True
        Case 0:
            ExamineBit = False
        Case Else
            ' Return the truth state of the 2 to the nth power bit:
            ExamineBit = ((x And 2 ^ Bit) > 0)
    End Select
End Function

    Dim i As Long
    Dim str As String
    Dim str_len As Long
    str_len = 0
    If Len(code_Line) > 0 Then
        If (Len(code_Line) Mod 8) > 0 Then
            code_Line = code_Line & String(8 - (Len(code_Line) Mod 8), "0")
        End If
        str = ""
        For i = 8 To Len(code_Line) Step 8
            the_byte = Mid(code_Line, i - 7, 8)
            str = str & Chr$(generateByte(the_byte))
        Next
        str_len = Len(str)
        Put FileHandle, the_start, str
    End If
    writeLine = the_start + str_len