EXTRACTION D'INFORMATIONS IPTC D'UNE IMAGE

<%
'Attention à n'utiliser que dans des pages codées en "Europe Occidental" : iso-8859-1 / CODEPAGE=1252
'
'===========================================
'Class d'extraction de tags IPTC d'une image
'===========================================
'
'Créé par Olivier Briat (olivier@briat.org) septembre 2006
'Basé sur les information collecté sur les pages suivantes :
' - http://www.codeproject.com/bitmap/iptc.asp?df=100&forumid=2301&exp=0&select=600249#xx600249xx
' - http://www.awaresystems.be/imaging/tiff/tifftags/docs/photoshopthumbnail.html

'
' VERSION 0.2:
' 0.2 : (29/09/06) Correction de l'extraction du segment 8BIM, et support TIFF
' 0.1 : (25/09/06) Version de base de la classe
'
' UTILISATION :
'
' 'Instancier l'objet :
' Set IP = New IPTC
' 'Ouvrir un fichier (chemin sur le disque, penser à utiliser Request.ServerVariables("APPL_PHYSICAL_PATH")):
' IP.Open(RepDest_NomFichier)
' ' Gestion des erreurs
'	if (IP.Erreurs<>"") then
'		Resultat=IP.Erreurs
'	else
''		On boucle le contenu du dictionnaire contenant les infos IPTC
'		For Each key in IP.Infos
'		 	Credits= Credits & key & " : " & IP.Infos.item(key) & "<br>"
' 		next
'	end if
' 'Destruction de l'objet
'Set IP=Nothing
'
'
' TODO :
' - gestion des encodages de caractères
' - analyse d'autres types d'entêtes
' - écriture dans un fichier
'
'
'


Class IPTC

	'On Error resume next

	Public Infos

	Private VarArrayBinRequest
	Private StreamRequest
	Private MesEr



'CONSTRUCTOR/DESTRUCTOR
'-------------------------------------------
	Private Sub Class_Initialize()
		Set Infos = Server.CreateObject("Scripting.Dictionary")
		Set StreamRequest = Server.CreateObject("ADODB.Stream")
		StreamRequest.Type = 1 'adTypeBinary
		StreamRequest.Open
		MesEr=""
	End Sub

	Private Sub Class_Terminate()
		If IsObject(Infos) Then
			Infos.RemoveAll()
			Set Infos = Nothing
		End If

		StreamRequest.Close
		Set StreamRequest = Nothing
	End Sub

'PUBLIC FUNCTIONS
'-------------------------------------------

	Public Sub Open(path)
		StreamRequest.LoadFromFile(path)
		VarArrayBinRequest=StreamRequest.Read

		if (Err.number <>0) then
			MesEr="Impossible d'ouvrir le fichier :  " & path
			VarArrayBinRequest=Empty
		else
			Analyse
		end if
	End Sub


' PROPERTIES
'-------------------------------------------

	Public Property Get Erreurs()
			Erreurs = MesEr
	End Property


'PRIVATE FUNCTIONS
'-------------------------------------------

'ANALYSE LES HEADERS JPEG
	Private Sub Analyse()
		MJpg = ChrB(&hFF) & ChrB(&hD8)
		MPhoto = ChrB(&hFF) & ChrB(&hED)
		M8bim = ChrB(&h38) & ChrB(&h42) & ChrB(&h49) & ChrB(&h4D)
		Miptc =  ChrB(&h1C) & ChrB(&h02)

		'On démarre au début du fichier Jpeg
		'nCurPos = FindToken(MPhoto,1)
		'If (nCurPos <= 1)  Then
		'		MesEr="Ce n'est pas un fichier Jpeg valide."
		'else
		'On passe au début du segment Photoshop
		'	nCurPos = FindToken(MPhoto,nCurPos)
		'	If (nCurPos <= 1)  Then
		'			MesEr="Ce fichier ne contient pas de section Photoshop."
		'	else
		'		nCurPos = SkipToken(MPhoto,nCurPos)
		'		'On passe au début du segment M8BIM
		'		nCurPos = FindToken(M8bim,nCurPos)
		'	end if
		'end if
		nCurPos = FindToken(M8bim,1)
		If (nCurPos <= 1)  Then
			MesEr="Ce fichier ne contient pas de section 8BIM."
		else
			VarArrayBinRequest=Extract8Bim(nCurPos)
			'On passe au début du premier tag IPTC
			nCurPos = SkipToken(Miptc,1)
			If (nCurPos <= 1)  Then
				MesEr="Ce fichier ne contient aucune information IPTC."
			else
				'On analyse les tag IPTC suivants
				do
					Call NomIPTC(nCurPos)
					nCurPos = SkipToken(Miptc,nCurPos)
				loop while (nCurPos > 1)
			end if
		end if
	End Sub

	'Placer le curseur au début d'un segment
	Private Function FindToken(sToken, nStart)
		FindToken = InstrB(nStart, VarArrayBinRequest, sToken)
	End Function

	'Placer le curseur après le marqueur d'un segment
	Private Function SkipToken(sToken, nStart)
		SkipToken = InstrB(nStart, VarArrayBinRequest, sToken)
		If SkipToken > 0 then
			SkipToken = SkipToken + LenB(sToken)
		end if
	End Function


	'Extrait le contenu d'un segment
	'la taille est détermine par 2 octets situé à nSkip du début du segment
	'Delta : méthode empirique utilisée pour extrait un entête, pourquoi ???
	Private Function Extract(nStart,nSkip,Delta)
		Length = Byte2Int(MidB(VarArrayBinRequest,nStart+nSkip, 2))
		Extract= MidB(VarArrayBinRequest,nStart+nSkip+2-Delta, Length+Delta)
	End Function

	'Extrait le contenu d'un segment 8BIM
	Private Function Extract8Bim(nStart)
		ImgResId = Byte2Int(MidB(VarArrayBinRequest,nStart+4, 2))
		PascalLength = Byte2Int(MidB(VarArrayBinRequest,nStart+6, 1))
		Pascal=Byte2String(MidB(VarArrayBinRequest,nStart+6+1, PascalLength))
		if (PascalLength MOD 1=0) then
			Jump=PascalLength+1
		else
			Jump=PascalLength
		end if
		BimLength=Byte2Int(MidB(VarArrayBinRequest,nStart+6+Jump, 4))
		Extract8Bim = MidB(VarArrayBinRequest,nStart+10+Jump, BimLength)
	End Function


	'Détermine le type d'un marqueur IPTC et son contenu
	Private Function NomIPTC(nStart)
		'Détermine l'octect definissant le type de marqueur IPTC
		NomInt= Byte2Int(MidB(VarArrayBinRequest,nStart,1))
		'Extrait le contenu du marqueur IPTC
		ValIPTC=Extract(nStart,1,0)

		'INFOS : http://peccatte.karefil.com/Software/Metadata.htm#IPTC
		Select Case NomInt
				Case 0
						NomIPTC = "ApplicationRecordVersion"
						ValIPTC = Byte2Int(ValIPTC)
				Case 3
						NomIPTC = "ObjectTypeReference"
						ValIPTC = Byte2String(ValIPTC)
				Case 4
						NomIPTC = "ObjectAttributeReference"
						ValIPTC = Byte2String(ValIPTC)
				Case 5
						NomIPTC = "Nom de l'objet"
						ValIPTC = Byte2String(ValIPTC)
				Case 7
						NomIPTC = "Statut éditorial"
						ValIPTC = Byte2String(ValIPTC)
				Case 8
						NomIPTC = "EditorialUpdate"
						ValIPTC = Byte2String(ValIPTC)
				Case 10
						NomIPTC = "Priorité"
						ValIPTC = Byte2String(ValIPTC)
				Case 12
						NomIPTC = "SubjectReference"
						ValIPTC = Byte2String(ValIPTC)
				Case 15
						NomIPTC = "Catégorie"
						ValIPTC = Byte2String(ValIPTC)
				Case 20
						NomIPTC = "Catégorie supplmentaire"
						ValIPTC = Byte2String(ValIPTC)
				Case 22
						NomIPTC = "Identificateur"
						ValIPTC = Byte2String(ValIPTC)
				Case 25
						NomIPTC = "Mots-clés"
						ValIPTC = Byte2String(ValIPTC)
				Case 26
						NomIPTC = "ContentLocationCode"
						ValIPTC = Byte2String(ValIPTC)
				Case 27
						NomIPTC = "ContentLocationName"
						ValIPTC = Byte2String(ValIPTC)
				Case 30
						NomIPTC = "Date de disponibilité" '8 caractères, forme AAAAMMJJ
						ValIPTC = ExtractDate(ValIPTC,0)
				Case 35
						NomIPTC = "Heure de disponibilité" '11 caractères HHMMSSHHMM
						ValIPTC = ExtractDate(ValIPTC,1)
				Case 37
						NomIPTC = "ExpirationDate"
						ValIPTC = ExtractDate(ValIPTC,0)
				Case 38
						NomIPTC = "ExpirationTime"
						ValIPTC = ExtractDate(ValIPTC,1)
				Case 40
						NomIPTC = "Instructions spéciales"
						ValIPTC = Byte2String(ValIPTC)
				Case 42
						NomIPTC = "ActionAdvised"
						Select Case Byte2Int(ValIPTC)
								Case 1
										ValIPTC = "Object Kill"
								Case 2
										ValIPTC = "Object Replace"
								Case 3
										ValIPTC = "Ojbect Append"
								Case 4
										ValIPTC = "Object Reference"
						End Select
				Case 45
						NomIPTC = "Service de référence"
						ValIPTC = Byte2String(ValIPTC)
				Case 47
						NomIPTC = "Date de référence"
						ValIPTC = ExtractDate(ValIPTC,0)
				Case 50
						NomIPTC = "Numro de référence"
						ValIPTC = Byte2String(ValIPTC)
				Case 55
						NomIPTC = "Date de création de l'objet" '8 caractères, forme AAAAMMJJ
						ValIPTC = ExtractDate(ValIPTC,0)
				Case 60
						NomIPTC = "Heure de création de l'objet" '11 caractères HHMMSSHHMM
						ValIPTC = ExtractDate(ValIPTC,1)
				Case 62
						NomIPTC = "DigitalCreationDate"
						ValIPTC = ExtractDate(ValIPTC,0)
				Case 63
						NomIPTC = "DigitalCreationTime"
						ValIPTC = ExtractDate(ValIPTC,1)
				Case 65
						NomIPTC = "Programme ayant créé l'objet"
						ValIPTC = Byte2String(ValIPTC)
				Case 70
						NomIPTC = "Version du programme ayant créé l'objet"
						ValIPTC = Byte2String(ValIPTC)
				Case 75
						NomIPTC = "Cycle de l'objet"
						Select Case Byte2String(ValIPTC)
								Case "a"
										ValIPTC = "le matin"
								Case "b"
										ValIPTC = "Both Morning and Evening" ', 'b' = l'après-midi, 'c' = matin et après-midi ???
								Case "p"
										ValIPTC = "Evening"
						End Select
				Case 80
						NomIPTC = "Créateur de l'objet"
						ValIPTC = Byte2String(ValIPTC)
				Case 85
						NomIPTC = "Titre du créateur"
						ValIPTC = Byte2String(ValIPTC)
				Case 90
						NomIPTC = "Ville"
						ValIPTC = Byte2String(ValIPTC)
				Case 92
						NomIPTC = "Sub-location"
						ValIPTC = Byte2String(ValIPTC)
				Case 95
						NomIPTC = "Province/état"
						ValIPTC = Byte2String(ValIPTC)
				Case 100
						NomIPTC = "Code du pays" 'ISO3166 (codes pays sur 3 caractères)
						ValIPTC = Byte2String(ValIPTC)
				Case 101
						NomIPTC = "Libellé du pays"
						ValIPTC = Byte2String(ValIPTC)
				Case 103
						NomIPTC = "référence de la transmission (code)"
						ValIPTC = Byte2String(ValIPTC)
				Case 105
						NomIPTC = "Titre"
						ValIPTC = Byte2String(ValIPTC)
				Case 110
						NomIPTC = "Crédit"
						ValIPTC = Byte2String(ValIPTC)
				Case 115
						NomIPTC = "Source"
						ValIPTC = Byte2String(ValIPTC)
				Case 116
						NomIPTC = "Copyright"
						ValIPTC = Byte2String(ValIPTC)
				Case 118
						NomIPTC = "Contact"
						ValIPTC = Byte2String(ValIPTC)
				Case 120
						NomIPTC = "Description"
						ValIPTC = Byte2String(ValIPTC)
				Case 121
						NomIPTC = "LocalCaption"
						ValIPTC = Byte2String(ValIPTC)
				Case 122
						NomIPTC = "Auteur de la Description"
						ValIPTC = Byte2String(ValIPTC)
				Case 125
						NomIPTC = "RasterizedCaption"
						ValIPTC = Byte2String(ValIPTC)
				Case 130
						NomIPTC = "Type de l'image" 'cf. le document IPTC-NAA IIMV4
						ValIPTC = Byte2String(ValIPTC)
				Case 131
						NomIPTC = "Orientation de l'image"
						Select Case Byte2String(ValIPTC)
								Case "L"
										ValIPTC = "Paysage"
								Case "P"
										ValIPTC = "Portrait"
								Case "S"
										ValIPTC = "Carr"
						End Select
				Case 135
						NomIPTC = "LanguageIdentifier"
						ValIPTC = Byte2String(ValIPTC)
				Case 150
						NomIPTC = "AudioType"
						Select Case Byte2String(ValIPTC)
								Case "0T"
										ValIPTC = "Text Only"
								Case "1A"
										ValIPTC = "Mono Actuality"
								Case "1C"
										ValIPTC = "Mono Question and Answer Session"
								Case "1M"
										ValIPTC = "Mono Music"
								Case "1Q"
										ValIPTC = "Mono Response to a Question"
								Case "1R"
										ValIPTC = "Mono Raw Sound"
								Case "1S"
										ValIPTC = "Mono Scener"
								Case "1V"
										ValIPTC = "Mono Voicer"
								Case "1W"
										ValIPTC = "Mono Wrap"
								Case "2A"
										ValIPTC = "Stereo Actuality"
								Case "2C"
										ValIPTC = "Stereo Question and Answer Session"
								Case "2M"
										ValIPTC = "Stereo Music"
								Case "2Q"
										ValIPTC = "Stereo Response to a Question"
								Case "2R"
										ValIPTC = "Stereo Raw Sound"
								Case "2S"
										ValIPTC = "Stereo Scener"
								Case "2V"
										ValIPTC = "Stereo Voicer"
								Case "2W"
										ValIPTC = "Stereo Wrap"
						End Select
				Case 151
						NomIPTC = "AudioSamplingRate"
						ValIPTC = Byte2String(ValIPTC)
				Case 152
						NomIPTC = "AudioSamplingResolution"
						ValIPTC = Byte2String(ValIPTC)
				Case 153
						NomIPTC = "AudioDuration"
						ValIPTC = Byte2String(ValIPTC)
				Case 154
						NomIPTC = "AudioOutcue"
						ValIPTC = Byte2String(ValIPTC)
				Case 184
						NomIPTC = "JobID"
						ValIPTC = Byte2String(ValIPTC)
				Case 185
						NomIPTC = "MasterDocumentID"
						ValIPTC = Byte2String(ValIPTC)
				Case 186
						NomIPTC = "ShortDocumentID"
						ValIPTC = Byte2String(ValIPTC)
				Case 187
						NomIPTC = "UniqueDocumentID"
						ValIPTC = Byte2String(ValIPTC)
				Case 188
						NomIPTC = "OwnerID"
						ValIPTC = Byte2String(ValIPTC)
				Case 200
						NomIPTC = "ObjectPreviewFileFormat"
						Select Case Byte2Int(ValIPTC)
								Case 0
										ValIPTC = "No ObjectData"
								Case 1
										ValIPTC = "IPTC-NAA Digital Newsphoto Parameter Record"
								Case 2
										ValIPTC = "IPTC7901 Recommended Message Format"
								Case 3
										ValIPTC = "Tagged Image File Format (Adobe/Aldus Image data)"
								Case 4
										ValIPTC = "Illustrator (Adobe Graphics data)"
								Case 5
										ValIPTC = "AppleSingle (Apple Computer Inc)"
								Case 6
										ValIPTC = "NAA 89-3 (ANPA 1312)"
								Case 7
										ValIPTC = "MacBinary II"
								Case 8
										ValIPTC = "IPTC Unstructured Character Oriented File Format (UCOFF)"
								Case 9
										ValIPTC = "United Press International ANPA 1312 variant"
								Case 10
										ValIPTC = "United Press International Down-Load Message"
								Case 11
										ValIPTC = "JPEG File Interchange (JFIF)"
								Case 12
										ValIPTC = "Photo-CD Image-Pac (Eastman Kodak)"
								Case 13
										ValIPTC = "Bit Mapped Graphics File [.BMP] (Microsoft)"
								Case 14
										ValIPTC = "Digital Audio File [.WAV] (Microsoft amp; Creative Labs)"
								Case 15
										ValIPTC = "Audio plus Moving Video [.AVI] (Microsoft)"
								Case 16
										ValIPTC = "PC DOS/Windows Executable Files [.COM][.EXE]"
								Case 17
										ValIPTC = "Compressed Binary File [.ZIP] (PKWare Inc)"
								Case 18
										ValIPTC = "Audio Interchange File Format AIFF (Apple Computer Inc)"
								Case 19
										ValIPTC = "RIFF Wave (Microsoft Corporation)"
								Case 20
										ValIPTC = "Freehand (Macromedia/Aldus)"
								Case 21
										ValIPTC = "Hypertext Markup Language [.HTML] (The Internet Society)"
								Case 22
										ValIPTC = "MPEG 2 Audio Layer 2 (Musicom), ISO/IEC"
								Case 23
										ValIPTC = "MPEG 2 Audio Layer 3, ISO/IEC"
								Case 24
										ValIPTC = "Portable Document File [.PDF] Adobe"
								Case 25
										ValIPTC = "News Industry Text Format (NITF)"
								Case 26
										ValIPTC = "Tape Archive [.TAR]"
								Case 27
										ValIPTC = "Tidningarnas Telegrambyra NITF version (TTNITF DTD)"
								Case 28
										ValIPTC = "Ritzaus Bureau NITF version (RBNITF DTD)"
								Case 29
										ValIPTC = "Corel Draw [.CDR]"
						End Select
				Case 201
						NomIPTC = "ObjectPreviewFileVersion"
						ValIPTC = Byte2String(ValIPTC)
				Case 202
						NomIPTC = "ObjectPreviewData"
						ValIPTC = Byte2String(ValIPTC)
				Case 225
						NomIPTC = "ClassifyState"
						ValIPTC = Byte2String(ValIPTC)
				Case 228
						NomIPTC = "SimilarityIndex"
						ValIPTC = Byte2String(ValIPTC)
				Case 230
						NomIPTC = "DocumentNotes"
						ValIPTC = Byte2String(ValIPTC)
				Case 231
						NomIPTC = "DocumentHistory"
						ValIPTC = Byte2String(ValIPTC)
				Case 232
						NomIPTC = "ExifCameraInfo"
						ValIPTC = Byte2String(ValIPTC)
				Case else
						NomIPTC = "Inconnu"
						ValIPTC = Byte2String(ValIPTC)
		End Select
		Infos.Add NomIPTC, ValIPTC
	End Function

	'Extrait la date ou l'heure du format IPTC  format franais : JJ/MM/AAAA, HHhMM SSs  HHhMM
	Private Function ExtractDate(ByData, BoType)
		if (Botype=0) then
				'8 caractères, forme AAAAMMJJ
        ExtractDate=Mid(Byte2String(ByData),7,2) & "/" & Mid(Byte2String(ByData),5,2) & "/" & Mid(Byte2String(ByData),1,4)
		else
				'11 caractères HHMMSSHHMM
	       ExtractDate=Mid(Byte2String(ByData),1,2) & "h" & Mid(Byte2String(ByData),3,2) & " " & Mid(Byte2String(ByData),1,2)  & "s" &_
				 " " & Mid(Byte2String(ByData),7,1) & " " & Mid(Byte2String(ByData),8,2) & "h" & Mid(Byte2String(ByData),10,2)

	       'ExtractDate=Mid(Byte2String(ByData),5,2) & "/" & Mid(Byte2String(ByData),3,2) & "/" & Mid(Byte2String(ByData),1,2) &_
				 '" " & Mid(Byte2String(ByData),7,3) & "h" & Mid(Byte2String(ByData),10,2)
		end if
	End Function


	'Convertit un octet en entier
	Private Function Byte2Int(bsString)
		Dim i
		Byte2Int =0
		i=1
		while (i <= LenB(bsString))
				n=LenB(bsString)-i
				Byte2Int=Byte2Int+(AscB(MidB(bsString,i,1))*(2^(8*n)))
			i= i +1
		wend
	End Function



	'Convertit un octet en chaine de charactre (encodage ASCII)
	Private Function Byte2String(bsString)
		Dim i
		Byte2String =""
		For i = 1 to LenB(bsString)
     Byte2String = Byte2String & Chr(AscB(MidB(bsString,i,1)))
    Next
'		UTF8 ENCODING
'		Response.Write	 Byte2String
'		Byte2String =""
'		i=1
'		while (i <= LenB(bsString))
'				if (AscB(MidB(bsString,i,1)) =< 127)  then
'					Byte2String = Byte2String & Chr(AscB(MidB(bsString,i,1)))
'					i= i +1
'				elseif (AscB(MidB(bsString,i,1)) >= 192 AND AscB(MidB(bsString,i,1)) =<223)  then
'					Byte2String = Byte2String & ChrW( ((AscB(MidB(bsString,i,1))-192)*64) + (AscB(MidB(bsString,i+1,1))-128) )
'					i= i +2
'				elseif (AscB(MidB(bsString,i,1)) >=224 AND AscB(MidB(bsString,i,1)) <=239) then
'					Byte2String = Byte2String & ChrW( ((AscB(MidB(bsString,i,1))-224)*4096) + ((AscB(MidB(bsString,i+1,1))-128)*64) + (AscB(MidB(bsString,i+2,1))-128) )
'					i= i +3
'				elseif (AscB(MidB(bsString,i,1)) >=240 AND AscB(MidB(bsString,i,1)) <=247) then
'					Byte2String = Byte2String & ChrW( ((AscB(MidB(bsString,i,1))-240)*262144) +  ((AscB(MidB(bsString,i+1,1))-128)*4096) + ((AscB(MidB(bsString,i+2,1))-128)*64) + (AscB(MidB(bsString,i+3,1))-128) )
'					i= i +4
'				elseif (AscB(MidB(bsString,i,1)) >=248 AND AscB(MidB(bsString,i,1)) <=251) then
'					Byte2String = Byte2String & ChrW( ((AscB(MidB(bsString,i,1))-248)*16777216) +  ((AscB(MidB(bsString,i+1,1))-128)*262144) +  ((AscB(MidB(bsString,i+2,1))-128)*4096) + ((AscB(MidB(bsString,i+3,1))-128)*64) + (AscB(MidB(bsString,i+4,1))-128) )
'					i= i +5
'				elseif (AscB(MidB(bsString,i,1)) >=252 AND AscB(MidB(bsString,i,1)) <=253) then
'					Byte2String = Byte2String & ChrW	( ((AscB(MidB(bsString,i,1))-252)*1073741824) +  ((AscB(MidB(bsString,i+1,1))-128)*16777216) +  ((AscB(MidB(bsString,i+2,1))-128)*262144) +  ((AscB(MidB(bsString,i+3,1))-128)*4096) + ((AscB(MidB(bsString,i+4,1))-128)*64) + (AscB(MidB(bsString,i+5,1))-128) )
'					i= i +6
'				else
'					i= i +1
'				end if
'		wend
	End Function

end class
%>

25 septembre 2006 12:23:06 :

Correstion bug

29 septembre 2006 15:30:37 :

Correction de l'extraction du segment 8BIM, et support TIFF

29 septembre 2006 15:32:15 :

Correction de l'extraction du segment 8BIM, et support TIFF

29 septembre 2006 16:32:41 :

Correction coquille