'MacroName:245to700
'MacroDescription:add 700s for screenwriter, producer and director
'by John Lavalie, May 9, 2006
'inspired by Joel Hahn's 508-511to700 macro
'Designed for feature films, but will work for nonfiction titles.

option compare text
option explicit

global jobs(75,1) 
global StmtResp$(20)

'---------------------
sub loadJobs   
   'Note: when adding to this list, longer strings must be listed first
   '      so they are found before the shorter ones.  You may have to renumber.
   'Relator immediately follows job string
   
   jobs(0,0) = "written for the screen & directed by"
   jobs(0,1) = "aus " & chr(223) & "4 drt"
   jobs(1,0) = "written & directed by"
   jobs(1,1) = "aus " & chr(223) & "4 drt"
   jobs(2,0) = "written & produced by"
   jobs(2,1) = "aus " & chr(223) & "4 prd"
   jobs(3,0) = "produced & directed by"
   jobs(3,1) = "pro " & chr(223) & "4 drt"
   jobs(4,0) = "producer & director, "
   jobs(4,1) = "pro " & chr(223) & "4 drt"
   jobs(5,0) = "directed by" 
   jobs(5,1) = "drt"
   jobs(6,0) = "director" 
   jobs(6,1) = "drt"
   jobs(7,0) = "produced by" 
   jobs(7,1) = "pro"
   jobs(8,0) = "producers" 
   jobs(8,1) = "pro"
   jobs(9,0) = "producer" 
   jobs(9,1) = "pro"
   jobs(10,0) = "written by" 
   jobs(10,1) = "aus"
   jobs(11,0) = "original screenplay"
   jobs(11,1) = "aus"
   jobs(12,0) = "screenplay writers"
   jobs(12,1) = "aus"
   jobs(13,0) = "screenplay writer"
   jobs(13,1) = "aus"
   jobs(14,0) = "screenplay by" 
   jobs(14,1) = "aus"
   jobs(15,0) = "screenplay" 
   jobs(15,1) = "aus"
   jobs(16,0) = "writers"
   jobs(16,1) = "aus"
   jobs(17,0) = "writer" 
   jobs(17,1) = "aus"
   jobs(18,0) = "creator" 
   jobs(18,1) = "cre"
   jobs(19,0) = "created by" 
   jobs(19,1) = "cre"
   jobs(20,0) = "original story by"
   jobs(20,1) = "aus"
   jobs(21,0) = "original story"
   jobs(21,1) = "aus"
   jobs(22,0) = "screen story by"
   jobs(22,1) = "aus"
   jobs(23,0) = "screen story"
   jobs(23,1) = "aus"
   jobs(24,0) = "story by" 
   jobs(24,1) = "aus"
   jobs(25,0) = "story"
   jobs(25,1) = "aus"
   jobs(26,0) = "teleplay by"
   jobs(26,1) = "aus"
   jobs(27,0) = "teleplay by"
   jobs(27,1) = "aus"
 end sub
'--------------------   
function replace(strString as string, strOld as string, strNew as string) as string
   dim pos as integer
   pos = instr(strString, strOld)
   do while pos > 0
      strString = left(strString, pos - 1) & strNew & mid(strString, pos + len(strOld))
      pos = instr(strString, strOld)
   loop
   replace = strString   
end function
'-------------------
function clean710(heading as string) as string
   heading = replace(heading, "&", "")
   heading = trim(heading)
   
   if right(heading, 10) = "production" then heading = trim(replace(heading, "production", ""))
   if instr(heading, "presented by") > 0 then heading = trim(replace(heading, "presented by", ""))
   
   if left(heading, 2) = "a " then 
      heading = mid(heading, 3)
   elseif left(heading, 3) = "an " then 
      heading = mid(heading, 4)
   elseif left(heading, 4) = "the " then 
      heading = mid(heading, 5)
   end if
   
   if right(heading, 1) <> "." then heading = heading & "."
   
   clean710 = "7102 " & trim(heading)
end function
'-------------------
function MakeHeading(heading as string) as string
   dim split, x as integer
   dim firstName, lastName as string
   heading = trim(heading)
   
   x = len(heading)
   do
      if mid(heading, x, 1) = " " then split = x
      x = x - 1
   loop until x = 1 or split <> 0
    
   if split <> 0 then 
      firstName = trim(left(heading, split))
      lastName = trim(mid(heading, split))
   else
      firstName = heading
      lastName = ""
   end if
   
   'two first initials
   if right(firstName, 4) like "[A-Z].[A-Z]." then 
      firstName = left(firstName, len(firstName) - 2) & " " & right(firstName, 2)
   end if
   
   'put back suffix
   if instr(lastName, "|Jr.") > 0 then
      firstName = firstName & ", " & chr(223) & "c Jr"
      lastName = replace(lastName, "|Jr.", "")
   elseif instr(lastName, "|Sr.") > 0 then
      firstName = firstName & ", " & chr(223) & "c Sr"
      lastName = replace(lastName, "|Sr.", "")
   end if
   
   'move St. to beginning
   if right(firstName, 4) = " St." then 
      lastName = "St. " & lastName
      firstName = mid(firstName, 1, len(firstName) - 4)
   end if

   if lastName = "" then
      heading = "7001 " & firstName
   else
      heading = "7001 " & lastName & ", " & firstName 
   end if

   if right(heading, 1) <> "." then heading = heading & "."
   
   MakeHeading = heading 
   
end function
'---------------------
Sub Main 

On Error Goto ErrorHandler

   dim CS As Object
   Set CS = CreateObject("Connex.Client")
   
   dim Relators$(30) 
   dim tag700s$(30) 
   dim tag710s$(30) 
   dim Names$(10) 
   dim blobs$(10) 
   
   dim x, y, z, i, subC, pos as integer
   dim jobIndex%, currentJob%, nrtag710s%, nrTag700s%
   dim nrBlobs%, dup700pos%
   dim blnFound, bool
   dim tag245$, temp$
      
   call loadJobs
           
   'get 245 $c and clean it up
   bool = CS.GetField ("245", 1, tag245$)
   subC = instr(tag245$, chr(223) & "c")
   if subC = 0 then
      MsgBox "Record does not contain 245 $c.", 0, "Error"
      exit sub
   end if
   tag245$ = trim(mid(tag245$, subC + 2))
   tag245$ = replace(tag245$, ", Jr.", "|Jr.")            'comma causes problems here,
   tag245$ = replace(tag245$, ", Sr.", "|Sr.")            'will put back at end
   tag245$ = replace(tag245$, ", Inc.", "")
   tag245$ = replace(tag245$, ", Ltd.", "")               'headings *shouldn't* have 
   tag245$ = replace(tag245$, ", Pty.", "")               'these anyway
   tag245$ = replace(tag245$, "... [et al.]", "")
   tag245$ = replace(tag245$, "a production of ", "")
   tag245$ = replace(tag245$, "..",".")
   tag245$ = replace(tag245$, "[","")
   tag245$ = replace(tag245$, "]","")
   
   'make all connectors be ampersands
   tag245$ = replace(tag245$, ", and ", " & ")
   tag245$ = replace(tag245$, " and ", " & ")
   tag245$ = replace(tag245$, "/", " & ")
   tag245$ = replace(tag245$, " presents ", " & ")
   tag245$ = replace(tag245$, " presented by ", " & ")
   tag245$ = replace(tag245$, " present ", " & ")
   tag245$ = replace(tag245$, " presentation ", " & ")
   tag245$ = replace(tag245$, " presents ", " & ")
   tag245$ = replace(tag245$, " present a ", " & ")
   tag245$ = replace(tag245$, " in association with ", " & ")   
   tag245$ = replace(tag245$, " screen play ", " screenplay ")   
   
   'split heading by semicolon into array   
   blnFound = TRUE
   do until blnFound = FALSE
      pos = instr(tag245$, ";")
      if pos = 0 then
         blnFound = FALSE
         StmtResp$(i) = trim(left(tag245$, len(tag245$) - 1))
      else
         StmtResp$(i) = trim(left(tag245$, pos - 1))
         tag245$ = mid(tag245$, pos + 2)
         i = i + 1
      end if
   loop   
   
   'nrTag700s% = 0
   for x = 0 to i
      'find job
      jobIndex% = 0
      currentJob% = 0
      do until jobs(jobIndex%,0) = "" or currentJob% <> 0
         if instr(StmtResp$(x), jobs(jobIndex%,0)) > 0 then 
            currentJob% = jobIndex%
            StmtResp$(x) = trim(replace(StmtResp$(x), jobs(currentJob%,0), ""))
            if (left(StmtResp$(x), 1) like "[A-Z]") or (left(StmtResp$(x), 1) like "[a-z]") or (left(StmtResp$(x), 1) like "[0-9]") then 
               'do nothing-- easier than multiple nots
            else
               StmtResp$(x) = trim(mid(StmtResp$(x), 2))
            end if
         end if
         jobIndex% = jobIndex% + 1
      loop
      
      if currentJob% = 0 then
         'it's a 710
         StmtResp$(x) = replace(StmtResp$(x), " and ", "&")
         StmtResp$(x) = replace(StmtResp$(x), "& &", "& ")
         pos = instr(StmtResp$(x), "&")
         do while pos > 0
            if pos > 0 then 
               tag710s$(nrtag710s%) = clean710(left(StmtResp$(x), pos))
               StmtResp$(x) = trim(mid(StmtResp$(x), pos + 2))
               nrtag710s% = nrtag710s% + 1
            end if
            pos = instr(StmtResp$(x), "&")
         loop
         if StmtResp$(x) <> "" then 
            tag710s$(nrtag710s%) = clean710(StmtResp$(x))
            nrtag710s% = nrtag710s% + 1     'last added line
         else
            'what's left is garbage, ignore
            nrtag710s% = nrtag710s% - 1
         end if
      else
         'it's a 700
         StmtResp$(x) = replace(StmtResp$(x), " and ", "& ")
         StmtResp$(x) = replace(StmtResp$(x), ", ", " & ")
         nrBlobs% = 0
         pos = instr(StmtResp$(x), "&")
         do until pos = 0 
            blobs$(nrBlobs%) = trim(left(StmtResp$(x), pos - 1))
            StmtResp$(x) = trim(mid(StmtResp$(x), pos + 2))
            nrBlobs% = nrBlobs% + 1
            pos = instr(StmtResp$(x), "&")
         loop
         blobs$(nrBlobs%) = trim(StmtResp$(x))
          
         'check for dup names
         for y = 0 to nrBlobs%
            dup700pos% = -1
            for z = 0 to nrTag700s%
               if instr(blobs$(y), tag700s$(z)) > 0 and tag700s$(z) <> "" then dup700pos% = z             
            next z
         
            if dup700pos% >= 0 then
               'append relator
               'check for duplicate relators, most often story + screenplay
               if instr(relators$(dup700pos%), jobs(currentjob%, 1)) = 0 then 
                  relators$(dup700pos%) = relators$(dup700pos%) & " " & chr(223) & "4 " & jobs(currentjob%, 1)
               end if
            else
               'add heading
               tag700s$(nrTag700s%) = blobs$(y)
               relators$(nrTag700s%) = " " & chr(223) & "4 " & jobs(currentjob%, 1)
               nrTag700s% = nrTag700s% + 1
            end if
         next y
      end if 
   next x
   
   for x = 0 to nrTag700s% - 1
      temp$ = makeHeading(tag700s$(x))
      'check for blank relator
      if len(Relators$(x)) > 4 then temp$ = temp$ & Relators$(x)
   CS.AddField 99, temp$
   next x

   for x = 0 to nrTag710s%
      CS.AddField 99, tag710s$(x)
   next x
   
exit sub
ErrorHandler:
      MsgBox "Please reformat 245 $c.", 0, "Error"

end sub