clsjpeg.cls

把图片缩小压缩成jpg格式并保存到sql数据库

'熵码
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   '1/log(2)
                ElseIf code > 0 Then
                    rs = Int((Log(code) * 1.442695040889)) + 1    '1/log(2)
                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   '1/log(2)
   ElseIf Diff > 0 Then
      s = Int((Log(Diff) * 1.442695040889)) + 1    '1/log(2)
   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
   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   '1/log(2)
               ElseIf Diff > 0 Then
                  s = Int((Log(Diff) * 1.442695040889)) + 1    '1/log(2)
               Else
                  s = 0
               End If
               freqdc(s) = freqdc(s) + 1
            
             Next
          Next
      Next
   
      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
     Next
     For g = 0 To Vi - 1
        p(g) = p(g) + pLF
     Next
   Next

    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
        Next
    Next

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, , "错误量子化表"
            .FScale(k) = FDCTScale(i) * FDCTScale(j) / CDbl(.Qk(k))
         Next
      Next
   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
   Next
   p = p + 64
   
End Sub

Public Property Let Quality(vData As Long)
'图片质量1至100,质量越低,压缩率越高,决定量子化表的取值

    Dim i           As Long
    Dim qvalue      As Long
    Dim maxvalue    As Long
    Dim scalefactor As Long
    
    maxvalue = 255 '32767 if 16 bit quantum is allowed
    
    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
        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
        End With
        
        ExpandDQT 0
        ExpandDQT 1
    End If

End Property
Public Property Get Quality() As Long
   Quality = m_Quality
End Property

'图像取样

Public 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, , "无效采样值"
   If V1 < 1 Or V1 > 4 Then Err.Raise 1, , "无效采样值"
   
   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, , "无效采样值"
       If H3 < 1 Or H3 > 4 Then Err.Raise 1, , "无效采样值"
       If V2 < 1 Or V2 > 4 Then Err.Raise 1, , "无效采样值"
       If V3 < 1 Or V3 > 4 Then Err.Raise 1, , "无效采样值"
       Nf = 3         'YCbCr
       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