gdippropertyitem.cls

vb做的看图系统

        Name = "PixelUnit"
    Case PropertyTagPixelPerUnitX
        Name = "PixelPerUnitX"
    Case PropertyTagPixelPerUnitY
        Name = "PixelPerUnitY"
    Case PropertyTagPaletteHistogram
        Name = "PaletteHistogram"
    Case PropertyTagExifExposureTime
        Name = "ExifExposureTime"
    Case PropertyTagExifFNumber
        Name = "ExifFNumber"
    Case PropertyTagExifExposureProg
        Name = "ExifExposureProg"
    Case PropertyTagExifSpectralSense
        Name = "ExifSpectralSense"
    Case PropertyTagExifISOSpeed
        Name = "ExifISOSpeed"
    Case PropertyTagExifOECF
        Name = "ExifOECF"
    Case PropertyTagExifVer
        Name = "ExifVer"
    Case PropertyTagExifDTOrig
        Name = "ExifDTOrig"
    Case PropertyTagExifDTDigitized
        Name = "ExifDTDigitized"
    Case PropertyTagExifCompConfig
        Name = "ExifCompConfig"
    Case PropertyTagExifCompBPP
        Name = "ExifCompBPP"
    Case PropertyTagExifShutterSpeed
        Name = "ExifShutterSpeed"
    Case PropertyTagExifAperture
        Name = "ExifAperture"
    Case PropertyTagExifBrightness
        Name = "ExifBrightness"
    Case PropertyTagExifExposureBias
        Name = "ExifExposureBias"
    Case PropertyTagExifMaxAperture
        Name = "ExifMaxAperture"
    Case PropertyTagExifSubjectDist
        Name = "ExifSubjectDist"
    Case PropertyTagExifMeteringMode
        Name = "ExifMeteringMode"
    Case PropertyTagExifLightSource
        Name = "ExifLightSource"
    Case PropertyTagExifFlash
        Name = "ExifFlash"
    Case PropertyTagExifFocalLength
        Name = "ExifFocalLength"
    Case PropertyTagExifMakerNote
        Name = "ExifMakerNote"
    Case PropertyTagExifUserComment
        Name = "ExifUserComment"
    Case PropertyTagExifDTSubsec
        Name = "ExifDTSubsec"
    Case PropertyTagExifDTOrigSS
        Name = "ExifDTOrigSS"
    Case PropertyTagExifDTDigSS
        Name = "ExifDTDigSS"
    Case PropertyTagExifFPXVer
        Name = "ExifFPXVer"
    Case PropertyTagExifColorSpace
        Name = "ExifColorSpace"
    Case PropertyTagExifPixXDim
        Name = "ExifPixXDim"
    Case PropertyTagExifPixYDim
        Name = "ExifPixYDim"
    Case PropertyTagExifRelatedWav
        Name = "ExifRelatedWav"
    Case PropertyTagExifInterop
        Name = "ExifInterop"
    Case PropertyTagExifFlashEnergy
        Name = "ExifFlashEnergy"
    Case PropertyTagExifSpatialFR
        Name = "ExifSpatialFR"
    Case PropertyTagExifFocalXRes
        Name = "ExifFocalXRes"
    Case PropertyTagExifFocalYRes
        Name = "ExifFocalYRes"
    Case PropertyTagExifFocalResUnit
        Name = "ExifFocalResUnit"
    Case PropertyTagExifSubjectLoc
        Name = "ExifSubjectLoc"
    Case PropertyTagExifExposureIndex
        Name = "ExifExposureIndex"
    Case PropertyTagExifSensingMethod
        Name = "ExifSensingMethod"
    Case PropertyTagExifFileSource
        Name = "ExifFileSource"
    Case PropertyTagExifSceneType
        Name = "ExifSceneType"
    Case PropertyTagExifCfaPattern
        Name = "ExifCfaPattern"
    Case PropertyTagGpsVer
        Name = "GpsVer"
    Case PropertyTagGpsLatitudeRef
        Name = "GpsLatitudeRef"
    Case PropertyTagGpsLatitude
        Name = "GpsLatitude"
    Case PropertyTagGpsLongitudeRef
        Name = "GpsLongitudeRef"
    Case PropertyTagGpsLongitude
        Name = "GpsLongitude"
    Case PropertyTagGpsAltitudeRef
        Name = "GpsAltitudeRef"
    Case PropertyTagGpsAltitude
        Name = "GpsAltitude"
    Case PropertyTagGpsGpsTime
        Name = "GpsGpsTime"
    Case PropertyTagGpsGpsSatellites
        Name = "GpsGpsSatellites"
    Case PropertyTagGpsGpsStatus
        Name = "GpsGpsStatus"
    Case PropertyTagGpsGpsMeasureMode
        Name = "GpsGpsMeasureMode"
    Case PropertyTagGpsGpsDop
        Name = "GpsGpsDop"
    Case PropertyTagGpsSpeedRef
        Name = "GpsSpeedRef"
    Case PropertyTagGpsSpeed
        Name = "GpsSpeed"
    Case PropertyTagGpsTrackRef
        Name = "GpsTrackRef"
    Case PropertyTagGpsTrack
        Name = "GpsTrack"
    Case PropertyTagGpsImgDirRef
        Name = "GpsImgDirRef"
    Case PropertyTagGpsImgDir
        Name = "GpsImgDir"
    Case PropertyTagGpsMapDatum
        Name = "GpsMapDatum"
    Case PropertyTagGpsDestLatRef
        Name = "GpsDestLatRef"
    Case PropertyTagGpsDestLat
        Name = "GpsDestLat"
    Case PropertyTagGpsDestLongRef
        Name = "GpsDestLongRef"
    Case PropertyTagGpsDestLong
        Name = "GpsDestLong"
    Case PropertyTagGpsDestBearRef
        Name = "GpsDestBearRef"
    Case PropertyTagGpsDestBear
        Name = "GpsDestBear"
    Case PropertyTagGpsDestDistRef
        Name = "GpsDestDistRef"
    Case PropertyTagGpsDestDist
        Name = "GpsDestDist"
    Case Else
        Name = "unknown (" & m_lId & ")"
   End Select
End Property

Public Function ValueCount() As Long
   Select Case ItemType
   Case PropertyTagTypeASCII
      ' each item is 1 byte:
      ValueCount = 1
   
   Case PropertyTagTypeUndefined, PropertyTagTypeByte, 6 ' sbyte
      ValueCount = m_lLength
      
   Case PropertyTagTypeShort, 8 ' schar
      ' each item is 2 bytes:
      ValueCount = m_lLength / 2
      
   Case PropertyTagTypeRational, PropertyTagTypeSRational, 12 ' double
      ' each item is 8 bytes:
      ValueCount = m_lLength / 8
      
   Case PropertyTagTypeLong, PropertyTagTypeSLONG, 11 ' float
      ' each item is 4 bytes:
      ValueCount = m_lLength / 4
      
   End Select

End Function

Public Property Get ParseString() As String
    'returns the value of an Ascii type entry
    ParseString = TrimNulls(StrConv(m_bData, vbUnicode))
End Property
Public Function SetPropertyStringValue(inVal As String, Optional id As Long) As Boolean
    'used to write a new property or to update an existing one
    'property must be of ASCII type

    If id = 0 Then
        'if they didnt supply an id then assume they wanted to update the
        'currently loaded property, if of course there is one
        If m_lId <> 0 Then
            id = m_lId
        Else
            Exit Function
        End If
    End If

    'does this property id already exist?
    'if it does we need to confirm it is Ascii before we try and write to it
    If Not IsArrayEmpty(Not m_bData) Then
        'The array already contains some data
        'check to see that this item is ok to write ascii to
        If ItemType <> PropertyTagTypeASCII Then
            Exit Function
        End If
    Else
        'a new entry will be created
    End If

    'initialise our item
    CreateProperty id, Len(inVal), PropertyTagTypeASCII, StrConv(inVal, vbFromUnicode)

    SetPropertyStringValue = True
End Function


Public Property Get ParseRational(ByVal lItem As Long) As Variant
Dim lStart As Long
   If (lItem > 0) And (lItem <= ValueCount) Then
      lStart = (lItem - 1) * 8
      ReDim lValue(1 To 2) As Long
      CopyMemory lValue(1), m_bData(lStart), 4
      CopyMemory lValue(2), m_bData(lStart + 4), 4
      ParseRational = lValue
   Else
      'SetStatusHelper InvalidParameter
   End If
End Property
Public Property Get ParseShort(ByVal lItem As Long) As Integer
Dim lStart As Long
   If (lItem > 0) And (lItem <= ValueCount) Then
      lStart = (lItem - 1) * 2
      Dim iRet As Integer
      CopyMemory iRet, m_bData(lStart), 2
      ParseShort = iRet
   Else
      'SetStatusHelper InvalidParameter
      lStart = lStart
   End If
End Property
Public Property Get ParseLong(ByVal lItem As Long) As Long
Dim lStart As Long
   If (lItem > 0) And (lItem <= ValueCount) Then
      lStart = (lItem - 1) * 4
      Dim iRet As Long
      CopyMemory iRet, m_bData(lStart), 4
      ParseLong = iRet
   Else
      'SetStatusHelper InvalidParameter
   End If
End Property

Public Sub GetData(ByRef b() As Byte)
On Error Resume Next
Dim i As Long
   If (m_lLength > 0) Then
      For i = LBound(b) To UBound(b)
         b(i) = m_bData(i - LBound(b))
      Next i
   End If
End Sub

Public Property Get DataBufferSize() As Long
   DataBufferSize = ElementDataSize() * m_lLength
End Property

Public Property Get ElementDataSize() As Long
Dim lSize As Long
   Select Case ItemType
   Case PropertyTagTypeASCII, PropertyTagTypeUndefined, PropertyTagTypeByte, 6 ' sbyte
      ' each item is 1 byte:
      lSize = 1
   Case PropertyTagTypeShort, 8 ' schar
      ' each item is 2 bytes:
      lSize = 2
   Case PropertyTagTypeRational, PropertyTagTypeSRational, 12 ' double
      ' each item is 8 bytes:
      lSize = 8
   Case PropertyTagTypeLong, PropertyTagTypeSLONG, 11 ' float
      ' each item is 4 bytes:
      lSize = 4
   End Select
   ElementDataSize = lSize
End Property


'-----------------
'PRIVATE FUNCTIONS
'-----------------
Friend Sub fInit( _
      ByVal lId As Long, _
      ByVal lLength As Long, _
      ByVal eItemType As PropertyTagType, _
      ByVal lPtr As Long, _
      ByVal lSize As Long _
   )
    'used by cGDIP to create a property item
   m_lId = lId
   m_lLength = lLength
   m_itemType = eItemType
   If Not (lPtr = 0) And (lLength > 0) Then
      Dim lDataSize As Long
      lDataSize = lSize - 16
      If (lDataSize > 0) Then
         ReDim m_bData(0 To lDataSize - 1) As Byte
         CopyMemory m_bData(0), ByVal lPtr, lDataSize
      End If
   End If
End Sub

Private Sub CreateProperty( _
      ByVal lId As Long, _
      ByVal lLength As Long, _
      ByVal eItemType As PropertyTagType, _
      ByRef b() As Byte _
   )
    'used by us to create a property item
        Dim i As Long
        m_lId = lId
        m_lLength = lLength
        m_itemType = eItemType
        If (m_lLength > 0) Then
           ReDim m_bData(LBound(b) To UBound(b))
           For i = LBound(b) To UBound(b)
              m_bData(i - LBound(b)) = b(i)
           Next i
        End If
End Sub

Private Function TrimNulls(ByRef sText As String) As String
    Dim lPos As Long
    Dim sLeft As String
    Dim sRight As String
    'removes all the nulls out of a string
    lPos = InStr(1, sText, Chr$(0))
    Do While lPos > 0
        sLeft = Mid$(sText, 1, lPos - 1)
        sRight = Mid$(sText, lPos + 1, Len(sText) - lPos)
        sText = sLeft & sRight
        
       lPos = InStr(1, sText, Chr$(0))
    Loop
    TrimNulls = sText
End Function

Private Function IsArrayEmpty(ByVal lArrayPointer As Long) As Long
  'use like this
  '--Dim b() As Byte
  '--If IsArrayEmpty(Not b) Then
  '--  Debug.Print "The array has not been Redimmed."
  '--Else
  '--  Debug.Print "The array has been Redimmed."
  '--End If
  
  'lets you know if your array has any data in it
  IsArrayEmpty = (lArrayPointer = -1)
End Function