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
  
  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
    Set objNewImg = PaperSpace.AddRaster(strNewName, objImg.Origin, objImg.ScaleFactor, objImg.Rotation)
    DetachImage (strImgName)
    Kill strImgPath & strImgName & strImgExt
    Rename
  Next objImg
  End If
End Sub
Function DetachImage(ByVal strName As String)
'Function jacked then Bobbed from Luis Alberto who got it somewhere else http://groups.google.com/group/autodesk.autocad.customization.vba/browse_thread/thread/2a3de0506ce1ed32/4e8b16d28d05e7a2%234e8b16d28d05e7a2?sa=X&oi=groupsr&start=0&num=3
On Error GoTo NoPicYo
  Dim objImgDic As AcadDictionary
  Dim objImg As AcadObject
  
  Set objImgDic = ThisDrawing.Dictionaries("ACAD_IMAGE_DICT")
  Set objImg = objImgDic(strName)
  objImg.Delete
Bounce:
  Exit Function
NoPicYo:
  Set objImgDic = Nothing
  Set objImg = Nothing
End Function