乐筑天下

搜索
欢迎各位开发者和用户入驻本平台 尊重版权,从我做起,拒绝盗版,拒绝倒卖 签到、发布资源、邀请好友注册,可以获得银币 请注意保管好自己的密码,避免账户资金被盗
楼主: Maverick®

代码请求

[复制链接]

28

主题

249

帖子

7

银币

后起之秀

Rank: 20Rank: 20Rank: 20Rank: 20

铜币
361
发表于 2006-10-18 07:26:41 | 显示全部楼层
Bryco,
我能得到一份LISP例程的副本吗……请?
回复

使用道具 举报

170

主题

1424

帖子

8

银币

顶梁支柱

Rank: 50Rank: 50

铜币
2119
发表于 2006-10-18 09:19:00 | 显示全部楼层
我认为Bryco's解决方案是VBA而不是lisp
回复

使用道具 举报

170

主题

1424

帖子

8

银币

顶梁支柱

Rank: 50Rank: 50

铜币
2119
发表于 2006-10-18 09:21:12 | 显示全部楼层
VBA会工作得更好!
回复

使用道具 举报

28

主题

249

帖子

7

银币

后起之秀

Rank: 20Rank: 20Rank: 20Rank: 20

铜币
361
发表于 2006-10-18 16:55:55 | 显示全部楼层
Matersammichman,我认为这涵盖了它
  1. Private Sub DeleteUnloadedImages()
  2.     On Error GoTo Err_Control
  3.     Dim oDics As AcadDictionaries
  4.     Dim oDic As AcadDictionary
  5.     Dim oD, Imagedef
  6.     Dim i As Integer, sImageName As String
  7.     Dim oImage As AcadRasterImage
  8.     Dim SS As AcadSelectionSet
  9.     Dim Answer As Integer, strPrompt As String
  10.     Dim isThere As Boolean
  11.     Dim obj(0) As AcadEntity
  12.    
  13.     Set oDics = ThisDrawing.Dictionaries
  14.     For Each oD In oDics
  15.         If TypeOf oD Is AcadDictionary Then
  16.             If oD.Name = "ACAD_IMAGE_DICT" Then
  17.                 Set oDic = oD
  18.                 Set SS = sset(0, "Image")
  19.                 For Each Imagedef In oDic
  20.                     sImageName = oDic.GetName(Imagedef)
  21.                      Debug.Print sImageName, vbAssoc(Imagedef, 280)
  22.                     If vbAssoc(Imagedef, 280) = 0 Then
  23.                         strPrompt = "The image: """ & sImageName & """ is unloaded" & vbCrLf & "Choose Yes to delete"
  24.                         Answer = MsgBox(strPrompt, vbYesNo, "Unloaded Image Files")
  25.                         If Answer = vbYes Then
  26.                             Imagedef.Delete
  27.                         End If
  28.                         
  29.                     Else
  30.                         isThere = False
  31.                         If SS.count > 0 Then
  32.                             For Each oImage In SS
  33.                                   If oImage.Name = sImageName Then
  34.                                       isThere = True
  35.                                       Exit For
  36.                                   End If
  37. Nextimage:
  38.                             Next oImage
  39.                             If Not isThere Then
  40.                             Dim bl As Boolean
  41.                             bl = IsNestedImage(sImageName)
  42.                              Debug.Print sImageName, bl
  43.                                 If Not IsNestedImage(sImageName) Then
  44.                                     strPrompt = "The image: """ & sImageName _
  45.                                             & """ is unreferenced" & vbCrLf & "Choose Yes to delete"
  46.                                     Answer = MsgBox(strPrompt, vbYesNo, "Unreferenced Image Files")
  47.                                     If Answer = vbYes Then
  48.                                         Imagedef.Delete
  49.                                     End If
  50.                                 End If
  51.                             End If
  52.                         End If
  53.                         'SS.Delete
  54.                     End If
  55.                 Next Imagedef
  56.                 SS.Delete
  57.                 Exit For
  58.             End If
  59.         End If
  60.     Next oD
  61.    
  62. Exit_Here:
  63.     Exit Sub
  64. Err_Control:
  65.     Select Case Err.Number
  66.         Case -2145386476  'Key not found
  67.             Set obj(0) = oImage
  68.             SS.RemoveItems obj
  69.             oImage.Delete
  70.             Err.Clear
  71.             GoTo Nextimage
  72.     'Add your Case selections here
  73.         Case Else
  74.         'MsgBox Err.Description
  75.         Debug.Print Err.Number, Err.Description
  76.         Err.Clear
  77.         Resume Exit_Here
  78.     End Select
  79. End Sub
和一个函数
  1. Public Function sset(FilterType, FilterData As Variant, Optional ssName As String = "SS") As AcadSelectionSet
  2.    
  3.     Dim oSSets As AcadSelectionSets
  4.     Set oSSets = ThisDrawing.SelectionSets
  5.     For Each sset In oSSets
  6.         If sset.Name = ssName Then
  7.             sset.Delete
  8.             Exit For
  9.         End If
  10.     Next
  11.     Dim FType() As Integer
  12.     Dim FData() As Variant
  13.     Dim i As Integer
  14.     If IsArray(FilterType) = False Then
  15.         If IsArray(FilterData) = False Then
  16.             ReDim FType(0)
  17.             ReDim FData(0)
  18.             FType(0) = FilterType
  19.             FData(0) = FilterData
  20.         Else
  21.             Exit Function
  22.         End If
  23.     Else
  24.         If UBound(FilterType)  UBound(FilterData) Then
  25.             Exit Function 'They must be pairs
  26.         End If
  27.         
  28.         ReDim FType(UBound(FilterType))
  29.         ReDim FData(UBound(FilterType))
  30.         For i = 0 To UBound(FilterType)
  31.             FType(i) = FilterType(i)
  32.             FData(i) = FilterData(i)
  33.         Next
  34.     End If
  35.    
  36.     Set sset = ThisDrawing.SelectionSets.Add(ssName)
  37.     sset.Select 5, FilterType:=FType, FilterData:=FData
  38.     'To use this function for single filter
  39.     'Set SS = SSet(0, "insert")
  40.     'For multiple filter
  41.     'Set SS = SSet(array(0,2),array("insert",oBlock.name)) 'must be pairs
  42. End Function
回复

使用道具 举报

170

主题

1424

帖子

8

银币

顶梁支柱

Rank: 50Rank: 50

铜币
2119
发表于 2006-10-18 17:18:09 | 显示全部楼层
它被vbAssoc噎住了。
回复

使用道具 举报

发表回复

您需要登录后才可以回帖 登录 | 立即注册

本版积分规则

  • 微信公众平台

  • 扫描访问手机版

  • 点击图片下载手机App

QQ|关于我们|小黑屋|乐筑天下 繁体中文

GMT+8, 2025-7-6 21:20 , Processed in 1.012082 second(s), 60 queries .

© 2020-2025 乐筑天下

联系客服 关注微信 帮助中心 下载APP 返回顶部 返回列表