exif.cls

vb做的看图系统

    'get the property from the image
    Set pi = PropertyItemForID(id)
    'is it a valid object ?
    If pi.id = id Then
        'retreival was successful
         For j = 1 To pi.ValueCount
            If (j > 1) Then
               sItem = sItem & ", "
            End If
            sItem = sItem & pi.ParseShort(j)
         Next j
        'retreival was successful
         Select Case sItem
         Case 0
            sDescription = "Standard"
         Case 1
            sDescription = "Landscape"
         Case 2
            sDescription = "Portrait"
         Case 3
            sDescription = "Night Scene"
         End Select

         EXIFscene = sDescription
    End If
    Set pi = Nothing
    
End Property

Public Property Get EXIFlightsource() As String
    Const id = 37384      'PropertyTagExifLightSource = &H9208
    Dim j As Long
    Dim sItem As String
    Dim sDescription As String
    Dim pi As New GDIPPropertyItem
    'get the property from the image
    Set pi = PropertyItemForID(id)
    'is it a valid object ?
    If pi.id = id Then
        'retreival was successful
         For j = 1 To pi.ValueCount
            If (j > 1) Then
               sItem = sItem & ", "
            End If
            sItem = sItem & pi.ParseShort(j)
         Next j
        'retreival was successful
         Select Case sItem
         Case 0
            sDescription = "Unknown"
         Case 1
            sDescription = "Daylight"
         Case 2
            sDescription = "Fluorescent"
         Case 3
            sDescription = "Tungsten"
         Case 4
            sDescription = "Flash"
         Case 9
            sDescription = "Fine Weather"
         Case 10
            sDescription = "Cloudy Weather"
         Case 11
            sDescription = "Shade"
         Case 12
            sDescription = "Daylight Fluorescent"
         Case 13
            sDescription = "Day White Fluorescent"
         Case 14
            sDescription = "Cool White Fluorescent"
         Case 15
            sDescription = "White Fluorescent"
         Case 17
            sDescription = "Standard Light A"
         Case 18
            sDescription = "Standard Light B"
         Case 19
            sDescription = "Standard Light C"
         Case 20
            sDescription = "D55"
         Case 21
            sDescription = "D65"
         Case 22
            sDescription = "D75"
         Case 23
            sDescription = "D50"
         Case 24
            sDescription = "ISO Studio Tungsten "
         Case 255
            sDescription = "Other Light Source"
         End Select

         EXIFlightsource = sDescription
    End If
    Set pi = Nothing
    
End Property

Public Property Get EXIFxpTitle() As String
    Const id = 40091      '&H9C9B
    Dim pi As New GDIPPropertyItem
    'get the property from the image
    Set pi = PropertyItemForID(id)
    'is it a valid object ?
    If pi.id = id Then
        'retreival was successful
        EXIFxpTitle = pi.ParseString
    End If
    Set pi = Nothing
End Property

Public Property Let EXIFxpTitle(inVal As String)
    Const id = 40091      '&H9C9B
    Dim pi As New GDIPPropertyItem
    'limited to 999 bytes
    If Len(inVal) > 999 Then inVal = Left(inVal, 999)
    'create a properly formatted PropertyItem for adding
    If pi.SetPropertyStringValue(inVal, id) Then
        'use GDI+ to add it to the image (in memory - still will need physical save to disk)
        SetPropertyItem pi
        'change updated value
        EXIFmodified = Now
    End If
    Set pi = Nothing
End Property
Public Property Get EXIFxpComment() As String
    Const id = 40092      '&H9C9C
    Dim pi As New GDIPPropertyItem
    'get the property from the image
    Set pi = PropertyItemForID(id)
    'is it a valid object ?
    If pi.id = id Then
        'retreival was successful
        EXIFxpComment = pi.ParseString
    End If
    Set pi = Nothing
End Property

Public Property Let EXIFxpComment(inVal As String)
    Const id = 40092      '&H9C9C
    Dim pi As New GDIPPropertyItem
    'limited to 999 bytes
    If Len(inVal) > 999 Then inVal = Left(inVal, 999)
    'create a properly formatted PropertyItem for adding
    If pi.SetPropertyStringValue(inVal, id) Then
        'use GDI+ to add it to the image (in memory - still will need physical save to disk)
        SetPropertyItem pi
        'change updated value
        EXIFmodified = Now
    End If
    Set pi = Nothing
End Property

Public Property Get EXIFxpAuthor() As String
    Const id = 40093      'Author = &H9C9D
    Dim pi As New GDIPPropertyItem
    'get the property from the image
    Set pi = PropertyItemForID(id)
    'is it a valid object ?
    If pi.id = id Then
        'retreival was successful
        EXIFxpAuthor = pi.ParseString
    End If
    Set pi = Nothing
End Property

Public Property Let EXIFxpAuthor(inVal As String)
    Const id = 40093      'Author = &H9C9D
    Dim pi As New GDIPPropertyItem
    'limited to 999 bytes
    If Len(inVal) > 999 Then inVal = Left(inVal, 999)
    
    'create a properly formatted PropertyItem for adding
    If pi.SetPropertyStringValue(inVal, id) Then
        'use GDI+ to add it to the image (in memory - still will need physical save to disk)
        SetPropertyItem pi
        'change updated value
        EXIFmodified = Now
    End If
    Set pi = Nothing
End Property
Public Property Get EXIFxpKeywords() As String
    Const id = 40094      '&H9C9E
    Dim pi As New GDIPPropertyItem
    'get the property from the image
    Set pi = PropertyItemForID(id)
    'is it a valid object ?
    If pi.id = id Then
        'retreival was successful
        EXIFxpKeywords = pi.ParseString
    End If
    Set pi = Nothing
End Property

Public Property Let EXIFxpKeywords(inVal As String)
    Const id = 40094      '&H9C9E
    Dim pi As New GDIPPropertyItem
    'limited to 999 bytes
    If Len(inVal) > 999 Then inVal = Left(inVal, 999)
    'create a properly formatted PropertyItem for adding
    If pi.SetPropertyStringValue(inVal, id) Then
        'use GDI+ to add it to the image (in memory - still will need physical save to disk)
        SetPropertyItem pi
        'change updated value
        EXIFmodified = Now
    End If
    Set pi = Nothing
End Property
Public Property Get EXIFxpSubject() As String
    Const id = 40095      '&H9C9F
    Dim pi As New GDIPPropertyItem
    'get the property from the image
    Set pi = PropertyItemForID(id)
    'is it a valid object ?
    If pi.id = id Then
        'retreival was successful
        EXIFxpSubject = pi.ParseString
    End If
    Set pi = Nothing
End Property

Public Property Let EXIFxpSubject(inVal As String)
    Const id = 40095      '&H9C9F
    Dim pi As New GDIPPropertyItem
    'limited to 999 bytes
    If Len(inVal) > 999 Then inVal = Left(inVal, 999)
    'create a properly formatted PropertyItem for adding
    If pi.SetPropertyStringValue(inVal, id) Then
        'use GDI+ to add it to the image (in memory - still will need physical save to disk)
        SetPropertyItem pi
        'change updated value
        EXIFmodified = Now
    End If
    Set pi = Nothing
End Property

Public Property Get EXIFdistance() As String
'not yet verified - no camera i have access to shows distance

    Const id = 37382      'PropertyTagExifSubjectDist = &H9206
    Dim j As Long
    Dim sItem As String
    Dim pi As New GDIPPropertyItem
    'get the property from the image
    Set pi = PropertyItemForID(id)
    'is it a valid object ?
    If pi.id = id Then
        'retreival was successful
         For j = 1 To pi.ValueCount
            If (j > 1) Then
               sItem = sItem & ", "
            End If
            sItem = sItem & pi.ParseShort(j)
         Next j
        'retreival was successful
       EXIFdistance = sItem
    Else
        EXIFdistance = "Unknown"
    End If
    Set pi = Nothing
    
End Property

Public Property Get Height() As Long
    Dim retval As Long

    retval = GdipGetImageHeight(m_Image, Height)
    If retval Then
        ReportError retval, "Height evaluation", "Unable to determine image height"
    End If
   
End Property

Public Property Get Width() As Long
    Dim retval As Long

    retval = GdipGetImageWidth(m_Image, Width)
    If retval Then
        ReportError retval, "Width evaluation", "Unable to determine image width"
    End If
End Property

Public Function PaletteSize() As Long
    Dim lngSize As Long
    Dim retval As Long
    retval = GdipGetImagePaletteSize(m_Image, lngSize)
    PaletteSize = lngSize
End Function

Public Property Get PixelFormat() As String
    'returns colour depth
    Dim retval As Long
    Dim pf As Long 'PixelFormat
    Dim sDescription As String
    retval = GdipGetImagePixelFormat(m_Image, pf)
    If retval Then
        ReportError retval, "Pixel format evaluation", "Unable to determine image colour depth"
    Else
        Select Case pf
        Case PixelFormat1bppIndexed
            sDescription = "1bppIndexed"
        Case PixelFormat4bppIndexed
            sDescription = "4bppIndexed"
        Case PixelFormat8bppIndexed
            sDescription = "8bppIndexed"
        Case PixelFormat16bppARGB1555
            sDescription = "16bppARGB1555"
        Case PixelFormat16bppGrayScale
            sDescription = "16bppGrayScale"
        Case PixelFormat16bppRGB555
            sDescription = "16bppRGB555"
        Case PixelFormat16bppRGB565
            sDescription = "16bppRGB565"
        Case PixelFormat24bppRGB
            sDescription = "24bppRGB"
        Case PixelFormat32bppARGB
            sDescription = "32bppARGB"
        Case PixelFormat32bppPARGB
            sDescription = "32bppPARGB"
        Case PixelFormat32bppRGB
            sDescription = "32bppRGB"
        Case PixelFormat48bppRGB
            sDescription = "48bppRGB"
        Case PixelFormat64bppARGB
            sDescription = "64bppARGB"
        Case PixelFormat64bppPARGB
            sDescription = "64bppPARGB"
        Case Else
            sDescription = "Unknown"
        End Select
        
    End If
    PixelFormat = sDescription
End Property

Public Property Get EXIFversion() As String
    Const id = 36864      '&H9000
    Dim sItem As String
    Dim pi As New GDIPPropertyItem
    'get the property from the image
    Set pi = PropertyItemForID(id)
    'is it a valid object ?
    If pi.id = id Then
        'retreival was successful
        sItem = pi.ParseString
        If IsNumeric(sItem) Then
            sItem = sItem / 100
        End If
        EXIFversion = sItem
    End If
    Set pi = Nothing
End Property

Public Property Get EXIFid() As String
    Const id = 42016      'Unique Image ID = &HA420
    Dim pi As New GDIPPropertyItem
    'get the property from the image
    Set pi = PropertyItemForID(id)
    'is it a valid object ?
    If pi.id = id Then
        'retreival was successful
        EXIFid = pi.ParseString
    End If
    Set pi = Nothing
End Property

Public Property Let EXIFid(inVal As String)
    Const id = 42016      'Unique Image ID = &HA420
    Dim pi As New GDIPPropertyItem
    'limited to 32 bytes
    If Len(inVal) > 32 Then inVal = Left(inVal, 32)
    'create a properly formatted PropertyItem for adding
    If pi.SetPropertyStringValue(inVal, id) Then
        'use GDI+ to add it to the image (in memory - still will need physical save to disk)
        SetPropertyItem pi
        'change updated value