'**************************************************************************************************************************************************   
'* Created: December 12, 2008   
'* Author: Brandon Dempster   
'*   
'* Helpful Resources:   
'*      http://www.beardsworth.co.uk/downloads/iview/Get_MS_Office_document_properties.vbs.txt   
'*      http://forum.iview-multimedia.com/viewtopic.php?t=6908  
'*      PDF: http://download.microsoft.com/download/3/0/d/30df7f2d-1ba9-4868-bc16-c7d90ffef015/Media%202%20Scripting%20Guide%20for%20Windows_Final_2.pdf   
'*   
'**************************************************************************************************************************************************   
  
  
On Error Resume Next   
  
Dim app, mediaItems, mediaItem, i, j, catalog, prompt, initNumber, keyWord, oldKey,oIE, path, Title, level   
Dim L_title_text, L_message1_text, L_message2_text, L_message3_text, L_message4_text   
  
L_title_text = "Microsoft Expression Media"  
L_message1_text = "Please launch Microsoft Expression Media."  
L_message2_text = "You need to select at least one media item in the active catalog in order to use this script."  
 
 
  
Main()   
  
Sub Main()   
 Set app = CreateObject("ExpressionMedia.Application")   
    
 ' get the active catalog in Expression Media
 If (app.Catalogs.count = 0) Then   
  MsgBox L_message1_text, vbCritical, L_title_text   
 Elseif (app.ActiveCatalog.Selection.Count = 0) Then   
  MsgBox L_message2_text, vbCritical, L_title_text   
 Else   
  
        'Declare string with column headings   
         Dim myString    
         'myString = "File_Name" & vbTab & "Keywords" & vbCrLf   
             myString = "Photographers image reference number"  & "," & "caption (50 characters or less)" & "," & "Model Release" & _   
              "," & "Property Release" & "," & "Photographers Name" & "," & "Keywords" & "," & "Other" & vbCrLf   
    
     For Each mediaItem In app.ActiveCatalog.Selection   
            'Create CSV string for output to file   
            myString = myString & mediaItem.Name & ",,NA,NA,," & mediaItem.Annotations.keyWords & "," & _   
             mediaItem.Annotations.Location & " " & mediaItem.Annotations.City & " " & mediaItem.Annotations.State & vbCrLf   
     Next   
      End If   
         
      'Output keywords to CSV file   
      WriteToFile(myString)   
       
End Sub   
    
Function WriteToFile(strText)   
   Dim objFSO, objFolder, objShell, objTextFile, objFile   
    Dim strDirectory, strFile, strFileXLS   
    strDirectory = "c:\Keywording"  
       
    strFile = InputBox("Name of Keyword File: ")   
    strFileXLS = "\" & strFile & ".xls"            
    strFile = "\" & strFile & ".csv"   
    'msgbox(strFile)   
    
    ' Create the File System Object   
    Set objFSO = CreateObject("Scripting.FileSystemObject")   
       
       
    'Delete Temp File if it still exists   
       If objFSO.FileExists(strDirectory & strFile) Then   
                dim answer   
                answer=MsgBox("You are about to overwrite an existing keywords export!  Is this ok? ",4,"Warning!")   
                'msgbox("Answer: " & answer)    
                   
                If answer=6 then 'YES   
                        Set objFolder = objFSO.GetFolder(strDirectory)   
                        objFSO.DeleteFile(strDirectory & strFile)   
                Else 'NO; display existing file   
                       If err.number = vbEmpty then   
                           Set objShell = CreateObject("WScript.Shell")   
                           objShell.run ("Explorer" &" " & strDirectory & "\" )   
                        Else msgbox("VBScript Error: " & err.number)   
                        End If   
                        EXIT Function'If answer is no then display existing file and exit function   
                End If   
        End If   
                
    
    ' Check that the strDirectory folder exists   
    If objFSO.FolderExists(strDirectory) Then   
       Set objFolder = objFSO.GetFolder(strDirectory)   
    Else   
       Set objFolder = objFSO.CreateFolder(strDirectory)   
       'msgbox("Just created " & strDirectory)   
    End If   
    
            If objFSO.FileExists(strDirectory & strFile) Then   
               Set objFolder = objFSO.GetFolder(strDirectory)   
            Else   
               Set objFile = objFSO.CreateTextFile(strDirectory & strFile)   
               'msgbox("Just created " & strDirectory & strFile)   
            End If    
    
            set objFile = nothing  
            set objFolder = nothing  
            ' OpenTextFile Method needs a Const value   
            ' ForAppending = 8 ForReading = 1, ForWriting = 2  
            Const ForAppending = 8  
    
            Set objTextFile = objFSO.OpenTextFile _   
            (strDirectory & strFile, ForAppending, True)   
    
            ' Writes strText every time you run this VBScript   
            objTextFile.WriteLine(strText)   
            objTextFile.Close   
               
          'Open File Directory   
               'If err.number = vbEmpty then   
                '   Set objShell = CreateObject("WScript.Shell")   
                '   objShell.run ("Explorer" &" " & strDirectory & "\" )   
                'Else msgbox("VBScript Error: " & err.number)   
                'End If   
           
   'EXPORT to Excel   
            srccsvfile = strDirectory & strFile   
            srcxlsfile = strDirectory & strFileXLS   
    
            Set objExcel = CreateObject("Excel.Application")   
            objExcel.Visible = True  
            objExcel.displayalerts=True  
               
            Set objWorkbook = objExcel.Workbooks.open(srccsvfile)   
            Set objWorksheet1 = objWorkbook.Worksheets(1)   
            objWorksheet1.SaveAs srcxlsfile, 2   
    
     WScript.Quit   
End Function