天正电气6.0和autocad2005和excel2003的互相导入

这是天正电气6.0的表格导入和导出完整代码。</span>

Public Function merge(str1 As String, str2 As String)    Excel.Range(str1 & ":" & str2).Select         Excel.Selection.merge    Excel.Selection.VerticalAlignment = xlVAlignCenter    Excel.Selection.HorizontalAlignment = xlCenter    Excel.Selection.Orientation = xlVerticalEnd FunctionPublic Function quit()    Dim ret As Integer    ret = MsgBox("是否关闭并保存Excel？", vbYesNo)    If (ret = vbYes) Then        Dim strname As String        strname = InputBox("please input excel file name")        ExcelWorkbook.SaveAs strname        Excel.Application.quit        Set Excel = Nothing        End IfEnd FunctionPublic Function border(str1 As String, str2 As String)    Excel.Range(str1 & ":" & str2).Select          Excel.Selection.Borders(xlDiagonalDown).LineStyle = xlNone    Excel.Selection.Borders(xlDiagonalUp).LineStyle = xlNone    With Excel.Selection.Borders(xlEdgeLeft)        .LineStyle = xlContinuous        .Weight = xlThin        .ColorIndex = xlAutomatic    End With    With Excel.Selection.Borders(xlEdgeTop)        .LineStyle = xlContinuous        .Weight = xlThin        .ColorIndex = xlAutomatic    End With    With Excel.Selection.Borders(xlEdgeBottom)        .LineStyle = xlContinuous        .Weight = xlThin        .ColorIndex = xlAutomatic    End With    With Excel.Selection.Borders(xlEdgeRight)        .LineStyle = xlContinuous        .Weight = xlThin        .ColorIndex = xlAutomatic    End With    With Excel.Selection.Borders(xlInsideVertical)        .LineStyle = xlContinuous        .Weight = xlThin        .ColorIndex = xlAutomatic    End With    With Excel.Selection.Borders(xlInsideHorizontal)        .LineStyle = xlContinuous        .Weight = xlThin        .ColorIndex = xlAutomatic    End With  End FunctionPublic Function Border_bold(str1 As String, str2 As String)    Excel.Range(str1 & ":" & str2).Select    Excel.Selection.Borders(xlDiagonalDown).LineStyle = xlNone    Excel.Selection.Borders(xlDiagonalUp).LineStyle = xlNone    With Excel.Selection.Borders(xlEdgeLeft)        .LineStyle = xlContinuous        .Weight = xlMedium        .ColorIndex = xlAutomatic    End With    With Excel.Selection.Borders(xlEdgeTop)        .LineStyle = xlContinuous        .Weight = xlMedium        .ColorIndex = xlAutomatic    End With    With Excel.Selection.Borders(xlEdgeBottom)        .LineStyle = xlContinuous        .Weight = xlMedium        .ColorIndex = xlAutomatic    End With    With Excel.Selection.Borders(xlEdgeRight)        .LineStyle = xlContinuous        .Weight = xlMedium        .ColorIndex = xlAutomatic    End With    Excel.Selection.Borders(xlInsideVertical).LineStyle = xlNone    Excel.Selection.Borders(xlInsideHorizontal).LineStyle = xlNoneEnd FunctionPublic Function writeExcel()    Dim returnObj As ComSheet    Dim sheet As Integer        Dim basePnt As Variant    Dim rangeRow As Integer    Dim rangeColumn As Integer    Dim rangeRowMax As Integer    Dim rangeColumnMax As Integer    Dim cell1 As Object    Dim cell2 As Object        On Error Resume Next     Set Excel = CreateObject("Excel.Application")                   Set ExcelWorkbook = Excel.Workbooks.Add    Set ExcelSheet = Excel.ActiveSheet    Excel.Visible = True          On Error Resume Next        ' The following example waits for a selection from the user     ThisDrawing.Utility.GetEntity returnObj, basePnt, "Select an object"    Dim name    name = returnObj.ObjectName    Dim str As String    str = returnObj.TextString        If Not (name = "TDbSheet") Then        Exit Function    End If        nRowNum = returnObj.RowNum    nColumnNum = returnObj.ColumnNum        For j = 0 To nColumnNum - 1 Step 1        For i = 0 To nRowNum - 1 Step 1            If (returnObj.IsRange(i, j)) Then                rangeRow = returnObj.rangeRow(i, j)                rangeColumn = returnObj.rangeColumn(i, j)                rangeRowMax = returnObj.rangeRowMax(i, j)                rangeColumnMax = returnObj.rangeColumnMax(i, j)                Set cell1 = ExcelSheet.Cells(rangeRow + 1, rangeColumn + 1)                Set cell2 = ExcelSheet.Cells(rangeRowMax + 1, rangeColumnMax + 1)                Excel.Range(cell1, cell2).Select                     Excel.Selection.merge                Excel.Selection.VerticalAlignment = xlVAlignCenter                Excel.Selection.HorizontalAlignment = xlCenter                'Excel.Selection.Orientation = xlVertical                                End If            ExcelSheet.Cells(i + 1, j + 1).Value = returnObj.Text(i, j)        Next i    Next j                returnObj.Color = acRed        End Function Public Sub readExcel()    Dim Excel_cad As Excel.Application    Dim ExcelSheet_cad As Object    On Error Resume Next        Set Excel_cad = GetObject(, "Excel.Application")    If Err <> 0 Then        MsgBox ("请先打开一EXCEL文件，并框选中要复制的单元格。")        Set Excel_cad = Nothing        Exit Sub    End If    Dim sheet As ComSheet    Set ExcelSheet_cad = Excel_cad.ActiveSheet         Dim rowStart As Integer    Dim columnStart As Integer    rowStart = Excel_cad.Selection.row             '起点    columnStart = Excel_cad.Selection.column       '起点         Set sheet = New ComSheet    Dim row As Integer    Dim col As Integer    sheetrow = Excel_cad.Selection.Rows.Count    sheetcol = Excel_cad.Selection.Columns.Count    If (sheetrow < 1 Or sheetcol < 1) Then        Set ExcelSheet_cad = Nothing        Set Excel_cad = Nothing        Exit Sub    End If        Dim ret As Integer    ret = MsgBox("是否在图中新建一表格？Y-新建，N-更新(注意行列匹配)。", vbYesNo)    If (ret = vbNo) Then        ThisDrawing.Utility.GetEntity sheet, basePnt, "Select an object"        Dim name        name = sheet.ObjectName                 nRowNum = returnObj.RowNum        nColumnNum = returnObj.ColumnNum            If Not (name = "TDbSheet") Then            MsgBox ("选择失败！ 请正确选择天正表格。")            Set ExcelSheet_cad = Nothing            Set Excel_cad = Nothing            Exit Sub        End If        If (sheetrow <> sheet.RowNum) Or (sheetcol <> sheet.ColumnNum) Then            MsgBox ("表格行数或列数不匹配！ 请正确选择天正表格。")            Set ExcelSheet_cad = Nothing            Set Excel_cad = Nothing            Exit Sub        End If              '先把合并单元格恢复        For j = 0 To sheetrow - 1 Step 1            For i = 0 To sheetcol - 1 Step 1                Dim IsMerged As Boolean                IsMerged = sheet.IsRange(j, i)                If (IsMerged = True) Then                    sheet.ExplodeCell j, i                Else                    '我自己添加的else，目的是不管有没有合并的单元格都执行下边的语句，和保存是否成功有关系。2015-9-19                    sheet.ExplodeCell j, i                End If             Next i        Next j        Else        sheet.Create sheetrow, sheetcol    End If                                   For j = 0 To sheetrow - 1 Step 1        For i = 0 To sheetcol - 1 Step 1            Dim str As String            Dim r As Range            Dim IsMerge As Boolean            flag = ExcelSheet_cad.Cells(rowStart + j, columnStart + i).MergeCells            IsMerge = sheet.IsRange(j, i)            If (flag = True And IsMerge = False) Then                Set r = ExcelSheet_cad.Cells(rowStart + j, columnStart + i).MergeArea                MergeStartR = r.row - rowStart        '相对于TDbSheet                MergeStartC = r.column - columnStart                MergeCNum = r.Columns.Count                MergeRNum = r.Rows.Count                sheet.merge MergeStartR, MergeStartC, MergeRNum, MergeCNum            End If            If (IsMerge = False) Then               str = ExcelSheet_cad.Cells(rowStart + j, columnStart + i).Text ' sr modify by .Value 2004/6/14               sheet.SetCellText j, i, str            End If        Next i    Next j    ThisDrawing.Regen (acAllViewports)        'Excel.Application.quit    Set ExcelSheet_cad = Nothing    Set Excel_cad = Nothing         End Sub Public Sub sheet2Excel()    Dim OpenFlag As Boolean    OpenFlag = True        Dim Excel_cad As Excel.Application    Dim ExcelSheet_cad As Object    Dim ExcelWorkbook_cad As Object    Dim returnObj As ComSheet    Dim sheet As Integer        Dim basePnt As Variant    Dim rangeRow As Integer    Dim rangeColumn As Integer    Dim rangeRowMax As Integer    Dim rangeColumnMax As Integer    Dim cell1 As Object    Dim cell2 As Object        On Error Resume Next     Dim rowStart As Integer    Dim columnStart As Integer    rowStart = 1            '起点    columnStart = 0         '起点         ' The following example waits for a selection from the user     ThisDrawing.Utility.GetEntity returnObj, basePnt, "Select an object"    Dim name    name = returnObj.ObjectName    If Not (name = "TDbSheet") Then        Exit Sub    End If        nRowNum = returnObj.RowNum                'ComSheet行数    nColumnNum = returnObj.ColumnNum          'ComSheet列数    '    Dim ret As Integer'    ret = MsgBox("是否在图中新建一Excel表单？Y-新建，N-更新已有表单的选中区域(注意行列匹配)。", vbYesNo)'    If (ret = vbNo) Then'        On Error Resume Next'        Set Excel_cad = GetObject(, "Excel.Application")'        If Err <> 0 Then'            MsgBox ("请先打开一EXCEL文件，并框选中要复制的单元格。")'            Set Excel_cad = Nothing'            Exit Sub'        End If''        OpenFlag = False'        rowStart = Excel_cad.Selection.row             '起点'        columnStart = Excel_cad.Selection.column       '起点'        sheetrow = Excel_cad.Selection.Rows.Count'        sheetcol = Excel_cad.Selection.Columns.Count'        If (sheetrow <> nRowNum) Or (sheetcol <> nColumnNum) Then'            MsgBox ("所选EXCEL表格与天正表格行数或列数不匹配！")'            Set Excel_cad = Nothing'        End If'    Else        OpenFlag = True        Set Excel_cad = CreateObject("Excel.Application")        Set ExcelWorkbook_cad = Excel_cad.Workbooks.Add    'End If    Set ExcelSheet_cad = Excel_cad.ActiveSheet        '标题    Set cell1 = ExcelSheet_cad.Cells(rowStart, columnStart + 1)    Set cell2 = ExcelSheet_cad.Cells(rowStart, columnStart + nColumnNum)        Excel_cad.Range(cell1, cell2).Select    Excel_cad.Selection.merge    Excel_cad.Selection.VerticalAlignment = xlVAlignCenter    Excel_cad.Selection.HorizontalAlignment = xlCenter    Excel_cad.Cells(rowStart, columnStart + 1).Value = returnObj.Title                For j = 0 To nColumnNum - 1 Step 1        For i = 0 To nRowNum - 1 Step 1            If (OpenFlag = True) Then               If (returnObj.IsRange(i, j)) Then                   rangeRow = returnObj.rangeRow(i, j)                   rangeColumn = returnObj.rangeColumn(i, j)                   If (i = rangeRow And j = rangeColumn) Then                        rangeRowMax = returnObj.rangeRowMax(i, j)                        rangeColumnMax = returnObj.rangeColumnMax(i, j)                        Set cell1 = ExcelSheet_cad.Cells(rangeRow + rowStart + 1, rangeColumn + columnStart + 1)                        Set cell2 = ExcelSheet_cad.Cells(rangeRowMax + rowStart + 1, rangeColumnMax + columnStart + 1)                        If returnObj.TextColor(i, j) > 0 Then                             Excel_cad.Range(cell1, cell2).Interior.Color = returnObj.TextColor(i, j)                             Excel_cad.Range(cell1, cell2).Interior.Pattern = xlSolid                        End If                        Excel_cad.Range(cell1, cell2).Select                        Excel_cad.Selection.merge                        Excel_cad.Selection.VerticalAlignment = xlVAlignCenter                        Excel_cad.Selection.HorizontalAlignment = xlCenter                    End If               Else                   If returnObj.TextColor(i, j) > 0 Then                      ExcelSheet_cad.Cells(i + rowStart + 1, j + columnStart + 1).Interior.Color = returnObj.TextColor(i, j)                      ExcelSheet_cad.Cells(i + rowStart + 1, j + columnStart + 1).Interior.Pattern = xlSolid                   End If               End If               ExcelSheet_cad.Cells(i + rowStart + 1, j + columnStart + 1).Value = returnObj.Text(i, j)            Else                ExcelSheet_cad.Cells(i + rowStart, j + columnStart).Value = returnObj.Text(i, j)            End If        Next i    Next j        Excel_cad.Visible = True    Set ExcelWorkbook_cad = Nothing    Set ExcelSheet_cad = Nothing    Set Excel_cad = NothingEnd Sub