使用VBScript设置AutoCAD路径

Dim ACADApp
Set ACADApp = CreateObject("AutoCAD.application")
'Support File Search Paths:
  Dim Preferences As AcadPreferences
  Dim CurrPaths As String
  Dim NewPath1, NewPath2, NewPath3, NewPath4, NewPath5 As String
  Set Preferences = ThisDrawing.Application.Preferences
  CurrPaths = Preferences.Files.SupportPath
   
    NewPath1 = "I:\Directory\Directory"
'  'NewPath2 = "Path2"
'  'NewPath3 = "Path3"
'  'NewPath4 = "Path4"
'  'NewPath5 = "Path5"
'  'Support File Search Paths
   Preferences.Files.SupportPath = CurrPaths & ";" & NewPath1 '& ";" & NewPath2 & ";" & _
   NewPath3 & ";" & NewPath4 & ";" & NewPath5

Dim ACADAPP as Object
Dim Preferences as Object
Set ACADApp = CreateObject("AutoCAD.application")
Set Preferences = ACADApp.AcadPreferences 'you need to adres the holder acadapp if you aren't in acad
ACADApp.Visible = True
Dim CurrPaths 
'Dim NewPath1, NewPath2, NewPath3, NewPath4, NewPath5 
CurrPaths = Preferences.Files.SupportPath
'this is sloppy: 
'NewPath1 = "I:\Path\Test"
'NewPath2 = "Path2"
'NewPath3 = "Path3"
'NewPath4 = "Path4"
'NewPath5 = "Path5"
'Support File Search Paths
'Preferences.Files.SupportPath = CurrPaths & ";" & NewPath1 '& ";" & NewPath2 & ";" & _
'NewPath3 & ";" & NewPath4 & ";" & NewPath5
'How about:
Dim NewPath(5) as String
Dim AllPaths as String
Dim pCount as Integer
NewPath(0) = "I:\Path\Test"
NewPath(1) = ""
NewPath(2) = ""
NewPath(3) = ""
NewPath(4) = ""
Allpaths = Currpaths
For pCount = 0 to 4
    if Len NewPath(pCount) > 0 then
        Allpaths = Allpaths & ";" & NewPath(pCount)
    end if
next
Preferences.Files.SupportPath = Allpaths

Dim Preferences As AcadPreferences
Dim CurrPaths, NewPath(5), AllPaths As String
Dim Pcount As Integer
Set Preferences = ThisDrawing.Application.Preferences
CurrPaths = Preferences.Files.SupportPath
NewPath(0) = "Path"
NewPath(1) = "Path"
NewPath(2) = ""
NewPath(3) = ""
NewPath(4) = ""
For Pcount = 0 To 4
 If NewPath(Pcount)  0 Then
  AllPaths = AllPaths & ";" & CurrPaths & ";" & NewPath(Pcount)
 End If
Next Pcount
Preferences.Files.SupportPath = AllPaths

Option Explicit
Option Compare Text
Declare Function RegQueryValueEx& Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey&, ByVal lpszValueName$, ByVal lpdwRes&, lpdwType&, ByVal lpDataBuff$, nSize&)
Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
Private Declare Function ShellExecute Lib "shell32.dll" Alias _
      "ShellExecuteA" (ByVal hwnd As Long, ByVal lpszOp As _
      String, ByVal lpszFile As String, ByVal lpszParams As String, _
      ByVal lpszDir As String, ByVal FsShowCmd As Long) As Long
      Private Declare Function GetDesktopWindow Lib "user32" () As Long
Const HKEY_LOCAL_MACHINE = &H80000002
Const HKEY_CLASSES_ROOT = &H80000000
Const KEY_QUERY_VALUE = &H1&
Const KEY_ENUMERATE_SUB_KEYS = &H8&
Const KEY_NOTIFY = &H10&
Const READ_CONTROL = &H20000
Const STANDARD_RIGHTS_READ = READ_CONTROL
Const KEY_READ = STANDARD_RIGHTS_READ Or KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY
Const SW_SHOWNORMAL = 1
Const SE_ERR_FNF = 2&
Const SE_ERR_PNF = 3&
Const SE_ERR_ACCESSDENIED = 5&
Const SE_ERR_OOM = 8&
Const SE_ERR_DLLNOTFOUND = 32&
Const SE_ERR_SHARE = 26&
Const SE_ERR_ASSOCINCOMPLETE = 27&
Const SE_ERR_DDETIMEOUT = 28&
Const SE_ERR_DDEFAIL = 29&
Const SE_ERR_DDEBUSY = 30&
Const SE_ERR_NOASSOC = 31&
Const ERROR_BAD_FORMAT = 11&
Private Function GetAppPath(subkey As String, sAppEntry As String) As String
Dim s As String * 255, sAppPath As String
Dim lAppKey As Long, lType As Long, lLen As Long, lRC As Long
    lLen = Len(s)
    lRC = RegOpenKeyEx(HKEY_CLASSES_ROOT, sAppEntry, 0, KEY_READ, lAppKey)
    If lRC  0 Then Exit Function
    lRC = RegQueryValueEx( _
            lAppKey, _
            subkey, _
            0, _
            lType, _
            s, _
            lLen)
    's = Left$(s, lLen - 6)
    GetAppPath = Mid(s, 2, lLen - 8) 'Left$(s, lLen - 5)
End Function
 Function StartDoc(DocName As String, Param As String, Dir As String) As Long
          Dim Scr_hDC As Long
          Scr_hDC = GetDesktopWindow()
          StartDoc = ShellExecute(Scr_hDC, "Open", DocName, _
          Param, Dir, SW_SHOWNORMAL)
      End Function
Sub Main()
   
   Dim version As String
   Dim result As Boolean
   Dim sAcadEntry As String
   
   On Error Resume Next
   
   sAcadEntry = "AutoCAD.Drawing.16\shell\open\command"
   version = GetAppPath("", sAcadEntry)
   
   If StrConv(version, 1) Like "*ACAD.EXE"  True Then
    MsgBox ("El programa AutoCAD Ver. 2004 no se encuentra instalado. \nPor favor refiérase al Manual del Usuario.")
    End
   End If
   
   'result = Shell(version & " /b draftteam.scr", 1)
   Dim r As Long, msg As String, Dir As String
          Dir = App.Path
          r = StartDoc(version, " /b draftteam.scr", Dir)
          If r  "" Then
   Dim DttPath As String
   DttPath = objAcad.ActiveDocument.GetVariable("DWGPREFIX")
   Dim LDttPath As Integer
   LDttPath = Len(DttPath)
   If Right(DttPath, 1) = "" Then
        DttPath = Left(DttPath, LDttPath - 1)
   End If
   'Adicionar directorio donde esta instalado draftteam si no existe
   If StrConv(sPath, 1) Like "*" & StrConv(DttPath, 1) & "*"  True Then
        preferences.Files.SupportPath = sPath & ";" & DttPath
   End If
   End If
   Set objAcad = Nothing
   Set preferences = Nothing
   
End Sub