Так, спокойно.
Дмитрий77ZVI5. Частое Put также может тормозить изрядно, лучше набивать в памяти буфер или байтовый массив приличного размера, а затем изредка добавлять его в файл.
Хотя надежды что это поможет мало.
Поможет.
1) Сначала я попробовал делать Put один раз на строчку (ф-ция writeLine)
52 страницы скорость возросла до 37сек вместо 43
2) Потом попытался буферизовать страницу целиком:
в SFF_writePage объявляю Dim data() As Byte
при каждом вызове writeWhiteLinesToBuffer или writeLineToBuffer передаю туда data ByRef, высчитываю сколько байтов добавляю, делаю ReDim Preserve data по новому размеру и дописываю туда байты.
Put делаю один раз на страницу.
Код ниже:
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.
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
Dim data() As Byte ' the buffer
Dim data_lenth As Long
data_lenth = 0
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 'если предыдущие линии белые
data_lenth = writeWhiteLinesToBuffer(whiteLines, data_lenth, data)
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
data_lenth = writeWhiteLinesToBuffer(whiteLines, data_lenth, data)
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
data_lenth = writeLineToBuffer(codeline, data_lenth, data)
End If
Next y
Put FileHandle, the_start, data
the_start = the_start + data_lenth
CopyMemory ByVal VarPtrArray(bDib), 0&, 4
SFF_writePage = the_start
End Function
Private Function writeWhiteLinesToBuffer(whiteLines As Long, start_lenth As Long, ByRef data() As Byte) As Long
'returns next lenth of data()
Dim white_Lines As Long
Dim the_start_lenth As Long
Dim the_lenth As Long
Dim the_cur As Long
white_Lines = whiteLines
the_start_lenth = start_lenth
the_lenth = (white_Lines + 36) \ 37
the_cur = the_start_lenth
ReDim Preserve data(0 To the_start_lenth + the_lenth - 1) '(the_start_lenth-1)+the_lenth
If (white_Lines > 0) Then
Do While white_Lines > 37 ' max 37: 217..253
data(the_cur) = 253
white_Lines = white_Lines - 37
the_cur = the_cur + 1
Loop
data(the_cur) = 216 + white_Lines
the_cur = the_cur + 1
End If
writeWhiteLinesToBuffer = the_cur
End Function
Private Function writeLineToBuffer(codeline As String, start_lenth As Long, ByRef data() As Byte) As Long
'returns next lenth of data()
Dim code_Line As String
Dim the_start_lenth As Long
Dim the_byte As String
Dim the_lenth As Long
Dim the_cur As Long
code_Line = codeline
the_start_lenth = start_lenth
the_lenth = (Len(code_Line) + 7) \ 8
the_cur = the_start_lenth
If the_lenth <= 216 Then
ReDim Preserve data(0 To the_start_lenth + the_lenth) '(the_start_lenth-1)+1+the_lenth
data(the_cur) = the_lenth
the_cur = the_cur + 1
Else
ReDim Preserve data(0 To the_start_lenth + the_lenth + 2) '(the_start_lenth-1)+3+the_lenth
data(the_cur) = 0
data(the_cur + 1) = the_lenth Mod 256
data(the_cur + 2) = the_lenth \ 256
the_cur = the_cur + 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)
data(the_cur) = generateByte(the_byte)
the_cur = the_cur + 1
Next
End If
writeLineToBuffer = the_cur
End Function
Скорость возросла до 52страницы за 32-33сек.
Вопросы:
1) хорошо ли буферизовать страницу целиком как я делаю,динамически меняя размер массива ну килобайтов 200 там легко может быть. Не тормозит ли это(что целиком)? И можно ли так оставить?
2) по идее это надо делать по другому.
Брать например Dim data(2048) As Byte ' the buffer
и по заполнении скидывать в put.
Только как это организовать? Тогда перед каждым байтом надо делать проверку на количество записанных (это в разных местах кода) и хаотически вызывать из writeWhiteLines либо writeLine. Ну, не знаю как это сделать.
3) Надо ли буферизовать SFF_writeHeader и SFF_writePageHeader или это "копейки"?
