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