ReSQL.ru
     
powered by simpleCommunicator - 2.0.53     © 2025 Programmizd 02
Мобильная версия    Контакт    Правила    FAQ    Помощь
Доб. в избранное | Игнор. тему | Прикреп. тему | Пометить прочит. / непрочит. | Фильтр
Форумы / Visual Basic [игнор отключен] [закрыт для гостей] / Конвертер TIFF(BMP...)->SFF самому написать реально? Вопрос скорее к Бенедикту.
25 сообщений из 54, страница 2 из 3
  2  все
Конвертер TIFF(BMP...)->SFF самому написать реально? Вопрос скорее к Бенедикту.
    #37842795
Дмитрий77
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Дмитрий77
Участник
Дмитрий77У меня где-то ошибка. Где понять не могу. Декодер (вьюер) заламывает некоторые строчки картинки.
Подозреваю что проблема связана с неправильным выравниванием по границе байта.
В CAPI документе сказано:
CAPIMH coding is bit-oriented: the pixel bits are stored in the bits of code words, least significant first.
No EOL code words or fill bits are included. If the data includes EOL code words,
COMMON-ISDN-API ignores these.

В другом документе сказано, что якобы нули надо добавлять перед EOL (000000000001) чтоб добить доцелых байтов, пробовал и до и после, есть ряд строк, которые получаются битые (почему не знаю), и вьюером не отображаются.
Как правильно выровнять по границе байта?

С этим я разобрался. После кода makeUp должен в обязательном порядке стоять код term, даже если 0. Кодер глючил на
DoWhite(64), так как нулевой код терминации не дописывался. Выравнивание по границе байта скорее всего ни причем, EOL тоже можно думаю не ставить (если верить CAPI-цитате), а просто добить строку нулями кратно 8.
Код: vbnet
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
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



Узрел мелкую проблему:
Один из немецких вьюеров ругается на мой файл. Пишет "Gleitkommadivision durch Null" (что-то насчет деления ну нуль) -файл сгенерированный через GS он отображает без ругани.
Два остальных вьюера мой файл отображают.
Немцам что-ли написать (te-systems.de, их вьюер ругается), может помогут ошибку найти в моем SFF?

Ну и, нужна помощь по оптимизации кода на предмет быстродействия , код привел в предыдущем посте.
Подозреваю, что проблема торможения в том
1) как я высчитываю биты
2) как я их потом через анализ String загоняю через mid в байты.
Но у меня пока "чистых" идей как бороться с этими "типами данных" нет.
...
Рейтинг: 0 / 0
18.06.2012, 15:10
| Ответить | Цитировать | Написать  
Конвертер TIFF(BMP...)->SFF самому написать реально? Вопрос скорее к Бенедикту.
    #37842984
Дмитрий77
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Дмитрий77
Участник
Дмитрий77Узрел мелкую проблему:
Один из немецких вьюеров ругается на мой файл. Пишет "Gleitkommadivision durch Null" (что-то насчет деления ну нуль) -файл сгенерированный через GS он отображает без ругани.
Два остальных вьюера мой файл отображают.
Немцам что-ли написать (te-systems.de, их вьюер ругается), может помогут ошибку найти в моем SFF?

Нашел глюк:
Код: vbnet
1.
2.
3.
    sff_YPelsPerMeter = 196
...
    Put sff_FileHandle, sff_FilePos + 2, IIf(sff_YPelsPerMeter < 100, 0, 1) 'Resolution Vertical


Почему-то пишет в файл байт со значением "2", что не совместимо с понятиями чести того вьюера.
А должно быть "1", странно...

Сделал так (в человеко-читаемом виде):
Код: vbnet
1.
2.
3.
4.
5.
6.
7.
    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


Глюк ушел, пишет 1.

Непонятно еще, что с количеством '\0' в конце файла делать (соседний топик).

Так что, с оптимизацией/быстродействием никто не поможет? Кажется это все что мне надо для полного счастия.
...
Рейтинг: 0 / 0
18.06.2012, 16:53
| Ответить | Цитировать | Написать  
Конвертер TIFF(BMP...)->SFF самому написать реально? Вопрос скорее к Бенедикту.
    #37843342
Фотография AndreTM
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
AndreTM
Участник
Оптимизации? Хотя бы так...
Посмотрим на последний кусочек листинга writeLine() :
 
Код: vbnet
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
    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

Что видим? "Битовая строка" выравнивается по границе байта хитрым методом, "символьные биты" в байте идут в обратном порядке... Заменим вышеприведенный код на такой:
 
Код: vbnet
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
    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")
        For i = 8 To Len(code_Line) \ 8 Step 8
            the_byte = ""
            For j = i To i - 7 Step -1
                the_byte = the_byte & Mid(code_Line, j, 1)
            Next
            Put FileHandle, the_start, generateByteNew(the_byte)
            the_start = the_start + 1
        Next
    End If
    writeLine = the_start
End Function

Получаем выигрыш за счет только одного прохода по code_Line , ну и при этом получаем возможность использовать новую функцию для генерации байта, поскольку "символьное" представление его теперь "обычное":
 
Код: vbnet
1.
2.
3.
4.
5.
Private Declare Function vaStrBinToDec Lib "VBasm32.dll" (ByVal StrBin As String) As Long

Public Function generateByteNew(byteAsStr As String) As Long
    generateByteNew = vaStrBinToDec(byteAsStr)
End Function

В приложении - библиотека, содержащая vaStrBinToDec() (источник: http://geosoftua.od.ua/ASM32.html)
...
Рейтинг: 0 / 0
18.06.2012, 22:05
| Ответить | Цитировать | Написать  
Конвертер TIFF(BMP...)->SFF самому написать реально? Вопрос скорее к Бенедикту.
    #37843486
Дмитрий77
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Дмитрий77
Участник
AndreTM,

Спасибо что откликнулись.
Ну скажем так,
берем насыщенный файл 1 страница
если GS, то время конвертации ~1сек (это с учетом промежуточного pdf-а)
это я назвал "долгим".

если мой исх. код, то 5-6 сек
если чуть модифицировать (с вашей подсказкой, но по своему),
то в 5 сек укладывается, ладно убедили
Код: vbnet
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
    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


Если делать с вашей библиотекой, то те же 5 сек, фактически никакого выигрыша, а тащить за собой эту dll или пытаться вникнуть в ее исходники, не уверен что надо, тем более по вашей ссылке исходников нет.

P.S. У вас ошибка в строчке ниже (делите на 8), тем более итак уже выровняли кратно 8 строчкой выше
Код: vbnet
1.
For i = 8 To Len(code_Line) \ 8 Step 8


Когда я игрался с "добычей сырья", т.е. чтением битмап, тоже долго работало.
Я думаю основные тормоза где-то при чтении битмапа, а не при распечатке коротких code_Line. Вот только где?

Еще, я работаю со String, м.б. надо какой другой метод использовать?
...
Рейтинг: 0 / 0
19.06.2012, 01:54
| Ответить | Цитировать | Написать  
Конвертер TIFF(BMP...)->SFF самому написать реально? Вопрос скорее к Бенедикту.
    #37843487
Фотография AndreTM
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
AndreTM
Участник
Обшибся я немного... Как обычно, чтобы реципиент подумал над алгоритмом...
 
Код: vbnet
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
    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")
        For i = 8 To Len(code_Line) Step 8 ' \ 8 - не нужно, теперь уже...
            the_byte = ""
            For j = i To i - 7 Step -1
                the_byte = the_byte & Mid(code_Line, j, 1)
            Next
            Put FileHandle, the_start, generateByteNew(the_byte)
            the_start = the_start + 1
        Next
    End If
    code_Line = "" ' ну, раз так по алгоритму полОжено...
    writeLine = the_start
End Function

...
Рейтинг: 0 / 0
19.06.2012, 01:55
| Ответить | Цитировать | Написать  
Конвертер TIFF(BMP...)->SFF самому написать реально? Вопрос скорее к Бенедикту.
    #37843492
Фотография AndreTM
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
AndreTM
Участник
Дмитрий77Если делать с вашей библиотекой, то те же 5 сек, фактически никакого выигрыша, а тащить за собой эту dll или пытаться вникнуть в ее исходники, не уверен что надо, тем более по вашей ссылке исходников нетКак нет? А справа на странице ссылочка на ZIP? Да и просто распаковать экзешник - и получить библиотеку и пример использования в виде VB6-проекта? (в ссылке я просто ")" поставил впритык - а если скопировать ссылку руками? )
Там же (в библиотеке той), кстати, и асм'овская процедура получения бита из битмапа... попробуйте прикрутить...
...
Рейтинг: 0 / 0
19.06.2012, 02:04
| Ответить | Цитировать | Написать  
Конвертер TIFF(BMP...)->SFF самому написать реально? Вопрос скорее к Бенедикту.
    #37843497
Дмитрий77
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Дмитрий77
Участник
AndreTM,
Там есть пример использования библиотеки и упомянутая dll, а не ее исходники.
Для указанного вами места кода библиотека выигрыша не дает, разве попробовать бит вычислять и думать дальше что делать, если результат "ощутится".
Но таскать ее за собой желания по любому нет.
Проще Ghostscript таскать, тем более итак таскаю, ибо желания декодировать pdf-ы нет и не появится.
...
Рейтинг: 0 / 0
19.06.2012, 02:18
| Ответить | Цитировать | Написать  
Конвертер TIFF(BMP...)->SFF самому написать реально? Вопрос скорее к Бенедикту.
    #37843507
Дмитрий77
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Дмитрий77
Участник
AndreTM,

Ну, хорошо, если сделать только
Код: vbnet
1.
2.
3.
                   If vaIsSetBit(bDib(x, y), 7 - j) Then 'white bit
                        If (state = STATE_BLACK) Then
                            'кодируем предыдущие черные биты


вместо моего
Код: vbnet
1.
2.
3.
                    If (GetBitX(bDib(x, y), 7 - j)) = 1 Then  'black bit
                        If (state = STATE_WHITE) Then
                            If whiteLines > 0 Then 'если предыдущие линии белые



то результат уложится в 3 сек (говорим об exe, в среде будет + 1-2сек)

Если еще добавить ваш предыдущий ход, то будет попадать в 2-3 сек.

1) Как отыграть еще 2 секунды даб хотяб догнать GS ? (перегнать похоже не получится в силу сложности алгоритма)
2) Как не использовать вашу библиотеку? Счас вы скажете что она на C, использует битовые сдвиги и на VB так нельзя.

Я б с удовольствием загнал все в C++ для осуществления следующей идеи:
Димавысшим пилотажем было бы перекодирование TIFF в SFF на лету , т.е. без конвертации в физический SFF, а просто подменой заголовков в процессе передачи данных (ну и при приеме при записи в файл).
С самим MH проблем конечно не возникнет.
Но
1) У меня там нет замечательного класса CMultiFrameImage а рожать его по нулям я не осилю
2) Я не уверен, что вставлять GDI в код Opal есть хорошая идея (хотя мне его Linux-мультисистемность не нужна)
3) Рассчитывать что tiff будет в MH нельзя, поэтому переписывать заголовки суть идея бредовая, битмап действительно надо держать в памяти, а оттуда читать сканлинии.

Посему проще делать так: (дублирующие SFF-ы заранее готовить не хочу)
Я параллельно
1)Конвертирую TIFF->SFF (не жду!) и
2) Начинаю процесс набора номера и досылки этого SFF как факса (Но если его вдруг не окажется на момент начала отправки факса, то будет Ж!!!).
По идее SFF начинает быть доступным для чтения (отправки fax data) еще не "дописавшись", так что чего бояться - факс все одно идет дольше, еще пока номер наберется, пока там факс ответит...
3) потом удаляю
Ну естественно чем быстрее процедура конвертации и чем меньше грузит компьютер, тем лучше. А вдруг сразу будут начаты 20 процедур конвертации -> отправки...
В GS мне честно говоря не нравится то, что при вызове из VB (хоть бы все и vbHide), начинает мелькать всякими песочными часиками (вирусы так себя часто ведут, неприятно это).
...
Рейтинг: 0 / 0
19.06.2012, 03:10
| Ответить | Цитировать | Написать  
Конвертер TIFF(BMP...)->SFF самому написать реально? Вопрос скорее к Бенедикту.
    #37843520
Дмитрий77
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Дмитрий77
Участник
Неужели нет какой-нибудь родной API которая позволяет получить bit из байта?

Хотя...большая часть изображения (незакодированного) -белый лист (или повторяется черное)... Стало быть GetBitX(255,a) и GetBitX(0,b) можно и не вычислять по 8 раз, результат и без вычислений ясен. Надо будет попробовать.
...
Рейтинг: 0 / 0
19.06.2012, 04:27
| Ответить | Цитировать | Написать  
Конвертер TIFF(BMP...)->SFF самому написать реально? Вопрос скорее к Бенедикту.
    #37843707
Фотография AndreTM
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
AndreTM
Участник
Дмитрий77Хотя...большая часть изображения (незакодированного) -белый лист (или повторяется черное)... Стало быть GetBitX(255,a) и GetBitX(0,b) можно и не вычислять по 8 раз, результат и без вычислений ясенДа, действительно... Реальная факс-информация - это текст, так что "белых" полей-строк будет большинство, ну и можно их сразу скидывать по шаблону...
Еще можно попробовать записывать результирующий файл не побайтно, а сразу блоками (например, построчно).
...
Рейтинг: 0 / 0
19.06.2012, 10:09
| Ответить | Цитировать | Написать  
Конвертер TIFF(BMP...)->SFF самому написать реально? Вопрос скорее к Бенедикту.
    #37843964
Дмитрий77
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Дмитрий77
Участник
AndreTM,

Если сделать так:
Код: vbnet
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
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


то оставляя мой код generateByte(the_byte)
для упомянутого файла в 3 секунды я укладываюсь.

Если взять 52 страницы справочника по AT-командам модема, то сконвертируется за 43 секунды.
Вроде неплохо но: GS эти 52 страницы конвертит за 3 !!! секунды.

>Еще можно попробовать записывать результирующий файл не побайтно, а сразу блоками (например, построчно).
Чего-то не пойму как это делать.
Так как ниже не получается ничего (код не работает):
Код: vbnet
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
    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


И я сильно сомневаюсь что это ускорит.
...
Рейтинг: 0 / 0
19.06.2012, 11:54
| Ответить | Цитировать | Написать  
Конвертер TIFF(BMP...)->SFF самому написать реально? Вопрос скорее к Бенедикту.
    #37844007
Фотография AndreTM
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
AndreTM
Участник
Впрочем, всё это - телодвижения
Реально ускорить перекодирование можно только с помощью низкоуровневого "байт-интерпретатора". То есть либо C (без шарпов), либо ASM, либо Forth. На Форте, кстати, дело сводится только к перечислению 256 слов + ввод/вывод буфера. Но предлагать вам такое - это у меня рука не поднимается
...
Рейтинг: 0 / 0
19.06.2012, 12:04
| Ответить | Цитировать | Написать  
Конвертер TIFF(BMP...)->SFF самому написать реально? Вопрос скорее к Бенедикту.
    #37844114
Дмитрий77
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Дмитрий77
Участник
Короче, подведем итоги. По крайней мере с задачей справился.
А уж где использовать GS, а где этот код позже буду смотреть.

Если реально что-то можно улучшить (ускорить), я с удовольствием попробую.

Код ниже это "текущая версия" с учетом всех плюсов/минусов. Ну и причесанная малость.
Грубо, из любого TIFF 204x196 либо 204x98 шириной 1728 (а других не держим) я могу сделать
SFF 203x196 либо 203x98 (в любой комбинации), ковертанув либо все страницы, либо последовательный блок страниц (от и до).

 
Код: vbnet
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
73.
74.
75.
76.
77.
78.
79.
80.
81.
82.
83.
84.
85.
86.
87.
88.
89.
90.
91.
92.
93.
94.
95.
96.
97.
98.
99.
100.
101.
102.
103.
104.
105.
106.
107.
108.
109.
110.
111.
112.
113.
114.
115.
116.
117.
118.
119.
120.
121.
122.
123.
124.
125.
126.
127.
128.
129.
130.
131.
132.
133.
134.
135.
136.
137.
138.
139.
140.
141.
142.
143.
144.
145.
146.
147.
148.
149.
150.
151.
152.
153.
154.
155.
156.
'CMultiFrameImage (Class module)
...
Public Sub SaveFrameAs1bppSFF( _
   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)
 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 sff_FileHandle As Integer         ' file handle, from freefile()
 Dim sff_FilePos As Long               ' pointer to last byte read/written
 
 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 = DpiX
    .biYPelsPerMeter = DpiY
 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
 
 sff_FilePos = 1
 sff_FileHandle = FreeFile(0)
 Open FileName For Binary Access Write Lock Write As sff_FileHandle
    
 'SFF header
 sff_FilePos = SFF_writeHeader(sff_FileHandle, sff_FilePos)
    
 'Page header
 sff_FilePos = SFF_writePageHeader(sff_FileHandle, sff_FilePos, DpiX, DpiY, bmiDst.bmiHeader.biWidth, bmiDst.bmiHeader.biHeight)
    
 'Page Data
 sff_FilePos = SFF_writePage(sff_FileHandle, sff_FilePos, bmiDst.bmiHeader.biWidth, bmiDst.bmiHeader.biHeight, pBits)
    
 'Document end
 SFF_writeDocumentEnd sff_FileHandle, sff_FilePos
    
 Close sff_FileHandle
 
 DeleteObject hbmDst: hbmDst = 0: pBits = 0
End Sub

Public Sub SaveMultiFrameAs1bppSFF( _
   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)
 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 i As Long
 
 Dim sff_FileHandle As Integer         ' file handle, from freefile()
 Dim sff_FilePos As Long               ' pointer to last byte read/written
 
 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
 
 sff_FilePos = 1
 sff_FileHandle = FreeFile(0)
 Open FileName For Binary Access Write Lock Write As sff_FileHandle
    
 'SFF header
 sff_FilePos = SFF_writeHeader(sff_FileHandle, sff_FilePos)
 
 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
        .biXPelsPerMeter = DpiX
        .biYPelsPerMeter = DpiY
    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
    
    'Page header
    sff_FilePos = SFF_writePageHeader(sff_FileHandle, sff_FilePos, DpiX, DpiY, bmiDst.bmiHeader.biWidth, bmiDst.bmiHeader.biHeight)
    
    'Page Data
    sff_FilePos = SFF_writePage(sff_FileHandle, sff_FilePos, bmiDst.bmiHeader.biWidth, bmiDst.bmiHeader.biHeight, pBits)
 
    DeleteObject hbmDst: hbmDst = 0: pBits = 0
 Next i
 'Document end
 SFF_writeDocumentEnd sff_FileHandle, sff_FilePos
    
 Close sff_FileHandle
End Sub



 
Код: vbnet
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
73.
74.
75.
76.
77.
78.
79.
80.
81.
82.
83.
84.
85.
86.
87.
88.
89.
90.
91.
92.
93.
94.
95.
96.
97.
98.
99.
100.
101.
102.
103.
104.
105.
106.
107.
108.
109.
110.
111.
112.
113.
114.
115.
116.
117.
118.
119.
120.
121.
122.
123.
124.
125.
126.
127.
128.
129.
130.
131.
132.
133.
134.
135.
136.
137.
138.
139.
140.
141.
142.
143.
144.
145.
146.
147.
148.
149.
150.
151.
152.
153.
154.
155.
156.
157.
158.
159.
160.
161.
162.
163.
164.
165.
166.
167.
168.
169.
170.
171.
172.
173.
174.
175.
176.
177.
178.
179.
180.
181.
182.
183.
184.
185.
186.
187.
188.
189.
190.
191.
192.
193.
194.
195.
196.
197.
198.
199.
200.
201.
202.
203.
204.
205.
206.
207.
208.
209.
210.
211.
212.
213.
214.
215.
216.
217.
218.
219.
220.
221.
222.
223.
224.
225.
226.
227.
228.
229.
230.
231.
232.
233.
234.
235.
236.
237.
238.
239.
240.
241.
242.
243.
244.
245.
246.
247.
248.
249.
250.
251.
252.
253.
254.
255.
256.
257.
258.
259.
260.
261.
262.
263.
264.
265.
266.
267.
268.
269.
270.
271.
272.
273.
274.
275.
276.
277.
278.
279.
280.
281.
282.
283.
284.
285.
286.
287.
288.
289.
290.
291.
292.
293.
294.
295.
296.
297.
298.
299.
300.
301.
302.
303.
304.
305.
306.
307.
308.
309.
310.
311.
312.
313.
314.
315.
316.
317.
318.
319.
320.
321.
322.
323.
324.
325.
326.
327.
328.
329.
330.
331.
332.
333.
334.
335.
336.
337.
338.
339.
340.
341.
342.
343.
344.
345.
346.
347.
348.
349.
350.
351.
352.
353.
354.
355.
356.
357.
358.
359.
360.
361.
362.
363.
364.
365.
366.
367.
368.
369.
370.
371.
372.
373.
374.
375.
376.
377.
378.
379.
380.
381.
382.
383.
384.
385.
386.
387.
388.
389.
390.
391.
392.
393.
394.
395.
396.
397.
398.
399.
400.
401.
402.
403.
404.
405.
406.
407.
408.
409.
410.
411.
412.
413.
414.
415.
416.
417.
418.
419.
420.
421.
422.
423.
424.
425.
426.
427.
428.
429.
430.
431.
432.
433.
434.
435.
436.
437.
438.
439.
440.
441.
442.
443.
444.
445.
446.
447.
448.
449.
450.
451.
452.
453.
454.
455.
456.
457.
458.
459.
460.
461.
462.
463.
464.
465.
466.
467.
468.
469.
470.
471.
472.
473.
474.
475.
476.
477.
478.
479.
480.
481.
482.
483.
484.
485.
486.
487.
488.
489.
490.
491.
492.
493.
494.
495.
496.
497.
498.
499.
500.
501.
502.
503.
504.
505.
506.
507.
508.
509.
510.
511.
512.
513.
514.
515.
516.
517.
518.
519.
520.
521.
522.
523.
524.
525.
526.
527.
528.
529.
530.
531.
532.
533.
534.
535.
536.
537.
538.
539.
540.
541.
542.
543.
544.
545.
546.
547.
548.
549.
550.
551.
552.
553.
554.
555.
556.
557.
558.
559.
560.
561.
562.
563.
564.
565.
566.
567.
568.
569.
570.
571.
572.
573.
574.
575.
576.
577.
578.
579.
580.
581.
582.
583.
584.
585.
586.
587.
588.
589.
590.
591.
592.
593.
594.
595.
596.
597.
598.
599.
600.
601.
602.
603.
604.
605.
606.
607.
608.
609.
610.
611.
612.
613.
614.
615.
616.
617.
618.
619.
620.
621.
622.
623.
624.
625.
626.
627.
628.
629.
630.
631.
632.
633.
634.
635.
636.
637.
638.
639.
640.
641.
642.
643.
644.
645.
646.
647.
648.
649.
650.
651.
652.
653.
654.
655.
656.
657.
658.
659.
660.
661.
662.
663.
664.
665.
666.
667.
668.
669.
670.
671.
672.
673.
674.
675.
676.
677.
678.
679.
680.
681.
682.
683.
684.
685.
686.
687.
688.
689.
690.
691.
692.
693.
694.
695.
696.
697.
698.
699.
700.
701.
702.
703.
704.
705.
706.
707.
708.
709.
710.
711.
712.
713.
714.
715.
716.
717.
718.
719.
720.
721.
722.
723.
724.
725.
'ModuleHuffman (Module)
Option Explicit

Private Enum BITSTATE
   STATE_WHITE = 0
   STATE_BLACK = 1
End Enum

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

Private 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

Private 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

Private 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

Private 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 Function SFF_writeHeader(FileHandle As Integer, start As Long) As Long
    Put FileHandle, start, "Sfff"
    Put FileHandle, start + 4, 1 'Version
    Put FileHandle, start + 5, 0 'reserved
    Put FileHandle, start + 6, 0 'User Information
    Put FileHandle, start + 7, 0
    Put FileHandle, start + 8, 0 'Page Count
    Put FileHandle, start + 9, 0
    Put FileHandle, start + 10, 20 'Offset first page header
    Put FileHandle, start + 11, 0
    Put FileHandle, start + 12, 0 'Offset last page header
    Put FileHandle, start + 13, 0
    Put FileHandle, start + 14, 0
    Put FileHandle, start + 15, 0
    Put FileHandle, start + 16, 0 'Offset of document end
    Put FileHandle, start + 17, 0
    Put FileHandle, start + 18, 0
    Put FileHandle, start + 19, 0
    SFF_writeHeader = start + 20
End Function

Public Function SFF_writePageHeader(FileHandle As Integer, start As Long, _
  Optional ByVal DpiX As Single = 203, Optional ByVal DpiY As Long = 98, _
  Optional ByVal width As Long = 1728, Optional ByVal height As Long = 0) As Long
    Put FileHandle, start, 254 'Page header ID
    Put FileHandle, start + 1, 16 'Page header lenth
    If DpiY < 100 Then
        Put FileHandle, start + 2, 0 'Resolution Vertical(normal: 98)
    Else
        Put FileHandle, start + 2, 1 'Resolution Vertical(fine: 196)
    End If
    Put FileHandle, start + 3, 0 'Resolution Horizontal: 203
    Put FileHandle, start + 4, 0 'Coding: Modified Huffman
    Put FileHandle, start + 5, 0 'reserved
    Put FileHandle, start + 6, width Mod 256 'Line lenth
    Put FileHandle, start + 7, width \ 256
    Put FileHandle, start + 8, height Mod 256 'Page lenth
    Put FileHandle, start + 9, height \ 256
    Put FileHandle, start + 10, 0 'Offset Previous page
    Put FileHandle, start + 11, 0
    Put FileHandle, start + 12, 0
    Put FileHandle, start + 13, 0
    Put FileHandle, start + 14, 0 'Offset Next page
    Put FileHandle, start + 15, 0
    Put FileHandle, start + 16, 0
    Put FileHandle, start + 17, 0
    SFF_writePageHeader = start + 18
End Function

Public Function SFF_writePage(FileHandle As Integer, start As Long, _
  width As Long, height As Long, pBits As Long) As Long
    Dim the_start As Long
    Dim ScanLine_lenth As Long
    Dim runlen As Long
    Dim whiteLines As Long
    Dim codeline As String 'Scan Line coded using MH
    Dim state As BITSTATE
    Dim tSA As SAFEARRAY2D
    Dim bDib() As Byte
    Dim x As Long, y As Long
    Dim j As Long
    
    the_start = start
    ScanLine_lenth = ((width + 15) \ 16) * 2
    ' Get the bits in the from DIB section:
    With tSA
        .cbElements = 1
        .cDims = 2
        .Bounds(0).lLbound = 0
        .Bounds(0).cElements = height
        .Bounds(1).lLbound = 0
        .Bounds(1).cElements = ScanLine_lenth ' BytesPerScanLine()
        .pvData = pBits
    End With
    CopyMemory ByVal VarPtrArray(bDib()), VarPtr(tSA), 4
    
    'Modified Huffman
    whiteLines = 0
    For y = 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) <= width) Then ' интересует первые 1728 бит
                    If ExamineBit(bDib(x, y), 7 - j) Then 'white bit
                        If (state = STATE_BLACK) Then
                            'кодируем предыдущие черные биты
                            codeline = codeline & DoBlack(runlen)
                            state = STATE_WHITE
                            runlen = 1
                        Else
                            runlen = runlen + 1
                        End If
                    Else 'black bit
                        If (state = STATE_WHITE) Then
                            If whiteLines > 0 Then 'если предыдущие линии белые
                                the_start = writeWhiteLines(whiteLines, FileHandle, the_start)
                                whiteLines = 0
                            End If
                            'кодируем предыдущие белые биты
                            codeline = codeline & DoWhite(runlen)
                            state = STATE_BLACK
                            runlen = 1
                        Else
                            runlen = runlen + 1
                        End If
                    End If
                   
                End If
            Next j
        Next x
        If (runlen = width) And (state = STATE_WHITE) Then 'все биты белые
            whiteLines = whiteLines + 1
            If y = 0 Then 'last scanline
                the_start = writeWhiteLines(whiteLines, FileHandle, the_start)
                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
            the_start = writeLine(codeline, FileHandle, the_start)
        End If
    Next y
    CopyMemory ByVal VarPtrArray(bDib), 0&, 4
    SFF_writePage = the_start
End Function

Public Function SFF_writeDocumentEnd(FileHandle As Integer, start As Long) As Long
    Put FileHandle, start, 254
    'Put FileHandle, start + 1, 0
    SFF_writeDocumentEnd = start + 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
    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

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
    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
    
    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
End Function

Private 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
   
' The ExamineBit function will return True or False depending on
' the value of the nth bit (Bit%) of an integer (Byte%).
Private 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



Код: vbnet
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
'Form1
Dim m_mfi As New CMultiFrameImage

Private Sub Form_Load()
    m_mfi.LoadFromFile Command
    LabelResOriginal.Caption = "Resolution " & m_mfi.HorizontalResolution & "x" & m_mfi.VerticalResolution
    LabelPages.Caption = "Pages: " & m_mfi.FrameCount
End Sub
Private Sub Command1_Click()
    Dim time1 As Date
    Dim time2 As Date
    DeleteFile App.Path & "\newtest.sff"
    time1 = Now
    If m_mfi.VerticalResolution = 98 Then
        If ComboResolution.Text = "203x98" Then
            If m_mfi.FrameCount = 1 Then
                m_mfi.SaveFrameAs1bppSFF App.Path & "\newtest.sff", 0, 203, 98, 1 'файл в 1 страницу
            ElseIf (Val(TextFrom.Text) = 0) And (Val(TextTo.Text) = 0) Then 'все страницы
                m_mfi.SaveMultiFrameAs1bppSFF App.Path & "\newtest.sff", 0, 0, 203, 98, 1 'все страницы
            ElseIf (Val(TextFrom.Text) = Val(TextTo.Text)) Then 'одна страница
                m_mfi.SaveFrameAs1bppSFF App.Path & "\newtest.sff", Val(TextFrom.Text), 203, 98, 1 'файл в 1 страницу
            Else 'несколько страниц
                m_mfi.SaveMultiFrameAs1bppSFF App.Path & "\newtest.sff", Val(TextFrom.Text), Val(TextTo.Text), 203, 98, 1
            End If
        Else 'преобразование в Fine
            If m_mfi.FrameCount = 1 Then
                m_mfi.SaveFrameAs1bppSFF App.Path & "\newtest.sff", 0, 203, 196, 2 'файл в 1 страницу
            ElseIf (Val(TextFrom.Text) = 0) And (Val(TextTo.Text) = 0) Then
                m_mfi.SaveMultiFrameAs1bppSFF App.Path & "\newtest.sff", 0, 0, 203, 196, 2 'все страницы
            ElseIf (Val(TextFrom.Text) = Val(TextTo.Text)) Then 'одна страница
                m_mfi.SaveFrameAs1bppSFF App.Path & "\newtest.sff", Val(TextFrom.Text), 203, 196, 2 'файл в 1 страницу
            Else 'несколько страниц
                m_mfi.SaveMultiFrameAs1bppSFF App.Path & "\newtest.sff", Val(TextFrom.Text), Val(TextTo.Text), 203, 196, 2
            End If
        End If
    Else
        If ComboResolution.Text = "203x98" Then 'ухудшение до Normal
            If m_mfi.FrameCount = 1 Then
                m_mfi.SaveFrameAs1bppSFF App.Path & "\newtest.sff", 0, 203, 98, 0.5 'файл в 1 страницу
            ElseIf (Val(TextFrom.Text) = 0) And (Val(TextTo.Text) = 0) Then 'все страницы
                m_mfi.SaveMultiFrameAs1bppSFF App.Path & "\newtest.sff", 0, 0, 203, 98, 0.5 'все страницы
            ElseIf (Val(TextFrom.Text) = Val(TextTo.Text)) Then 'одна страница
                m_mfi.SaveFrameAs1bppSFF App.Path & "\newtest.sff", Val(TextFrom.Text), 203, 98, 0.5 'файл в 1 страницу
            Else 'несколько страниц
                m_mfi.SaveMultiFrameAs1bppSFF App.Path & "\newtest.sff", Val(TextFrom.Text), Val(TextTo.Text), 203, 98, 0.5
            End If
        Else 'оставляем в Fine
            If m_mfi.FrameCount = 1 Then
                m_mfi.SaveFrameAs1bppSFF App.Path & "\newtest.sff", 0, 203, 196, 1 'файл в 1 страницу
            ElseIf (Val(TextFrom.Text) = 0) And (Val(TextTo.Text) = 0) Then 'все страницы
                m_mfi.SaveMultiFrameAs1bppSFF App.Path & "\newtest.sff", 0, 0, 203, 196, 1 'все страницы
            ElseIf (Val(TextFrom.Text) = Val(TextTo.Text)) Then 'одна страница
                m_mfi.SaveFrameAs1bppSFF App.Path & "\newtest.sff", Val(TextFrom.Text), 203, 196, 1 'файл в 1 страницу
            Else 'несколько страниц
                m_mfi.SaveMultiFrameAs1bppSFF App.Path & "\newtest.sff", Val(TextFrom.Text), Val(TextTo.Text), 203, 196, 1
            End If
        End If
    End If
    
    time2 = Now
    MsgBox Format(time2 - time1, "hh:mm:ss") & " sec"
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Set m_mfi = Nothing
End Sub


Модератор: Дим, не забывай про спойлер
...
Рейтинг: 0 / 0
19.06.2012, 12:55
| Ответить | Цитировать | Написать  
Конвертер TIFF(BMP...)->SFF самому написать реально? Вопрос скорее к Бенедикту.
    #37844281
Фотография AndreTM
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
AndreTM
Участник
Кстати, для Хаффмана...
Можно заменить CASE в termXX и makeXX на решето (напрямую - на Эратосфена).
То есть, вместо выбора вариантов, - прямое обращение к массиву ответов.
Выигрыш по скорости будет оптимальнее затрат на использоване памяти.
...
Рейтинг: 0 / 0
19.06.2012, 13:58
| Ответить | Цитировать | Написать  
Конвертер TIFF(BMP...)->SFF самому написать реально? Вопрос скорее к Бенедикту.
    #37844546
Дмитрий77
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Дмитрий77
Участник
AndreTMМожно заменить CASE в termXX и makeXX на решето (напрямую - на Эратосфена).
То есть, вместо выбора вариантов, - прямое обращение к массиву ответов.
Как это сделать? Не покажете на примере кода?
...
Рейтинг: 0 / 0
19.06.2012, 15:27
| Ответить | Цитировать | Написать  
Конвертер TIFF(BMP...)->SFF самому написать реально? Вопрос скорее к Бенедикту.
    #37844620
Фотография AndreTM
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
AndreTM
Участник
Дмитрий77AndreTMМожно заменить CASE в termXX и makeXX на решето (напрямую - на Эратосфена).
То есть, вместо выбора вариантов, - прямое обращение к массиву ответов.
Как это сделать? Не покажете на примере кода?Ну, если будет время - покажу...
Просто мне очень лень реализовывать такой массив на VB... поскольку надо будет весь твой код анализировать... хотя-я... можно будет попробовать заменить четыре функции...
...
Рейтинг: 0 / 0
19.06.2012, 15:43
| Ответить | Цитировать | Написать  
Конвертер TIFF(BMP...)->SFF самому написать реально? Вопрос скорее к Бенедикту.
    #37844697
Дмитрий77
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Дмитрий77
Участник
AndreTM,

А чего там анализировать.
Есть две ф-ции:
DoWhite(runlen As Long)
DoBlack(runlen As Long)

Они используют 4 функции:
termWhite(runlen As Long)
termBlack(runlen As Long)
makeUpWhite(makeup As Long)
makeUpBlack(makeup As Long)

Вы предлагаете эти 4 на что-то заменить (массивы, константы).
Вот я и прошу показать как это сделать.
Я же не прошу весь массив за меня ручками рисовать.
Рисовать весь, согласен, рутинная работа. Я из libtiff все это копировал, а потом 2-3 часа сидел проставлял все эти case: и сверял тупо по трем документам (типа как р/счет на квитанции заполняете, считаете нули и ругаетесь), потому как в этих нулях и единицах запутаться на раз-два, там где стоит '? там в исходнике (упоминается в начале поста) были ошибки.
...
Рейтинг: 0 / 0
19.06.2012, 16:06
| Ответить | Цитировать | Написать  
Конвертер TIFF(BMP...)->SFF самому написать реально? Вопрос скорее к Бенедикту.
    #37845285
Фотография AndreTM
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
AndreTM
Участник
А что показывать? Примерно так:
Код: vbnet
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
Dim termWhite() As String

Private Sub create_termWhite()
    ReDim termWhite(0 To 63)
    termWhite = Array("00110101", "000111", "0111", ...
End Sub

Dim makeUpWhite() As String

Private Sub create_makeUpWhite()
    ReDim makeUpWhite(0 To 2560)
    makeUpWhite(64) = "11011"
    makeUpWhite(128) = "10010"
...
End Sub
...
Рейтинг: 0 / 0
19.06.2012, 21:55
| Ответить | Цитировать | Написать  
Конвертер TIFF(BMP...)->SFF самому написать реально? Вопрос скорее к Бенедикту.
    #37845483
Дмитрий77
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Дмитрий77
Участник
AndreTM,

Ну, я сделал как вы сказали, а именно:
 
Код: vbnet
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
73.
74.
75.
76.
77.
78.
79.
80.
81.
82.
83.
84.
85.
86.
87.
88.
89.
90.
91.
92.
93.
94.
95.
96.
97.
98.
99.
100.
101.
102.
103.
104.
105.
106.
107.
108.
109.
110.
111.
112.
113.
114.
115.
116.
117.
118.
119.
120.
121.
122.
123.
124.
125.
126.
127.
128.
129.
Dim termWhite() As Variant
Dim termBlack() As Variant
Dim makeUpWhite() As String
Dim makeUpBlack() As String

Public Sub InitTermAndmakeUp()
    create_termWhite
    create_termBlack
    create_makeUpWhite
    create_makeUpBlack
End Sub

Private Sub create_termWhite()
    ReDim termWhite(0 To 63)
    termWhite = Array("00110101", "000111", "0111", "1000", "1011", "1100", "1110", "1111", _
      "10011", "10100", "00111", "01000", "001000", "000011", "110100", "110101", _
      "101010", "101011", "0100111", "0001100", "0001000", "0010111", "0000011", "0000100", _
      "0101000", "0101011", "0010011", "0100100", "0011000", "00000010", "00000011", "00011010", _
      "00011011", "00010010", "00010011", "00010100", "00010101", "00010110", "00010111", "00101000", _
      "00101001", "00101010", "00101011", "00101100", "00101101", "00000100", "00000101", "00001010", _
      "00001011", "01010010", "01010011", "01010100", "01010101", "00100100", "00100101", "01011000", _
      "01011001", "01011010", "01011011", "01001010", "01001011", "00110010", "00110011", "00110100")
End Sub

Private Sub create_termBlack()
    ReDim termBlack(0 To 63)
    termBlack = Array("0000110111", "010", "11", "10", "011", "0011", "0010", "00011", _
      "000101", "000100", "0000100", "0000101", "0000111", "00000100", "00000111", "000011000", _
      "0000010111", "0000011000", "0000001000", "00001100111", _
      "00001101000", "00001101100", "00000110111", "00000101000", _
      "00000010111", "00000011000", "000011001010", "000011001011", _
      "000011001100", "000011001101", "000001101000", "000001101001", _
      "000001101010", "000001101011", "000011010010", "000011010011", _
      "000011010100", "000011010101", "000011010110", "000011010111", _
      "000001101100", "000001101101", "000011011010", "000011011011", _
      "000001010100", "000001010101", "000001010110", "000001010111", _
      "000001100100", "000001100101", "000001010010", "000001010011", _
      "000000100100", "000000110111", "000000111000", "000000100111", _
      "000000101000", "000001011000", "000001011001", "000000101011", _
      "000000101100", "000001011010", "000001100110", "000001100111")
End Sub

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

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


ДимаЕсли взять 52 страницы справочника по AT-командам модема, то сконвертируется за 43 секунды.
Вроде неплохо но: GS эти 52 страницы конвертит за 3 !!! секунды.AndreTMТо есть, вместо выбора вариантов, - прямое обращение к массиву ответов.
Выигрыш по скорости будет оптимальнее затрат на использоване памяти.
Зря старался, получилось 46 секунд вместо 43. Память растранжирили, скорость наоборот чуть упала. Склоняюсь к исходному варианту.
...
Рейтинг: 0 / 0
20.06.2012, 03:10
| Ответить | Цитировать | Написать  
Конвертер TIFF(BMP...)->SFF самому написать реально? Вопрос скорее к Бенедикту.
    #37845488
Фотография AndreTM
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
AndreTM
Участник
Какой Variant , нах...?
А не пробовали Array() As String ? Или еще проще - Dim termWhite() As String * 8 и так далее?
...
Рейтинг: 0 / 0
20.06.2012, 03:24
| Ответить | Цитировать | Написать  
Конвертер TIFF(BMP...)->SFF самому написать реально? Вопрос скорее к Бенедикту.
    #37845497
Дмитрий77
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Дмитрий77
Участник
AndreTMКакой Variant , нах...?
А не пробовали Array() As String ? Или еще проще - Dim termWhite() As String * 8 и так далее?
Пробовал. Только Array() предполагает Variant, а если As String, то Array() выдаст
Type Mismatch.

Нет проблем, напишите как правильно.

http://www.vb6.us/tutorials/understanding-arrays

Another way to do this is with the Array function, which is convenient to use, but incurs the overhead of the Variant datatype. The way to use the function is as follows:

First, declare a Variant variable to hold your array. It may be declared with or without the open parentheses. Recall that since Variant is the default datatype, the "As Variant" clause is optional:

Dim astrDayAbbrev() As Variant

Second, use the Array function to assign a list of data items to the variable :

astrDayAbbrev = Array("Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat")
...
Рейтинг: 0 / 0
20.06.2012, 03:53
| Ответить | Цитировать | Написать  
Конвертер TIFF(BMP...)->SFF самому написать реально? Вопрос скорее к Бенедикту.
    #37845562
ZVI
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
ZVI
Участник
Советы:

1. If- ElseIf - … - ElseIf -_End If в VB немного быстрее, чем Select - Case - … - End Select

2. Использование Dictionary возможно даст выигрыш, но это нужно проверять для конкретного случая.

3. Если использовать массивы, то лучше, действительно, задать переменные массива явно текстовыми:
Dim termWhite(0 To 63) As String
а инициализацию массива делать, задавая значение каждого элемента без Array("…")
То есть: White(0) = "00110101" и т.д.
И в массивах makeUpWhite() и makeUpBlack() незачем шагать через 64, достаточно объявить их как Dim makeUpWhite$(1 To 40) , makeUpBlack$(1 To 40), а индекс перед обращением к массиву делить на 64.

4. Наиболее тормознутой выглядит конкатенация строк, как улучшить – см. Как ускорить создание строковых буферов
Еще вариант - набить массив, а затем выполнить Join, так как в Join реализован именно такой быстрый способ конкатенации.

5. Частое Put также может тормозить изрядно, лучше набивать в памяти буфер или байтовый массив приличного размера, а затем изредка добавлять его в файл.
...
Рейтинг: 0 / 0
20.06.2012, 08:41
| Ответить | Цитировать | Написать  
Конвертер TIFF(BMP...)->SFF самому написать реально? Вопрос скорее к Бенедикту.
    #37846585
Дмитрий77
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Дмитрий77
Участник
ZVI3. Если использовать массивы, то лучше, действительно, задать переменные массива явно текстовыми:
Dim termWhite(0 To 63) As String
а инициализацию массива делать, задавая значение каждого элемента без Array("…")
То есть: White(0) = "00110101" и т.д.
И в массивах makeUpWhite() и makeUpBlack() незачем шагать через 64, достаточно объявить их как Dim makeUpWhite$(1 To 40) , makeUpBlack$(1 To 40), а индекс перед обращением к массиву делить на 64..Сделал:
 
Код: vbnet
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
73.
74.
75.
76.
77.
78.
79.
80.
81.
82.
83.
84.
85.
86.
87.
88.
89.
90.
91.
92.
93.
94.
95.
96.
97.
98.
99.
100.
101.
102.
103.
104.
105.
106.
107.
108.
109.
110.
111.
112.
113.
114.
115.
116.
117.
118.
119.
120.
121.
122.
123.
124.
125.
126.
127.
128.
129.
130.
131.
132.
133.
134.
135.
136.
137.
138.
139.
140.
141.
142.
143.
144.
145.
146.
147.
148.
149.
150.
151.
152.
153.
154.
155.
156.
157.
158.
159.
160.
161.
162.
163.
164.
165.
166.
167.
168.
169.
170.
171.
172.
173.
174.
175.
176.
177.
178.
179.
180.
181.
182.
183.
184.
185.
186.
187.
188.
189.
190.
191.
192.
193.
194.
195.
196.
197.
198.
199.
200.
201.
202.
203.
204.
205.
206.
207.
208.
209.
210.
211.
212.
213.
214.
215.
216.
217.
218.
219.
220.
221.
222.
223.
224.
225.
226.
227.
228.
229.
230.
231.
232.
233.
234.
235.
236.
237.
238.
239.
240.
241.
242.
243.
244.
245.
246.
247.
248.
249.
250.
251.
252.
253.
254.
255.
256.
257.
258.
259.
260.
261.
262.
263.
264.
265.
266.
267.
268.
269.
270.
271.
272.
273.
274.
275.
276.
Dim termWhite() As String
Dim termBlack() As String
Dim makeUpWhite() As String
Dim makeUpBlack() As String

Public Sub InitTermAndmakeUp()
    create_termWhite
    create_termBlack
    create_makeUpWhite
    create_makeUpBlack
End Sub

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

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

Private Sub create_makeUpWhite()
    ReDim makeUpWhite(1 To 40)
    makeUpWhite(1) = "11011" '64
    makeUpWhite(2) = "10010" '128
    makeUpWhite(3) = "010111" '192
    makeUpWhite(4) = "0110111" '256
    makeUpWhite(5) = "00110110" '320
    makeUpWhite(6) = "00110111" '384
    makeUpWhite(7) = "01100100" '448
    makeUpWhite(8) = "01100101" '512
    makeUpWhite(9) = "01101000" '576
    makeUpWhite(10) = "01100111" '640
    makeUpWhite(11) = "011001100" '704
    makeUpWhite(12) = "011001101" '768
    makeUpWhite(13) = "011010010" '832
    makeUpWhite(14) = "011010011" '896 ?
    makeUpWhite(15) = "011010100" '960
    makeUpWhite(16) = "011010101" '1024
    makeUpWhite(17) = "011010110" '1088
    makeUpWhite(18) = "011010111" '1152
    makeUpWhite(19) = "011011000" '1216
    makeUpWhite(20) = "011011001" '1280
    makeUpWhite(21) = "011011010" '1344
    makeUpWhite(22) = "011011011" '1408
    makeUpWhite(23) = "010011000" '1472
    makeUpWhite(24) = "010011001" '1536
    makeUpWhite(25) = "010011010" '1600
    makeUpWhite(26) = "011000" '1664
    makeUpWhite(27) = "010011011" '1728
    makeUpWhite(28) = "00000001000" '1792
    makeUpWhite(29) = "00000001100" '1856
    makeUpWhite(30) = "00000001101" '1920
    makeUpWhite(31) = "000000010010" '1984
    makeUpWhite(32) = "000000010011" '2048
    makeUpWhite(33) = "000000010100" '2112
    makeUpWhite(34) = "000000010101" '2176
    makeUpWhite(35) = "000000010110" '2240
    makeUpWhite(36) = "000000010111" '2304
    makeUpWhite(37) = "000000011100" '2368
    makeUpWhite(38) = "000000011101" '2432
    makeUpWhite(39) = "000000011110" '2496
    makeUpWhite(40) = "000000011111" '2560
End Sub

Private Sub create_makeUpBlack()
    ReDim makeUpBlack(1 To 40)
    makeUpBlack(1) = "0000001111" '64 ?
    makeUpBlack(2) = "000011001000" '128 ?
    makeUpBlack(3) = "000011001001" '192
    makeUpBlack(4) = "000001011011" '256
    makeUpBlack(5) = "000000110011" '320
    makeUpBlack(6) = "000000110100" '384
    makeUpBlack(7) = "000000110101" '448
    makeUpBlack(8) = "0000001101100" '512
    makeUpBlack(9) = "0000001101101" '576
    makeUpBlack(10) = "0000001001010" '640
    makeUpBlack(11) = "0000001001011" '704
    makeUpBlack(12) = "0000001001100" '768
    makeUpBlack(13) = "0000001001101" '832
    makeUpBlack(14) = "0000001110010" '896
    makeUpBlack(15) = "0000001110011" '960
    makeUpBlack(16) = "0000001110100" '1024
    makeUpBlack(17) = "0000001110101" '1088
    makeUpBlack(18) = "0000001110110" '1152
    makeUpBlack(19) = "0000001110111" '1216
    makeUpBlack(20) = "0000001010010" '1280
    makeUpBlack(21) = "0000001010011" '1344
    makeUpBlack(22) = "0000001010100" '1408
    makeUpBlack(23) = "0000001010101" '1472
    makeUpBlack(24) = "0000001011010" '1536
    makeUpBlack(25) = "0000001011011" '1600
    makeUpBlack(26) = "0000001100100" '1664
    makeUpBlack(27) = "0000001100101" '1728
    makeUpBlack(28) = "00000001000" '1792
    makeUpBlack(29) = "00000001100" '1856
    makeUpBlack(30) = "00000001101" '1920
    makeUpBlack(31) = "000000010010" '1984
    makeUpBlack(32) = "000000010011" '2048
    makeUpBlack(33) = "000000010100" '2112
    makeUpBlack(34) = "000000010101" '2176
    makeUpBlack(35) = "000000010110" '2240
    makeUpBlack(36) = "000000010111" '2304
    makeUpBlack(37) = "000000011100" '2368
    makeUpBlack(38) = "000000011101" '2432
    makeUpBlack(39) = "000000011110" '2496
    makeUpBlack(40) = "000000011111" '2560
End Sub
...

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(40) '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 / 64)
    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(40) '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 / 64)
    End If
    code = code & termBlack(run_len) ' max 63
    DoBlack = code
End Function


Для 52 страниц вместо 43 сек получил 42-43 сек, т.е. выигрыша никакого.


Стоит ли проверять:ZVI1. If- ElseIf - … - ElseIf -_End If в VB немного быстрее, чем Select - Case - … - End SelectПредлагаете использовать ф-ции как в исходном варианте, но заменить case на If- ElseIf ?


Стоит ли проверять:ZVI2. Использование Dictionary возможно даст выигрыш, но это нужно проверять для конкретного случая.И здесь поподробнее. Как это?


ZVI4. Наиболее тормознутой выглядит конкатенация строк, как улучшить – см. Как ускорить создание строковых буферов
Еще вариант - набить массив, а затем выполнить Join, так как в Join реализован именно такой быстрый способ конкатенации.
Вы про это?
Код: vbnet
1.
2.
3.
4.
5.
Public Function SFF_writePage(FileHandle As Integer, start As Long, _
...
codeline = codeline & DoBlack(runlen)
...
codeline = codeline & DoWhite(runlen)


Вообще есть подозрение, что основная проблема именно при чтении bitmap, оптимизация получения значения бита (с библиотекой от AndreTM) дает чуть прирост скорости, но не очень сильный, причем это компенсируется той идеей что я сделал -не вычислять биты если байт =0 либо =255. Поэтому проблема возможно в конкатенации строк.
Не подкрепите еще кодами?

ZVI5. Частое Put также может тормозить изрядно, лучше набивать в памяти буфер или байтовый массив приличного размера, а затем изредка добавлять его в файл.Не покажете как на примере кода? Набивать String, а потом делать Put у меня ничего не получилось.
...
Рейтинг: 0 / 0
20.06.2012, 15:13
| Ответить | Цитировать | Написать  
Конвертер TIFF(BMP...)->SFF самому написать реально? Вопрос скорее к Бенедикту.
    #37847209
Дмитрий77
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Дмитрий77
Участник
ZVIСоветы:4. Наиболее тормознутой выглядит конкатенация строк, как улучшить – см. Как ускорить создание строковых буферов
Попробовал по 3-му ("самому быстрому") варианту:
 
Код: vbnet
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
73.
74.
75.
76.
77.
78.
79.
80.
81.
82.
83.
84.
85.
86.
87.
88.
89.
90.
91.
92.
93.
94.
95.
96.
97.
98.
99.
100.
101.
102.
103.
104.
105.
106.
107.
108.
109.
110.
111.
112.
113.
114.
115.
116.
117.
118.
119.
120.
121.
122.
123.
Public Function SFF_writePage(FileHandle As Integer, start As Long, _
  width As Long, height As Long, pBits As Long) As Long
    Dim the_start As Long
    Dim ScanLine_lenth As Long
    Dim runlen As Long
    Dim whiteLines As Long
    Dim codeline As String 'Scan Line coded using MH
    Dim state As BITSTATE
    Dim tSA As SAFEARRAY2D
    Dim bDib() As Byte
    Dim x As Long, y As Long
    Dim j As Long
    
    the_start = start
    ScanLine_lenth = ((width + 15) \ 16) * 2
    ' Get the bits in the from DIB section:
    With tSA
        .cbElements = 1
        .cDims = 2
        .Bounds(0).lLbound = 0
        .Bounds(0).cElements = height
        .Bounds(1).lLbound = 0
        .Bounds(1).cElements = ScanLine_lenth ' BytesPerScanLine()
        .pvData = pBits
    End With
    CopyMemory ByVal VarPtrArray(bDib()), VarPtr(tSA), 4
    
    Dim lCur As Long, lNew As Long
    Dim strNew As String
    
    'Modified Huffman
    whiteLines = 0
    For y = height - 1 To 0 Step -1
        runlen = 0
        state = STATE_WHITE
        codeline = Space(1)  ' начальный буфер
        lCur = 1        ' текущий указатель в буфере
        For x = 0 To ScanLine_lenth - 1
            For j = 0 To 7
                If ((x * 8 + j + 1) <= width) Then ' интересует первые 1728 бит
                    If ExamineBit(bDib(x, y), 7 - j) Then 'white bit
                        If (state = STATE_BLACK) Then
                            'кодируем предыдущие черные биты
                            strNew = DoBlack(runlen)
                            lNew = Len(strNew)
                            While lCur + lNew - 1 > Len(codeline)
                                ' удвоение длины буфера
                                codeline = codeline & codeline
                            Wend
                            Mid$(codeline, lCur) = strNew
                            lCur = lCur + lNew
                            state = STATE_WHITE
                            runlen = 1
                        Else
                            runlen = runlen + 1
                        End If
                    Else 'black bit
                        If (state = STATE_WHITE) Then
                            If whiteLines > 0 Then 'если предыдущие линии белые
                                the_start = writeWhiteLines(whiteLines, FileHandle, the_start)
                                whiteLines = 0
                            End If
                            'кодируем предыдущие белые биты
                            strNew = DoWhite(runlen)
                            lNew = Len(strNew)
                            While lCur + lNew - 1 > Len(codeline)
                                ' удвоение длины буфера
                                codeline = codeline & codeline
                            Wend
                            Mid$(codeline, lCur) = strNew
                            lCur = lCur + lNew
                            state = STATE_BLACK
                            runlen = 1
                        Else
                            runlen = runlen + 1
                        End If
                    End If
                   
                End If
            Next j
        Next x
        If (runlen = width) And (state = STATE_WHITE) Then 'все биты белые
            whiteLines = whiteLines + 1
            If y = 0 Then 'last scanline
                the_start = writeWhiteLines(whiteLines, FileHandle, the_start)
                whiteLines = 0
            End If
        Else
            If state = STATE_WHITE Then
                strNew = DoWhite(runlen)
                lNew = Len(strNew)
                While lCur + lNew - 1 > Len(codeline)
                    ' удвоение длины буфера
                    codeline = codeline & codeline
                Wend
                Mid$(codeline, lCur) = strNew
                lCur = lCur + lNew
            Else
                strNew = DoBlack(runlen)
                lNew = Len(strNew)
                While lCur + lNew - 1 > Len(codeline)
                    ' удвоение длины буфера
                    codeline = codeline & codeline
                Wend
                Mid$(codeline, lCur) = strNew
                lCur = lCur + lNew
            End If
            strNew = "000000000001" '+ EOL
            lNew = Len(strNew)
            While lCur + lNew - 1 > Len(codeline)
                ' удвоение длины буфера
                codeline = codeline & codeline
            Wend
            Mid$(codeline, lCur) = strNew
            lCur = lCur + lNew
            ' формирование окончательного буфера
            codeline = Left$(codeline, lCur - 1)
            the_start = writeLine(codeline, FileHandle, the_start)
        End If
    Next y
    CopyMemory ByVal VarPtrArray(bDib), 0&, 4
    SFF_writePage = the_start
End Function

Для 52 страниц вместо 42-43 сек получаем теперь 42-47 сек, т.е. опять выигрыша никакого.
Т.е. пока имеем, что извращаем код до человеко-непонимания, а скорость не растет.
Ну, в вашем примере 20000 конкатенаций на строку.
А у меня 1728 (максимум!!!) это если белое и черное идут через пиксель (что практически нереально), в реальности их гораздо меньше, м.б. пара десятков, ну сотня если текст.
Огород по удвоению буферов скорее замедлит чем ускорит.

ZVI5. Частое Put также может тормозить изрядно, лучше набивать в памяти буфер или байтовый массив приличного размера, а затем изредка добавлять его в файл.
Дайте пример кода. Хотя надежды что это поможет мало.
...
Рейтинг: 0 / 0
20.06.2012, 20:09
| Ответить | Цитировать | Написать  
Конвертер TIFF(BMP...)->SFF самому написать реально? Вопрос скорее к Бенедикту.
    #37847403
Фотография AndreTM
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
AndreTM
Участник
Хорошо, всё..., мы поняли, поняли...
Я же говорил, что скорость можно получить только хитровы.. хитрыми методами
Предлагал же перейти на Форт (тот же самый PostScript)?
...
Рейтинг: 0 / 0
20.06.2012, 23:10
| Ответить | Цитировать | Написать  
25 сообщений из 54, страница 2 из 3
  2  все
Форумы / Visual Basic [игнор отключен] [закрыт для гостей] / Конвертер TIFF(BMP...)->SFF самому написать реально? Вопрос скорее к Бенедикту.
Целевая тема:
Создать новую тему:
Автор:
Закрыть
Цитировать
Найденые пользователи ...
Разблокировать пользователей ...
Читали тему (0):
Читали форум (0):
Пользователи онлайн (0):
Польз. соглашение
NoSQL.ru       Новости, Чат       Фотоальбом: Участники, Встречи
Закрыть
start [/forum/topic.php?fid=60&msg=37845488&tid=2157584]:
 0ms
get settings:
 9ms
get forum list:
 15ms
check forum access:
 4ms
check topic access:
 4ms
track hit:
 45ms
get topic data:
 10ms
get forum data:
 3ms
get page messages:
 60ms
get tp. blocked users:
 1ms
others: 14ms
total:  165ms
созд. / загр.: 165ms
x
x
Закрыть


Просмотр
0 / 0
Close
Debug Console [Select Text]