Jag håller på att göra ett script som ksa flytta be bilder srån en mapp som INTE är dubbleter.
Jag har alltså en mapp men den massa under mappar. De flesta bilder fins det dubbletter av.
Det jag vill är att jag vill flytta alla bilder som det bara finns en kopia av.
<!-- #include file="adovbs.inc" -->
<%
Server.ScriptTimeout = 3600
Dim fso, folders, folder, files, FolderContents, FileItem, temp, procent
Set rs = Server.CreateObject("Adodb.Recordset")
With rs
.CursorLocation = adUseClient
.Fields.Append "s", adInteger
.Fields.Append "n", adVarChar, 500
.Fields.Append "d", adDBTimeStamp
.open
End With
Sub addfile( Id, Name, Group )
rs.AddNew
rs( "n" ) = Id
rs( "d" ) = Name
rs( "s" ) = Group
rs.Update
End Sub
Set Image = Server.CreateObject("SImageUtil.Image")
Image.PhysicalPath = TRUE
function GetSubFolders(pfolder)
Dim sFolders, fldr, fil
For Each fldr In pfolder.SubFolders
sFolders = sFolders & GetSubFolders(fldr)
Next
For Each FileItem In pfolder.Files
If Lcase(right(FileItem,3)) = "jpg" or Lcase(right(FileItem,3)) = "gif" Then
session("fil") = FileItem.path
Image.OpenImageFile(FileItem)
If len(Image.GetExif("Date"))=0 Then
datum = fileItem.DateLastModified
Else
datum = Cdate(replace(left(Image.GetExif("Date"),11),":","-")&right(Image.GetExif("Date"),8))
End If
addfile FileItem.path, datum, FileItem.Size
image.close
End If
Next
Set fileItem = Nothing
Set fldr = Nothing
GetSubFolders = sFolders
End function
Set fso = CreateObject("Scripting.FileSystemObject")
Set folders = fso.getFolder("E:\bilder\")
GetSubFolders(folders)
Det som ligger i mitt recset nu är alla bilder som finns i mappen bilder och dess undermappar.
Hur gör jag nu för att skriva ut vilka biler det bara finns en kopia på?
Ett förslag. Ändra ditt recordset så att du även sparar själva filnamnet:
<%
With rs
.CursorLocation = adUseClient
.Fields.Append "s", adInteger
.Fields.Append "FullPath", adVarChar, 500
.Fields.Append "d", adDBTimeStamp
.Fields.Append "FileName", adVarChar, 500
.open
End With
' ..
Sub addfile( FullPath, Name, Group, FileName )
rs.AddNew
rs( "FullPath" ) = FullPath
rs( "d" ) = Name
rs( "s" ) = Group
rs( "FileName" ) = FileName
rs.Update
End Sub
' ...
addfile FileItem.path, datum, FileItem.Size, File.Name
%>
sen borde du kunna sålla ut unika filnamn så här:
<%
dim sPrev, sCurr, sNex, sFullName
rs.Sort = "FileName asc"
If Not rs.EOF Then rs.MoveFirst
sPrev = ""
sNext = ""
Do While Not rs.EOF
sCurr = rs("FileName")
sFullName=rs("FullPath")
rs.MoveNext
If Not rs.EOF Then
sNext = rs("FileName")
If sCurr <> sPrev And sNext <> sCurr Then
response.write sFullName & " är en unik bild.<br>"
End If
sPrev = sCurr
Else
If sCurr <> sPrev Then
response.write sFullName & " är en unik bild.<br>"
End If
Exit Do
End If
Loop
%>
Nu utgår jag ifrån att du med "kopia" menar att bilderna har samma namn, inte att dom är identiskt lika byte för byte.
Tyvärr så är det så att de kan hetta olika saker. Men man borde kunda göra jämnförelsen på createdate.
OK. Fast eftersom du ibland använder tidstämpeln i jpeg-headern så blir ju den jämförelsen bara relevant om alla bilder är tagna av samma person. Annars kan dom ju mycket väl ha samma tidsangivelse utan att vara kopior?
Men i så fall borde du kunna behålla din egen kod för addfile och köra så här istället?
<%
dim dPrev, dCurr, dNext, sFullName
rs.Sort = "d asc"
If Not rs.EOF Then rs.MoveFirst
dPrev = DateAdd("yyyy", -1000, Now)
dNext = DateAdd("yyyy", 1000, Now)
Do While Not rs.EOF
dCurr = rs("d")
sFullName=rs("n")
rs.MoveNext
If Not rs.EOF Then
dNext = rs("d")
If dCurr <> dPrev And dNext <> dCurr Then
response.write sFullName & " är en unik bild.<br>"
End If
dPrev = dCurr
Else
If dCurr <> dPrev Then
response.write sFullName & " är en unik bild.<br>"
End If
Exit Do
End If
Loop
%>
.. om bilderna har samma tidstämpel på sekundnivå.
Fast två filer kan kan ha samma storlek utan att vara lika. Men visst, jämför man både tidsstämpel och filstorlek så kommer man nog rätt nära sanningen.
