TRI DE COLLECTION D'IMAGES : COMPARE ET LISTE

'beaucoup trop long, voir Zip

'extrait de CompKern.bas : la récupération de la résolution XY :
Private Sub GET_PicXYRes(InFormat As Long, OutXres As Long, OutYres As Long)
Dim bMarker As Byte
Dim iLength As Byte
Dim lSeek As Long
Dim iXres As Integer
Dim iYres As Integer
Dim Checking As Integer
Dim HWtbl(1 To 4) As Byte
Dim JpegDebug As Long

Select Case InFormat
Case 1 ' BMP
    Get #1, 19, OutXres
    Get #1, 23, OutYres
Case 2 ' JPG
    'le format JPEG standard est rarement respecté, aussi il faut procéder a différent "saut"
    'avant de trouver le marqueur SOF0, auquel est rattaché la résolution
    
    Get #1, 3, Checking
    If Checking <> &HE0FF Then
        'non-JFIF (exif ?)
        i = 5
        ts = LOF(1) - 1
        Do Until Checking = &HE0FF Or Checking = &HD8FF Or Checking = &HC0FF
            Get #1, i, Checking
            i = i + 1
            If i >= ts Then
                'format jpeg incompatible ou inconnu
                OutXres = 0
                OutYres = 0
                Exit Sub
            End If
        Loop
        lSeek = i
    Else
        'JFIF
        lSeek = 21
    End If
    
    
JpegMarkSeek:
    Get #1, lSeek, bMarker
    If bMarker = 255 Then
        Get #1, lSeek + 1, bMarker
        If bMarker >= 192 And bMarker <= 195 Then  'marqueur SOF0 , SOF1 ou SOF2 de base
            Get #1, lSeek + 5, HWtbl
            OutYres = HWtbl(1) * 256 + HWtbl(2)
            OutXres = HWtbl(3) * 256 + HWtbl(4)
            'OutXres = CLng(iXres)
            'OutYres = CLng(iYres)
            
            
            Get #1, LOF(1) - 1, Checking
            If Checking <> &HD9FF And Checking <> 0 Then
                'image buggé (fin incorrect)
                OutXres = 0
                OutYres = 0
            End If
        
        Else
            lSeek = lSeek + 1
            GoTo JpegMarkSeek
        End If
        
    Else
        lSeek = lSeek + 1
        GoTo JpegMarkSeek

        'non-JFIF
        OutXres = 0
        OutYres = 0
    End If
Case 3 ' GIF
    Get #1, 7, iXres
    Get #1, 9, iYres
    OutXres = CLng(iXres)
    OutYres = CLng(iYres)
Case Else
    OutXres = 0
    OutYres = 0
End Select
End Sub    

Télécharger le zip