clsjpeg.cls

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

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

Public Function SampleHDC(ByVal lHDC As Long, lWidth As Long, lHeight As Long, Optional lSrcLeft As Long, Optional lSrcTop As Long) As Long
   '给定一个有效lHDC, 创建图像采样数据。图像将分解成YCbCr块，通过这些块创建DIB数据
   '返回: 0 = 成功
   '      1 = 创建DIB数据时API出错
   Dim hDIb       As Long    'DIB数据句柄
   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   'YCbCr块序号
   Dim qp         As Long
   Dim rm         As Single 'RGB->YCbCr  红色比例
   Dim gm         As Single 'RGB->YCbCr  绿色比例
   Dim bm         As Single 'RGB->YCbCr  蓝色比例
   Dim s          As Single 'RGB->YCbCr  级别
   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   '8X8点块左边点索引
   Dim j0         As Long   '8X8点块上边点索引
   Dim i          As Long   'Pixel 水平方向索引
   Dim j          As Long   'Pixel 垂直方向索引
   Dim p          As Long   'DCT 水平方向索引
   Dim q          As Long   'DCT 垂直方向索引
   
   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
                 For j = BI.bmiHeader.biHeight - (yi8 - yi) To BI.bmiHeader.biHeight - 1
                    BitBlt hdc, 0, j, xi8, 1, hdc, 0, j - 1, vbSrcCopy
                 Next
               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
                         j = j - 1
                     Next
                     FDCT
                     Quantize .data, qp, QTable(.Tqi).FScale
                  Wend
               Wend
               CopyMemory ByVal VarPtrArray(Pixel), 0&, 4
            End With
         Next
         
         SelectObject hdc, hBmpOld
         DeleteObject hDIb
      End If
      DeleteObject hdc
   End If
   
End Function

Public Property Let Comment(Value As String)
'JPEG图片文件注释
   If Len(Value) > 65535 Then Err.Raise 1, , "无效注释长度"
   m_Comment = Value
End Property
Public 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                    'SOF
   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
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
   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
       If i = 64 Then              '8 bit 精度
           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
       Else                        '16 bit 精度
           If PP <> 12 Then Err.Raise 1, , "量子化表中无效精度"
           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
       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
           For i = 0 To j - 1
              m_Data(m_Ptr) = .HUFFVAL(i)
              m_Ptr = m_Ptr + 1
           Next
        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
           For i = 0 To j - 1
              m_Data(m_Ptr) = .HUFFVAL(i)
              m_Ptr = m_Ptr + 1
           Next
        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                          'SOS
   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                          'SOS
   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
   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
         pLF(f) = 64 * h * (.Vi - 1)
         
         MCUr(f) = (h Mod .Hi)
         If MCUr(f) = 0 Then MCUr(f) = .Hi
      End With
   Next
   
   WriteBitsBegin
   For j = 1 To MCUy - 1
      
      For i = 1 To MCUx - 1