|
发表于 2007-4-24 22:55:00
|
显示全部楼层
Public Function ChangeDwgPicPath(AcadObj As AcadApplication, Optional DWGFullName As String = "")
Dim JJ As Integer
Dim pImg As AcadRasterImage
Dim PEnt As AcadEntity
Dim pDrive As String
Dim NowChar As String
Dim PicPathName As String
Dim DwgIsOpen As Boolean
'将DWGFullName置为当前
DwgIsOpen = False
If DWGFullName "" Then
For JJ = 0 To AcadObj.Documents.Count - 1
If UCase(AcadObj.Documents(JJ).FullName) = UCase(DWGFullName) Then
DwgIsOpen = True
AcadObj.Documents(JJ).Activate
End If
Next
If Not DwgIsOpen Then
AcadObj.Documents.Open DWGFullName
End If
End If
If UCase(AcadObj.ActiveDocument.ActiveLayout.Name) "MODEL" Then
AcadObj.ActiveDocument.SetVariable "CTAB", "Model"
End If
'选择图片
Dim SSetObj As AcadSelectionSet
Dim fType, fData As Variant
BuildFilter fType, fData, 0, "IMAGEDEF"'请问如何选择所有图片?
'首先不能用ActiveDocuments.ModesSpace取所有对象,那速度太慢了,
Set SSetObj = CreateSelectionSet(AcadObj, "Pic")
'选择名称为的所有块
SSetObj.Select acSelectionSetAll, , , fType, fData
Erase fType: Erase fData
Debug.Print SSetObj.Count
For Each PEnt In SSetObj
If TypeOf PEnt Is AcadRasterImage Then
Set pImg = PEnt
PicPathName = pImg.ImageFile
If Mid(pImg.ImageFile, 1, 1) = "." Then
'将相对路径转换为绝对路径
pDrive = Mid(AcadObj.ActiveDocument.FullName, 1, 3)
For JJ = 1 To Len(PicPathName)
NowChar = Mid(PicPathName, JJ, 1)
If NowChar "\" And NowChar "." Then
Exit For
End If
Next
PicPathName = pDrive & Right(PicPathName, Len(PicPathName) - JJ + 1)
If pFSO.FileExists(PicPathName) Then
pImg.ImageFile = PicPathName
End If
End If
End If
Next
End Function |
|