的SF，如果您稍后重置它，则可以工作，尽管
Sub RastaRenameMon()
Dim objSelSets As AcadSelectionSets
Dim objSelSet As AcadSelectionSet
Dim intType(0) As Integer
Dim varData(0) As Variant
Dim objImg As AcadRasterImage
Dim objNewImg As AcadRasterImage
Dim strImgName As String
Dim strDwgName As String
Dim strImgExt As String
Dim strImgPath As String
Dim strNewName As String
Dim dblScale As Double
strDwgName = Left(ThisDrawing.Name, Len(ThisDrawing.Name) - 4)
Set objSelSets = ThisDrawing.SelectionSets
For Each objSelSet In objSelSets
If objSelSet.Name = "Imagen" Then
objSelSets.Item("Imagen").Delete
Exit For
End If
Next
Set objSelSet = objSelSets.Add("Imagen")
intType(0) = 0
varData(0) = "IMAGE"
objSelSet.Select acSelectionSetAll, _
filtertype:=intType, filterdata:=varData
If objSelSet.Count > 0 Then
For Each objImg In objSelSet
strImgExt = Right(objImg.ImageFile, 4)
strImgName = objImg.Name
strImgPath = Left(objImg.ImageFile, Len(objImg.ImageFile) - Len(strImgName) - 4)
strNewName = strImgPath & strDwgName & strImgExt
FileCopy objImg.ImageFile, strNewName
dblScale = objImg.ScaleFactor
Set objNewImg = PaperSpace.AddRaster(strNewName, objImg.Origin, dblScale, objImg.Rotation)
objNewImg.ScaleFactor = dblScale
DetachImage (strImgName)
Kill strImgPath & strImgName & strImgExt
Next objImg
End If
End Sub
页:
1
[2]