exif.cls

vb做的看图系统

        EXIFmodified = Now
    End If
    Set pi = Nothing
End Property


Public Property Get FileType() As String
    Const ImageFormatSuffix        As String = "-0728-11D3-9D7B-0000F81EF32E}"
    Const ImageFormatUndefined     As String = "{B96B3CA9" & ImageFormatSuffix
    Const ImageFormatMemoryBMP     As String = "{B96B3CAA" & ImageFormatSuffix
    Const ImageFormatBMP           As String = "{B96B3CAB" & ImageFormatSuffix
    Const ImageFormatEMF           As String = "{B96B3CAC" & ImageFormatSuffix
    Const ImageFormatWMF           As String = "{B96B3CAD" & ImageFormatSuffix
    Const ImageFormatJPEG          As String = "{B96B3CAE" & ImageFormatSuffix
    Const ImageFormatPNG           As String = "{B96B3CAF" & ImageFormatSuffix
    Const ImageFormatGIF           As String = "{B96B3CB0" & ImageFormatSuffix
    Const ImageFormatTIFF          As String = "{B96B3CB1" & ImageFormatSuffix
    Const ImageFormatEXIF          As String = "{B96B3CB2" & ImageFormatSuffix
    Const ImageFormatIcon          As String = "{B96B3CB5" & ImageFormatSuffix
    
    Dim retval As Long
    Dim FormatID As CLSID
    
    retval = GdipGetImageRawFormat(m_Image, FormatID)
    
    Select Case GetGuidString(FormatID)
           Case ImageFormatUndefined
             FileType = "Undefined"
           Case ImageFormatMemoryBMP
             FileType = "Memory BMP"
           Case ImageFormatBMP
             FileType = "BMP"
           Case ImageFormatEMF
             FileType = "EMF"
           Case ImageFormatWMF
             FileType = "WMF"
           Case ImageFormatJPEG
             FileType = "JPEG"
           Case ImageFormatPNG
             FileType = "PNG"
           Case ImageFormatGIF
             FileType = "GIF"
           Case ImageFormatTIFF
             FileType = "TIFF"
           Case ImageFormatEXIF
             FileType = "EXIF"
           Case ImageFormatIcon
             FileType = "Icon"
    End Select

End Property


'-----------------
'PRIVATE FUNCTIONS
'-----------------
Private Function DisposeImage()
    Dim retval As Long
    retval = GdipDisposeImage(m_Image)
    If retval = 0 Then
        m_Image = 0
    Else
        'cant release image
    End If
End Function

Private Function PropertyItemForID(ByVal lId As Long) As GDIPPropertyItem
    'gets a property from the image and stores it in the property item structure
    Dim lSize As Long
    If m_Image <> 0 Then
        GdipGetPropertyItemSize m_Image, lId, lSize
        If (lSize > 0) Then
           ReDim b(0 To lSize - 1) As Byte
           Dim lPtrBuff As Long
           lPtrBuff = VarPtr(b(0))
           LocalGdipGetPropertyItem m_Image, lId, lSize, lPtrBuff
           Dim p As PropertyItem
           Dim cItem As New GDIPPropertyItem
           Dim lDataSize As Long
           If Not (lPtrBuff = 0) And (lSize > 0) Then
              CopyMemory p, ByVal lPtrBuff, Len(p)
              cItem.fInit p.id, p.Length, p.Type, p.ValuePtr, lSize
           End If
           Set PropertyItemForID = cItem
        End If
    End If
End Function

Private Sub SetPropertyItem(item As GDIPPropertyItem)
    Dim retval As Long
    Dim p As GdiPlus.PropertyItem
    'make sure we have an image loaded
    If m_Image <> 0 Then
        'and a valid property item assigned
        If item.id <> 0 Then
            p.id = item.id
            p.Length = item.Length
            p.Type = item.ItemType
            ReDim b(0 To item.DataBufferSize - 1) As Byte
            item.GetData b()
            p.ValuePtr = VarPtr(b(0))
            retval = GdipSetPropertyItem(m_Image, p)
        End If
    End If
End Sub




'------------------------
'PRIVATE HELPER FUNCTIONS
'------------------------
Private Property Get Initialised() As Boolean
    If m_hGDIplus <> 0 Then
        Initialised = True
    End If
End Property
Private Function GetEncoderClsid(sMimeType As String) As CLSID
   Dim lNumCoders       As Long
   Dim lSize            As Long
   Dim uInfo()          As ImageCodecInfo
   Dim lIdx             As Long
   Dim strEncoder       As String

   GdipGetImageEncodersSize lNumCoders, lSize
   If lSize > 0 Then
      ReDim uInfo(0 To lSize \ LenB(uInfo(0))) As ImageCodecInfo
      GdipGetImageEncoders lNumCoders, lSize, uInfo(0)
      For lIdx = 0 To lNumCoders - 1
        strEncoder = PtrToStrW(uInfo(lIdx).MimeTypePtr)
         If StrComp(strEncoder, sMimeType, vbTextCompare) = 0 Then
            GetEncoderClsid = uInfo(lIdx).CLSID
            Exit For
         End If
      Next
   End If
End Function

'   Dereferences an ANSI or Unicode string pointer
'   and returns a normal VB BSTR
Private Function PtrToStrW(ByVal lpsz As Long) As String
   Dim sOut             As String
   Dim lLen             As Long
   lLen = lstrlenW(lpsz)
   If (lLen > 0) Then
      sOut = String$(lLen * 2, vbNullChar)
      CopyMemory ByVal sOut, ByVal lpsz, lLen * 2
      PtrToStrW = Replace(sOut, Chr$(0), "", 1)
   End If
End Function
Private Function ISODateTimeToDate( _
      ByVal isoDateTime As String _
   ) As Date
   'to test
   'example = "2003:12:03 18:24:55"
On Error Resume Next
Dim dDate As Date
   dDate = DateSerial( _
         Mid(isoDateTime, 1, 4), _
         Mid(isoDateTime, 6, 2), _
         Mid(isoDateTime, 9, 2)) + _
      TimeSerial( _
         Mid(isoDateTime, 12, 2), _
         Mid(isoDateTime, 15, 2), _
         Mid(isoDateTime, 18, 2))
   ISODateTimeToDate = dDate
End Function

Private Function DateToISODateTime(ByVal dDateTime As Date) As String
    'converts a datetime into ISO date time format
    'example = "2003:12:03 18:24:55"
    Dim retval As String
    Dim dp As String
    
    If IsDate(dDateTime) Then
        retval = Year(dDateTime)
        retval = retval & ":"
        dp = Month(dDateTime)
        If Len(dp) = 1 Then dp = "0" & dp
        retval = retval & dp
        retval = retval & ":"
        dp = Day(dDateTime)
        If Len(dp) = 1 Then dp = "0" & dp
        retval = retval & dp
        retval = retval & " "
        dp = Hour(dDateTime)
        If Len(dp) = 1 Then dp = "0" & dp
        retval = retval & dp
        retval = retval & ":"
        dp = Minute(dDateTime)
        If Len(dp) = 1 Then dp = "0" & dp
        retval = retval & dp
        retval = retval & ":"
        dp = Second(dDateTime)
        If Len(dp) = 1 Then dp = "0" & dp
        retval = retval & dp
    End If
    DateToISODateTime = retval
End Function

Private Function GetATemporaryFileName() As String
    'used to create swap file for lossless saving
    On Error Resume Next
    Dim sTempDir As String
    Dim sTempFileName As String
    
    'Create buffers
    sTempDir = String(100, Chr$(0))
    sTempFileName = String(260, 0)
    'Get the temporary path
    GetTempPath 100, sTempDir
    'Strip the 0's off the end
    sTempDir = Left$(sTempDir, InStr(sTempDir, Chr$(0)) - 1)
    'backup in case none found
    If Len(sTempDir) = 0 Then
        sTempDir = "C:\"
    End If
    'get file name
    GetTempFileName sTempDir, "IMG", 0, sTempFileName
    'Strip the 0's off the end
    sTempFileName = Left$(sTempFileName, InStr(sTempFileName, Chr$(0)) - 1)
    GetATemporaryFileName = sTempFileName
End Function

Private Function ReportError(ByVal lError As Long, Optional sTitle As String, Optional sText As String)
    Dim m As String
    Dim sT1 As String
    
    sT1 = "Error"
    If Len(sTitle) > 0 Then
        sT1 = sT1 & " : " & sTitle
    End If
    
    m = m & "Error code " & lError & vbCrLf
    m = m & GdiErrorString(lError) & vbCrLf
    
    If Len(sText) > 0 Then
        m = m & sText & vbCrLf
    End If
    
    'MsgBox M, vbCritical, sT1
End Function

Private Function GdiErrorString(ByVal lError As Long) As String
  Dim S As String
  
  Select Case lError
    Case 0: S = "No Error"
    Case 1: S = "Generic Error"
    Case 2: S = "Invalid Parameter"
    Case 3: S = "Out Of Memory"
    Case 4: S = "Object Busy"
    Case 5: S = "Insufficient Buffer"
    Case 6: S = "Not Implemented"
    Case 7: S = "Win32 Error"
    Case 8: S = "Wrong State"
    Case 9: S = "Aborted"
    Case 10: S = "File Not Found"
    Case 11: S = "Value Overflow"
    Case 12: S = "Access Denied"
    Case 13: S = "Unknown Image Format"
    Case 14: S = "FontFamily Not Found"
    Case 15: S = "FontStyle Not Found"
    Case 16: S = "Not TrueType Font"
    Case 17: S = "Unsupported Gdiplus Version"
    Case 18: S = "Gdiplus Not Initialized"
    Case 19: S = "Property Not Found"
    Case 20: S = "Property Not Supported"
    Case Else: S = "Unknown Error"
  End Select
  
  GdiErrorString = S
End Function


Private Function WriteFileToDisk(sFileName As String, uEncParams As EncoderParameters) As Long
    'does the actual saving of the image
    Dim sEncoder As String
    sEncoder = "image/jpeg"
  
    WriteFileToDisk = GdipSaveImageToFile(m_Image, sFileName, GetEncoderClsid(sEncoder), uEncParams)

End Function

Private Function hexPad(ByVal Value As Long, ByVal padSize As Long) As String
    'used below
    Dim sRet As String
    Dim lMissing As Long
    sRet = Hex$(Value)
    lMissing = padSize - Len(sRet)
    If (lMissing > 0) Then
        sRet = String$(lMissing, "0") & sRet
    ElseIf (lMissing < 0) Then
    End If
        sRet = Mid$(sRet, -lMissing + 1)
    hexPad = sRet
End Function

Private Function GetGuidString(GUID As CLSID) As String
    'used to help determine an Image Type
    Dim i As Long
    Dim sGuid As String

    sGuid = "{" & hexPad(GUID.Data1, 8) & "-" & hexPad(GUID.Data2, 4) & "-" & hexPad(GUID.Data3, 4) & "-"
    sGuid = sGuid & hexPad(GUID.Data4(0), 2) & hexPad(GUID.Data4(1), 2) & "-"
    For i = 2 To 7
        sGuid = sGuid & hexPad(GUID.Data4(i), 2)
    Next i
    sGuid = sGuid & "}"
    GetGuidString = sGuid
End Function

'-----------------
'CLASS FUNCTIONS
'-----------------
Private Sub Class_Initialize()
    'start the GDI engine
    On Error GoTo Handler
    
    Dim GpInput As GdiplusStartupInput
    GpInput.GdiplusVersion = 1
    GdiplusStartup m_hGDIplus, GpInput
    
    Exit Sub
Handler:
    ReportError Err.Number, "Initialising GDI+", Err.Description
    Resume Next
End Sub

Private Sub Class_Terminate()
    If Initialised Then
        DisposeImage
        Call GdiplusShutdown(m_hGDIplus)
    End If
End Sub

Public Function SaveAs(Degree As EncoderValue) As Boolean
    Dim retval        As Long
    Dim encoderCLSID  As CLSID
    Dim uEncParams As EncoderParameters
    Dim OriginalFilePath As String
    Dim TempFileRotated As String
  
    If Not Initialised Then Exit Function
    
    'get the values we will need for file swapping
    OriginalFilePath = m_FileName
    TempFileRotated = GetATemporaryFileName
    
    'prepare the encoder for a rotation of ? degrees
    uEncParams.Count = 1
    With uEncParams.Parameter
        .GUID = CLSIDFromString(EncoderTransformation)
        .NumberOfValues = 1
        .Type = EncoderParameterValueTypeLong
        .ValuePtr = VarPtr(Degree)
    End With
    
    'save the image to a temp location
    retval = WriteFileToDisk(TempFileRotated, uEncParams)
    'if save went ok then proceed with file swap
    If retval = 0 Then
'release the image we have locked
'necessary?
    DisposeImage
    End If
    'rename the original file to some temp name so we have a backup
    retval = CopyFile(TempFileRotated, OriginalFilePath, 0)
    'remove the tempory files
    retval = DeleteFile(TempFileRotated)
    
End Function