CAD表格转换至Excel

wenwengg

Public xlApp As Excel.Application
Public xlWork As Excel.Workbook
Public xlSheet As Excel.Worksheet

Function OpenExcel() As Boolean
  On Error Resume Next
  If xlApp Is Nothing Then
    Set xlApp = GetObject(, "Excel.Application")
  End If
  If xlApp Is Nothing Then
'  Set xlApp = GetObject(, "Excel.Application")
'  If Err.Number <> 0 Then
    On Error GoTo OpenExcelFaild
    Set xlApp = CreateObject("Excel.Application")
  End If
  OpenExcel = True
  Exit Function
OpenExcelFaild:
  OpenExcel = False
End Function

Private Sub cmdPickup_Click()
    On Error Resume Next
    ThisDrawing.SelectionSets.Item("sHLine").Delete
    ThisDrawing.SelectionSets.Item("sVLine").Delete
    ThisDrawing.SelectionSets.Item("ss").Delete
    On Error GoTo 0
    Dim pt(0 To 2) As Double, pt1(0 To 2) As Double
    Dim seldata(0) As Variant, selcode(0) As Integer
    Dim gpdata As Variant, gpcode As Variant
    Dim ret As Variant
    Dim sel As AcadSelectionSet
    Dim shl As AcadSelectionSet, svl As AcadSelectionSet
    Dim i As Long, j As Long
    Dim obj As AcadEntity, objLine As AcadLine
    Dim minpt As Variant, maxpt As Variant
    Dim addobj(0) As AcadEntity
    Dim x As Double, y As Double, x0 As Double
    Dim x1 As Double, y1 As Double
    Dim n1 As Long, n2 As Long
    Dim s As String, np As Long, nf As Long
    With ThisDrawing
        Me.Hide
        ret = .Utility.GetPoint(, "指定左上角：")
        SetRet ret, pt
        ret = .Utility.GetCorner(pt, "指定对角点：")
        SetRet ret, pt1
        Set sel = .SelectionSets.Add("ss")
        selcode(0) = 0: gpcode = selcode
        seldata(0) = "Line": gpdata = seldata
        sel.Select acSelectionSetCrossing, pt, pt1, gpcode, gpdata
        lv.ListItems.Clear
        lv.ColumnHeaders.Clear
        Set shl = .SelectionSets.Add("sHLine")
        Set svl = .SelectionSets.Add("sVLine")
        For Each obj In sel
            obj.GetBoundingBox minpt, maxpt
            Set addobj(0) = obj
            If Abs(minpt(0) - maxpt(0)) > Abs(minpt(1) - maxpt(1)) Then
                shl.AddItems addobj
            Else
                svl.AddItems addobj
            End If
        Next
        Sort shl, 0
        Sort svl, 1
        n1 = shl.count
        n2 = svl.count
        lb.Caption = "选择了" & vbCrLf & n1 & "行水平线" & vbCrLf & n2 & "行垂直线"
        If n1 > 0 And n2 > 0 Then
            For i = 1 To n2
                lv.ColumnHeaders.Add , , "col" & i
            Next
            lv.ColumnHeaders.Item(1).Text = "No."
            lv.ColumnHeaders.Item(1).Width = 30
            Set obj = svl.Item(0)
            obj.GetBoundingBox minpt, maxpt
            x0 = minpt(0)
            If x0 > pt(0) Then
                lv.ColumnHeaders.Add , , "col" & lv.ColumnHeaders.count + 1
                np = 1
                x0 = pt(0)
            End If
            Set obj = svl.Item(n2 - 1)
            obj.GetBoundingBox minpt, maxpt
            x = minpt(0)
            If x < pt1(0) Then
                lv.ColumnHeaders.Add , , "col" & lv.ColumnHeaders.count + 1
                nf = 1
            End If
            x = x0
            Set obj = shl.Item(0)
            obj.GetBoundingBox minpt, maxpt
            y = minpt(1)
            For i = 1 To n1 - 1
                lv.ListItems.Add , , i
                Set obj = shl.Item(i)
                obj.GetBoundingBox minpt, maxpt
                y1 = minpt(1)
                If np = 1 Then
                    Set obj = svl.Item(0)
                    obj.GetBoundingBox minpt, maxpt
                    x1 = minpt(0)
                    s = GetText(x, y, x1, y1)
                    lv.ListItems(i).SubItems(1) = s
                    x = x1
                End If
                For j = 1 To n2 - 1
                    Set obj = svl.Item(j)
                    obj.GetBoundingBox minpt, maxpt
                    x1 = minpt(0)
                    s = GetText(x, y, x1, y1)
                    lv.ListItems(i).SubItems(j + np) = s
                    x = x1
                Next
                If nf = 1 Then
                    x1 = pt1(0)
                    s = GetText(x, y, x1, y1)
                    lv.ListItems(i).SubItems(j + np) = s
                End If
    Debug.Print
                x = x0
                y = y1
            Next
        End If
               
        .SelectionSets.Item("sHLine").Delete
        .SelectionSets.Item("sVLine").Delete
        .SelectionSets.Item("ss").Delete
        Me.Show
       
    End With
End Sub

wenwengg

wenwengg

已经取消了密码

jubuhui

很好，有点遗憾的是代码是vb编写，而不是vc，只好动手转成vc

style6301

请大家看一下贴子：《怎么样才能通过VBA程序将这些统计数据写入DBF文件中。（已建有相同字段的D:\CYC\DeckP.dbf文件）》

帮忙解决一下燃眉之急，谢谢！

surveyhpu

很不错，只是有点遗憾，在单元格边线错开时，提取出来的文本就重复读取。

兰州人

专门研究此帖子。

745016342

hhhhhhhhh

taizih

好东西 ，学习 向楼主的无私致敬

haifeng168

改进一下那就更好了，呵呵