这是天正电气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 = xlVertical

End Function


Public 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 If

End Function


Public 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 Function

Public 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 = xlNone

End Function

Public 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 = Nothing

End Sub