[VBA程序]：国外的execl－cad的数据交互连接程序(破解)

发条兔子

我因为不太懂，所以请版主帮忙看看这个对大家学习有没有帮助 ：）
密码我破解了已经。execl的密码"cadjsmemy'
文件包含execl和cad文件各1个。
部分代码如下（模块acadlinkcode）：
Option Explicit
Public isBlocks As Integer
Public bXYZ As Boolean
Public bLayer As Boolean
Public bScale As Boolean
Private cfBlockName As Range
Private pBlock As Object
Public listBlocks() As String
Public sBlocks As String

Sub initDataLink()
    Err.Clear
    On Error GoTo Error_Msg
    If Not AcadLinkWbk.bInitaialized Or CInt(CfgSheet.Range("B3").Value) Then Exit Sub
   
    ' kontrola, jestli m醡e jm閚o bloku
        
    Dim i As Integer
    Dim n As Integer
    Dim res As Integer
    Dim bName As String
   
    CfgSheet.bCreate = False
   
    Set cfBlockName = CfgSheet.Range("B1")
    n = CfgSheet.Range("B2")
    DataSet.Activate
    If CfgSheet.CheckWithOutDlg.Value = False Then
        DataSet.Range("1:1").ClearContents
        
        bName = ""
        
        'res = MsgBox("Would you rather pick the block in your drawing (instead of selecting from a block list)? (note: you have to switch to AutoCAD manually)", vbYesNo + vbQuestion + vbDefaultButton2)
        
        Load frmImpType
        frmImpType.Show
        If frmImpType.bOk = False Then Exit Sub
        
        
        'If res = vbYes Then
        If frmImpType.OptionButtonBlocks.Value = False Then
            isBlocks = 0
            CfgSheet.Range("B1").Value = ""
        Else
            If frmImpType.CheckBox1.Value = True Then
                isBlocks = 2
            Else
                isBlocks = 1
            End If
        End If
        Unload frmImpType
        If isBlocks > 0 Then
            CfgSheet.OptionButton1.Value = True
            selBlocks
        Else
            CfgSheet.OptionButton1.Value = False
            CfgSheet.OptionButton2.Value = True
            
        End If
               
        If isBlocks > 0 And CStr(cfBlockName.Value) = "" Then Exit Sub
        'If CStr(cfBlockName.Value) <> "" Then
            
            'VM: X-Y-Z, Lay, Scale ------------------
        headRow

        'Else
            'Exit Sub
        'End If
    Else
        If CfgSheet.OptionButton1.Value Then
            If CfgSheet.CheckPickDwg.Value Then
                isBlocks = 2
            Else
                isBlocks = 1
            End If
            If (Len(cfBlockName.Value) = 0 Or n <= 0) Then
                selBlocks
            End If
            
        End If
        If CfgSheet.OptionButton2.Value Then isBlocks = 0
        headRow
    End If
   
    DataSet.nColumns = n
    DataSet.nRows = 0
    DataSet.Range("1:1").Font.Bold = 1
    DataSet.Range("2:1000").Clear
   
    'Read data
    Dim row: row = 0
    'DEMO sentinel VM
    Dim MAXROW: MAXROW = 20     '20
    Dim blkName As String: blkName = cfBlockName.Value
    Dim aAttribs, insPt As Variant
    Dim crsr As Integer
    Dim entType As Integer
    Dim isCurBlock As Boolean: isCurBlock = False
    Dim tmpBlockName As Variant
    Dim sHandle As String
    If isBlocks > 0 Then
        entType = 7 'acBlockReference
        Dim curBlockName As String
    Else
        entType = 22 'acPoint
    End If
    If CfgSheet.OptionButton4.Value Then
        Set AcadLinkWbk.acadMSpace = AcadLinkWbk.acadDoc.PaperSpace
    Else
        Set AcadLinkWbk.acadMSpace = AcadLinkWbk.acadDoc.ModelSpace
    End If
   
    For Each pBlock In AcadLinkWbk.acadMSpace
        On Error GoTo bad_obj_type
        
        If pBlock.EntityType = entType Then
            If isBlocks > 0 Then curBlockName = pBlock.Name
            isCurBlock = False
            If isBlocks > 0 Then
                For Each tmpBlockName In listBlocks
                    If StrComp(tmpBlockName, curBlockName, vbTextCompare) = 0 Then
                        'MsgBox tmpBlockName + ", " + curBlockName
                        isCurBlock = True
                        Exit For
                    End If
                Next
            End If
            If (isBlocks = 0 Or isCurBlock = True) And row < MAXROW Then
            'Or StrComp(blkName, curBlockName, vbTextCompare) = 0 And row < MAXROW Then
                row = row + 1
                Application.ScreenUpdating = False
                'VM: XYZ-L-Sc ----------------------
                crsr = 1
                If CfgSheet.CheckXYZ.Value Then
                 If isBlocks Then
                    insPt = pBlock.InsertionPoint
                 Else
                    insPt = pBlock.Coordinates
                End If
                 DataSet.Cells(1 + row, 1).Value = insPt(0)
                 DataSet.Cells(1 + row, 3).Value = insPt(1)
                 DataSet.Cells(1 + row, 5).Value = insPt(2)
                 crsr = crsr + 3
                End If
                'sHandle = pBlock.handle
                'DataSet.Cells(1 + row, 6).NumberFormat = "@"
                DataSet.Cells(1 + row, 6).Value = "'" & pBlock.handle
                'MsgBox sHandle

               
                If CfgSheet.CheckLay.Value Then
                DataSet.Cells(1 + row, crsr * 2 - 1).Value = pBlock.Layer
                 crsr = crsr + 1
                End If
                If isBlocks > 0 Then
                aAttribs = pBlock.GetAttributes()
                If CfgSheet.CheckScale.Value Then
                DataSet.Cells(1 + row, crsr * 2 - 1).Value = pBlock.XScaleFactor
                 crsr = crsr + 1
                End If
                'VM: end ------------------------
                For i = LBound(aAttribs) To UBound(aAttribs)
                    With DataSet.Cells(1 + row, crsr * 2 - 1)
                        '.NumberFormat = xlGeneral
                        If CfgSheet.CheckForceText Then
                            .Value = "'" & aAttribs(i).TextString
                        Else
                            .Value = aAttribs(i).TextString
                        End If
                    End With
                    With DataSet.Cells(1 + row, crsr * 2)
                        '.NumberFormat = xlText
                        .NumberFormat = "@"
                        .Value = "'" & aAttribs(i).handle
                    End With
                    crsr = crsr + 1
                    If (crsr * 2) = 256 Then Exit For
                Next
                'DEMO sentinel VM
                End If
                If row = MAXROW Then
                 DataSet.Cells(2 + row, 1).Value = "DEMO LIMITED TO 20 ROWS !"
                 DataSet.Cells(2 + row, 1).Font.Color = RGB(255, 0, 0)
                 DataSet.Cells(2 + row, 1).Font.Bold = 1
                End If
                Application.ScreenUpdating = True
            End If
        End If
        GoTo err_cont
bad_obj_type:
        If Err.Number = 438 Then
            Resume err_cont
        Else
            MsgBox Err.Description
        End If
err_cont:
    Next
   
    DataSet.Range(Cells(1, 1), Cells(row + 1, n * 2)).AutoFormat xlRangeAutoFormatSimple, False, False, False, True, True
    DataSet.bOnLine = True
    DataSet.nRows = row
   
    CfgSheet.Range("D2").Value = row
    Exit Sub
Error_Msg:
    MsgBox Err.Description
   
   
End Sub

Sub selBlocks()

    Dim ss As Object
    Dim res As Integer
    Dim pObj As Variant
    Dim i As Integer: i = 0
    Dim j As Integer: j = 0
    If isBlocks = 2 Then
         
                Set ss = AcadLinkWbk.acadDoc.SelectionSets.Add("XLLINK")
try_again:
                ss.Clear
                Application.Visible = False
                ss.SelectOnScreen
                Application.Visible = True
                Application.ActiveWindow.Activate
                If ss.Count = 0 Then
                    res = MsgBox("Invalid selection (select a single entity)... retry?", vbYesNo)
                    If res = vbYes Then
                        GoTo try_again
                    Else
                        Exit Sub
                    End If
                End If
                ReDim listBlocks(0)
                ReDim listBlocks(ss.Count)
                sBlocks = ""
                For Each pObj In ss
                'If ss.Item(0).EntityType <> acBlockReference Then
                    'j = j + 1
                    If pObj.EntityType = 7 Then  'acBlockReference
                    listBlocks(i) = pObj.Name
                    If Len(sBlocks) > 0 Then sBlocks = sBlocks + ","
                    sBlocks = sBlocks + pObj.Name
                    i = i + 1
                    'res = MsgBox("Wrong entity ... retry?", vbYesNo)
                    'If res = vbYes Then
                     '   GoTo try_again
                'Else
                    
                    
                     '   Exit Sub
                    'End If
                    End If
                Next

                cfBlockName.Value = sBlocks 'ss.Item(0).Name
            
                ss.Delete
                  
    Else
                ' data z dialogu
                frmBlckSel.Hide
                Set frmBlckSel.pBlocks = AcadLinkWbk.acadDoc.Blocks
                frmBlckSel.readData
                frmBlckSel.Show
                If frmBlckSel.bOk Then
                    cfBlockName.Value = sBlocks
                    'cfBlockName.Value = frmBlckSel.strBlockName
                    'MsgBox frmBlckSel.sBlocks
                End If
                    Unload frmBlckSel
    End If
End Sub

Sub DisconnectAutoCAD()

    Set AcadLinkWbk.acadApp = Nothing
    Set AcadLinkWbk.acadDoc = Nothing
    Set AcadLinkWbk.acadMSpace = Nothing
    AcadLinkWbk.bInitaialized = False
    DataSet.bOnLine = False
    CfgSheet.Range("B3").Value = 1

End Sub

Sub headRow()
    Dim n As Integer
    Dim i As Integer
    n = 0
    If CfgSheet.CheckXYZ.Value Then
            bXYZ = True
            DataSet.Cells(1, 1).Value = "X"
            DataSet.Cells(1, 2).Columns(1).Hidden = True
            DataSet.Cells(1, 3).Value = "Y"
            DataSet.Cells(1, 4).Columns(1).Hidden = True
            DataSet.Cells(1, 5).Value = "Z"
            DataSet.Cells(1, 6).Columns(1).Hidden = True
            n = n + 3
    Else
            bXYZ = False
    End If
        If CfgSheet.CheckLay.Value Then
            bLayer = True
            DataSet.Cells(1, n * 2 + 1).Value = "Layer"
            DataSet.Cells(1, n * 2 + 2).Columns(1).Hidden = True
            n = n + 1
    Else
            bLayer = False
    End If
    If isBlocks > 0 Then
        Dim sTmp: sTmp = cfBlockName.Value
        Dim nBlck As Integer
        Dim nCarka As Integer: nCarka = 1
        'If isListBlocks Then
        
        nBlck = 0
        Do While True
            nCarka = InStr(nCarka + 1, sTmp, ",", vbTextCompare)
            nBlck = nBlck + 1
            If nCarka = 0 Then Exit Do
        Loop
        ReDim listBlocks(0)
        ReDim listBlocks(nBlck)
        'MsgBox Str(nBlck)
        nBlck = 0
        Do While True
            nCarka = InStr(sTmp, ",")
            If nCarka = 0 Then
                listBlocks(nBlck) = sTmp
                Exit Do
            End If
            listBlocks(nBlck) = Strings.Left(sTmp, nCarka - 1)
            sTmp = Strings.Mid(sTmp, nCarka + 1)
            nBlck = nBlck + 1
        Loop
        'End If
            
        If CfgSheet.CheckScale.Value Then
                bScale = True
                DataSet.Cells(1, n * 2 + 1).Value = "Scale"
                DataSet.Cells(1, n * 2 + 2).Columns(1).Hidden = True
                n = n + 1
            Else
                bScale = False
            End If
            'VM: end -------------------------------
            ' najdi attributy
            Application.ScreenUpdating = False
            Dim nAtt As Integer: nAtt = 0
            Dim nAttL As Integer: nAttL = 0
            Dim tmpBlockName
            For Each tmpBlockName In listBlocks
                nAtt = 0
                If Len(tmpBlockName) > 0 Then
                Set pBlock = AcadLinkWbk.acadDoc.Blocks(tmpBlockName)  ' cfBlockName.Value)
                For i = 0 To pBlock.Count - 1
                    If pBlock(i).EntityType = 5 Then 'acAttribute
                        nAtt = nAtt + 1
                        If nAtt > nAttL Then
                        n = n + 1
                        If (n * 2) = 256 Then Exit For
                        DataSet.Cells(1, n * 2 - 1).Value = pBlock(i).TagString
                        DataSet.Cells(1, n * 2).Value = "_Handle"
                        DataSet.Cells(1, n * 2 - 1).Columns(1).Hidden = False
                        DataSet.Cells(1, n * 2).Columns(1).Hidden = True
                        End If
                    End If
                Next
                If nAttL < nAtt Then nAttL = nAtt
                End If
            Next
     End If
            Application.ScreenUpdating = True
            CfgSheet.Range("B2") = n
End Sub

lsjjm

Execl 和AutoCAD的数据交互连接的VBA程序自R14.01以后有许多公开的范例. 不需要破解...

发条兔子

已经把密码 公布了，并把附件改为不收取爱心币了。
希望那个对大家有用。（这个程序原来好像还是收费的）

z954134

非常感谢，先研究下

sdxylijian

要学的东西真的太多了，这里的资源真多，谢谢。我要认真学习一下。

zhb001

也想学，看不懂，谁能说说看？

zzlphp

我也看不懂，我是想学，有没有好的办法？

zhacer

谢谢。我要认真学习一下

dearjdz123

谢谢,可惜我的爱心币不够呀,下不了,发一个给我吧

saraqi

期待爱心币升值：p

gcgerkaven

好程序
我是小弟
还要多多向大家学习
努力中

june0448

支持一下

xiongmao371

嗯，不错，下载了看看

gxls63

好好好！建议斑竹加分，这样的程序以后应该多搞些上来，让我等第三世界国家居民也学习学习，提高为人民服务的本领

200142066

楼主系好人，可惜偶看不懂。