Страница: 1
Вопрос: Как Рисование мышью
Добавлено: 02.07.10 12:10
Автор вопроса: ilgar
Ребята у меня маленькая проблема.
Ответить
Номер ответа: 2Автор ответа: AWP ICQ: 345685652 Вопросов: 96Ответов: 1212
Web-сайт: xawp.narod.ru Профиль | | #2
Добавлено: 02.07.10 16:42
вот тебе конкретный класс
Option Explicit
Option Base 0
Private Const SOF0 As Long = &HC0&
Private Const DHT As Long = &HC4& Private Const SOI As Long = &HD8& Private Const EOI As Long = &HD9& Private Const SOS As Long = &HDA& Private Const DQT As Long = &HDB& Private Const COM As Long = &HFE&
Private QLumin(63) As Integer Private QChrom(63) As Integer Private FDCTScale(7) As Double Private IDCTScale(7) As Double Private ZigZag(7, 7) As Long
Private Const COLORONCOLOR As Long = 3 Private Const HALFTONE As Long = 4
Private Const BI_RGB As Long = 0
Private Const DIB_RGB_COLORS As Long = 0
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 Type RGBQUAD
rgbBlue As Byte
rgbGreen As Byte
rgbRed As Byte
rgbReserved As Byte
End Type
Private Type BITMAPINFOHEADER
biSize As Long
biWidth As Long
biHeight As Long
biPlanes As Integer
biBitCount As Integer
biCompression As Long
biSizeImage As Long
biXPelsPerMeter As Long
biYPelsPerMeter As Long
biClrUsed As Long
biClrImportant As Long
End Type
Private Type BITMAPINFO
bmiHeader As BITMAPINFOHEADER
bmiColors As RGBQUAD
End Type
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long ) As Long
Private Declare Function CreateDIBSection2 Lib "gdi32" Alias "CreateDIBSection" (ByVal hdc As Long , pBitmapInfo As BITMAPINFO, ByVal un As Long , lplpVoid As Long , ByVal handle As Long , ByVal dw As Long ) As Long Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long , ByVal X As Long , ByVal Y As Long , ByVal nWidth As Long , ByVal nHeight As Long , ByVal hSrcDC As Long , ByVal xSrc As Long , ByVal ySrc As Long , ByVal dwRop As Long ) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long , ByVal hObject As Long ) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long ) As Long
Private Declare Function VarPtrArray Lib "msvbvm60.dll" Alias "VarPtr" (Ptr() As Any) As Long
Private Declare Function SetStretchBltMode Lib "gdi32" (ByVal hdc As Long , ByVal nStretchMode As Long ) As Long
Private Declare Function StretchBlt Lib "gdi32" (ByVal hdc As Long , ByVal X As Long , ByVal Y As Long , ByVal nWidth As Long , ByVal nHeight As Long , ByVal hSrcDC As Long , ByVal xSrc As Long , ByVal ySrc As Long , ByVal nSrcWidth As Long , ByVal nSrcHeight As Long , ByVal dwRop As Long ) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long )
Private Type QUANTIZATIONTABLE
Qk(63) As Integer
FScale(63) As Single
IScale(63) As Single
End Type
Private Type HUFFMANTABLE
Bits(15) As Byte
HUFFVAL(255) As Byte
EHUFSI(255) As Long
EHUFCO(255) As Long
MINCODE(15) As Long
MAXCODE(15) As Long
End Type
Private Type COMPONENT
Ci As Long
Hi As Long
Vi As Long
Tqi As Long
Data() As Integer
End Type
Private PP As Long Private YY As Long Private XX As Long Private Nf As Long
Private HMax As Long Private VMax As Long
Private m_Data() As Byte Private m_Chr As Long Private m_Ptr As Long Private m_Bit As Long
Private m_Block(7, 7) As Single
Private QTable(3) As QUANTIZATIONTABLE Private HuffDC(3) As HUFFMANTABLE Private HuffAC(3) As HUFFMANTABLE Private Comp() As COMPONENT
Private m_Quality As Long
Private m_Comment As String
Private Sub FDCT()
Static t0 As Single
Static t1 As Single
Static t2 As Single
Static t3 As Single
Static t4 As Single
Static t5 As Single
Static t6 As Single
Static t7 As Single
Static t8 As Single
Static I As Long
For I = 0 To 7
t0 = m_Block(I, 0) + m_Block(I, 7)
t1 = m_Block(I, 0) - m_Block(I, 7)
t2 = m_Block(I, 1) + m_Block(I, 6)
t3 = m_Block(I, 1) - m_Block(I, 6)
t4 = m_Block(I, 2) + m_Block(I, 5)
t5 = m_Block(I, 2) - m_Block(I, 5)
t6 = m_Block(I, 3) + m_Block(I, 4)
t7 = m_Block(I, 3) - m_Block(I, 4)
t7 = t7 + t5
t8 = t0 - t6
t6 = t6 + t0
t0 = t2 + t4
t2 = (t2 - t4 + t8) * 0.707106781186548
t4 = t1 + t3
t3 = (t3 + t5) * 0.707106781186548
t5 = (t4 - t7) * 0.382683432365091
t7 = t7 * 0.541196100146196 - t5
t4 = t4 * 1.30656296487638 - t5
t5 = t1 + t3
t1 = t1 - t3
m_Block(I, 0) = t6 + t0
m_Block(I, 4) = t6 - t0
m_Block(I, 1) = t5 + t4
m_Block(I, 7) = t5 - t4
m_Block(I, 2) = t8 + t2
m_Block(I, 6) = t8 - t2
m_Block(I, 5) = t1 + t7
m_Block(I, 3) = t1 - t7
Next I
For I = 0 To 7
t0 = m_Block(0, I) + m_Block(7, I)
t1 = m_Block(0, I) - m_Block(7, I)
t2 = m_Block(1, I) + m_Block(6, I)
t3 = m_Block(1, I) - m_Block(6, I)
t4 = m_Block(2, I) + m_Block(5, I)
t5 = m_Block(2, I) - m_Block(5, I)
t6 = m_Block(3, I) + m_Block(4, I)
t7 = m_Block(3, I) - m_Block(4, I)
t7 = t7 + t5
t8 = t0 - t6
t6 = t6 + t0
t0 = t2 + t4
t2 = (t2 - t4 + t8) * 0.707106781186548
t4 = t1 + t3
t3 = (t3 + t5) * 0.707106781186548
t5 = (t4 - t7) * 0.382683432365091
t7 = t7 * 0.541196100146196 - t5
t4 = t4 * 1.30656296487638 - t5
t5 = t1 + t3
t1 = t1 - t3
m_Block(0, I) = t6 + t0
m_Block(4, I) = t6 - t0
m_Block(1, I) = t5 + t4
m_Block(7, I) = t5 - t4
m_Block(2, I) = t8 + t2
m_Block(6, I) = t8 - t2
m_Block(5, I) = t1 + t7
m_Block(3, I) = t1 - t7
Next I
End Sub
Private Sub OptimizeHuffman(TheHuff As HUFFMANTABLE, freq() As Long )
Dim I As Long
Dim J As Long
Dim k As Long
Dim n As Long
Dim V1 As Long
Dim V2 As Long
Dim others(256) As Long
Dim codesize(256) As Long
Dim Bits(256) As Long
Dim swp As Long
Dim swp2 As Long
For I = 0 To 256
others(I) = -1
Next I
freq(256) = 1
Do
V1 = -1
V2 = -1
swp = 2147483647
swp2 = 2147483647
For I = 0 To 256
If freq(I) <> 0 Then
If (freq(I) <= swp2) Then
If (freq(I) <= swp) Then
swp2 = swp
V2 = V1
swp = freq(I)
V1 = I
Else
swp2 = freq(I)
V2 = I
End If
End If
End If
Next I
If V2 = -1 Then
freq(V1) = 0
Exit Do
End If
freq(V1) = freq(V1) + freq(V2)
freq(V2) = 0
codesize(V1) = codesize(V1) + 1
While (others(V1) >= 0)
V1 = others(V1)
codesize(V1) = codesize(V1) + 1
Wend
others(V1) = V2
codesize(V2) = codesize(V2) + 1
While (others(V2) >= 0)
V2 = others(V2)
codesize(V2) = codesize(V2) + 1
Wend
Loop
n = 0
For I = 0 To 256
If codesize(I) <> 0 Then
Bits(codesize(I)) = Bits(codesize(I)) + 1
If n < codesize(I) Then n = codesize(I)
End If
Next I
I = n
While I > 16
While Bits(I) > 0
For J = I - 2 To 1 Step -1
If Bits(J) > 0 Then Exit For
Next J
Bits(I) = Bits(I) - 2
Bits(I - 1) = Bits(I - 1) + 1
Bits(J + 1) = Bits(J + 1) + 2
Bits(J) = Bits(J) - 1
Wend
I = I - 1
Wend
Bits(I) = Bits(I) - 1
With TheHuff
For I = 1 To 16
.Bits(I - 1) = Bits(I)
Next I
k = 0
For I = 1 To n
For J = 0 To 255
If codesize(J) = I Then
.HUFFVAL(k) = J
k = k + 1
End If
Next J
Next I
End With
End Sub
Private Sub ExpandHuffman(TheHuff As HUFFMANTABLE, Optional MaxSymbol As Long = 255)
Dim I As Long
Dim J As Long
Dim k As Long
Dim si As Long
Dim code As Long
Dim symbol As Long
With TheHuff
For I = 0 To 255
.EHUFSI(I) = 0
.EHUFCO(I) = -1
Next I
J = 0
si = 1
code = 0
For I = 0 To 15
k = J + .Bits(I)
If k > 256 Then Err.Raise 1, , "Bad Huffman Table"
If J = k Then
.MINCODE(I) = J - code
.MAXCODE(I) = -1
Else
.MINCODE(I) = J - code
While J < k
symbol = .HUFFVAL(J)
If symbol > MaxSymbol Then Err.Raise 1, , "Bad Huffman Table"
If .EHUFCO(symbol) >= 0 Then Err.Raise 1, , "Bad Huffman Table"
.EHUFSI(symbol) = si
.EHUFCO(symbol) = code
code = code + 1
J = J + 1
Wend
.MAXCODE(I) = code - 1
End If
si = si * 2
If code >= si Then Err.Raise 1, , "Bad Huffman Table"
code = code * 2
Next I
If J = 0 Then Err.Raise 1, , "Bad Huffman Table"
End With
End Sub
Private Sub WriteBitsBegin()
m_Chr = 0
m_Bit = 128
End Sub
Private Sub WriteBitsEnd()
If m_Bit <> 128 Then WriteBits m_Bit, -1
End Sub
Private Sub WriteBits(ByVal si As Long , code As Long )
While si > 0
If (code And si) <> 0 Then m_Chr = (m_Chr Or m_Bit)
If m_Bit = 1 Then
m_Data(m_Ptr) = m_Chr
If m_Chr = 255 Then
m_Data(m_Ptr + 1) = 0
m_Ptr = m_Ptr + 2
Else
m_Ptr = m_Ptr + 1
End If
m_Chr = 0
m_Bit = 128
Else
m_Bit = m_Bit \ 2
End If
si = si \ 2
Wend
End Sub
Private Sub EncodeCoefficients(Data() As Integer , P As Long , Pred As Long , Td As Long , Ta As Long )
Dim R As Long
Dim rs As Long
Dim si As Long
Dim code As Long
Dim p2 As Long
p2 = P + 64
code = Data(P) - Pred
Pred = Data(P)
P = P + 1
si = 1
rs = 0
If code < 0 Then
Do While si <= -code
si = si * 2
rs = rs + 1
Loop
code = code - 1
Else
Do While si <= code
si = si * 2
rs = rs + 1
Loop
End If
si = si \ 2
WriteBits HuffDC(Td).EHUFSI(rs), HuffDC(Td).EHUFCO(rs)
WriteBits si, code
With HuffAC(Ta)
R = 0
Do
If Data(P) = 0 Then
R = R + 1
Else
While R > 15
WriteBits .EHUFSI(240), .EHUFCO(240)
R = R - 16
Wend
code = Data(P)
rs = R * 16
si = 1
If code < 0 Then
Do While si <= -code
si = si * 2
rs = rs + 1
Loop
code = code - 1
Else
Do While si <= code
si = si * 2
rs = rs + 1
Loop
End If
si = si \ 2
WriteBits .EHUFSI(rs), .EHUFCO(rs)
WriteBits si, code
R = 0
End If
P = P + 1
Loop While P < p2
If R <> 0 Then WriteBits .EHUFSI(0), .EHUFCO(0)
End With
End Sub
Private Sub CollectStatisticsAC(Data() As Integer , freqac() As Long )
Dim code As Long
Dim n As Long
Dim P As Long
Dim p2 As Long
Dim R As Long
Dim rs As Long
n = UBound(Data) + 1
P = 0
While P <> n
P = P + 1
p2 = P + 63
R = 0
While P <> p2
If Data(P) = 0 Then
R = R + 1
Else
While R > 15
freqac(240) = freqac(240) + 1
R = R - 16
Wend
code = Data(P)
If code < 0 Then
rs = Int((Log(-code) * 1.442695040889)) + 1
ElseIf code > 0 Then
rs = Int((Log(code) * 1.442695040889)) + 1
Else
rs = 0
End If
rs = (R * 16) Or rs
freqac(rs) = freqac(rs) + 1
R = 0
End If
P = P + 1
Wend
If R <> 0 Then freqac(0) = freqac(0) + 1
Wend
End Sub
Private Sub CollectStatisticsDCNonInterleaved(Data() As Integer , freqdc() As Long )
Dim Diff As Long
Dim Pred As Long
Dim n As Long
Dim P As Long
Dim S As Long
n = UBound(Data) + 1
P = 0
Pred = 0
While P <> n
Diff = Data(P) - Pred
Pred = Data(P)
If Diff < 0 Then
S = Int((Log(-Diff) * 1.442695040889)) + 1
ElseIf Diff > 0 Then
S = Int((Log(Diff) * 1.442695040889)) + 1
Else
S = 0
End If
freqdc(S) = freqdc(S) + 1
P = P + 64
Wend
End Sub
Private Sub CollectStatisticsDCInterleaved(Data() As Integer , freqdc() As Long , Hi As Long , Vi As Long )
Dim P() As Long
Dim f As Long
Dim G As Long
Dim H As Long
Dim I As Long
Dim J As Long
Dim n As Long
Dim S As Long
Dim Diff As Long
Dim Pred As Long
Dim pLF As Long
Dim MCUr As Long
Dim MCUx As Long
Dim MCUy As Long
n = UBound(Data) + 1
ReDim P(Vi - 1)
MCUx = (XX + 8 * HMax - 1) \ (8 * HMax)
MCUy = (YY + 8 * VMax - 1) \ (8 * VMax)
H = (-Int(-XX * Hi / HMax) + 7) \ 8
For G = 0 To Vi - 1
P(G) = 64 * H * G
Next G
pLF = 64 * H * (Vi - 1)
MCUr = (H Mod Hi)
If MCUr = 0 Then MCUr = Hi
For J = 1 To MCUy - 1
For I = 1 To MCUx - 1
For G = 1 To Vi
For H = 1 To Hi
Diff = Data(P(G - 1)) - Pred
Pred = Data(P(G - 1))
P(G - 1) = P(G - 1) + 64
If Diff < 0 Then
S = Int((Log(-Diff) * 1.442695040889)) + 1
ElseIf Diff > 0 Then
S = Int((Log(Diff) * 1.442695040889)) + 1
Else
S = 0
End If
freqdc(S) = freqdc(S) + 1
Next H
Next G
Next I
For G = 1 To Vi
For H = 1 To Hi
If H > MCUr Then
S = 0
Else
Diff = Data(P(G - 1)) - Pred
Pred = Data(P(G - 1))
P(G - 1) = P(G - 1) + 64
If Diff < 0 Then
S = Int((Log(-Diff) * 1.442695040889)) + 1
ElseIf Diff > 0 Then
S = Int((Log(Diff) * 1.442695040889)) + 1
Else
S = 0
End If
End If
freqdc(S) = freqdc(S) + 1
Next H
Next G
For G = 0 To Vi - 1
P(G) = P(G) + pLF
Next G
Next J
For I = 1 To MCUx
For G = 1 To Vi
For H = 1 To Hi
If P(G - 1) >= n Or (I = MCUx And H > MCUr) Then
S = 0
Else
Diff = Data(P(G - 1)) - Pred
Pred = Data(P(G - 1))
P(G - 1) = P(G - 1) + 64
If Diff < 0 Then
S = Int((Log(-Diff) * 1.442695040889)) + 1
ElseIf Diff > 0 Then
S = Int((Log(Diff) * 1.442695040889)) + 1
Else
S = 0
End If
End If
freqdc(S) = freqdc(S) + 1
Next H
Next G
Next I
End Sub
Private Sub ExpandDQT(Tqi As Long )
Dim I As Long
Dim J As Long
Dim k As Byte
Dim maxvalue As Long
With QTable(Tqi)
If PP = 12 Then
maxvalue = 65535
Else
maxvalue = 255
End If
For I = 0 To 7
For J = 0 To 7
k = ZigZag(I, J)
If .Qk(k) < 1 Or .Qk(k) > maxvalue Then Err.Raise 1, , "Bad Quantization Table"
.FScale(k) = FDCTScale(I) * FDCTScale(J) / CDbl (.Qk(k))
Next J
Next I
End With
End Sub
Private Sub Quantize(Data() As Integer , P As Long , FScale() As Single )
Dim I As Long
Dim J As Long
Dim T As Long
For J = 0 To 7
For I = 0 To 7
T = ZigZag(I, J)
Data(P + T) = m_Block(I, J) * FScale(T)
Next I
Next J
P = P + 64
End Sub
Friend Property Let Quality(vData As Long )
Dim I As Long
Dim qvalue As Long
Dim maxvalue As Long
Dim scalefactor As Long
maxvalue = 255
If vData > 0 And vData <= 100 Then
m_Quality = vData
If (m_Quality < 50) Then
If m_Quality <= 0 Then
scalefactor = 5000
Else
scalefactor = 5000 / m_Quality
End If
Else
If m_Quality > 100 Then
scalefactor = 0
Else
scalefactor = 200 - m_Quality * 2
End If
End If
With QTable(0)
For I = 0 To 63
qvalue = (QLumin(I) * scalefactor + 50) / 100
If qvalue <= 0 Then
qvalue = 1
ElseIf qvalue > maxvalue Then
qvalue = maxvalue
End If
.Qk(I) = qvalue
Next I
End With
With QTable(1)
For I = 0 To 63
qvalue = (QChrom(I) * scalefactor + 50) / 100
If qvalue <= 0 Then
qvalue = 1
ElseIf qvalue > maxvalue Then
qvalue = maxvalue
End If
.Qk(I) = qvalue
Next I
End With
ExpandDQT 0
ExpandDQT 1
End If
End Property
Friend Property Get Quality() As Long
Quality = m_Quality
End Property
Friend Sub SetSamplingFrequencies(H1 As Long , V1 As Long , H2 As Long , V2 As Long , H3 As Long , V3 As Long )
Dim I As Long
If H1 < 1 Or H1 > 4 Then Err.Raise 1, , "Invalid Sampling Value"
If V1 < 1 Or V1 > 4 Then Err.Raise 1, , "Invalid Sampling Value"
If (H2 Or H3 Or V2 Or V3) = 0 Then
Nf = 1
ReDim Comp(0)
Comp(0).Hi = 1
Comp(0).Vi = 1
Else
If H2 < 1 Or H2 > 4 Then Err.Raise 1, , "Invalid Sampling Value"
If H3 < 1 Or H3 > 4 Then Err.Raise 1, , "Invalid Sampling Value"
If V2 < 1 Or V2 > 4 Then Err.Raise 1, , "Invalid Sampling Value"
If V3 < 1 Or V3 > 4 Then Err.Raise 1, , "Invalid Sampling Value"
Nf = 3
ReDim Comp(2)
Comp(0).Hi = H1
Comp(0).Vi = V1
Comp(0).Tqi = 0
Comp(1).Hi = H2
Comp(1).Vi = V2
Comp(1).Tqi = 1
Comp(2).Hi = H3
Comp(2).Vi = V3
Comp(2).Tqi = 1
End If
HMax = -1
VMax = -1
For I = 0 To Nf - 1
If HMax < Comp(I).Hi Then HMax = Comp(I).Hi
If VMax < Comp(I).Vi Then VMax = Comp(I).Vi
Next I
End Sub
Friend Function SampleHDC(ByVal lHDC As Long , lWidth As Long , lHeight As Long , Optional lSrcLeft As Long , Optional lSrcTop As Long ) As Long
Dim hDIb As Long
Dim hBmpOld As Long
Dim hdc As Long
Dim lPtr As Long
Dim BI As BITMAPINFO
Dim sA As SAFEARRAY2D
Dim Pixel() As Byte
Dim f As Long
Dim qp As Long
Dim rm As Single
Dim gm As Single
Dim bm As Single
Dim S As Single
Dim xi As Long
Dim yi As Long
Dim xi2 As Long
Dim yi2 As Long
Dim xi8 As Long
Dim yi8 As Long
Dim i0 As Long
Dim j0 As Long
Dim I As Long
Dim J As Long
Dim P As Long
Dim q As Long
PP = 8
YY = lHeight
XX = lWidth
hdc = CreateCompatibleDC(0)
If hdc = 0 Then
SampleHDC = 1
Else
With BI.bmiHeader
.biSize = Len(BI.bmiHeader)
.biWidth = (lWidth + 7) And &HFFFFFFF8
.biHeight = (lHeight + 7) And &HFFFFFFF8
.biPlanes = 1
.biBitCount = 24
.biCompression = BI_RGB
.biSizeImage = ((.biWidth * 3 + 3) And &HFFFFFFFC) * .biHeight
End With
hDIb = CreateDIBSection2(hdc, BI, DIB_RGB_COLORS, lPtr, 0, 0)
If hDIb = 0 Then
SampleHDC = 1
Else
With sA
.cbElements = 1
.cDims = 2
.Bounds(0).lLbound = 0
.Bounds(0).cElements = BI.bmiHeader.biHeight
.Bounds(1).lLbound = 0
.Bounds(1).cElements = ((BI.bmiHeader.biWidth * 3 + 3) And &HFFFFFFFC)
.pvData = lPtr
End With
hBmpOld = SelectObject(hdc, hDIb)
If SetStretchBltMode(hdc, HALFTONE) = 0 Then SetStretchBltMode hdc, COLORONCOLOR
For f = 0 To Nf - 1
Select Case f
Case 0
rm = 0.299
gm = 0.587
bm = 0.114
S = -128
Case 1
rm = -0.16874
gm = -0.33126
bm = 0.5
S = 0
Case 2
rm = 0.5
gm = -0.41869
bm = -0.08131
S = 0
End Select
With Comp(f)
.Ci = f + 1
xi = -Int(-XX * .Hi / HMax)
yi = -Int(-YY * .Vi / VMax)
xi8 = ((xi + 7) And &HFFFFFFF8)
yi8 = ((yi + 7) And &HFFFFFFF8)
ReDim .Data(xi8 * yi8 - 1)
If xi8 <> xi2 Or yi8 <> yi2 Then
If xi = XX And yi = YY Then
BitBlt hdc, 0, BI.bmiHeader.biHeight - yi8, xi, yi, lHDC, lSrcLeft, lSrcTop, vbSrcCopy
Else
StretchBlt hdc, 0, BI.bmiHeader.biHeight - yi8, xi, yi, lHDC, lSrcLeft, lSrcTop, lWidth, lHeight, vbSrcCopy
End If
For I = xi To xi8 - 1
BitBlt hdc, I, BI.bmiHeader.biHeight - yi8, 1, yi, hdc, I - 1, BI.bmiHeader.biHeight - yi8, vbSrcCopy
Next I
For J = BI.bmiHeader.biHeight - (yi8 - yi) To BI.bmiHeader.biHeight - 1
BitBlt hdc, 0, J, xi8, 1, hdc, 0, J - 1, vbSrcCopy
Next J
End If
xi2 = xi8
yi2 = yi8
qp = 0
CopyMemory ByVal VarPtrArray(Pixel), VarPtr(sA), 4&
J = yi8 - 1
While J > 0
I = 0
j0 = J
While I < 3 * xi8
J = j0
i0 = I
For P = 0 To 7
I = i0
For q = 0 To 7
m_Block(q, P) = rm * Pixel(I + 2, J) + _
gm * Pixel(I + 1, J) + _
bm * Pixel(I, J) + S
I = I + 3
Next q
J = J - 1
Next P
FDCT
Quantize .Data, qp, QTable(.Tqi).FScale
Wend
Wend
CopyMemory ByVal VarPtrArray(Pixel), 0&, 4
End With
Next f
SelectObject hdc, hBmpOld
DeleteObject hDIb
End If
DeleteObject hdc
End If
End Function
Friend Property Let Comment(Value As String )
If Len(Value) > 65535 Then Err.Raise 1, , "Illegal Comment Length"
m_Comment = Value
End Property
Friend Property Get Comment() As String
Comment = m_Comment
End Property
Private Sub InsertJFIF()
If m_Ptr + 17 > UBound(m_Data) Then Err.Raise 9
CopyMemory m_Data(m_Ptr + 0), &H1000E0FF, 4&
CopyMemory m_Data(m_Ptr + 4), &H4649464A, 4&
CopyMemory m_Data(m_Ptr + 8), &H10100, 4&
CopyMemory m_Data(m_Ptr + 12), &H1000100, 4&
CopyMemory m_Data(m_Ptr + 16), &H0&, 2&
m_Ptr = m_Ptr + 18
End Sub
Private Sub InsertSOF(SOFMarker As Long )
Dim I As Long
Dim lx As Long
lx = 8 + 3 * Nf
m_Data(m_Ptr) = 255
m_Data(m_Ptr + 1) = SOFMarker And 255
m_Data(m_Ptr + 2) = lx \ 256
m_Data(m_Ptr + 3) = lx And 255
m_Data(m_Ptr + 4) = PP
m_Data(m_Ptr + 5) = YY \ 256
m_Data(m_Ptr + 6) = YY And 255
m_Data(m_Ptr + 7) = XX \ 256
m_Data(m_Ptr + 8) = XX And 255
m_Data(m_Ptr + 9) = Nf
m_Ptr = m_Ptr + 10
For I = 0 To Nf - 1
With Comp(I)
m_Data(m_Ptr) = .Ci
m_Data(m_Ptr + 1) = .Hi * 16 Or .Vi
m_Data(m_Ptr + 2) = .Tqi
End With
m_Ptr = m_Ptr + 3
Next I
End Sub
Private Sub InsertCOM(TheComment As String )
Dim I As Long
Dim lx As Long
lx = Len(TheComment) + 2
If lx > 2 Then
m_Data(m_Ptr) = 255
m_Data(m_Ptr + 1) = COM
m_Data(m_Ptr + 2) = lx \ 256
m_Data(m_Ptr + 3) = lx And 255
m_Ptr = m_Ptr + 4
For I = 1 To Len(TheComment)
m_Data(m_Ptr) = Asc(Mid$(TheComment, I, 1))
m_Ptr = m_Ptr + 1
Next I
End If
End Sub
Private Sub InsertDQT(ByVal MarkerPos As Long , Tqi As Long )
Dim I As Long
If m_Ptr < MarkerPos + 4 Then
m_Ptr = MarkerPos + 4
m_Data(m_Ptr - 4) = 255
m_Data(m_Ptr - 3) = DQT
End If
With QTable(Tqi)
For I = 0 To 63
If .Qk(I) > 255 Then Exit For
Next I
If I = 64 Then
m_Data(m_Ptr) = Tqi
m_Ptr = m_Ptr + 1
For I = 0 To 63
m_Data(m_Ptr) = .Qk(I)
m_Ptr = m_Ptr + 1
Next I
Else
If PP <> 12 Then Err.Raise 1, , "Illegal precission in Quantization Table"
m_Data(m_Ptr) = Tqi Or 16
m_Ptr = m_Ptr + 1
For I = 0 To 63
m_Data(m_Ptr) = .Qk(I) \ 256
m_Data(m_Ptr + 1) = .Qk(I) And 255
m_Ptr = m_Ptr + 2
Next I
End If
End With
m_Data(MarkerPos + 2) = (m_Ptr - MarkerPos - 2) \ 256&
m_Data(MarkerPos + 3) = (m_Ptr - MarkerPos - 2) And 255&
End Sub
Private Sub InsertDHT(ByVal MarkerPos As Long , HIndex As Long , IsAC As Boolean )
Dim I As Long
Dim J As Long
If m_Ptr < MarkerPos + 4 Then
m_Ptr = MarkerPos + 4
m_Data(m_Ptr - 4) = 255
m_Data(m_Ptr - 3) = DHT
End If
If IsAC Then
With HuffAC(HIndex)
m_Data(m_Ptr) = HIndex Or 16
m_Ptr = m_Ptr + 1
J = 0
For I = 0 To 15
m_Data(m_Ptr) = .Bits(I)
m_Ptr = m_Ptr + 1
J = J + .Bits(I)
Next I
For I = 0 To J - 1
m_Data(m_Ptr) = .HUFFVAL(I)
m_Ptr = m_Ptr + 1
Next I
End With
Else
With HuffDC(HIndex)
m_Data(m_Ptr) = HIndex
m_Ptr = m_Ptr + 1
J = 0
For I = 0 To 15
m_Data(m_Ptr) = .Bits(I)
m_Ptr = m_Ptr + 1
J = J + .Bits(I)
Next I
For I = 0 To J - 1
m_Data(m_Ptr) = .HUFFVAL(I)
m_Ptr = m_Ptr + 1
Next I
End With
End If
m_Data(MarkerPos + 2) = (m_Ptr - MarkerPos - 2) \ 256&
m_Data(MarkerPos + 3) = (m_Ptr - MarkerPos - 2) And 255&
End Sub
Private Sub InsertMarker(TheMarker As Long )
m_Data(m_Ptr) = 255
m_Data(m_Ptr + 1) = TheMarker
m_Ptr = m_Ptr + 2
End Sub
Private Sub InsertSOSNonInterleaved(CompIndex As Long , Td As Long , Ta As Long )
Dim P As Long
Dim n As Long
Dim Pred As Long
m_Data(m_Ptr) = 255
m_Data(m_Ptr + 1) = SOS
m_Data(m_Ptr + 2) = 8 \ 256
m_Data(m_Ptr + 3) = 8 And 255
m_Data(m_Ptr + 4) = 1
m_Ptr = m_Ptr + 5
m_Data(m_Ptr) = Comp(CompIndex).Ci
m_Data(m_Ptr + 1) = Td * 16 Or Ta
m_Ptr = m_Ptr + 2
m_Data(m_Ptr) = 0
m_Data(m_Ptr + 1) = 63
m_Data(m_Ptr + 2) = 0
m_Ptr = m_Ptr + 3
With Comp(CompIndex)
P = 0
n = UBound(.Data) + 1
Pred = 0
WriteBitsBegin
While P <> n
EncodeCoefficients .Data, P, Pred, Td, Ta
Wend
WriteBitsEnd
End With
End Sub
Private Sub InsertSOSInterleaved(CompIndex() As Long , Td() As Long , Ta() As Long , FirstIndex As Long , SecondIndex As Long )
Dim f As Long
Dim G As Long
Dim H As Long
Dim I As Long
Dim J As Long
Dim lx As Long
Dim Ns As Long
Dim MCUx As Long
Dim MCUy As Long
Dim P() As Long
Dim pLF() As Long
Dim Pred() As Long
Dim MCUr() As Long
Dim Pad64(63) As Integer
Ns = SecondIndex - FirstIndex + 1
lx = 6 + 2 * Ns
m_Data(m_Ptr) = 255
m_Data(m_Ptr + 1) = SOS
m_Data(m_Ptr + 2) = lx \ 256
m_Data(m_Ptr + 3) = lx And 255
m_Data(m_Ptr + 4) = Ns
m_Ptr = m_Ptr + 5
For I = FirstIndex To SecondIndex
m_Data(m_Ptr) = Comp(CompIndex(I)).Ci
m_Data(m_Ptr + 1) = Td(I) * 16 Or Ta(I)
m_Ptr = m_Ptr + 2
Next I
m_Data(m_Ptr) = 0
m_Data(m_Ptr + 1) = 63
m_Data(m_Ptr + 2) = 0
m_Ptr = m_Ptr + 3
ReDim P(FirstIndex To SecondIndex, VMax - 1)
ReDim Pred(FirstIndex To SecondIndex)
ReDim pLF(FirstIndex To SecondIndex)
ReDim MCUr(FirstIndex To SecondIndex)
MCUx = (XX + 8 * HMax - 1) \ (8 * HMax)
MCUy = (YY + 8 * VMax - 1) \ (8 * VMax)
For f = FirstIndex To SecondIndex
With Comp(CompIndex(f))
H = (-Int(-XX * .Hi / HMax) + 7) \ 8
For G = 0 To .Vi - 1
P(f, G) = 64 * H * G
Next G
pLF(f) = 64 * H * (.Vi - 1)
MCUr(f) = (H Mod .Hi)
If MCUr(f) = 0 Then MCUr(f) = .Hi
End With
Next f
WriteBitsBegin
For J = 1 To MCUy - 1
For I = 1 To MCUx - 1
For f = FirstIndex To SecondIndex
With Comp(CompIndex(f))
For G = 1 To .Vi
For H = 1 To .Hi
EncodeCoefficients .Data, P(f, G - 1), Pred(f), Td(f), Ta(f)
Next H
Next G
End With
Next f
Next I
For f = FirstIndex To SecondIndex
With Comp(CompIndex(f))
For G = 1 To .Vi
For H = 1 To .Hi
If H > MCUr(f) Then
Pad64(0) = Pred(f)
EncodeCoefficients Pad64, 0, Pred(f), Td(f), Ta(f)
Else
EncodeCoefficients .Data, P(f, G - 1), Pred(f), Td(f), Ta(f)
End If
Next H
Next G
End With
Next f
For f = FirstIndex To SecondIndex
For G = 0 To Comp(CompIndex(f)).Vi - 1
P(f, G) = P(f, G) + pLF(f)
Next G
Next f
Next J
For I = 1 To MCUx
For f = FirstIndex To SecondIndex
With Comp(CompIndex(f))
For G = 1 To .Vi
For H = 1 To .Hi
If P(f, G - 1) > UBound(.Data) Or (I = MCUx And H > MCUr(f)) Then
Pad64(0) = Pred(f)
EncodeCoefficients Pad64, 0, Pred(f), Td(f), Ta(f)
Else
EncodeCoefficients .Data, P(f, G - 1), Pred(f), Td(f), Ta(f)
End If
Next H
Next G
End With
Next f
Next I
WriteBitsEnd
End Sub
Private Sub InsertSequentialScans(CompIndex() As Long , Td() As Long , Ta() As Long , FirstIndex As Long , SecondIndex As Long )
Dim f As Long
Dim G As Long
Dim Nb As Long
Const MaxNb As Long = 10
Dim flag As Boolean
f = FirstIndex
G = FirstIndex
Nb = 0
flag = False
While f <= SecondIndex
Nb = Nb + Comp(CompIndex(G)).Hi * Comp(CompIndex(G)).Vi
G = G + 1
If Nb > MaxNb Then
flag = True
If f <> G - 1 Then G = G - 1
Else
If (G - f) = 3 Or G > SecondIndex Then flag = True
End If
If flag Then
If f = G - 1 Then
InsertSOSNonInterleaved CompIndex(f), Td(f), Ta(f)
Else
InsertSOSInterleaved CompIndex, Td, Ta, f, G - 1
End If
Nb = 0
f = G
flag = False
End If
Wend
End Sub
Private Function OptimizeHuffmanTables(CompIndex() As Long , Td() As Long , Ta() As Long , FirstIndex As Long , SecondIndex As Long ) As Long
Dim f As Long
Dim G As Long
Dim I As Long
Dim J As Long
Dim k As Long
Dim k1 As Long
Dim k2 As Long
Dim Nb As Long
Const MaxNb As Long = 10
Dim freq(256) As Long
Dim freq2() As Long
Dim IsInter() As Boolean
Dim TdUsed() As Boolean
Dim TaUsed() As Boolean
Dim flag As Boolean
ReDim IsInter(FirstIndex To SecondIndex)
ReDim TaUsed(3)
ReDim TdUsed(3)
f = FirstIndex
G = FirstIndex
Nb = 0
flag = False
While f <= SecondIndex
Nb = Nb + Comp(CompIndex(G)).Hi * Comp(CompIndex(G)).Vi
G = G + 1
If Nb > MaxNb Then
flag = True
If f <> G - 1 Then G = G - 1
Else
If (G - f) = 3 Or G > SecondIndex Then flag = True
End If
If flag Then
If f = G - 1 Then
TdUsed(Td(f)) = True
TaUsed(Ta(f)) = True
IsInter(f) = False
Else
For I = f To G - 1
TdUsed(Td(I)) = True
TaUsed(Ta(I)) = True
IsInter(I) = True
Next I
End If
Nb = 0
f = G
flag = False
End If
Wend
For I = 0 To 3
If TdUsed(I) Then
For f = FirstIndex To SecondIndex
With Comp(CompIndex(f))
If Td(f) = I Then
If IsInter(f) Then
CollectStatisticsDCInterleaved .Data, freq, .Hi, .Vi
Else
CollectStatisticsDCNonInterleaved .Data, freq
End If
End If
End With
Next f
ReDim freq2(0 To 256)
CopyMemory freq2(0), freq(0), 1024
OptimizeHuffman HuffDC(I), freq
ExpandHuffman HuffDC(I), IIf(PP = 12, 15, 11)
For J = 0 To 15
If freq2(J) <> 0 Then
k1 = J + Int(Log(HuffDC(I).EHUFSI(J)) * 1.442695040889) + 1
k2 = k2 + freq2(J) * k1
k = k + k2 \ 8
k2 = k2 Mod 8
End If
Next J
End If
If TaUsed(I) Then
For f = FirstIndex To SecondIndex
If Td(f) = I Then CollectStatisticsAC Comp(CompIndex(f)).Data, freq
Next f
ReDim freq2(0 To 256)
CopyMemory freq2(0), freq(0), 1024
OptimizeHuffman HuffAC(I), freq
ExpandHuffman HuffAC(I), 255
For J = 0 To 255
If freq2(J) <> 0 Then
k1 = (J And 15) + Int(Log(HuffAC(I).EHUFSI(J)) * 1.442695040889) + 1
k2 = k2 + freq2(J) * k1
k = k + k2 \ 8
k2 = k2 Mod 8
End If
Next J
End If
Next I
If (k2 Mod 8) <> 0 Then k = k + 1
OptimizeHuffmanTables = k
End Function
Friend Function SaveFile(FileName As String ) As Long
Dim CompIndex() As Long
Dim Td() As Long
Dim Ta() As Long
Dim FileNum As Integer
Dim I As Long
If Len(FileName) = 0 Then
SaveFile = 1
Else
If (Len(Dir(FileName, vbNormal Or vbReadOnly Or vbHidden Or vbSystem Or vbArchive)) > 0) Then
SaveFile = 2
Else
ReDim CompIndex(Nf - 1)
ReDim Td(Nf - 1)
ReDim Ta(Nf - 1)
For I = 0 To Nf - 1
CompIndex(I) = I
Td(I) = IIf(I = 0, 0, 1)
Ta(I) = IIf(I = 0, 0, 1)
Next I
I = OptimizeHuffmanTables(CompIndex, Td, Ta, 0, Nf - 1)
I = 1.3 * I + 1000 + Len(m_Comment)
ReDim m_Data(I)
m_Ptr = 0
InsertMarker SOI
InsertJFIF
If Len(m_Comment) > 0 Then InsertCOM m_Comment
InsertDQT m_Ptr, 0
If Nf > 1 Then InsertDQT m_Ptr, 1
InsertSOF SOF0
InsertDHT m_Ptr, 0, False
InsertDHT m_Ptr, 0, True
If Nf > 1 Then
InsertDHT m_Ptr, 1, False
InsertDHT m_Ptr, 1, True
End If
InsertSequentialScans CompIndex, Td, Ta, 0, Nf - 1
InsertMarker EOI
ReDim Preserve m_Data(m_Ptr - 1)
FileNum = FreeFile
Open FileName For Binary Access Write As FileNum
Put #FileNum, , m_Data
Close FileNum
Erase m_Data
End If
End If
End Function
Private Sub Class_Initialize()
Dim I As Long
Dim J As Long
Dim dx As Long
Dim zz As Long
I = 0
J = 0
dx = 1
For zz = 0 To 63
ZigZag(I, J) = zz
I = I + dx
J = J - dx
If I > 7 Then
I = 7
J = J + 2
dx = -1
ElseIf J > 7 Then
J = 7
I = I + 2
dx = 1
ElseIf I < 0 Then
I = 0
dx = 1
ElseIf J < 0 Then
J = 0
dx = -1
End If
Next zz
QLumin(0) = 16: QLumin(1) = 11: QLumin(2) = 12: QLumin(3) = 14
QLumin(4) = 12: QLumin(5) = 10: QLumin(6) = 16: QLumin(7) = 14
QLumin(8) = 13: QLumin(9) = 14: QLumin(10) = 18: QLumin(11) = 17
QLumin(12) = 16: QLumin(13) = 19: QLumin(14) = 24: QLumin(15) = 40
QLumin(16) = 26: QLumin(17) = 24: QLumin(18) = 22: QLumin(19) = 22
QLumin(20) = 24: QLumin(21) = 49: QLumin(22) = 35: QLumin(23) = 37
QLumin(24) = 29: QLumin(25) = 40: QLumin(26) = 58: QLumin(27) = 51
QLumin(28) = 61: QLumin(29) = 60: QLumin(30) = 57: QLumin(31) = 51
QLumin(32) = 56: QLumin(33) = 55: QLumin(34) = 64: QLumin(35) = 72
QLumin(36) = 92: QLumin(37) = 78: QLumin(38) = 64: QLumin(39) = 68
QLumin(40) = 87: QLumin(41) = 69: QLumin(42) = 55: QLumin(43) = 56
QLumin(44) = 80: QLumin(45) = 109: QLumin(46) = 81: QLumin(47) = 87
QLumin(48) = 95: QLumin(49) = 98: QLumin(50) = 103: QLumin(51) = 104
QLumin(52) = 103: QLumin(53) = 62: QLumin(54) = 77: QLumin(55) = 113
QLumin(56) = 121: QLumin(57) = 112: QLumin(58) = 100: QLumin(59) = 120
QLumin(60) = 92: QLumin(61) = 101: QLumin(62) = 103: QLumin(63) = 99
QChrom(0) = 17: QChrom(1) = 18: QChrom(2) = 18: QChrom(3) = 24
QChrom(4) = 21: QChrom(5) = 24: QChrom(6) = 47: QChrom(7) = 26
QChrom(8) = 26: QChrom(9) = 47: QChrom(10) = 99: QChrom(11) = 66
QChrom(12) = 56: QChrom(13) = 66: QChrom(14) = 99: QChrom(15) = 99
QChrom(16) = 99: QChrom(17) = 99: QChrom(18) = 99: QChrom(19) = 99
QChrom(20) = 99: QChrom(21) = 99: QChrom(22) = 99: QChrom(23) = 99
QChrom(24) = 99: QChrom(25) = 99: QChrom(26) = 99: QChrom(27) = 99
QChrom(28) = 99: QChrom(29) = 99: QChrom(30) = 99: QChrom(31) = 99
QChrom(32) = 99: QChrom(33) = 99: QChrom(34) = 99: QChrom(35) = 99
QChrom(36) = 99: QChrom(37) = 99: QChrom(38) = 99: QChrom(39) = 99
QChrom(40) = 99: QChrom(41) = 99: QChrom(42) = 99: QChrom(43) = 99
QChrom(44) = 99: QChrom(45) = 99: QChrom(46) = 99: QChrom(47) = 99
QChrom(48) = 99: QChrom(49) = 99: QChrom(50) = 99: QChrom(51) = 99
QChrom(52) = 99: QChrom(53) = 99: QChrom(54) = 99: QChrom(55) = 99
QChrom(56) = 99: QChrom(57) = 99: QChrom(58) = 99: QChrom(59) = 99
QChrom(60) = 99: QChrom(61) = 99: QChrom(62) = 99: QChrom(63) = 99
FDCTScale(0) = 0.353553390593273
FDCTScale(1) = 0.25489778955208
FDCTScale(2) = 0.270598050073098
FDCTScale(3) = 0.300672443467523
FDCTScale(4) = 0.353553390593273
FDCTScale(5) = 0.449988111568207
FDCTScale(6) = 0.653281482438186
FDCTScale(7) = 1.28145772387074
SetSamplingFrequencies 2, 2, 1, 1, 1, 1
Quality = 75
End Sub
Public Function SaveToJpeg(ByVal hdc As Long , ByVal X As Long , ByVal Y As Long , ByVal Width As Long , ByVal Height As Long , ByVal JpegFile As String , Optional ByVal JpegQuality As Long = 20, Optional ByVal Progressive As Boolean = True , Optional ByVal GrayScale As Boolean = False , Optional SamplingWidth As Long = 1, Optional ByVal CommentText As String = "SCINSpy - Created by SCINER: lenar2003@mail.ru" ) As Boolean
Dim Ret As Long
Me .Comment = CommentText
Me .Quality = JpegQuality
If GrayScale Then
If Progressive Then
Me .SetSamplingFrequencies 4, 4, 0, 0, 0, 0
Else
Me .SetSamplingFrequencies 1, 1, 0, 0, 0, 0
End If
Else
If Progressive Then
Me .SetSamplingFrequencies 4, 4, SamplingWidth, SamplingWidth, SamplingWidth, SamplingWidth
Else
Me .SetSamplingFrequencies 1, 1, SamplingWidth, SamplingWidth, SamplingWidth, SamplingWidth
End If
End If
Ret = Me .SampleHDC(hdc, Width, Height, X, Y)
If Ret = 0 Then Me .SaveFile JpegFile
SaveToJpeg = Ret = 0
End Function
Ответить
Номер ответа: 3Автор ответа: ilgar Вопросов: 2Ответов: 1
Профиль | | #3
Добавлено: 02.07.10 17:02
Код такой маленкий
Ответить
Страница: 1
Поиск по форуму
ilgar
VβÐUηìt
ilgar
im gr As Graphics