autocad (dwg) to excel

[shamsam1]

here is code to extract block attributes to actocad using vb.6..
but i need to code to extract the dimesions value or mtext without opening outocad..

add reference for autocad and excel

 
Sub Extract()
    Row = 2
    col = 1
    ' Form1.Cls
    Dim sheet As Object
    Dim shapes As Object
    Dim elem As Object
    Dim excel As Object
    Dim Max As Integer
    Dim Min As Integer
    Dim NoOfIndices As Integer
    Dim excelSheet As Object
    Dim RowNum As Integer
    Dim Array1 As Variant
    Dim Count As Integer
    Dim Teller As Integer
    Dim Teller1 As Integer
    Dim str() As String
    Screen.MousePointer = vbHourglass
    For i = 0 To List2.ListCount - 1
        Text6.Text = i
        Text7.Text = List2.List(i)
        procOpenDrawing
        Set Doc = acad.ActiveDocument
        Set mspace = Doc.ModelSpace
        RowNum = 1
        Dim Header As Boolean
        Header = False
        Teller = 0
        Teller1 = 0
        Text1.Text = ""
        Text2.Text = ""
        Text3.Text = ""
        Text4.Text = ""
        ' Text5.Text = ""
        List1.Clear
        For Each elem In mspace
            With elem
                If StrComp(.EntityName, "AcDbBlockReference", 1) = 0 Then
                    If .HasAttributes Then
                        Teller = Teller + 1
                        Array1 = .GetAttributes
                        ' Text1.Text = Text1.Text & vbNewLine & " ****** Read the TAGS ***** " & vbNewLine
                        ' For Count = LBound(Array1) To UBound(Array1)
                            ' If Header = False Then
                                ' If StrComp(Array1(Count).EntityName, "AcDbBlockReference", 1) = 0 Then
                                    ' Text1.Text = Text1.Text & Array1(Count).TagString & vbNewLine
                                ' End If
                            ' End If
                            ' Debug.Print
                        ' Next Count
                        RowNum = RowNum + 1
                        ' Text1.Text = Text1.Text & vbNewLine & " ****** Read the VALUE ***** " & vbNewLine
                        str1 = ""
                        For Count = LBound(Array1) To UBound(Array1)
                            Teller1 = Teller1 + 1
                            str1 = Array1(Count).tagstring
                            If str1 = "Materiale" Or str1 = UCase("Materiale") Then
                                Text2.Text = Text2.Text & Array1(Count).textstring
                            ElseIf str1 = "BesKrivelse1" Or str1 = UCase("BesKrivelse1") Or _
                                str1 = "BesKrivelse2" Or str1 = UCase("BesKrivelse2") Or _
                                str1 = "BesKrivelse3" Or _
                                str1 = UCase("BesKrivelse3") Then
                                Text3.Text = Array1(Count).textstring
                                If Val(Text3.Text) Then
                                    str = Split(Text3.Text, "x")
                                    For intLoop1 = LBound(str) To UBound(str)
                                        List1.AddItem (Val(str(intLoop1)))
                                    Next intLoop1
                                End If
                            ElseIf str1 = "Tegningsnr" Or str1 = UCase("Tegningsnr") Then
                                Text4.Text = Array1(Count).textstring
                            ElseIf str1 = "Varenr" Or str1 = UCase("Varenr") Then
                                Text1.Text = Array1(Count).textstring
                            End If
                        Next Count
                        Debug.Print
                        Header = True
                    End If
                End If
            End With
        Next elem
        ' myexcel.ActiveSheet.Cells(row, col).HorizontalAlignment = xlCenter
        ' myexcel.ActiveSheet.Cells(row, col).Font.Bold = True
        ' myexcel.Visible = True
        myexcel.ActiveSheet.Cells(Row, col) = Text1.Text
        myexcel.ActiveSheet.Cells(Row, col + 1) = Text2.Text
        myexcel.ActiveSheet.Cells(Row, col + 3) = List1.List(0)
        myexcel.ActiveSheet.Cells(Row, col + 4) = List1.List(1)
        myexcel.ActiveSheet.Cells(Row, col + 5) = List1.List(2)
        myexcel.ActiveSheet.Cells(Row, col + 6) = Text4.Text
        Row = Row + 1
        col = 1
    Next i
    NumberOfAttributes = RowNum - 1
    If NumberOfAttributes > 0 Then
    Else
        MsgBox "No attributes found in the current drawing"
    End If
    Set acad = Nothing
    ' Me.SetFocus
    Screen.MousePointer = vbNormal
End Sub