I think the problem is that I'm currently accessing the links, even though they are broken. Would it work better in vba and if not, would it be possible with objectdbx and does anybody know how to formulate something like this in dbx?
For those interested in dbx, here's something I got from vbdesign on the subject. It most likely won't work right out, but should give a start in it. I for one don't yet understand it.
Option Explicit
Const ATTR_DIRECTORY = 16
Dim objAcad As AcadApplication
Public Sub main()
Dim FileArray As Variant
Dim strDir As String
Dim i As Integer
'acad must be running
Set objAcad = GetObject(, "AutoCAD.Application")
strDir = "P:\Temp\test" 'your dir goes here
FileArray = GetFilesInDir(strDir)
For i = 0 To UBound(FileArray)
OpenAndDoStuff strDir & FileArray(i)
Next i
MsgBox i & " Files Processed"
End Sub
Public Function GetFilesInDir(pDir As String) As Variant
Dim dirReturn As String
Dim subFiles As String
Dim intLen As Integer
Dim intCount As Integer
Dim varRet() As Variant
intLen = Len(pDir)
If Mid(pDir, intLen, 1) <> "\" Then
pDir = pDir & "\"
End If
dirReturn = Dir(pDir & "*.dwg")
'First we find all of the subdirs
Do While dirReturn <> ""
DoEvents
If GetAttr(pDir & dirReturn) <> ATTR_DIRECTORY Then
' that is NOT a dir so add it to listbox
subFiles = dirReturn
ReDim Preserve varRet(0 To intCount)
varRet(intCount) = subFiles
intCount = intCount + 1
End If
dirReturn = Dir
Loop
GetFilesInDir = varRet
End Function
Private Function OpenAndDoStuff(strFileName As String) As Variant
Dim objDbx As Object
Dim i As Integer
Dim objAcadEnt As AcadEntity
Dim objBlockRef As AcadBlockReference
Dim objLayer As AcadLayer
Dim strSearchBlckName As String
Dim dblSearchScale As Double
Dim dblCurrScale As Double
Dim dblNewScale As Double
Dim basePt(0 To 2) As Double
On Error GoTo Err_Control
'set up search parameters. these should be passed in as args
dblSearchScale = 48#
strSearchBlckName = "borsiv36"
Set objDbx = objAcad.GetInterfaceObject("ObjectDBX.AxDbDocument")
objDbx.Open strFileName
i = 0
For Each objAcadEnt In objDbx.ModelSpace
If TypeName(objAcadEnt) = "IAcadBlockReference" Then
Set objBlockRef = objAcadEnt
If objBlockRef.Name = "borsiv36" Then
dblCurrScale = objBlockRef.XScaleFactor
Exit For ' assumes only one block of borsiv36 in file
End If
End If
Next objAcadEnt
If dblCurrScale <> dblSearchScale Then
dblNewScale = dblSearchScale / dblCurrScale 'set up the scale-by factor
'just in case layers are locked, unlock them
For Each objLayer In objDbx.Layers
objLayer.Lock = False
Next objLayer
'scale all the modelspace entities by the new factor
For Each objAcadEnt In objDbx.ModelSpace
objAcadEnt.ScaleEntity basePt, dblNewScale
Next objAcadEnt
objDbx.SaveAs strFileName
Else
objDbx.SaveAs strFileName
End If
Debug.Print "Finished " & strFileName
Set objDbx = Nothing
Exit_Here:
Exit Function
Err_Control:
MsgBox Err.Description
Set objDbx = Nothing
Resume Exit_Here
End Function
Option Explicit
Public FileInfo() As String
Public Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
Public Const MAX_PATH = 2600
Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Declare Function FindWindow Lib "user32" _
Alias "FindWindowA" (ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Declare Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, _
ByVal pszPath As String) As Long
Public Sub BatchDBX()
Dim frmDBX As New UserForm1
frmDBX.Show
Set frmDBX = Nothing
End Sub
Public Function ReturnFolder(lngHwnd As Long) As String
Dim Browser As BROWSEINFO
Dim lngFolder As Long
Dim strPath As String
With Browser
.hOwner = lngHwnd
.lpszTitle = "Select Directory to work in"
.pszDisplayName = String(MAX_PATH, 0)
End With
strPath = String(MAX_PATH, 0) '<-- VERY Important!!
lngFolder = SHBrowseForFolder(Browser)
If lngFolder Then
SHGetPathFromIDList lngFolder, strPath
ReturnFolder = Left(strPath, InStr(strPath, vbNullChar) - 1)
End If
End Function
Public Function ParseOut(strIn As String, strChar As String) As String
Dim intCnt As Integer
Dim strFile As String
intCnt = 1
Do
If Mid(strIn, intCnt, 1) = strChar Then
strFile = Mid(strIn, 1, intCnt - 1)
strIn = Mid(strIn, intCnt + 1, Len(strIn))
ParseOut = strFile
Exit Function
End If
intCnt = intCnt + 1
Loop
End Function
