乐筑天下

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

请教如何用选择集取到光栅图像?

[复制链接]

23

主题

76

帖子

3

银币

初露锋芒

Rank: 3Rank: 3Rank: 3

铜币
168
发表于 2005-6-14 22:30:00 | 显示全部楼层 |阅读模式
请教各位大侠以下的问题:
小弟最近用VBA编程时,需要穷举图纸中的所有光栅图像。这是小弟的源代码:
Dim        a         As AcadSelectionSet
Set        a = ThisDrawing.SelectionSets.Add("SSS67ETEXC")
                 Dim ft(0 To 1) As Integer
                 Dim fd(0 To 1) As Variant
                 ft(0) = 0
                 fd(0) = "IMAGEDEF"
                        ft(1) = 8
                 fd(1) = "*"
a.Select acSelectionSetAll, , , ft, fd
关键是选择集的过滤条件 Filter的问题。
这个组码是我将.dwg转换成dxf后查到的。可是用这个方式却怎么也取不到
光栅对象。
请问,如何用选择集取到所有的光栅对象呢?
谢谢各位!
回复

使用道具 举报

hnz

1

主题

5

帖子

2

银币

初来乍到

Rank: 1

铜币
9
发表于 2006-7-9 11:35:00 | 显示全部楼层
"AcDbRasterImage"
回复

使用道具 举报

0

主题

3

帖子

1

银币

初来乍到

Rank: 1

铜币
3
发表于 2007-4-24 22:44:00 | 显示全部楼层
AcDbRasterImage不行,真是奇怪,难道没人知道吗?版主哪去了?
回复

使用道具 举报

0

主题

3

帖子

1

银币

初来乍到

Rank: 1

铜币
3
发表于 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
回复

使用道具 举报

发表回复

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

本版积分规则

  • 微信公众平台

  • 扫描访问手机版

  • 点击图片下载手机App

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

GMT+8, 2025-7-7 17:36 , Processed in 1.532355 second(s), 60 queries .

© 2020-2025 乐筑天下

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