VB中如何提取图片的exif信息?
发布网友
发布时间：2022-05-06 16:45
共2个回答
热心网友
时间：2022-04-23 10:01
热心网友
时间：2022-04-23 11:19
Dim Offset_to_IFD0
Dim Offset_to_APP0
Dim Offset_to_APP1
Dim Offset_to_TIFF
Dim Offset_to_SOS
Dim Length_of_APP0
Dim Length_of_APP1
Dim Offset_to_Next_IFD
Dim IFDDirectory
IFDDirectory = Array(0)
Dim Offset_to_ExifSubIFD
Dim ImageFile
Dim IsLoaded
Dim ExifTemp
ExifTemp = Array(0)
Const IFD_IDX_Tag_No = 0
Const IFD_IDX_Tag_Name = 1
Const IFD_IDX_Data_Format = 2
Const IFD_IDX_Components = 3
Const IFD_IDX_Value = 4
Const IFD_IDX_Value_Desc = 5
Const IFD_IDX_OffsetToValue = 6
Function LookupExifTag(which)
Dim item
For Each item In ExifLookup
If ExifLookup(item) = which Then
LookupExifTag = item
Exit Function
End If
Next
LookupExifTag = which
End Function
Function GetExifByName(ExifTag)
If IsLoaded = False And ImageFile <> "" Then
LoadImage (ImageFile)
ElseIf IsLoaded = False And ImageFile = "" Then
Exit Function
End If
Dim i
For i = 0 To UBound(IFDDirectory) - 1
If IFDDirectory(i)(IFD_IDX_Tag_Name) = ExifTag Then
GetExifByName = IFDDirectory(i)(IFD_IDX_Value)
Exit For
End If
Next
End Function
Sub LoadImage(picFile)
If ImageFile = "" Then
ImageFile = picFile
If ImageFile = "" Then
Exit Sub
End If
End If
OpenJPGFile ImageFile
If InspectJPGFile = False Then
IsLoaded = False
Exit Sub
End If
If IsIntel Then
Offset_to_IFD0 = _
HexToDec(ExifTemp(Offset_to_APP1 + 17)) * 256 * 256 * 256 + _
HexToDec(ExifTemp(Offset_to_APP1 + 16)) * 256 * 256 + _
HexToDec(ExifTemp(Offset_to_APP1 + 15)) * 256 + _
HexToDec(ExifTemp(Offset_to_APP1 + 14))
Else
Offset_to_IFD0 = _
HexToDec(ExifTemp(Offset_to_APP1 + 14)) * 256 * 256 * 256 + _
HexToDec(ExifTemp(Offset_to_APP1 + 15)) * 256 * 256 + _
HexToDec(ExifTemp(Offset_to_APP1 + 16)) * 256 + _
HexToDec(ExifTemp(Offset_to_APP1 + 17))
End If
'Debug.Print "Offset_to_IFD0: " & Offset_to_IFD0
IsLoaded = True
GetDirectoryEntries Offset_to_TIFF + Offset_to_IFD0
MakeSenseOfMeaninglessValues
End Sub
Function InspectJPGFile()
Dim i
If ExifTemp(0) <> "FF" And ExifTemp(1) <> "D8" Then
InspectJPGFile = False
Else
For i = 2 To UBound(ExifTemp) - 1
If ExifTemp(i) = "FF" And ExifTemp(i + 1) = "E0" Then
Offset_to_APP0 = i
Exit For
End If
Next
If Offset_to_APP0 = 0 Then
InspectJPGFile = False
End If
Length_of_APP0 = _
HexToDec(ExifTemp(Offset_to_APP0 + 2)) * 256 + _
HexToDec(ExifTemp(Offset_to_APP0 + 3))
For i = 2 To UBound(ExifTemp) - 1
If ExifTemp(i) = "FF" And ExifTemp(i + 1) = "E1" Then
Offset_to_APP1 = i
Exit For
End If
Next
If Offset_to_APP1 = 0 Then
InspectJPGFile = False
End If
Offset_to_TIFF = Offset_to_APP1 + 10
Length_of_APP1 = _
HexToDec(ExifTemp(Offset_to_APP1 + 2)) * 256 + _
HexToDec(ExifTemp(Offset_to_APP1 + 3))
If Chr(HexToDec(ExifTemp(Offset_to_APP1 + 4))) & Chr(HexToDec(ExifTemp(Offset_to_APP1 + 5))) & _
Chr(HexToDec(ExifTemp(Offset_to_APP1 + 6))) & Chr(HexToDec(ExifTemp(Offset_to_APP1 + 7))) <> "Exif" Then
InspectJPGFile = False
Exit Function
End If
InspectJPGFile = True
End If
End Function
Function IsIntel()
If ExifTemp(Offset_to_TIFF) = "49" Then
IsIntel = True
Else
IsIntel = False
End If
End Function
Function writeExifToJPG(ExifData, FileName)
Dim FSO, FSO2, File, i
'Const adTypeBinary = 1
'Const adTypeText = 2
'Const adSaveCreateOverWrite = 2
If IsLoaded = False And ImageFile <> "" Then
LoadImage (ImageFile)
ElseIf IsLoaded = False And ImageFile = "" Then
Exit Function
End If
'Create Stream object
'Dim BinaryStream
'Set BinaryStream = CreateObject("ADODB.Stream")
'Specify stream type - we want To save binary data.
'BinaryStream.Type = adTypeBinary
'Open the stream And write binary data To the object
'BinaryStream.Open
'BinaryStream.Write ByteArray
Set FSO = CreateObject("Scripting.FileSystemObject")
'Create text stream object
Dim TextStream
Set TextStream = FSO.CreateTextFile(FileName & ".TMP")
For i = 0 To (Offset_to_APP0 + 2 + Length_of_APP0 - 1)
TextStream.Write Hex2Ascii(ExifTemp(i))
Next
TextStream.Write Hex2Ascii(ExifData)
For i = (Offset_to_APP0 + 2 + Length_of_APP0) To UBound(ExifTemp)
TextStream.Write Hex2Ascii(ExifTemp(i))
Next
Set FSO2 = Server.CreateObject("Scripting.FileSystemObject")
If FSO2.FileExists(FileName) Then
Set File = FSO2.OpenTextFile(FileName, ForReading, False, TristateFalse)
i = 0
While Not File.AtEndOfStream
If i > UBound(ExifTemp) Then
'BinaryStream.Write File.Read(1)
TextStream.Write File.Read(1)
End If
i = i + 1
Wend
File.Close
Set File = Nothing
Else
Response.Write ("File does not exist")
End If
Set FSO2 = Nothing
Set FSO = Nothing
'Save binary data To disk
'BinaryStream.SaveToFile FileName & ".TMP", adSaveCreateOverWrite
End Function
