<%
'============================================================
' MODULE:   cGIFInfo.asp
' APPL:        GIFInfo
' AUTHOR:   © www.u229.no
' CREATED:  July 2005
' LAST MODIFIED: September 2005
'============================================================
' COMMENT: This class reads various properties from GIF files, including "hidden" text.
'                  References for the GIF Format: http://www.w3.org/Graphics/GIF/spec-gif89a.txt
'                  I know the GIF reference stuff about ApplicationIdentifier etc can be confusing.
'                  Also very few GIF's actually contain these blocks. See the reference if you
'                  are interested, or see www.u229.no/stuff/GIFFormat/.
'                  This code assumes that the GIF you are working with does have correct syntax.
'                  Otherwise the code will break.
'============================================================
' TODO: There are many more GIF features not covered by this class. I leave those to you :-)
'============================================================
' ROUTINES:

' - Public Property Let FilePath(sPath)
' - Public Property Get GIFType()
' - Public Property Get Width()
' - Public Property Get Height()
' - Public Property Get ColorDepth()
' - Public Property Get Comments()
' - Public Property Get ImageSize()
' - Public Property Get DateCreated()
' - Public Property Get DateLastAccessed()
' - Public Property Get DateLastModified()
' - Public Property Get ApplicationIdentifier()
' - Public Property Get ApplicationAuthCode()
' - Public Property Get ApplicationData()
' - Public Property Get PixelRatio()
' - Public Property Get NumberOfImages()
' - Public Property Get NumberOfColors()
' - Public Property Get Colors()
' - Public Property Get ErrorMessage()

' - Private Sub Class_Initialize()
' - Private Sub Class_Terminate()
' - Public Function GetGIFInfo()
' - Private Function LoadGIF()
' - Private Function LoadGIFAsBytes()
' - Private Function GetPixelAspectRatio()
' - Private Function IIf(Condition, Truecond, Falsecond)
' - Private Sub CountColors()
' - Private Function IsSafeArray(arr)
' - Function TrimTail(s, t)
' - Sub BubbleSort(arr)
'============================================================



'============================================================
Class cGifInfo
'============================================================

'// MODULE VARIABLES
Private m_arrGIF                              '// Read GIF into byte array
Private m_sFilePath                           '// Path to GIF file
Private m_sGIFType                          '// GIF87a or GIF89a
Private m_lWidth                               '// Width of gif in pixels
Private m_lHeight                              '// Height of gif in pixels
Private m_lColorDepth                       '// Bits pr Pixel: 4/16 colors, 5/32 colors, 6/64 colors, 7/128 colors, 8/256 colors
Private m_bGlobalColorTableFlag     '// Is there a Global Color Table present in this GIF?
Private m_lSizeGlobalColorTable       '// Size of Global Color Table. If present this follows right after the header.
Private m_lNumberOfColors               '// Number of  colors in Global Color Table. This requires the existence of a Global Color Table
Private m_sRGB     '// Return a string with the colors found in the Global Color Table. Separated with a Chr(32), finished with a Chr(44)
Private m_sComments                       '// Comments read from the GIF image
Private m_lImageSize                       '// Image size in bytes
Private m_sDateCreated                   '// Date created
Private m_sDateLastAccessed           '// Date last accessed
Private m_sDateLastModified             '// Date last saved
Private m_sAppIdentifier                   '// Application Identifier
Private m_sAppAuthCode                  '// Application Authentication code
Private m_sAppData                          '// Application data
Private m_lPixelRatio                        '// Width of the pixel divided by the height of the pixel. If no aspect ratio is specified, 0 is returned.
Private m_lNumberOfImages             '// Number of images. If > 0 then this is an animated GIF
Private m_sErrorMessage                  '// Return a human readable error message



'// PROPERTIES
Public Property Let FilePath(sPath)
    m_sFilePath = sPath
End Property
Public Property Get GIFType()
    GIFType = m_sGIFType
End Property
Public Property Get Width()
    Width = m_lWidth
End Property
Public Property Get Height()
    Height = m_lHeight
End Property
Public Property Get ColorDepth()
    ColorDepth = m_lColorDepth
End Property
Public Property Get Comments()
    Comments = m_sComments
End Property
Public Property Get ImageSize()
    ImageSize = m_lImageSize
End Property
Public Property Get DateCreated()
    DateCreated = m_sDateCreated
End Property
Public Property Get DateLastAccessed()
    DateLastAccessed = m_sDateLastAccessed
End Property
Public Property Get DateLastModified()
    DateLastModified = m_sDateLastModified
End Property
Public Property Get ApplicationIdentifier()
    '// Each character separated by a space character
    ApplicationIdentifier = m_sAppIdentifier
End Property
Public Property Get ApplicationAuthCode()
    '// Each character separated by a space character
    ApplicationAuthCode = RTrim(m_sAppAuthCode)
End Property
Public Property Get ApplicationData()
    ApplicationData = m_sAppData
End Property
Public Property Get PixelRatio()
    PixelRatio = m_lPixelRatio
End Property
Public Property Get NumberOfImages()
    NumberOfImages = m_lNumberOfImages
End Property
Public Property Get NumberOfColors()
    NumberOfColors = m_lNumberOfColors
End Property
Public Property Get Colors()
    Colors = m_sRGB
End Property
Public Property Get ErrorMessage()
    ErrorMessage = m_sErrorMessage
End Property

'------------------------------------------------------------------------------------------------------------
' Comment: Initialize our module variables
'------------------------------------------------------------------------------------------------------------
Private Sub Class_Initialize()
    On Error Resume Next

    m_lWidth = 0
    m_lHeight = 0
    m_lColorDepth = 0
    m_lImageSize = 0
    m_sDateCreated = ""
    m_sDateLastAccessed = ""
    m_sDateLastModified = ""
    m_sGIFType = "Unknown"
    m_sErrorMessage = ""
    m_lNumberOfColors = 0
    m_lNumberOfImages = 0
    m_sAppIdentifier = ""
    m_sAppAuthCode = ""
    m_sAppData = ""
    m_sRGB = ""

End Sub

'--------------------------------------------------------------------------------------------------------
' Comment:
'--------------------------------------------------------------------------------------------------------
Private Sub Class_Terminate()
End Sub

'------------------------------------------------------------------------------------------------------------
' Comment: Main routine. Returns the GIF properties.
'------------------------------------------------------------------------------------------------------------
Public Function GetGIFInfo()
    On Error Resume Next

    Dim i, m, k, iCurByte, lngLengthSubBlock, lngBlockLabel, lTmp, LngByteAscii
    '// A factor to calculate the actual size of the Global Color Table.
    Dim lngGlobalColorFactor

'---------------------------- Verify input data

    If Len(m_sFilePath) = 0 Then m_sErrorMessage = "Missing Parameter: FilePath": Exit Function

'---------------------------- Load GIF

    If (Not LoadGIFAsBytes) Or (Not LoadGIF) Then m_sErrorMessage = "Error opening file": Exit Function

'---------------------------- Start reading the GIF header

    If AscB(MidB(m_arrGIF, 1, 1)) = 71 And AscB(MidB(m_arrGIF, 2, 1)) = 73 And AscB(MidB(m_arrGIF, 3, 1)) = 70 Then

        m_sGIFType = "GIF89a"

        If AscB(MidB(m_arrGIF, 5, 1)) = 55 Then m_sGIFType = "GIF87a"

        m_lWidth = CLng(AscB(MidB(m_arrGIF, 7, 1)) + (AscB(MidB(m_arrGIF, 8, 1)) * 256))
        m_lHeight = CLng(AscB(MidB(m_arrGIF, 9, 1)) + (AscB(MidB(m_arrGIF, 10, 1)) * 256))
        m_lColorDepth = 2 ^ ((Asc(CStr(AscB(MidB(m_arrGIF, 11, 1)))) And 7) + 1)
        m_lPixelRatio = GetPixelAspectRatio

    End If

'---------------------------- Global Color Table

    lTmp = AscB(MidB(m_arrGIF, 11, 1))
    
    '// Global Color Table exists?
    If lTmp And 128 Then m_bGlobalColorTableFlag = True

    If m_bGlobalColorTableFlag Then

        '// The 3 least significant bits in byte 11 give us a factor to calculate the size of Global Color Table
        If lTmp And 4 Then lngGlobalColorFactor = 4
        If lTmp And 2 Then lngGlobalColorFactor = lngGlobalColorFactor Or 2
        If lTmp And 1 Then lngGlobalColorFactor = lngGlobalColorFactor Or 1

        '// Now calculate the size (# of bytes) of Global Color Table
        m_lSizeGlobalColorTable = CLng(3 * (2 ^ (lngGlobalColorFactor + 1)))
        
        '// Loop the Global Color Table counting unique colors
        Call CountColors

    End If

'================== Start looping the GIF byte array
    For i = 12 To m_lImageSize
'==================

        iCurByte = AscB(MidB(m_arrGIF, i, 1))

'---------------------------- Count # Image Frames

        If iCurByte = 44 Then

            '// We have an image frame if byte pattern = 00 2C (Perhaps a little ugly, but it works)
            If AscB(MidB(m_arrGIF, i - 1, 1)) = 0 Then
                
                '// If # of images in a GIF > 1 we have what is called an animated GIF
                m_lNumberOfImages = (m_lNumberOfImages + 1)

            End If
        End If

'---------------------------- Look for &H21 which identifies the various blocks like the Comment and Application blocks

        If iCurByte = 33 Then

            lngBlockLabel = AscB(MidB(m_arrGIF, i + 1, 1))
        
'======================= This looks like a valid Comment Extension Block

            If lngBlockLabel = 254 And AscB(MidB(m_arrGIF, i - 1, 1)) = 0 Then
                
'---------------------------- Loop the Comment(s)

                m = (i + 3)

                Do While m < m_lImageSize
                    '// There might be several comment blocks in an GIF. Here we just join them
                    '// in one big string. Every block starts with a byte telling the size of the
                    '// following block. If present, these bytes/numbers will be added to the string.
                    LngByteAscii = AscB(MidB(m_arrGIF, m, 1))

                    If LngByteAscii = 0 Then Exit Do
                    m_sComments = m_sComments & Chr(LngByteAscii)
                    m = (m + 1)
                Loop

            End If
        End If

'======================= Application Extension Block

        If lngBlockLabel = 255 Then

            '// Next byte should have the fixed value of 11
            If AscB(MidB(m_arrGIF, i + 2, 1)) = 11 Then

                '// Move counter to start of text.
                m = (i + 3)
                                      
'------------------------------------- Read the Application Identifier
                
                For k = 0 To 7
                    '// This should be ASCII characters
                    m_sAppIdentifier = (m_sAppIdentifier & Chr(AscB(MidB(m_arrGIF, m + k, 1))))
                Next
                
                '// Move pointer to start of Authentic Code Field
                m = (m + 8)
                
'-------------------------------------- Read the Application Authentication Code

                For k = 0 To 2
                    '// Return App. Auth. Code characters (can be binary or ASCII) with their decimal value separated by a space character.
                    m_sAppAuthCode = (m_sAppAuthCode & CStr(AscB(MidB(m_arrGIF, m + k, 1))) & Chr(32))
                Next
                                                                                                             
                m = (m + 3)
                
'-------------------------------------- Read the Application Data

                lngLengthSubBlock = AscB(MidB(m_arrGIF, m, 1))
                k = 1
'---------------------------- Loop the Application Data Sub Blocks

                Do While k <= lngLengthSubBlock
                    lTmp = k

                    If lTmp < lngLengthSubBlock Then
                        '// Return the Application Data (binary) with their decimal values separated by a space character Chr(32)
                        m_sAppData = (m_sAppData & CStr(AscB(MidB(m_arrGIF, m + lTmp, 1))) & Chr(32))
                        k = (k + 1)
                    End If

                    If lTmp = lngLengthSubBlock Then

                        '// Add the last character
                        m_sAppData = m_sAppData & CStr(AscB(MidB(m_arrGIF, m + lTmp, 1)))
                        '// Check if we have another comment sub block following
                        lngLengthSubBlock = AscB(MidB(m_arrGIF, m + lTmp + 1, 1))
                                                        
                        '// If this value is zero we have reached the end of the comment block ..
                        If lngLengthSubBlock = 0 Then Exit Do
                                                        
                        '// .. otherwise we have more blocks and we separate them with a Chr(0)
                        m_sAppData = m_sAppData & Chr(0)

                        m = (m + lTmp + 1)
                        k = 1

                    End If

                    If k + 1 >= m_lImageSize Then Exit Do          '// Make sure we avoid overflow error

                Loop

            End If
        End If

'==================
    Next
'==================

End Function

'------------------------------------------------------------------------------------------------------------
' Comment: Open the GIF file with FileSystemObject.
'------------------------------------------------------------------------------------------------------------
Private Function LoadGIF()
    On Error Resume Next

    Const ForReading = 1                  '// Open a file for reading only. You can't write to this file.
    Const TristateUseDefault = -2    '// Opens the file using the system default.

    Dim oFSO
    Dim oFile

    If IsEmpty(oFSO) Then Set oFSO = Server.CreateObject("Scripting.FileSystemObject")

    If Not oFSO.FileExists(m_sFilePath) Then
        Set oFSO = Nothing
        m_sErrorMessage = "File Not Found"
        Exit Function
    End If

    '// Create a new file object to read file properties
    Set oFile = oFSO.GetFile(m_sFilePath)

    '// Get some file properties
    m_lImageSize = oFile.Size
    m_sDateCreated = oFile.DateCreated
    m_sDateLastAccessed = oFile.DateLastAccessed
    m_sDateLastModified = oFile.DateLastModified

    '// Clean up
    Set oFile = Nothing
    Set oFSO = Nothing
    
    '// Return a boolean
    LoadGIF = (Err.Number = 0)

End Function

'------------------------------------------------------------------------------------------------------------
' Comment: Read image into byte array.
'------------------------------------------------------------------------------------------------------------
Private Function LoadGIFAsBytes()
    On Error Resume Next

    Dim oStream

    If IsEmpty(oStream) Then Set oStream = Server.CreateObject("ADODB.Stream")

    With oStream
        .Type = 1                     '// adTypeBinary
        .Open
        .LoadFromFile m_sFilePath
        m_arrGIF = .Read
    End With

    oStream.Close
    Set oStream = Nothing

    LoadGIFAsBytes = (LenB(m_arrGIF) > 0 And Err.Number = 0)

End Function

'------------------------------------------------------------------------------------------------------------
' Comment: Return the pixel ratio value.
'------------------------------------------------------------------------------------------------------------
Private Function GetPixelAspectRatio()
    On Error Resume Next

    Dim iTmp

    iTmp = AscB(MidB(m_arrGIF, 12, 1))
    GetPixelAspectRatio = IIf(iTmp, (iTmp + 15) / 64, 0)
    
End Function

'------------------------------------------------------------------------------------------------------------
' Comment: Home made IIf routine.
'------------------------------------------------------------------------------------------------------------
Private Function IIf(Condition, Truecond, Falsecond)
    On Error Resume Next

    IIf = Falsecond
    If Condition Then IIf = Truecond

End Function
 
'------------------------------------------------------------------------------------------------------------
' Comment: Counting the RGB values in the Global Color Table.
'------------------------------------------------------------------------------------------------------------
Private Sub CountColors()
    On Error Resume Next

    '// Since we are here we must have a Global Color Table. This starts with byte 14. Length of table = m_lSizeGlobalColorTable
    Dim i, l, iMax, arrTmp(), arrColors(), iRGBTmp, iRGBCur

    iMax = (14 + m_lSizeGlobalColorTable) - 1
    l = 0

'---------------------------- Store the colors in a temporary array

    For i = 14 To iMax Step 3
        '// Harvest the RGB values: separate them with a Chr(32) and finish them with a Chr(44)
        iRGBCur = CStr(AscB(MidB(m_arrGIF, i, 1))) & Chr(32) & CStr(AscB(MidB(m_arrGIF, i + 1, 1))) & _
            Chr(32) & CStr(AscB(MidB(m_arrGIF, i + 2, 1))) & Chr(44)
        
        ReDim Preserve arrTmp(l)
        arrTmp(l) = iRGBCur
        l = l + 1

    Next

'---------------------------- Sort the colors

    If Not IsSafeArray(arrTmp) Then Exit Sub
    Call BubbleSort(arrTmp)

'---------------------------- Loop the temporary array to get rid of duplicates. Copy the unique values to arrColors.

    iMax = UBound(arrTmp)
    l = 0

    For i = 0 To iMax

        iRGBCur = arrTmp(i)

        If iRGBCur <> iRGBTmp Then
            '// Add a unique RGB value
            ReDim Preserve arrColors(l)
            arrColors(l) = iRGBCur
            '// Store this value to the next loop
            iRGBTmp = iRGBCur
            l = l + 1
        End If

    Next

'---------------------------- Set module values

    '// Set the number of unique colors
    m_lNumberOfColors = l

    '// Return the colors we have found
    If IsSafeArray(arrColors) Then m_sRGB = TrimTail(Join(arrColors), Chr(44))

End Sub

'------------------------------------------------------------------------------------------------------------
' Comment: Returns true if array has values, false if it is empty.
'------------------------------------------------------------------------------------------------------------
Private Function IsSafeArray(arr)
    On Error Resume Next

    Dim lUp

    If Not IsArray(arr) Then IsSafeArray = False: Exit Function

    lUp = UBound(arr)

    IsSafeArray = (Err.Number = 0)
    
    Err.Clear
    
End Function

'------------------------------------------------------------------------------------------------------------
' Comment: Trims off a trailing character if present.
'------------------------------------------------------------------------------------------------------------
Function TrimTail(s, t)
    On Error Resume Next

    If Right(s, 1) = t Then s = Mid(s, 1, Len(s) - 1)
    TrimTail = s

End Function

'------------------------------------------------------------------------------------------------------------
' Comment: BubbleSort. Best on smaller arrays.
'                 http://www.4guysfromrolla.com/demos/bubblesort.asp
'------------------------------------------------------------------------------------------------------------
Sub BubbleSort(arr)
    On Error Resume Next

    Dim row, j
    Dim StartingKeyValue, NewKeyValue, swap_pos

    For row = 0 To UBound(arr) - 1
        'Take a snapshot of the first element
        'in the array because if there is a
        'smaller value elsewhere in the array
        'we'll need to do a swap.
        StartingKeyValue = arr(row)
        NewKeyValue = arr(row)
        swap_pos = row
            
        For j = row + 1 To UBound(arr)

            'Start inner loop.
            If arr(j) < NewKeyValue Then
                'This is now the lowest number -
                'remember it's position.
                swap_pos = j
                NewKeyValue = arr(j)
            End If

        Next
        
        If swap_pos <> row Then
            'If we get here then we are about to do a swap
            'within the array.
            arr(swap_pos) = StartingKeyValue
            arr(row) = NewKeyValue
        End If

    Next

End Sub

'============================================================
End Class
'============================================================
%>