exif.cls

vb做的看图系统

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "cEXIF"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'****************************************************************************
'人人为我，我为人人
'枕善居汉化收藏整理
'发布日期：2007/10/12
'描    述：极速数码照片查看播放工具 Ver 2.02
'网    站：http://www.Mndsoft.com/  (VB6源码博客)
'网    站：http://www.VbDnet.com/   (VB.NET源码博客,主要基于.NET2005)
'e-mail  ：[e-mail]
'e-mail  ：[e-mail]
'OICQ    ：88382850
'          如果您有新的好的代码别忘记给枕善居哦!
'****************************************************************************

'What does this do ?
'-------------------
'used for the sole purpose of accessing EXIF information
'each property item is loaded as it is needed.
'ie we dont do a mass load of all property items like we do in the FILE class
'this is because GDI+ places a lock on the file when it is opened

'How to use :
'------------
'.load a file using its full path name
'add / edit its meta data
'if you have made any changes then these can be saved back losslessly

'Example useage
'--------------
'dim x as new duncan_metadata.exif
'x.Load ("c:\myfile.jpg")
'x.EXIFdescription = "Hello baby its me"
'x.Save
'set x = nothing

'Requirements
'needs GDI+ TYPE LIBRARY from Dana Seaman located at http://www.cyberactivex.com

'Public Const PropertyTagResolutionXUnit = &H5001
'Public Const PropertyTagResolutionYUnit = &H5002
'Public Const PropertyTagExifExposureProg = &H8822
'Public Const PropertyTagExifShutterSpeed = &H9201
'Public Const PropertyTagExifAperture = &H9202
'Public Const PropertyTagExifBrightness = &H9203
'Public Const PropertyTagExifExposureBias = &H9204
'Public Const PropertyTagExifMaxAperture = &H9205

Option Explicit
'-----------------
'MY VARIABLES
'-----------------
Private m_hGDIplus As Long      'token to GDI engine
Private m_Image As Long         'handle to image
Private m_FileName As String    'remembers the file name we have open
'-----------------
'API FUNCTIONS
'-----------------
Private Declare Function GetTempFileName Lib "kernel32" Alias "GetTempFileNameA" (ByVal lpszPath As String, ByVal lpPrefixString As String, ByVal wUnique As Long, ByVal lpTempFileName As String) As Long
Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Private Declare Function CopyFile Lib "kernel32" Alias "CopyFileA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String, ByVal bFailIfExists As Long) As Long
Private Declare Function DeleteFile Lib "kernel32" Alias "DeleteFileA" (ByVal lpFileName As String) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDst As Any, pSrc As Any, ByVal ByteLen As Long)

'-----------------
'GDI+ FUNCTIONS
'-----------------
Private Declare Function LocalGdipGetPropertyItem Lib "gdiplus.dll" Alias "GdipGetPropertyItem" _
   (ByVal img As Long, _
   ByVal lId As Long, _
   ByVal lSize As Long, _
   ByVal lPtrBuff As Long) As Long
  Private Declare Function CreateDCAsNull Lib "gdi32" Alias "CreateDCA" (ByVal lpDriverName As String, lpDeviceName As Any, lpOutput As Any, lpInitData As Any) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
'-----------------
'PUBLIC FUNCTIONS
'-----------------
Public Function Load(sFileName As String) As Boolean
    Dim retval As Long
    DisposeImage
    m_FileName = sFileName
    retval = GdipLoadImageFromFile(sFileName, m_Image)
    If retval = 0 Then
        Load = True
    Else
        ReportError retval, "Loading Image", "Image not loaded"
    End If
End Function

Public Function PaintDC(ByVal hDC As Long, x As Integer, y As Integer)
    Dim sngWidth As Single
    Dim sngHeight As Single
    Dim graphic As Long
    
    'get a link to the DC we are going to paint onto
    GdipCreateFromHDC hDC, graphic
    
    'draw onto it
    
        GdipGetImageDimension m_Image, sngWidth, sngHeight
        GdipDrawImageRect graphic, m_Image, x, y, sngWidth, sngHeight
    
    
    GdipDeleteGraphics graphic
End Function

Public Property Get PropertyCount() As Long
    Dim numProperties As Long
    If m_Image <> 0 Then
        GdipGetPropertyCount m_Image, numProperties
    End If
    PropertyCount = numProperties
End Property

Public Function Save() As Boolean
    'saves the file back to where it was loaded from
    'need to do a 90 then 270 transform so that we dont recompress the JPG
    Dim retval        As Long
    Dim encoderCLSID  As CLSID
    Dim uEncParams As EncoderParameters

    Const EncoderValueTransformRotate90 As Long = 13
    Const EncoderValueTransformRotate270 As Long = 15
  
    Dim OriginalFilePath As String
    Dim TempFileOriginal As String
    Dim TempFileRotated90 As String
  
    If Not Initialised Then Exit Function
    
    'get the values we will need for file swapping
    OriginalFilePath = m_FileName
    TempFileOriginal = GetATemporaryFileName
    TempFileRotated90 = GetATemporaryFileName
    
    'prepare the encoder for a rotation of 90 degrees
    uEncParams.Count = 1
    With uEncParams.Parameter
        .GUID = CLSIDFromString(EncoderTransformation)
        .NumberOfValues = 1
        .Type = EncoderParameterValueTypeLong
        .ValuePtr = VarPtr(EncoderValueTransformRotate90)
    End With
    
    'save the image to a temp location
    retval = WriteFileToDisk(TempFileRotated90, uEncParams)
    'if save went ok then proceed with file swap
    If retval = 0 Then
'release the image we have locked
'necessary?
DisposeImage
    'rename the original file to some temp name so we have a backup
        retval = CopyFile(OriginalFilePath, TempFileOriginal, 0)
        If retval > 0 Then  'backup succeeded
    'remove the original
             'retval = DeleteFile(OriginalFilePath)
    'now load the temp file we just saved
            If Load(TempFileRotated90) Then
    'rotate this back 270 degrees
                With uEncParams.Parameter
                    .GUID = CLSIDFromString(EncoderTransformation)
                    .NumberOfValues = 1
                    .Type = EncoderParameterValueTypeLong
                    .ValuePtr = VarPtr(EncoderValueTransformRotate270)
                End With
    'and save it
                retval = WriteFileToDisk(OriginalFilePath, uEncParams)
                If retval = 0 Then
                    'saving of the new image went successfully
                    Save = True
                Else
                    'we couldnt complete the transformation
                    'restore the backup
                    ReportError retval, "Saving", "Writing transform 2."
                    retval = CopyFile(TempFileOriginal, OriginalFilePath, 0)
                End If
    'load the original again so the new data is in memory
                Load OriginalFilePath
            Else
                ReportError retval, "Saving", "Loading transform 1."
            End If
        Else
            ReportError retval, "Saving", "Backing up original file."
        End If
    Else
        'save failed, exit out
        ReportError retval, "Saving", "Writing transform 1."
    End If
    
    'remove the tempory files
    retval = DeleteFile(TempFileOriginal)
    retval = DeleteFile(TempFileRotated90)
    
End Function


'-----------------
'EXIF PROPERTIES
'-----------------
'since there are only a handfull of EXIF tags I want to edit I have written these wrappers
'to get and then set the values back
'its basically just a fast and easy way for me to access the info I want

'PropertyTagImageTitle = &H320 = 800
'PropertyTagImageDescription = &H10E = 270
'PropertyTagEquipMake = &H10F = 271
'PropertyTagEquipModel = &H110 = 272
'PropertyTagArtist = &H13B = 315
'PropertyTagCopyright = &H8298 =  33432
'PropertyTagExifUserComment = &H9286 = 37510
'PropertyTagExifDTOrig = &H9003 = 36867
'PropertyTagExifDTDigitized = &H9004 = 36868
'PropertyTagDateTime = &H132 = 306

Public Property Get EXIFtitle() As String
    Const id = 800      'PropertyTagImageTitle = &H320 = 800
    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
        EXIFtitle = pi.ParseString
    End If
    Set pi = Nothing
End Property

Public Property Let EXIFtitle(inVal As String)
    Const id = 800      'PropertyTagImageTitle = &H320 = 800
    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 EXIFdescription() As String
    Const id = 270      'PropertyTagImageDescription = &H10E = 270
    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
        EXIFdescription = pi.ParseString
    End If
    Set pi = Nothing
End Property

Public Property Let EXIFdescription(inVal As String)
    Const id = 270      'PropertyTagImageDescription = &H10E = 270
    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 EXIFartist() As String
    Const id = 315      'PropertyTagArtist = &H13B = 315
    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
        EXIFartist = pi.ParseString
    End If
    Set pi = Nothing
End Property

Public Property Let EXIFartist(inVal As String)
    Const id = 315      'PropertyTagArtist = &H13B = 315
    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 EXIFcomment() As String
    Const id = 37510      'PropertyTagExifUserComment = &H9286 = 37510
    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
        EXIFcomment = pi.ParseString
    End If
    Set pi = Nothing
End Property

Public Property Let EXIFcomment(inVal As String)
    Const id = 37510      'PropertyTagExifUserComment = &H9286 = 37510
    Dim pi As New GDIPPropertyItem
    '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
      
    End If
    Set pi = Nothing
End Property
Public Property Get EXIFcopyright() As String
    Const id = 33432      'PropertyTagCopyright = &H8298 = 33432
    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
        EXIFcopyright = pi.ParseString
    End If
    Set pi = Nothing
End Property

Public Property Let EXIFcopyright(inVal As String)
    Const id = 33432      'PropertyTagCopyright = &H8298 = 33432
    Dim pi As New GDIPPropertyItem
    '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 EXIFmodified() As Date
    Const id = 306      'PropertyTagDateTime = &H132 = 306
    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
        EXIFmodified = ISODateTimeToDate(pi.ParseString)
    End If
    Set pi = Nothing
End Property

Public Property Let EXIFmodified(inVal As Date)