雪山飞狐_lzh 发表于 2004-7-2 12:00:00

利用ObjectDbx预览块图像

本帖最后由 作者 于 2004-7-2 14:36:20 编辑 <br /><br /> Private        pFileName        As        String<BR>Private        objDbx        As        AxDbDocument<BR>Public        Names        As        New        Collection



Private        Sub        Class_Initialize()


                                Set        objDbx        =        GetInterfaceObject("ObjectDBX.AxDbDocument.16")<BR>                                <BR>End        Sub


Public        Function        GetBlock(ByVal        BlockName        As        String)        As        AcadBlock<BR>'将文件中的块读入当前图形


                                Dim        pBlock        As        AcadBlock<BR>                                Dim        pnt(2)        As        Double<BR>                                Dim        pObjs()        As        AcadEntity<BR>                                <BR>                                Set        pBlock        =        objDbx.Blocks(BlockName)<BR>                                <BR>                                ReDim        pObjs(pBlock.Count        -        1)        As        AcadEntity<BR>                                <BR>                                For        i        =        0        To        pBlock.Count        -        1<BR>                                                                Set        pObjs(i)        =        pBlock(i)<BR>                                Next        i<BR>                                <BR>                                Set        GetDbxBlock        =        ThisDrawing.Blocks.Add(pnt,        "*U")<BR>                                objDbx.CopyObjects        pObjs,        GetDbxBlock<BR>                                <BR>End        Function


Public        Function        GetBlockImage(ByVal        BlockName        As        String)        As        IPictureDisp<BR>'获取块的预览图像


                                Dim        pObj(0)        As        AcadEntity<BR>                                Dim        pnt(2)        As        Double<BR>                                Dim        ss        As        AcadSelectionSet<BR>                                <BR>                                Set        pObj(0)        =        objDbx.ModelSpace.InsertBlock(pnt,        BlockName,        1,        1,        1,        0)<BR>                                objDbx.CopyObjects        pObj,        ThisDrawing.ModelSpace<BR>                                <BR>                                Set        pObj(0)        =        ThisDrawing.ModelSpace(ThisDrawing.ModelSpace.Count        -        1)<BR>                                pObj(0).GetBoundingBox        d1,        d2<BR>                                <BR>                                ThisDrawing.Application.ZoomWindow        d1,        d2<BR>                                <BR>                                On        Error        Resume        Next<BR>                                ThisDrawing.SelectionSets("*TlsDbx*").Delete<BR>                                Set        ss        =        ThisDrawing.SelectionSets.Add("*TlsDbx*")<BR>                                ss.AddItems        pObj<BR>                                <BR>                                ThisDrawing.Export        "c:\Temp",        "wmf",        ss<BR>                                ss.Delete<BR>                                pObj(0).Delete<BR>                                ThisDrawing.Blocks(BlockName).Delete<BR>                                ThisDrawing.Application.ZoomPrevious<BR>                                <BR>                                Set        GetBlockImage        =        LoadPicture("c:\temp.wmf")<BR>                                Kill        "c:\temp.wmf"<BR>                                <BR>End        Function


<BR>Public        Property        Let        FileName(ByVal        str        As        String)<BR>'打开文件


                                Dim        i        As        AcadBlock


                                pFileName        =        str<BR>                                objDbx.Open        str<BR>                                <BR>                                Set        Names        =        New        Collection<BR>                                <BR>                                For        Each        i        In        objDbx.Blocks<BR>                                                                If        Not        (i.IsLayout Or i.IsXRef)        Then<BR>                                                                                                Names.Add        i.Name<BR>                                                                End        If<BR>                                Next        i


End        Property





上述代码存为TlsDbx类


插入一个窗体


加入ListBox控件和Image控件


在窗体加入下列代码


Dim a As New TlsDbx


Private Sub ListBox1_Click()<BR>Set Me.Image1.Picture = a.GetBlockImage(ListBox1.Text)


End Sub


Private Sub UserForm_Activate()<BR>a.FileName = "d:\ccd.dwg"<BR>For Each i In a.Names<BR>Me.ListBox1.AddItem i<BR>Debug.Print i<BR>Next i<BR>End Sub<BR>

mikewolf2k 发表于 2004-7-4 15:35:00

太好了，试试看

nxy_918 发表于 2004-8-10 09:05:00

强大！！！


<b>ObjectDbx看来要好研究研究</b>


<b>关注ing</b>

leer 发表于 2004-8-18 18:34:00

可是预览那一块似乎不好用，算法好像是把图插入当前图然后输出为wmf再导入图形控件中，预览不完善而且觉得这样的过程似乎有点麻烦，有没有更好的方法呢？

yicol 发表于 2004-8-21 15:03:00

Private        objDbx        As        AxDbDocument


此句无效，是为什么

liufx2000 发表于 2004-8-25 15:09:00

上述代码存为TlsDbx类？以上所有的代码么？不好意思水平比较差

雪山飞狐_lzh 发表于 2004-8-25 16:16:00

yicol发表于2004-8-21 15:03:00static/image/common/back.gifPrivate        objDbx        As        AxDbDocument



此句无效，是为什么

<BR>引用DBX

yicol 发表于 2004-8-25 17:52:00

不行啊，版主，看到了文件生成，但那个图元文件是没有图像的，在窗体中预览不到，另外我在原文件中确定块是正常的，单击list后没有任何反应

tonyhuangg 发表于 2004-9-13 11:00:00

<DIV><FONT face=宋体 size=2>我正准备用objectdbx在不打开autocad情况下读取dwg里图框里的文字信息，能举一例子或提示用哪些方法和属性可以成功吗，（不熟cad编程，但要马上交货了，盼能得到您的帮助），谢谢，我是用vb开发的。</FONT></DIV>

雪山飞狐_lzh 发表于 2004-9-13 15:39:00

<FONT size=2>不打开autocad，objectdbx也干不了，：）</FONT>
页: [1] 2
查看完整版本: 利用ObjectDbx预览块图像