property targetFolder : "" 
try 
  targetFolder as alias 
on error 
  set targetFolder to (choose folder with prompt "Einen Zielordner für die Schriften wählen.") as Unicode text 
end try 
 
tell document 1 of application "QuarkXPress 6.5" 
  set fontList to font list 
  repeat with i from 1 to count of fontList 
    set curFont to name of item i of my fontList 
    set dR to button returned of (display dialog curFont buttons  ¬ 
      {" Abbrechen ", "Weiter", "Ordner wählen"} default button 3 with icon 1) 
    if dR is "Ordner wählen" then 
      set fontFolder to choose folder with prompt  ¬ 
        "Den Ordner der Schrift \"" & curFont & "\" wählen." as Unicode text 
      my copyFonts(fontFolder) 
    else if dR is " Abbrechen " then 
      error number -128 
    end if 
  end repeat 
end tell 
 
on copyFonts(fontFolder) 
  try 
    tell application "Finder" to duplicate folder fontFolder to folder targetFolder 
  end try 
end copyFonts 

property targetFolder : "" 
try 
  targetFolder as alias 
on error 
  set targetFolder to (choose folder with prompt "Einen Zielordner für die Schriftnamen-Datei wählen.") as Unicode text 
end try 
 
tell document 1 of application "QuarkXPress 6.5" 
  activate 
  set docName to name 
  set fontList to font list 
  set fList to {} 
  repeat with i from 1 to count of fontList 
    set end of fList to name of item i of my fontList 
  end repeat 
  set AppleScript's text item delimiters to {return} 
  set fString to every item of fList as string 
  set AppleScript's text item delimiters to {""} 
  set fString to docName & return & return & fString 
  my writeString(docName, fString) 
  display dialog "Fertig." buttons "OK" default button 1 with icon 1 giving up after 1 
end tell 
 
on writeString(docName, fString) 
  set fontNames to targetFolder & docName & ".txt" 
  try 
    open for access file fontNames with write permission 
    set eof of file fontNames to 0 
    write fString to file fontNames 
    close access file fontNames 
  on error 
    try 
      close access file fontNames 
    end try 
  end try 
end writeString