Code aus Form1.frm
Option Explicit
Const SOI = &HD8
Const EOI = &HD9
Const APP0 = &HE0
Const SOF = &HC0
Const DQT = &HDB
Const DHT = &HC4
Const SOS = &HDA
Const DRI = &HDD
Const COM = &HFE
Const mark = &HFF
Const APP12 = &HEC
Const APP14 = &HEE
Dim QTable(0 To 3, 0 To 63) As Double
Dim ZigZag() As Variant
Private Type HuffmanTable
  Length(0 To 16) As Long
  minor_code(0 To 16) As Long
  major_code(0 To 16) As Long
End Type
Dim v_ac(0 To 3, 0 To 65535) As Byte
Dim v_dc(0 To 3, 0 To 65535) As Byte
Dim HTableAC(0 To 3) As HuffmanTable
Dim HTableDC(0 To 3) As HuffmanTable
Dim MCU_Restart As Long, Restart_Markers As Boolean
Dim tab_1(0 To 63) As Byte, tab_2(0 To 63) As Byte, tab_3(0 To 63) _
    As Byte, tab_4(0 To 63) As Byte
Dim units As Long, xdensity As Long, ydensity As Long
Dim xthumbnail As Long, ythumbnail As Long, SOS_found As Boolean
Dim SOF_found As Boolean, Length As Long, ac As Boolean
Dim j As Long, old_bp As Long, QT_Info As Long, HT_Info As Long
Dim Precision As Long, Y_Image As Long, X_Image As Long
Dim nr_components As Long, comp_id As Long, YH As Long
Dim YV As Long, YQ_nr As Long, CbH As Long, CbV As Long
Dim CbQ_Nr As Long, CrH As Long, CrV As Long, CrQ_nr As Long
Dim YDC_nr As Long, YAC_nr As Long, CbAC_nr As Long, CbDC_nr As Long
Dim CrAC_nr As Long, CrDC_nr As Long, Hmax As Long, Vmax As Long
Dim X_round As Long, Y_round As Long, y_inc_value As Long
Dim Decode_MCU As String, MCU_dim_x As Long, Y_MCU_nr As Long
Dim X_MCU_nr As Long, x_image_bytes As Long, im_loc_inc As Long
Dim nr_mcu As Long, im_loc As Currency, y_mcu_cnt As Long
Dim x_mcu_cnt As Long
Dim im_buffer() As Byte
Dim w1 As Long, w2 As Long, wordval As Long, d_k As Long
Dim DCY As Long, DCCb As Long, DCCr As Long, DCT_coeff(0 To 63) As Long
Dim file As String, Stream As String, buf() As Byte
Dim bp As Long
Dim y(0 To 63) As Byte, Cb(0 To 63) As Byte, Cr(0 To 63) As Byte
Dim Y_1(0 To 63) As Byte, Y_2(0 To 63) As Byte, Y_3(0 To 63) As _
    Byte, Y_4(0 To 63) As Byte
Dim rlimit_table() As Byte
Dim Cr_tab(0 To 255) As Long, Cb_tab(0 To 255) As Long
Dim Cr_Cb_Green_tab(0 To 65535) As Long
Public Sub Init()
    ZigZag = Array(0, 1, 5, 6, 14, 15, 27, 28, 2, 4, 7, 13, 16, _
        26, 29, 42, 3, 8, 12, 17, 25, 30, 41, 43, 9, 11, 18, 24, _
        31, 40, 44, 53, 10, 19, 23, 32, 39, 45, 52, 54, 20, 22, _
        33, 38, 46, 51, 55, 60, 21, 34, 37, 47, 50, 56, 59, 61, _
        35, 36, 48, 49, 57, 58, 62, 63)
    
    Prepare_Range_Limit_Table
    Precalculate_Cr_Cb_Tables
End Sub
Public Function Inc(ByRef p As Variant) As Variant
    p = p + 1
    Inc = p
End Function
Public Function Inc2(ByRef p As Long) As Long
    p = p + 2
    Inc2 = p
End Function
Function Word(buf() As Byte, bp As Long) As Long
    Word = buf(bp) * 2 ^ 8 + buf(bp + 1)
End Function
Public Sub LoadQuantTable(QuantTable As Long, buf() As Byte, ByRef _
    bp As Long)
  Dim scalefactor() As Variant, j As Long, row As Long, col As Long
    
    scalefactor = Array(1#, 1.387039845, 1.306562965, 1.175875602, _
        1#, 0.785694958, 0.5411961, 0.275899379)
    
    For j = 0 To 63
      QTable(QuantTable, j) = buf(bp + ZigZag(j))
    Next j
    
    j = 0
    For row = 0 To 7
      If row > 0 Then
        Debug.Print
      End If
      For col = 0 To 7
        Debug.Print Format(QTable(QuantTable, j), "00") & " ";
        QTable(QuantTable, j) = QTable(QuantTable, j) * _
            scalefactor(row) * scalefactor(col)
        Inc j
      Next col
    Next row
    Debug.Print
    
    bp = bp + 64
End Sub
Public Function Word_hi_lo(k As Byte, j As Byte) As Long
    Word_hi_lo = k * 2 ^ 8 + j
End Function
Public Sub LoadHuffmanTableAC(HTable As Long, buf() As Byte, bp As Long)
  Dim k As Long, j As Long, code As Currency
    
    For j = 1 To 16
      HTableAC(HTable).Length(j) = buf(bp)
      Inc bp
    Next j
    
    For k = 1 To 16
      For j = 0 To HTableAC(HTable).Length(k) - 1
        v_ac(HTable, Word_hi_lo(CByte(k), CByte(j))) = buf(bp)
        Inc bp
      Next j
    Next k
    
    code = 0
    For k = 1 To 16
      HTableAC(HTable).minor_code(k) = CLng(code)
      
      For j = 1 To HTableAC(HTable).Length(k)
        Inc code
      Next j
      
      HTableAC(HTable).major_code(k) = CLng(code - 1)
      code = code * 2
      
      If HTableAC(HTable).Length(k) = 0 Then
        HTableAC(HTable).minor_code(k) = 65535
        HTableAC(HTable).major_code(k) = 0
      End If
    Next k
    
    Debug.Print "Length: ";
    For k = 1 To 16
      Debug.Print HTableAC(HTable).Length(k) & " ";
    Next k
    Debug.Print
    
    Debug.Print "Minor_Code: ";
    For k = 1 To 16
      Debug.Print HTableAC(HTable).minor_code(k) & " ";
    Next k
    Debug.Print
    
    Debug.Print "Major_Code: ";
    For k = 1 To 16
      Debug.Print HTableAC(HTable).major_code(k) & " ";
    Next k
    Debug.Print
End Sub
Public Sub LoadHuffmanTableDC(HTable As Long, buf() As Byte, bp As Long)
  Dim k As Long, j As Long, code As Currency
    
    For j = 1 To 16
      HTableDC(HTable).Length(j) = buf(bp)
      Inc bp
    Next j
    
    For k = 1 To 16
      For j = 0 To HTableDC(HTable).Length(k) - 1
        v_dc(HTable, Word_hi_lo(CByte(k), CByte(j))) = buf(bp)
        Inc bp
      Next j
    Next k
    
    code = 0
    For k = 1 To 16
      HTableDC(HTable).minor_code(k) = CLng(code)
      
      For j = 1 To HTableDC(HTable).Length(k)
        Inc code
      Next j
      
      HTableDC(HTable).major_code(k) = CLng(code - 1)
      code = code * 2
      
      If HTableDC(HTable).Length(k) = 0 Then
        HTableDC(HTable).minor_code(k) = 65535
        HTableDC(HTable).major_code(k) = 0
      End If
    Next k
    
    Debug.Print "Length: ";
    For k = 1 To 16
      Debug.Print HTableDC(HTable).Length(k) & " ";
    Next k
    Debug.Print
    
    Debug.Print "Minor_Code: ";
    For k = 1 To 16
      Debug.Print HTableDC(HTable).minor_code(k) & " ";
    Next k
    Debug.Print
    
    Debug.Print "Major_Code: ";
    For k = 1 To 16
      Debug.Print HTableDC(HTable).major_code(k) & " ";
    Next k
    Debug.Print
End Sub
Public Sub resync(buf() As Byte, ByRef bp As Long)
    Inc2 bp
    
    Inc bp
    w1 = Word_hi_lo(buf(bp - 1), 0)
    If buf(bp - 1) = 255 Then
      Inc bp
    End If
    
    Inc bp
    w1 = w1 + buf(bp - 1)
    If buf(bp - 1) = 255 Then
      Inc bp
    End If
    
    Inc bp
    w2 = Word_hi_lo(buf(bp - 1), 0)
    If buf(bp - 1) = 255 Then
      Inc bp
    End If
    
    Inc bp
    w2 = w2 + buf(bp - 1)
    If buf(bp - 1) = 255 Then
      Inc bp
    End If
    
    wordval = w1
    d_k = 0
    DCY = 0
    DCCb = 0
    DCCr = 0
End Sub
Public Sub calculate_tabs(YV As Long, YH As Long)
  Dim tab_temp(0 To 255) As Byte, x As Byte, y As Byte
    
    For y = 0 To 15
      For x = 0 To 15
        tab_temp(y * 16 + x) = Int((y \ YV) * 8 + x \ YH)
      Next x
    Next y
    
    For y = 0 To 7
      For x = 0 To 7
        tab_1(y * 8 + x) = tab_temp(y * 16 + x)
      Next x
      
      For x = 8 To 15
        tab_2(y * 8 + (x - 8)) = tab_temp(y * 16 + x)
      Next x
    Next y
    
    For y = 8 To 15
      For x = 0 To 7
        tab_3((y - 8) * 8 + x) = tab_temp(y * 16 + x)
      Next x
      
      For x = 8 To 15
        tab_4((y - 8) * 8 + (x - 8)) = tab_temp(y * 16 + x)
      Next x
    Next y
End Sub
Private Sub Command1_Click()
    Init
    
    Command1.Enabled = False
    
    file = App.Path & "\t.jpg"
    Debug.Print "Datei: " & file
    
    Open file For Binary As #1
    Stream = Input(LOF(1), #1)
    Close #1
    
    buf = StrConv(Stream, vbFromUnicode)
    
    bp = 0
    
    If buf(0) <> mark And buf(1) <> SOI Then
      Exit Sub
    End If
    If buf(2) <> mark And buf(3) <> APP0 Then
      Exit Sub
    End If
    If buf(6) <> Asc("J") And buf(7) <> Asc("F") And buf(8) <> _
        Asc("I") And buf(9) <> Asc("F") And buf(10) <> 0 Then
      Exit Sub
    End If
    Debug.Print "SOI and APP0 gefunden, JPEG-Datei erkannt"
    
    ' init_JPG_decoding();
    bp = 11
    
    
    Debug.Print "JPEG-Version: " & buf(bp)
    If buf(bp) <> 1 Then
      Exit Sub
    End If
    Inc bp
    
    Debug.Print "JPEG.VersionLow: " & buf(bp)
    Inc bp
    
    units = buf(bp)
    Inc bp
    
    Debug.Print "Units: " & units
    If units <> 0 Then
      Exit Sub
    End If
    
    xdensity = Word(buf, bp)
    Inc2 bp
    
    ydensity = Word(buf, bp)
    Inc2 bp
    
    Debug.Print "X Density: " & xdensity
    Debug.Print "Y-Density: " & ydensity
    'If xdensity <> 1 And ydensity <> 1 Then Exit Sub
    
    xthumbnail = buf(bp)
    Inc bp
    
    ythumbnail = buf(bp)
    Inc bp
    
    Debug.Print "X Thumbnail: " & xthumbnail
    Debug.Print "Y Thumbnail: " & ythumbnail
    If xthumbnail <> 0 And ythumbnail <> 0 Then
      Exit Sub
    End If
    
    SOS_found = False
    SOF_found = False
    Restart_Markers = False
    
    Debug.Print
    
    While bp < UBound(buf) And Not SOS_found
      If buf(bp) = 255 Then
        Inc bp
        
        Inc bp
        Select Case buf(bp - 1)
          Case DQT
            Length = Word(buf, bp)
            Inc2 bp
            
            j = 0
            While j < Length - 2
              old_bp = bp
              
              QT_Info = buf(bp)
              Inc bp
              
              If CLng(QT_Info \ 2 ^ 4) <> 0 Then
                Exit Sub
              End If
              
              LoadQuantTable QT_Info And &HF, buf, bp
              
              j = j + bp - old_bp
              
              Debug.Print "Quantisierungstabelle " & (QT_Info And _
                  &HF) & " ausgelesen"
            Wend
          Case DHT
            Length = Word(buf, bp)
            Inc2 bp
            
            j = 0
            While j < Length - 2
              old_bp = bp
              
              HT_Info = buf(bp)
              Inc bp
              
              If (HT_Info And &H10) <> 0 Then
                ac = True
              Else
                ac = False
              End If
              
              If ac Then
                LoadHuffmanTableAC HT_Info And &HF, buf, bp
              Else
                LoadHuffmanTableDC HT_Info And &HF, buf, bp
              End If
              
              j = j + bp - old_bp
              
              Debug.Print "Huffmantabelle " & IIf(ac, "AC", "DC") _
                  & " " & (HT_Info And &HF) & " ausgelesen"
            Wend
          Case COM
            Debug.Print "Kommentar vorhanden"
            Length = Word(buf, bp)
            bp = bp + Length
          Case DRI
            Restart_Markers = True
            Length = Word(buf, bp)
            Inc2 bp
            
            MCU_Restart = Word(buf, bp)
            Inc2 bp
            
            If MCU_Restart = 0 Then
              Restart_Markers = False
            End If
            
            Debug.Print "Restart-Marker gefunden"
          Case SOF
            Length = Word(buf, bp)
            Inc2 bp
            
            Precision = buf(bp)
            Inc bp
            If Precision <> 8 Then
              Exit Sub
            End If
            
            Y_Image = Word(buf, bp)
            Inc2 bp
            
            X_Image = Word(buf, bp)
            Inc2 bp
            
            Debug.Print "X Image: " & X_Image
            Debug.Print "y Image: " & Y_Image
            
            nr_components = buf(bp)
            Inc bp
            If nr_components <> 3 Then
              Exit Sub
            End If
            
            For j = 1 To 3
              comp_id = buf(bp)
              Inc bp
              
              If comp_id = 0 Or comp_id > 3 Then
                Exit Sub
              End If
              
              Select Case comp_id
                Case 1
                  'Y
                  YH = buf(bp) \ 2 ^ 4
                  YV = buf(bp) And &HF
                  Inc bp
                  
                  YQ_nr = buf(bp)
                  Inc bp
                Case 2
                  'Cb
                  CbH = buf(bp) \ 2 ^ 4
                  CbV = buf(bp) And &HF
                  Inc bp
                  
                  CbQ_Nr = buf(bp)
                  Inc bp
                Case 3
                  'Cr
                  CrH = buf(bp) \ 2 ^ 4
                  CrV = buf(bp) And &HF
                  Inc bp
                  
                  CrQ_nr = buf(bp)
                  Inc bp
              End Select
            Next j
            
            SOF_found = True
            Debug.Print "Rahmen ausgelesen"
          Case SOS
            Length = Word(buf, bp)
            Inc2 bp
            
            nr_components = buf(bp)
            Inc bp
            
            If nr_components <> 3 Then
              Exit Sub
            End If
            
            For j = 1 To 3
              comp_id = buf(bp)
              Inc bp
              
              If comp_id = 0 Or comp_id > 3 Then
                Exit Sub
              End If
              
              Select Case comp_id
                Case 1
                  YDC_nr = buf(bp) \ 2 ^ 4
                  YAC_nr = buf(bp) And &HF
                  Inc bp
                Case 2
                  CbDC_nr = buf(bp) \ 2 ^ 4
                  CbAC_nr = buf(bp) And &HF
                  Inc bp
                Case 3
                  CrDC_nr = buf(bp) \ 2 ^ 4
                  CrAC_nr = buf(bp) And &HF
                  Inc bp
              End Select
            Next j
            
            bp = bp + 3
            SOS_found = True
            
            Debug.Print "Scan ausgelesen"
          Case 255
          Case APP12
            Length = Word(buf, bp)
            bp = bp + Length
            Debug.Print "APP12-Marker gefunden - Length: " & Length
          Case APP14
            Length = Word(buf, bp)
            bp = bp + Length
            Debug.Print "APP14-Marker gefunden - Length: " & Length
          Case Else
            Length = Word(buf, bp)
            bp = bp + Length
            Debug.Print "Unknown Marker - " & buf(bp - Length - 1) _
                & " " & Hex(buf(bp - Length - 1)) & " - Length: " _
                & Length
        End Select
        Debug.Print
      Else
        Inc bp
      End If
    Wend
    
    If Not SOS_found Then
      Exit Sub
    End If
    If Not SOF_found Then
      Exit Sub
    End If
    
    If CbH > YH Or CrH > YH Then
      Exit Sub
    End If
    If CbV > YV And CrV > YV Then
      Exit Sub
    End If
    
    If CbH >= 2 And CbV >= 2 Then
      Exit Sub
    End If
    If CrH >= 2 And CrV >= 2 Then
      Exit Sub
    End If
    
    Hmax = YH
    Vmax = YV
    
    If (X_Image Mod (Hmax * 8)) = 0 Then
      X_round = X_Image
    Else
      X_round = (X_Image \ (Hmax * 8) + 1) * (Hmax * 8)
    End If
    
    If (Y_Image Mod (Vmax * 8)) = 0 Then
      Y_round = Y_Image
    Else
      Y_round = (Y_Image \ (Vmax * 8) + 1) * (Vmax * 8)
    End If
    
    Debug.Print "X Round: " & X_round
    Debug.Print "Y Round: " & Y_round
    
    ReDim im_buffer(X_round * Y_round * 4)
    
    Debug.Print "JPEG-Header komplett geladen"
    Debug.Print "Dekodiere JPEG-Daten"
    
    bp = bp - 2
    resync buf, bp
    
    y_inc_value = 32 * X_round
    
    calculate_tabs YV, YH
    
    Decode_MCU = CStr(YH) & "x" & CStr(YV)
    
    MCU_dim_x = Hmax * 8 * 4
    
    Y_MCU_nr = Y_round \ (Vmax * 8)
    X_MCU_nr = X_round \ (Hmax * 8)
    
    x_image_bytes = X_round * 4
    im_loc_inc = (Vmax * 8 - 1) * x_image_bytes
    nr_mcu = 0
    im_loc = 0
    
    For y_mcu_cnt = 0 To Y_MCU_nr - 1
      For x_mcu_cnt = 0 To X_MCU_nr - 1
        Select Case Decode_MCU
          Case "1x1"
            'Decode_MCU_1x1
          Case "1x2"
            'decode_mcu_1x2
          Case "2x2"
            Decode_MCU_2x2
          Case "2x1"
            'decode_mcu_2x1
        End Select
        
        If MCU_Restart <> 0 Then
          If Restart_Markers And ((nr_mcu + 1) Mod MCU_Restart = 0) Then
            resync buf, bp
          End If
        End If
        Inc nr_mcu
        
        im_loc = im_loc + MCU_dim_x
      Next x_mcu_cnt
      im_loc = im_loc + im_loc_inc
    Next y_mcu_cnt
    
    
  Dim outbuf() As Byte
    Get_JPEG_Buffer outbuf
    
    Write_Buf_To_BMP outbuf, App.Path & "\test.bmp"
    
    Set Picture1.Picture = LoadPicture(App.Path & "\test.bmp")
    
    Command1.Enabled = True
    
    Debug.Print "Fertig"
End Sub
Public Sub Decode_MCU_2x2()
    Process_Huffman_Data_Unit YDC_nr, YAC_nr, DCY
    IDCT_Transform DCT_coeff, Y_1, YQ_nr
    Process_Huffman_Data_Unit YDC_nr, YAC_nr, DCY
    IDCT_Transform DCT_coeff, Y_2, YQ_nr
    Process_Huffman_Data_Unit YDC_nr, YAC_nr, DCY
    IDCT_Transform DCT_coeff, Y_3, YQ_nr
    Process_Huffman_Data_Unit YDC_nr, YAC_nr, DCY
    IDCT_Transform DCT_coeff, Y_4, YQ_nr
    
    Process_Huffman_Data_Unit CbDC_nr, CbAC_nr, DCCb
    IDCT_Transform DCT_coeff, Cb, CbQ_Nr
    
    Process_Huffman_Data_Unit CrDC_nr, CrAC_nr, DCCr
    IDCT_Transform DCT_coeff, Cr, CrQ_nr
    
    Convert_8x8_YCbCr_To_RGB_Tab Y_1, Cb, Cr, tab_1, im_loc, _
        x_image_bytes, im_buffer
    Convert_8x8_YCbCr_To_RGB_Tab Y_2, Cb, Cr, tab_2, im_loc + 32, _
        x_image_bytes, im_buffer
    Convert_8x8_YCbCr_To_RGB_Tab Y_3, Cb, Cr, tab_3, im_loc + _
        y_inc_value, x_image_bytes, im_buffer
    Convert_8x8_YCbCr_To_RGB_Tab Y_4, Cb, Cr, tab_4, im_loc + _
        y_inc_value + 32, x_image_bytes, im_buffer
End Sub
Public Sub Process_Huffman_Data_Unit(DC_nr As Long, AC_nr As Long, _
    previous_DC As Long)
  Dim nr As Long, DCT_tcoeff(0 To 63) As Double, min_val As Long
  Dim k As Long, max_val As Long, tmp_Hcode As Currency
  Dim size_val As Long, EOB_found As Boolean, byte_temp As Long
  Dim count_0 As Long
    
    On Error Resume Next
    
    For nr = 0 To 63
      DCT_tcoeff(nr) = 0
    Next nr
    
    nr = 0
    
    For k = 1 To 16
      min_val = HTableDC(DC_nr).minor_code(k)
      max_val = HTableDC(DC_nr).major_code(k)
      
      tmp_Hcode = lookKbits(k)
      If (tmp_Hcode <= max_val) And (tmp_Hcode >= min_val) Then
        skipKbits k
        size_val = v_dc(DC_nr, Word_hi_lo(CByte(k), _
            CByte(tmp_Hcode - min_val)))
        
        If size_val = 0 Then
          DCT_tcoeff(0) = previous_DC
        Else
          DCT_tcoeff(0) = previous_DC + getKbits(size_val)
          previous_DC = DCT_tcoeff(0)
        End If
        
        Goto nextk
      End If
    Next k
nextk:
    
    
    nr = 1
    EOB_found = False
    
    While nr <= 63 And EOB_found = False
      For k = 1 To 16
        min_val = HTableAC(AC_nr).minor_code(k)
        max_val = HTableAC(AC_nr).major_code(k)
        
        tmp_Hcode = lookKbits(k)
        
        If tmp_Hcode <= max_val And tmp_Hcode >= min_val Then
          skipKbits k
          byte_temp = v_ac(AC_nr, Word_hi_lo(CByte(k), _
              CByte(tmp_Hcode - min_val)))
          size_val = byte_temp And &HF
          count_0 = byte_temp \ 2 ^ 4
          
          If size_val = 0 Then
            If count_0 = 0 Then
              EOB_found = True
            Else
              If count_0 = &HF Then
                nr = nr + 16
              End If
            End If
          Else
            nr = nr + count_0
            DCT_tcoeff(nr) = getKbits(size_val)
            Inc nr
          End If
          
          Goto nextk2
        End If
      Next k
nextk2:
      
      If k > 16 Then
        Inc nr: Stop
      End If
    Wend
    
    For j = 0 To 63
      DCT_coeff(j) = DCT_tcoeff(ZigZag(j))
    Next j
End Sub
Public Function lookKbits(k As Long) As Long
    lookKbits = wordval \ 2 ^ (16 - k)
End Function
Public Sub skipKbits(k As Long)
  Dim b_high As Long, b_low As Long
    
    d_k = d_k + k
    
    If d_k >= 16 Then
      d_k = d_k - 16
      w1 = w2
      
      Inc bp
      If buf(bp - 1) <> 255 Then
        b_high = buf(bp - 1)
      Else
        If buf(bp) = 0 Then
          Inc bp
        Else
          bp = bp - 1
        End If
        b_high = 255
      End If
      
      Inc bp
      If buf(bp - 1) <> 255 Then
        b_low = buf(bp - 1)
      Else
        If buf(bp) = 0 Then
          Inc bp
        Else
          bp = bp - 1
        End If
        b_low = 255
      End If
      
      w2 = Word_hi_lo(CByte(b_high), CByte(b_low))
    End If
    
  Dim s1 As String, s2 As String, w11 As String, i As Long
    
    For i = 15 To 0 Step -1
      If w1 And 2 ^ i Then
        s1 = s1 & "1"
      Else
        s1 = s1 & "0"
      End If
    Next i
    
    For i = 15 To 0 Step -1
      If w2 And 2 ^ i Then
        s2 = s2 & "1"
      Else
        s2 = s2 & "0"
      End If
    Next i
    
    s1 = s1 & String(16, "0")
    If Len(s2) < Len(s1) Then
      s2 = String(Len(s1) - Len(s2), "0") & s2
    ElseIf Len(s1) > Len(s2) Then
      s1 = String(Len(s2) - Len(s1), "0") & s1
    End If
    
  Dim mark As Byte
    mark = 0
    For i = Len(s1) To 1 Step -1
      If Mid$(s1, i, 1) = "0" And Mid$(s2, i, 1) = "0" And mark = 0 Then
        w11 = "0" & w11
      ElseIf Mid$(s1, i, 1) = "0" And Mid$(s2, i, 1) = "0" And _
          mark = 1 Then
        w11 = "1" & w11
        mark = 0
      ElseIf Mid$(s1, i, 1) = "0" And Mid$(s2, i, 1) = "1" And _
          mark = 0 Then
        w11 = "1" & w11
      ElseIf Mid$(s1, i, 1) = "0" And Mid$(s2, i, 1) = "1" And _
          mark = 1 Then
        w11 = "0" & w11
        mark = 1
      ElseIf Mid$(s1, i, 1) = "1" And Mid$(s2, i, 1) = "0" And _
          mark = 0 Then
        w11 = "1" & w11
      ElseIf Mid$(s1, i, 1) = "1" And Mid$(s2, i, 1) = "1" And _
          mark = 0 Then
        w11 = "0" & w11
        mark = 1
      ElseIf Mid$(s1, i, 1) = "1" And Mid$(s2, i, 1) = "0" And _
          mark = 1 Then
        w11 = "0" & w11
        mark = 1
      ElseIf Mid$(s1, i, 1) = "1" And Mid$(s2, i, 1) = "1" And _
          mark = 1 Then
        w11 = "1" & w11
        mark = 1
      End If
    Next i
    If mark = 1 Then
      w11 = "1" & w11
    End If
    
    w11 = w11 & String(d_k, "0")
    w11 = Left$(w11, Len(w11) - 16)
    If Len(w11) > 16 Then
      w11 = Right$(w11, 16)
    End If
    
  Dim n As Long
    
    wordval = 0
    n = 15
    For i = 1 To 16
      If Mid$(w11, i, 1) = "1" Then
        wordval = wordval Or 2 ^ n
      End If
      n = n - 1
    Next i
    
    'wordval = ((DWORD)(w1)<<16) + w2;
    'Äwordval <<= d_k;
    'wordval >>= 16;
    
    'Debug.Print w1
    'Debug.Print w2
    'wordval = CLng(w1) * CLng(2 ^ 16) + CLng(w2)
    'Debug.Print wordval
    'wordval = CLng(CLng(w1) * 2 ^ d_k + CLng(w2) * 2 ^ (d_k - 16))
    'Debug.Print wordval
    'wordval = Int(wordval / 2 ^ 16)
End Sub
Public Function getKbits(k As Long) As Long
  Dim signed_wordvalue As Long
    
    signed_wordvalue = get_svalue(k)
    skipKbits k
    
    getKbits = signed_wordvalue
End Function
Public Function get_svalue(k As Long) As Long
  Dim var As Integer, n2() As Variant, i As Long, nb As Long
  Dim np As Long
    
    n2 = Array(0, -1, -3, -7, -15, -31, -63, -127, -255, -511, _
        -1023, -2047, -4095, -8191, -16383, -32767)
    
    var = Int(wordval * 2 ^ (k - 16))
    
    If (var And 2 ^ (k - 1)) = 0 Then
      var = var + n2(k)
    End If
    
    get_svalue = var
End Function
Public Sub IDCT_Transform(incoeff() As Long, outcoeff() As Byte, _
    Q_nr As Long)
  Dim p_ic As Long, p_ws As Long, ws(0 To 63) As Double
  Dim p_qt As Long, x As Long, y As Long, dcval As Double, p_out As Long
  Dim tmp0 As Double, tmp1 As Double, tmp2 As Double, tmp3 As Double
  Dim tmp4 As Double, tmp5 As Double, tmp6 As Double, tmp7 As Double
  Dim tmp8 As Double, tmp9 As Double, tmp10 As Double, tmp11 As Double
  Dim tmp12 As Double, tmp13 As Double, z5 As Double, z10 As Double
  Dim z11 As Double, z12 As Double, z13 As Double
    
    p_ic = 0
    p_ws = 0
    p_qt = 0
    
    For y = 0 To 7
      If (incoeff(p_ic + 8) Or incoeff(p_ic + 16) Or incoeff(p_ic _
          + 24) Or incoeff(p_ic + 32) Or incoeff(p_ic + 40) Or _
          incoeff(p_ic + 48) Or incoeff(p_ic + 56)) = 0 Then
        dcval = incoeff(p_ic + 0) * QTable(Q_nr, p_qt + 0)
        ws(p_ws + 0) = dcval
        ws(p_ws + 8) = dcval
        ws(p_ws + 16) = dcval
        ws(p_ws + 24) = dcval
        ws(p_ws + 32) = dcval
        ws(p_ws + 40) = dcval
        ws(p_ws + 48) = dcval
        ws(p_ws + 56) = dcval
        
        Inc p_ic
        Inc p_ws
        Inc p_qt
        
        Goto nexty
      End If
      
      tmp0 = incoeff(p_ic + 0) * QTable(Q_nr, p_qt + 0)
      tmp1 = incoeff(p_ic + 16) * QTable(Q_nr, p_qt + 16)
      tmp2 = incoeff(p_ic + 32) * QTable(Q_nr, p_qt + 32)
      tmp3 = incoeff(p_ic + 48) * QTable(Q_nr, p_qt + 48)
      
      tmp10 = tmp0 + tmp2
      tmp11 = tmp0 - tmp2
      
      tmp13 = tmp1 + tmp3
      tmp12 = (tmp1 - tmp3) * 1.414213562 - tmp13
      
      tmp0 = tmp10 + tmp13
      tmp3 = tmp10 - tmp13
      tmp1 = tmp11 + tmp12
      tmp2 = tmp11 - tmp12
      
      tmp4 = incoeff(p_ic + 8) * QTable(Q_nr, p_qt + 8)
      tmp5 = incoeff(p_ic + 24) * QTable(Q_nr, p_qt + 24)
      tmp6 = incoeff(p_ic + 40) * QTable(Q_nr, p_qt + 40)
      tmp7 = incoeff(p_ic + 56) * QTable(Q_nr, p_qt + 56)
      
      z13 = tmp6 + tmp5
      z10 = tmp6 - tmp5
      z11 = tmp4 + tmp7
      z12 = tmp4 - tmp7
      
      tmp7 = z11 + z13
      tmp11 = (z11 - z13) * 1.414213562
      
      z5 = (z10 + z12) * 1.847759065
      tmp10 = 1.0823922 * z12 - z5
      tmp12 = -2.61312593 * z10 + z5
      
      tmp6 = tmp12 - tmp7
      tmp5 = tmp11 - tmp6
      tmp4 = tmp10 + tmp5
      
      ws(p_ws + 0) = tmp0 + tmp7
      ws(p_ws + 56) = tmp0 - tmp7
      ws(p_ws + 8) = tmp1 + tmp6
      ws(p_ws + 48) = tmp1 - tmp6
      ws(p_ws + 16) = tmp2 + tmp5
      ws(p_ws + 40) = tmp2 - tmp5
      ws(p_ws + 32) = tmp3 + tmp4
      ws(p_ws + 24) = tmp3 - tmp4
      
      Inc p_ic
      Inc p_qt
      Inc p_ws
      
nexty:
    Next y
    
    p_ws = 0
    For x = 0 To 7
      tmp10 = ws(p_ws + 0) + ws(p_ws + 4)
      tmp11 = ws(p_ws + 0) - ws(p_ws + 4)
      
      tmp13 = ws(p_ws + 2) + ws(p_ws + 6)
      tmp12 = (ws(p_ws + 2) - ws(p_ws + 6)) * 1.414213562 - tmp13
      
      tmp0 = tmp10 + tmp13
      tmp3 = tmp10 - tmp13
      tmp1 = tmp11 + tmp12
      tmp2 = tmp11 - tmp12
      
      z13 = ws(p_ws + 5) + ws(p_ws + 3)
      z10 = ws(p_ws + 5) - ws(p_ws + 3)
      z11 = ws(p_ws + 1) + ws(p_ws + 7)
      z12 = ws(p_ws + 1) - ws(p_ws + 7)
      
      tmp7 = z11 + z13
      tmp11 = (z11 - z13) * 1.414213562
      
      z5 = (z10 + z12) * 1.847759065
      tmp10 = 1.0823922 * z12 - z5
      tmp12 = -2.61312593 * z10 + z5
      
      tmp6 = tmp12 - tmp7
      tmp5 = tmp11 - tmp6
      tmp4 = tmp10 + tmp5
      
      outcoeff(p_out + 0) = rlimit_table(128 + (DESCALE(tmp0 + _
          tmp7, 3) And 1023))
      outcoeff(p_out + 7) = rlimit_table(128 + (DESCALE(tmp0 - _
          tmp7, 3) And 1023))
      outcoeff(p_out + 1) = rlimit_table(128 + (DESCALE(tmp1 + _
          tmp6, 3) And 1023))
      outcoeff(p_out + 6) = rlimit_table(128 + (DESCALE(tmp1 - _
          tmp6, 3) And 1023))
      outcoeff(p_out + 2) = rlimit_table(128 + (DESCALE(tmp2 + _
          tmp5, 3) And 1023))
      outcoeff(p_out + 5) = rlimit_table(128 + (DESCALE(tmp2 - _
          tmp5, 3) And 1023))
      outcoeff(p_out + 4) = rlimit_table(128 + (DESCALE(tmp3 + _
          tmp4, 3) And 1023))
      outcoeff(p_out + 3) = rlimit_table(128 + (DESCALE(tmp3 - _
          tmp4, 3) And 1023))
      
      p_out = p_out + 8
      p_ws = p_ws + 8
    Next x
End Sub
Public Function oldRIGHT_SHIFT(x As Long, shft As Long) As Long
  Dim shift_temp As Long
    
    shift_temp = x
    If shift_temp < 0 Then
      shift_temp = (shift_temp \ 2 ^ shft)
      Stop
    Else
      shift_temp = shift_temp \ 2 ^ shft
    End If
    
    oldRIGHT_SHIFT = shift_temp
End Function
Public Function RIGHT_SHIFT(ByVal Value As Long, ByVal ShiftCount _
    As Long) As Long
    Select Case ShiftCount
      Case 0&:  RIGHT_SHIFT = Value
      Case 1&:  RIGHT_SHIFT = (Value And &HFFFFFFFE) \ &H2&
      Case 2&:  RIGHT_SHIFT = (Value And &HFFFFFFFC) \ &H4&
      Case 3&:  RIGHT_SHIFT = (Value And &HFFFFFFF8) \ &H8&
      Case 4&:  RIGHT_SHIFT = (Value And &HFFFFFFF0) \ &H10&
      Case 5&:  RIGHT_SHIFT = (Value And &HFFFFFFE0) \ &H20&
      Case 6&:  RIGHT_SHIFT = (Value And &HFFFFFFC0) \ &H40&
      Case 7&:  RIGHT_SHIFT = (Value And &HFFFFFF80) \ &H80&
      Case 8&:  RIGHT_SHIFT = (Value And &HFFFFFF00) \ &H100&
      Case 9&:  RIGHT_SHIFT = (Value And &HFFFFFE00) \ &H200&
      Case 10&: RIGHT_SHIFT = (Value And &HFFFFFC00) \ &H400&
      Case 11&: RIGHT_SHIFT = (Value And &HFFFFF800) \ &H800&
      Case 12&: RIGHT_SHIFT = (Value And &HFFFFF000) \ &H1000&
      Case 13&: RIGHT_SHIFT = (Value And &HFFFFE000) \ &H2000&
      Case 14&: RIGHT_SHIFT = (Value And &HFFFFC000) \ &H4000&
      Case 15&: RIGHT_SHIFT = (Value And &HFFFF8000) \ &H8000&
      Case 16&: RIGHT_SHIFT = (Value And &HFFFF0000) \ &H10000
      Case 17&: RIGHT_SHIFT = (Value And &HFFFE0000) \ &H20000
      Case 18&: RIGHT_SHIFT = (Value And &HFFFC0000) \ &H40000
      Case 19&: RIGHT_SHIFT = (Value And &HFFF80000) \ &H80000
      Case 20&: RIGHT_SHIFT = (Value And &HFFF00000) \ &H100000
      Case 21&: RIGHT_SHIFT = (Value And &HFFE00000) \ &H200000
      Case 22&: RIGHT_SHIFT = (Value And &HFFC00000) \ &H400000
      Case 23&: RIGHT_SHIFT = (Value And &HFF800000) \ &H800000
      Case 24&: RIGHT_SHIFT = (Value And &HFF000000) \ &H1000000
      Case 25&: RIGHT_SHIFT = (Value And &HFE000000) \ &H2000000
      Case 26&: RIGHT_SHIFT = (Value And &HFC000000) \ &H4000000
      Case 27&: RIGHT_SHIFT = (Value And &HF8000000) \ &H8000000
      Case 28&: RIGHT_SHIFT = (Value And &HF0000000) \ &H10000000
      Case 29&: RIGHT_SHIFT = (Value And &HE0000000) \ &H20000000
      Case 30&: RIGHT_SHIFT = (Value And &HC0000000) \ &H40000000
      Case 31&: RIGHT_SHIFT = CBool(Value And &H80000000)
    End Select
End Function
Public Function DESCALE(x As Long, n As Long) As Long
    DESCALE = RIGHT_SHIFT(x + (1 * 2 ^ (n - 1)), n)
End Function
Public Sub Prepare_Range_Limit_Table()
  Dim j As Long, p As Long
    
    p = 0
    ReDim rlimit_table(-256 To 4 * 256 + 128)
    
    'p = p + 256
    
    For j = 0 To 255
      rlimit_table(p + j) = j
    Next j
    
    For j = 256 To 639
      rlimit_table(p + j) = 255
    Next j
    
    For j = 0 To 127
      rlimit_table(p + j + 1024) = j
    Next j
End Sub
Public Sub Convert_8x8_YCbCr_To_RGB_Tab(ny() As Byte, Cb() As _
    Byte, Cr() As Byte, ntab() As Byte, ByVal im_loc As Long, _
    x_image_bytes As Long, im_buffer() As Byte)
  Dim x As Long, y As Long, nr As Long, im_nr As Long
  Dim y_val As Long, cb_val As Long, cr_val As Long
    
    nr = 0
    For y = 0 To 7
      im_nr = 0
      For x = 0 To 7
        y_val = ny(nr)
        cb_val = Cb(ntab(nr))
        cr_val = Cr(ntab(nr))
        
        im_buffer(im_loc + im_nr) = rlimit_table(y_val + Cb_tab(cb_val))
        Inc im_nr
        im_buffer(im_loc + im_nr) = rlimit_table(y_val + _
            Cr_Cb_Green_tab(Word_hi_lo(CByte(cr_val), CByte(cb_val))))
        Inc im_nr
        im_buffer(im_loc + im_nr) = rlimit_table(y_val + Cr_tab(cr_val))
        Inc im_nr
        
        Inc nr
        Inc im_nr
      Next x
      im_loc = im_loc + x_image_bytes
    Next y
End Sub
Public Sub Precalculate_Cr_Cb_Tables()
  Dim k As Long, Cr_v As Long, Cb_v As Long
    
    For k = 0 To 255
      Cr_tab(k) = Fix((k - 128) * 1.402)
    Next k
    
    For k = 0 To 255
      Cb_tab(k) = Fix((k - 128) * 1.772)
    Next k
    
    For Cr_v = 0 To 255
      For Cb_v = 0 To 255
        Cr_Cb_Green_tab(Word_hi_lo(CByte(Cr_v), CByte(Cb_v))) = _
            Int(-0.34414 * (Cb_v - 128) - 0.71414 * (Cr_v - 128))
      Next Cb_v
    Next Cr_v
End Sub
Public Sub Get_JPEG_Buffer(ByRef dest_buffer() As Byte)
  Dim y As Long, src_bytes_per_line As Long, dest_bytes_per_line As Long
  Dim p_dest As Long, p_src As Long, x As Long
    
    src_bytes_per_line = X_round * 4
    dest_bytes_per_line = X_Image * 4
    
    ReDim dest_buffer(X_Image * Y_Image * 4)
    
    For y = 0 To Y_Image - 1
      For x = 0 To dest_bytes_per_line - 1
        dest_buffer(p_dest + x) = im_buffer(p_src + x)
      Next x
      p_src = p_src + src_bytes_per_line
      p_dest = p_dest + dest_bytes_per_line
    Next y
End Sub
Public Sub Write_Buf_To_BMP(im_buffer() As Byte, dateiname As String)
  Dim ff As Long, nr_fillingbytes As Long, im_loc_bytes As Long
  Dim x As Long, y As Long, i As Long
    
    ff = FreeFile
    Open dateiname For Binary As #ff
    
    If X_Image Mod 4 <> 0 Then
      nr_fillingbytes = 4 - ((X_Image * 3) Mod 4)
    Else
      nr_fillingbytes = 0
    End If
    
    Put #ff, , CInt(Asc("M") * 256 + Asc("B"))
    Put #ff, , CLng(54 + Y_Image * (X_Image * 3 + nr_fillingbytes))
    Put #ff, , CLng(0)
    Put #ff, , CLng(54)
    Put #ff, , CLng(&H28)
    Put #ff, , CLng(X_Image)
    Put #ff, , CLng(Y_Image)
    Put #ff, , CInt(1)
    Put #ff, , CInt(24)
    Put #ff, , CLng(0)
    Put #ff, , CLng(0)
    Put #ff, , CLng(&HB40)
    Put #ff, , CLng(&HB40)
    Put #ff, , CLng(0)
    Put #ff, , CLng(0)
    
    im_loc_bytes = (Y_Image - 1) * X_Image * 4
    
    For y = 0 To Y_Image - 1
      For x = 0 To X_Image - 1
        Put #ff, , CByte(im_buffer(im_loc_bytes + 0))
        Put #ff, , CByte(im_buffer(im_loc_bytes + 1))
        Put #ff, , CByte(im_buffer(im_loc_bytes + 2))
        im_loc_bytes = im_loc_bytes + 4
      Next x
      
      For i = 0 To nr_fillingbytes - 1
        Put #ff, , CByte(0)
      Next i
      
      im_loc_bytes = im_loc_bytes - 2 * X_Image * 4
    Next y
    
    Close #ff
End Sub