VBA图像控制

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