' ------------------------------------------------------------------------------------ ' TransfertPictures.vbs ' This script will transfert pictures and videos from a digital camera. ' A dialog box asks the user to select a camera. If you are always using the same ' camera you can select it by its ID. Replace the first "Const" with the actual value ' for your camera. ' The user is prompted for a target folder and the pictures are copied there. ' Optionnaly the pictures can be automatically erased from the cameras (set the ' "bDeletePicAfterTransfer" constant to "True", not all cameras support this). ' ' Note: Windows XP SP1 needed and the WIAAut.dll DLL is required (to use the WIA ' Automation Layer), see: ' http://msdn.microsoft.com/library/default.asp?url=/library/en-us/wiaaut/wia/wiax/overviews/gettingstartedsamples.asp ' ------------------------------------------------------------------------------------ option explicit ' You can define here the ID of your default camera so you will not be prompted ' to select a camera const CamID = "" '"{6BDD1FC6-810F-11D0-BEC7-08002BE2092F}\0020" Const bDeletePicAfterTransfer = False const CameraDeviceType = 2 Dim devMngr Dim s, alb, sOutputPath, pic Dim device 'As Device App.ClearTrace set devMngr = CreateObject( "WIA.DeviceManager" ) ' List all available devices by Name and DeviceID Dim i, n 'As Integer n = devMngr.DeviceInfos.Count App.Trace "Number of device found = " & n, -1, TRACE_INFORMATION set device = Nothing if CamID = "" then ' No default cam define, so prompt the user. dim CommonDialog1 set CommonDialog1 = CreateObject("WIA.CommonDialog") on error resume next set device = CommonDialog1.ShowSelectDevice( CameraDeviceType, True, False ) on error goto 0 err.clear else For i = 1 to devMngr.DeviceInfos.Count app.Trace " Device " & i & ":" & vbTab & devMngr.DeviceInfos(i).Properties("Name").Value & vbTab & "ID: " & devMngr.DeviceInfos(i).DeviceID, &hff0000 if devMngr.DeviceInfos(i).DeviceID = CamID then set device = devMngr.DeviceInfos(i).Connect App.Trace "Default camera found !", -1, TRACE_ARROW end if Next end if if device is Nothing then app.Trace "No camera found, check connexion and script configuration", 255, TRACE_ERROR else set alb = app.GetCurrentAlbum ' Use the album folder as the default output folder sOutputPath = alb.ExpandMacro( Nothing, "%Af" ) s = "Select the output folder (default is the album folder)" if bDeletePicAfterTransfer then s = s & vbCRLF & vbCRLF & "CAUTION: Pictures will be removed from the camera!" sOutputPath = app.GetFilename( s, 2, sOutputPath, "", 0 ) if sOutputPath <> "" then if not device is Nothing then TransfertPic device, "", True end if end if app.Trace "Done!", -1, TRACE_GREENDOT ' ------------------------------------------------------------------------------------ ' Transfer pictures and videos from one camera ' ------------------------------------------------------------------------------------ sub TransfertPic( byref dev, sCamID, bIsLeftCam ) 'App.Trace "Items:", -1, TRACE_INFORMATION if dev.Properties.Exists("Pictures Taken") then app.Trace "Pictures to transfert = " & dev.Properties("Pictures Taken").Value, -1, TRACE_INFORMATION end if Dim img, itm, sName, sExt, sDate, sFileName For Each itm In dev.Items sDate = "" sExt = "" If itm.Properties.Exists("Item Name") Then sName = itm.Properties("Item Name").Value If itm.Properties.Exists("Item Time Stamp") Then Dim v 'As Vector Set v = itm.Properties("Item Time Stamp").Value If v.Count = 8 Then sDate = v.Date End If End If If itm.Properties.Exists("Filename extension") Then sExt = lcase(itm.Properties("Filename extension").value) ' Check file extension (add other extensions if needed) if sExt = "jpg" sExt = "tif" or sExt = "mov" or sExt = "mpg" Then sFileName = sName & sCamID & "." & sExt if alb.GetPictureByFilename( sFileName ) is Nothing then sFileName = sOutputPath & "\" & sFileName app.Trace " transfering picture " & sName & "." & sExt & " " & vbTab & "(taken " & sDate & ") ---> " & sFileName Set Img = Itm.Transfer Img.SaveFile sFileName set pic = alb.AddPicture( sFileName ) if bDeletePicAfterTransfer then For i = 1 to Dev.Items.Count If dev.Items(i).ItemID = itm.ItemID Then 'Some Cameras don't support deleting pictures On Error Resume Next dev.Items.Remove i If Err.Number <> 0 Then app.Trace "Error while deleting picture: " & Err.Description, -1, TRACE_ERROR Err.Clear End If On Error Goto 0 Exit For End If Next end if else app.Trace "Picture '" & sFileName & "' already in album!", -1, TRACE_WARNING end if end if end if else ''App.Trace "Unnamed item..." end if Next alb.Redraw end sub