|
|
看看这一段程序
'----------------------------????BOM?????--------------------------
Private Function TableToExcel(ByVal part As ModelDoc2, _
ByVal inExcelName As String) As Boolean
Dim exCOUNT As Integer
Dim swBomFeat As SldWorks.BomFeature
Dim vTableArr As Variant
Dim vTable As Variant
Dim swTable As Variant
Dim swFeat As SldWorks.feature
Dim swWeldmentCutListFeat As SldWorks.WeldmentCutListFeature
Dim vWeldCutListAnnotations As Variant
Dim WeldForI As Integer
Dim WeldForJ As Integer
Dim a1 As Integer
Dim a2 As Integer
Dim s As String
Dim s1 As String
Dim s2 As String
Dim f1 As Single
Dim f2 As Single
Dim ExcelName As String
Dim textName As String
Dim oRes As New ADODB.Recordset
Dim oConn As New ADODB.Connection
Dim myTable() As String
Dim bTableIn As Boolean '??????д??
Dim c1 As String '????????
Dim SQLstr As String '??????SQL????
On Error GoTo ToExcelErr
bTableIn = False
ExcelName = inExcelName + ".xls"
Set swFeat = part.FirstFeature
Do While Not swFeat Is Nothing
If swFeat.GetTypeName = "BomFeat" Then
'--------------- ????????????----------
Set swBomFeat = swFeat.GetSpecificFeature2
vTableArr = swBomFeat.GetTableAnnotations
For Each vTable In vTableArr
Set swTable = vTable
exCOUNT = swTable.RowCount - 2
bTableIn = True
ReDim myTable(0 To exCOUNT, 0 To 8) As String '????????
For a1 = 0 To exCOUNT
For a2 = 0 To swTable.ColumnCount
If IsNull(swTable.text(a1, a2)) Then
s = " "
Else
s = swTable.text(a1, a2)
'If Len(s) = 0 Then s = " "
End If
myTable(a1, a2) = s
Next a2
Next a1
Next vTable
End If
If swFeat.GetTypeName = "WeldmentTableFeat" Then
'-----------------?????и?????????-----------
Set swWeldmentCutListFeat = swFeat.GetSpecificFeature2
vWeldCutListAnnotations = swWeldmentCutListFeat.GetTableAnnotations
WeldForJ = vWeldCutListAnnotations(0).ColumnCount - 1
exCOUNT = vWeldCutListAnnotations(0).RowCount - 2
bTableIn = True
ReDim myTable(0 To exCOUNT, 0 To 8) As String
For a1 = 0 To exCOUNT
For a2 = 0 To WeldForJ
If IsNull(vWeldCutListAnnotations(0).text(a1, a2)) Then
s = " "
Else
s = vWeldCutListAnnotations(0).text(a1, a2)
'If Len(s) = 0 Then s = " "
End If
myTable(a1, a2) = s
Next a2
Next a1
'????????????????????????????????(?????????????)???,???????????????????
For a1 = 0 To exCOUNT
s = myTable(a1, 6)
s1 = myTable(a1, 7)
If Len(Trim(s)) > 0 Then
If Len(Trim(s1)) = 0 Then
myTable(a1, 7) = "L=" & s
Else
myTable(a1, 4) = myTable(a1, 5) + " L=" + s
End If
End If
Next a1
End If
Set swFeat = swFeat.GetNextFeature
Loop
If bTableIn Then '??????????????????????excel???
For a1 = 0 To exCOUNT '????????[3] X [5]?????
s = myTable(a1, 3)
s1 = myTable(a1, 5)
If Len(Trim(s)) > 0 Then
f1 = CSng(s)
Else
f1 = 0
End If
If Len(Trim(s1)) > 0 Then
f2 = CSng(s1)
Else
f2 = 0
End If
myTable(a1, 6) = Format(f1 * f2, "##0.00")
Next a1
DeleteFile ExcelName '??????·???е?????????????
oConn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & ExcelName & ";Extended Properties=""Excel 8.0;"""
oRes.Open "CREATE TABLE a (IndexID TEXT,PCPNO TEXT,PCPName TEXT,Amount TEXT,MaterialName TEXT,Weight TEXT,Tweight TEXT,Remark TEXT,Source TEXT)", oConn, adOpenStatic
For a1 = exCOUNT To 0 Step -1
s = "IndexID,PCPNO,PCPName,Amount,MaterialName,Weight,Tweight,Remark"
s2 = ""
c1 = """"
For a2 = 0 To 7
myTable(a1, a2) = c1 & myTable(a1, a2) & c1
s2 = s2 & myTable(a1, a2) & "," '???????????????
Next a2
s2 = Left(s2, Len(s2) - 1)
SQLstr = "INSERT INTO a (" & s & ") VALUES (" & s2 & ")"
oRes.Open SQLstr, oConn, adOpenStatic
Next a1
oConn.Close
End If
TableToExcel = True
Exit Function
ToExcelErr:
TableToExcel = False
End Function
复制代码 |
|
发表于 2018-11-1 15:52:06
QQ好友和群
QQ空间
腾讯微博
腾讯朋友
收藏
转播
教程|习题|模型|技巧
点赞
拍砖
鲁公网安备 37028502190335号