注册 登录  
 加关注
   显示下一条  |  关闭
温馨提示!由于新浪微博认证机制调整,您的新浪微博帐号绑定已过期,请重新绑定!立即重新绑定新浪微博》  |  关闭

零售创新,创新那些事儿,SPSS,VBA

零售创新

 
 
 

日志

 
 
关于我

新浪微博,零售创新 研究经理,数据分析师 希望和市场研究和零售业的同事共同进步! 本博客发表的都是免费或试用的资料,如果有版权问题请发邮件wangli12a@163.com联系删除。 spss excel vba blog

网易考拉推荐

利用VBA将AutoCAD表格转换为Excel  

2012-03-28 11:17:50|  分类: VB和VBA知识 |  标签: |举报 |字号 订阅

  下载LOFTER 我的照片书  |

利用VBA将AutoCAD表格转换为Excel

利用VBA将AutoCAD表格转换为Excel

放在这里,供备份和参考。太长不做详细解释。
模块:MReadTable
Dim dicHorizontalLine As Variant
Dim dicVerticalLine As Variant
Dim arrText() As CText
Dim file
Const WRITE_LOG = 0
Dim WorkDrawing
Sub test()
    Dim xlApp As Excel.Application
    Dim xlBook As Excel.Workbook
    Dim xlSheet As Excel.WorkSheet
    Set xlApp = CreateObject("Excel.Application")
    Set xlBook = xlApp.Workbooks.Add
    Set xlSheet = xlBook.Worksheets(1)
    xlApp.Visible = True
  
End Sub
Sub ReadTable()
  
    'file.WriteLine "Type;Object;TagID;Position;Track;Segment;Accuracy;Note;SetupOffset"
  
    SelectionName = "ss1"
    Dim sset As AcadSelectionSet '?¨???????????ó
    Dim element As AcadEntity '?¨???????????????????ó
    For Each sset In ThisDrawing.SelectionSets
        If sset.name = SelectionName Then
            sset.Delete
            Exit For
        End If
    Next
  
    Erase arrText
    Set dicHorizontalLine = CreateObject("Scripting.Dictionary")
    Set dicVerticalLine = CreateObject("Scripting.Dictionary")
    'Set dicText = CreateObject("Scripting.Dictionary")
    Dim txt As AcadText
    Dim txtNum As Integer
    txtNum = 0
  
    Set sset = ThisDrawing.SelectionSets.Add(SelectionName) '???¨??????????
    Dim objType As String
    sset.SelectOnScreen '?á?????§????"
    If sset.Count > 0 Then
        For Each element In sset '???????????????­?·
            objType = element.ObjectName
            Select Case objType
            Case "AcDbLine"
                AddLine element.StartPoint, element.EndPoint
            Case "AcDbText"
                Set txt = element
                If 1 Then
                    On Error Resume Next
                    txtNum = UBound(arrText)
                End If
                txtNum = txtNum + 1
                ReDim Preserve arrText(1 To txtNum)
                Set arrText(txtNum) = New CText
                arrText(txtNum).TextString = txt.TextString
                Dim MinPoint, MaxPoint
                txt.GetBoundingBox MinPoint, MaxPoint
                arrText(txtNum).SetMaxPoint MaxPoint
                arrText(txtNum).SetMinPoint MinPoint
                'GetBoundingBox
            End Select
        Next
        If WRITE_LOG = 1 Then
            SaveLines dicHorizontalLine, "Horizontal"
            SaveLines dicVerticalLine, "Vertical"
          
            Dim fsObj
            Set fsObj = CreateObject("Scripting.FileSystemObject")
            Set file = fsObj.CreateTextFile(ThisDrawing.Path & "\debug.csv", True)
            file.WriteLine "Remove Horizontal..."
        End If
        RemoveShortLines dicHorizontalLine, dicVerticalLine
        If WRITE_LOG = 1 Then
            file.WriteLine "Remove Vertical..."
        End If
        RemoveShortLines dicVerticalLine, dicHorizontalLine
        'DrawLines dicHorizontalLine
        'DrawLines dicVerticalLine, False
        'DrawTexts
        ExportExcel
        If WRITE_LOG = 1 Then
            file.Close
        End If
    End If
    sset.Delete '??????????"
    'dim ttps as
    'For Each tps In dicHorizontalLine
  
    'Next
End Sub
Sub ExportExcel()
    Dim xlApp As Excel.Application
    Dim xlBook As Excel.Workbook
    Dim xlSheet As Excel.WorkSheet
    Set xlApp = CreateObject("Excel.Application")
    Set xlBook = xlApp.Workbooks.Add
    Set xlSheet = xlBook.Worksheets(1)
    '
    'dicVerticalLine
  
    Dim dicHorizontalSort
    Dim dicVerticalSort
    Set dicHorizontalSort = CreateObject("Scripting.Dictionary")
    Set dicVerticalSort = CreateObject("Scripting.Dictionary")
    SortDic dicHorizontalLine, dicHorizontalSort
    SortDic dicVerticalLine, dicVerticalSort
  
    Dim dicCells
    Set dicCells = CreateObject("Scripting.Dictionary")
  
    iHorizontal = dicHorizontalSort.Count
    iVertical = dicVerticalSort.Count
    Dim downH, upH
    Dim downV, upV
    Dim x, y
    Dim col_from, col_to, row_from, row_to
    Dim strCell As String
    Dim aCell As CCell
    Dim txt As CText
    For Each atxt In arrText
        Set txt = atxt
        'xlSheet.Cells(row, col) = txt
        'col = col + 1
        x = txt.GetMidX()
        y = txt.GetMidY()
        GetScale dicHorizontalLine, y, x, downH, upH
        GetScale dicVerticalLine, x, y, downV, upV
        'Debug.Print x, y, dicHorizontalSort(downH), dicHorizontalSort(upH), dicVerticalSort(downV), dicVerticalSort(upV)
        'Debug.Print txt.TextString, downV, x, upV, downH, y, upH
        'Debug.Print txt.TextString, dicVerticalSort(downV), x, dicVerticalSort(upV), iHorizontal - dicHorizontalSort

(downH), y, iHorizontal - dicHorizontalSort(upH)
        col_from = dicVerticalSort(downV) - 1
        col_to = dicVerticalSort(upV) - 1
        row_from = iHorizontal - dicHorizontalSort(upH)
        row_to = iHorizontal - dicHorizontalSort(downH)
      
        strCell = xlSheet.Cells(row_from + 1, col_from + 1)
        xlSheet.Range(xlSheet.Cells(row_from + 1, col_from + 1), xlSheet.Cells(row_to, col_to)).MergeCells = True
        xlSheet.Cells(row_from + 1, col_from + 1).NumberFormat = "@"
        strCell = (col_from + 1) & "-" & (row_from + 1)
        If dicCells.exists(strCell) Then
            dicCells(strCell).AddText txt
        Else
            Set aCell = New CCell
            aCell.col = col_from + 1
            aCell.row = row_from + 1
            aCell.AddText txt
            dicCells.Add strCell, aCell
        End If
    Next
  
    For Each ecell In dicCells
        Set aCell = dicCells(ecell)
        xlSheet.Cells(aCell.row, aCell.col) = aCell.GetString
    Next
        If Trim(strCell) <> "" Then
            strCell = strCell & Chr(10) & txt.TextString
        Else
            strCell = txt.TextString
        End If
        xlSheet.Cells(row_from + 1, col_from + 1) = txt.TextString
    xlApp.Visible = True
End Sub

Sub GetScale(dic, y_x, x_y, down, up)
    down = -1
    up = 9999999
    For Each v In dic
        If dic(v).IsWithin(x_y) Then
            If v > down And v < y_x Then
                down = v
            End If
            If v < up And v > y_x Then
                up = v
            End If
        End If
    Next
End Sub
Sub SortDic(dic, sort)
    'j = 0
    For Each num In dic
        i = 1
        For Each num1 In dic
            If num > num1 Then
                i = i + 1
            End If
        Next
        'j = j + 1
        sort.Add num, i
    Next
    'For Each num In sort
    '    Debug.Print num, dicHorizontalSort(num)
    'Next
End Sub

Sub SaveLines(dic, fn)
    If WRITE_LOG = 1 Then
    Dim fsObj
    Set fsObj = CreateObject("Scripting.FileSystemObject")
    Set file = fsObj.CreateTextFile(ThisDrawing.Path & "\" & fn & ".csv", True)
    file.WriteLine fn & ";Min;Max"
    For Each tp In dic
        For Each ctp In dic(tp).GetPoints
            file.WriteLine tp & ";" & ctp.MinP & ";" & ctp.MaxP
        Next
    Next
    file.Close
    End If
End Sub
Sub DrawLines(dic, Optional Horizontal As Boolean = True)
    Dim ctp As CPoint
    For Each tps In dic
        For Each tp In dic(tps).GetPoints
            Set ctp = tp
            DrawLine tps, ctp.MinP, ctp.MaxP, Horizontal
        Next
    Next
End Sub
Sub DrawTexts()
    Dim MyText As AcadText
    For Each txt In arrText
        'Set MyText = ThisDrawing.ModelSpace.AddText(txt.TextString, txt.MinPoint, 1)
    Next
End Sub
Sub DrawLine(pc, p1, p2, Optional Horizontal As Boolean = True)
    Dim sp(0 To 2) As Double
    Dim ep(0 To 2) As Double
    x_offset = 0
    y_offset = 25
    If Horizontal Then
        sp(0) = p1 + x_offset
        sp(1) = pc + y_offset
        sp(2) = 0
        ep(0) = p2 + x_offset
        ep(1) = pc + y_offset
        ep(2) = 0
    Else
        sp(0) = pc + x_offset
        sp(1) = p1 + y_offset
        sp(2) = 0
        ep(0) = pc + x_offset
        ep(1) = p2 + y_offset
        ep(2) = 0
    End If
    Dim MyLine As AcadLine
    Set MyLine = ThisDrawing.ModelSpace.AddLine(sp, ep)
End Sub
Sub RemoveShortLines(ori, ref)
    Dim ctp As CPoint
    Dim dicRemove As Variant
  
    For Each tps In ori
        Set dicRemove = CreateObject("Scripting.Dictionary")
        'i = 1
        For Each tp In ori(tps).GetPoints
            Set ctp = tp
            'Debug.Print "Remove?", tps, tp.MinP, tp.MaxP
            'strline =
            If WRITE_LOG = 1 Then
                file.WriteLine "Remove?" & ";" & tps & ";" & tp.MinP & ";" & tp.MaxP
            End If
            If Not IsBorder(ctp, ref) Then
                dicRemove.Add ctp, ""
            End If
        Next
        ori(tps).RemoveShortLines (dicRemove)
        Set dicRemove = Nothing
    Next
    For Each tps In ori
        If ori(tps).Count = 0 Then
            ori.Remove tps
        End If
    Next
End Sub
Function IsBorder(ByVal tp As CPoint, ByVal ref) As Boolean
    IsBorder = False
    For Each tps In ref
        If tps = tp.MinP Or _
            tps = tp.MaxP Then
            IsBorder = True
            Exit Function
        End If
    Next
End Function
Sub AddLine(StartPoint, EndPoint)
    NumDigits = 1
    ShortestLine = 0.3
    line_len = ((StartPoint(0) - EndPoint(0)) ^ 2 + (StartPoint(1) - EndPoint(1)) ^ 2) ^ 0.5
    If line_len < ShortestLine Then Exit Sub
    StartPoint(0) = Round(StartPoint(0), NumDigits)
    StartPoint(1) = Round(StartPoint(1), NumDigits)
    EndPoint(0) = Round(EndPoint(0), NumDigits)
    EndPoint(1) = Round(EndPoint(1), NumDigits)
  
  
    If StartPoint(0) = EndPoint(0) Then
        AddLineTo dicVerticalLine, StartPoint(0), StartPoint(1), EndPoint(1)
    End If
    If StartPoint(1) = EndPoint(1) Then
        AddLineTo dicHorizontalLine, StartPoint(1), StartPoint(0), EndPoint(0)
    End If

End Sub

Sub AddLineTo(dicLine, x_y, sp, ep)
    If dicLine.exists(x_y) Then
        dicLine(x_y).Add sp, ep
    Else
        Dim tps As CPointSet
        Set tps = New CPointSet
        tps.Add sp, ep
        dicLine.Add x_y, tps
    End If
End Sub

类:CCell
Private TextList() As CText
Public col As Integer
Public row As Integer

Public Sub AddText(txt As CText)
    Count = 0
    If 1 Then
        On Error Resume Next
        Count = UBound(TextList)
    End If
    Count = Count + 1
    ReDim Preserve TextList(1 To Count)
    Set TextList(Count) = txt
End Sub

Public Function GetString()
    On Error Resume Next
    Count = UBound(TextList)
    If Count = 1 Then
        GetString = TextList(1).TextString
        Exit Function
    End If
    GetString = ""
    Dim strList() As String, strTemp As String
    Dim yList() As Double, yTemp As Double
    ReDim strList(1 To Count)
    ReDim yList(1 To Count)
  
    For i = 1 To Count
    'For Each txt In TextList
        'GetString = GetString & Chr(10) & txt.TextString
        strList(i) = TextList(i).TextString
        yList(i) = TextList(i).GetMidY
    Next
  
    For i = 1 To Count - 1
        For j = i + 1 To Count
            If yList(i) < yList(j) Then
                yTemp = yList(i)
                yList(i) = yList(j)
                yList(j) = yTemp
                strTemp = strList(i)
                strList(i) = strList(j)
                strList(j) = strTemp
            End If
        Next
    Next
    GetString = strList(1)
    For i = 2 To Count
        GetString = GetString & Chr(10) & strList(i)
    Next
End Function

类:CPoint
Public MinP As Double
Public MaxP As Double

类:CPointSet
Public Count As Integer
Private arrPoints() As CPoint
Public Function GetPoints()
    GetPoints = arrPoints
End Function

Public Function IsWithin(v) As Boolean
    IsWithin = False
    For Each p In arrPoints
        If p.MinP <= v And p.MaxP >= v Then
            IsWithin = True
            Exit Function
        End If
    Next
End Function

Public Function RemoveShortLines(dicRemove) As Integer
    RemoveShortLines = Count
    If Count < 1 Then Exit Function
    Dim arrP() As CPoint
    ReDim arrP(1 To Count)
    j = 0
    Dim bRemove As Boolean
    For i = 1 To Count
        bRemove = False
        For Each p In dicRemove
            If p.MinP = arrPoints(i).MinP And p.MaxP = arrPoints(i).MaxP Then
                bRemove = True
            End If
        Next
        If Not bRemove Then
            j = j + 1
            Set arrP(j) = arrPoints(i)
        End If
    Next
  
    If j > 0 Then
        ReDim Preserve arrP(1 To j)
        arrPoints = arrP
    End If
  
    Count = j
    RemoveShortLines = Count
End Function
Public Function RemoveWith(ByVal cpt As CPoint) As Integer
    If Count = 0 Then
        Count = 0
        RemoveWith = 0
        Exit Function
    End If
    iRemoveAt = 0
  
    For i = 1 To Count
        If arrPoints(i).MaxP = cpt.MaxP And arrPoints(i).MinP = cpt.MinP Then
            iRemoveAt = i
            Exit For
        End If
    Next
    If iRemoveAt > 0 Then
        Count = Count - 1
        If Count > 0 Then
            'If iRemoveAt <= Count Then
                For j = iRemoveAt To Count
                    arrPoints(j).MaxP = arrPoints(j + 1).MaxP
                    arrPoints(j).MinP = arrPoints(j + 1).MinP
                Next
            'End If
            ReDim Preserve arrPoints(1 To Count)
        Else
            Count = 0
            'ReDim arrPoints()
        End If
    End If
    RemoveWith = Count
End Function


Public Sub Add(Point1, Point2)
    If Point1 > Point2 Then
        MinP = Point2
        MaxP = Point1
    Else
        MinP = Point1
        MaxP = Point2
    End If
  
    If Count > 0 Then
        For Each point In arrPoints
            If point.MaxP = MinP Then
                point.MaxP = MaxP
                Exit Sub
            End If
            If point.MinP = MaxP Then
                point.MinP = MinP
                Exit Sub
            End If
            If point.MaxP = MaxP And point.MinP = MinP Then Exit Sub
        Next
    End If
    Count = Count + 1
    ReDim Preserve arrPoints(1 To Count)
    Set arrPoints(Count) = New CPoint
    arrPoints(Count).MinP = MinP
    arrPoints(Count).MaxP = MaxP
  
End Sub

类:CText
Private MinPoint(0 To 2) As Double
Private MaxPoint(0 To 2) As Double
Public TextString As String

Public Sub SetMinPoint(p)
    MinPoint(0) = p(0)
    MinPoint(1) = p(1)
    MinPoint(2) = p(2)
End Sub

Public Sub SetMaxPoint(p)
    MaxPoint(0) = p(0)
    MaxPoint(1) = p(1)
    MaxPoint(2) = p(2)
End Sub

Public Function GetMinPoint()
    GetMinPoint = MinPoint
End Function

Public Function GetMaxPoint()
    GetMaxPoint = MaxPoint()
End Function

Public Function GetMidX()
    GetMidX = (MinPoint(0) + MaxPoint(0)) / 2
End Function
Public Function GetMidY()
    GetMidY = (MinPoint(1) + MaxPoint(1)) / 2
End Function

不完善的地方:
1.没有用Set Get定义类的属性
2.没有用算法去合并某一行或某一列所有的表格线,只是对首尾能够连接上的做了处理

 

  评论这张
 
阅读(698)| 评论(0)
推荐 转载

历史上的今天

在LOFTER的更多文章

评论

<#--最新日志,群博日志--> <#--推荐日志--> <#--引用记录--> <#--博主推荐--> <#--随机阅读--> <#--首页推荐--> <#--历史上的今天--> <#--被推荐日志--> <#--上一篇,下一篇--> <#-- 热度 --> <#-- 网易新闻广告 --> <#--右边模块结构--> <#--评论模块结构--> <#--引用模块结构--> <#--博主发起的投票-->
 
 
 
 
 
 
 
 
 
 
 
 
 
 

页脚

网易公司版权所有 ©1997-2017