Bom to File .txt or Bom to File .xls(Excel) (DS SolidWorks/SolidWorks)

'-----------------------------------------------------------
' Bom to File .txt or Bom to File .xls(Excel) '
' Autor: Ing.Sup.Mec. Pedro Omar Sánchez Curbelo (swPeter) '
' Sevilla. Spain. 28 July 2005 '
'-----------------------------------------------------------

Option Explicit

' PasteSpecial of Excel
'Public Const xlPasteSpecialOperationAdd = 2
'Public Const xlPasteAll = -4104

' Used to be TYPE_DRAWING
Public Const swDocDRAWING = 3

Public swViewBOM As SldWorks.BomTable 'Object '
Public nNumRow As Long
Public nNumCol As Long

Public xlsApp As Object 'Excel.Application '

Public Const CF_TEXT = 1
Public Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
Public Declare Function CloseClipboard Lib "user32" () As Long
Public Declare Function OpenClipboard Lib "user32" (ByVal hWnd As Long) As Long
Public Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As Long) As Long
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDst As Any, pSrc As Long, ByVal ByteLen As Long)

Public Declare Function ShellExecute Lib "Shell32.Dll" Alias "ShellExecuteA" (ByVal hWnd As Long, ByVal pOperation As String, ByVal pFile As String, ByVal pParameters As String, ByVal pdirectory As String, ByVal nShowCmd As Long) As Long

Public Function AttachBOM() As Boolean

Dim xlsWB As Object 'Excel.Workbook '
Dim xlsSht As Object 'Excel.Worksheet '
Dim ObjRange As Object 'Excel.Range '

If swViewBOM.Attach3 Then
nNumRow = swViewBOM.GetTotalRowCount
nNumCol = swViewBOM.GetTotalColumnCount
Set xlsApp = GetObject(, "Excel.Application")
If Not xlsApp Is Nothing Then
Set xlsWB = xlsApp.ActiveWorkbook
If Not xlsWB Is Nothing Then
Set xlsSht = xlsWB.Sheets(1)
If Not xlsSht Is Nothing Then
Set ObjRange = xlsWB.Sheets(1).Range(xlsWB.Sheets(1).Cells(1, 1), xlsWB.Sheets(1).Cells(nNumRow, nNumCol))
If Not ObjRange Is Nothing Then
ObjRange.Copy
Set ObjRange = Nothing
AttachBOM = True
End If
Set xlsSht = Nothing
Else
MsgBox "Error attacking the Sheet in Excel"
End If
Set xlsWB = Nothing
Else
MsgBox "There is no active Workbook"
End If
'Set xlsApp = Nothing
Else
MsgBox "It was not possible to be connected with Excel"
End If
swViewBOM.Detach
Set swViewBOM = Nothing
Else
MsgBox "Error attacking the BOM"
End If

End Function

Sub main()

Dim swApp As SldWorks.SldWorks 'Object '
Dim swModel As SldWorks.ModelDoc2 'Object '
Dim swDraw As SldWorks.DrawingDoc 'Object '
Dim swView As SldWorks.View 'Object '
Dim swView_Name As String
Dim bRet As Boolean
Dim I As Long
Dim sPathName As String
Dim nPos As Long
Dim sfolderDoc As String
Dim NewBook As Object 'Excel.Workbook '
Dim ObjRange As Object 'Excel.Range '
Dim FileBOM As Boolean
Dim ObjExcel As Object
Dim Fs As Object
Dim iRet As Integer

Dim LngClipBoard As Long
Dim TxT As Object
Dim hStrPtr As Long
Dim lLength As Long
Dim sBuffer As String
Dim FileTxTBOM As Boolean
Dim sPathFile As String

Set swApp = GetObject(, "SldWorks.Application")
If Not swApp Is Nothing Then
Set swModel = swApp.ActiveDoc
If Not swModel Is Nothing Then
If swModel.GetType = swDocDRAWING Then
sPathName = swModel.GetPathName
If sPathName <> "" Then
nPos = InStrRev(sPathName, ".")
sfolderDoc = Left$(sPathName, nPos - 1)
Set swDraw = swModel
Set swView = swDraw.GetFirstView
Set swView = swView.GetNextView
Do While Not swView Is Nothing
swView_Name = swView.Name
bRet = swModel.Extension.SelectByID2(swView_Name, "DRAWINGVIEW", 0, 0, 0, False, 0, Nothing, 0)
If bRet <> False Then
Set swViewBOM = swView.GetBomTable
If Not swViewBOM Is Nothing Then
If AttachBOM Then

Set Fs = CreateObject("Scripting.FileSystemObject")
If Not Fs Is Nothing Then
Set TxT = Fs.CreateTextFile(sfolderDoc & "_BOM " & CStr(I) & ".txt", True)
If Not TxT Is Nothing Then
LngClipBoard = OpenClipboard(0)
If LngClipBoard Then
hStrPtr = GetClipboardData(CF_TEXT)
If hStrPtr <> 0 Then
lLength = lstrlen(hStrPtr)
If lLength > 0 Then
sBuffer = Space$(lLength)
CopyMemory ByVal sBuffer, ByVal hStrPtr, lLength
TxT.WriteLine (sBuffer)
FileTxTBOM = True
TxT.Close
Set TxT = Nothing
Set Fs = Nothing
End If
End If
CloseClipboard
End If
End If
End If

'Set NewBook = xlsApp.Workbooks.Add
'If Not NewBook Is Nothing Then
'I = I + 1
'NewBook.SaveAs sfolderDoc & "_BOM " & CStr(I) & ".xls"
'Set ObjRange = NewBook.Sheets(1).Range(NewBook.Sheets(1).Cells(1, 1), NewBook.Sheets(1).Cells(nNumRow, nNumCol))
'ObjRange.PasteSpecial 'xlPasteAll, xlPasteSpecialOperationAdd, 0, 0
'Set ObjRange = Nothing
'NewBook.Save
'NewBook.Close
'Set NewBook = Nothing
'Set xlsApp = Nothing
'FileBOM = True
'End If

End If
End If
End If
Set swView = swView.GetNextView
Loop
Set swView = Nothing
Set swDraw = Nothing
Set swModel = Nothing
Else
MsgBox "First save this document"
End If
Else
MsgBox "Only Allowed on document DRAWs"
End If
Else
MsgBox "There is no active document"
End If
Set swApp = Nothing
Else
MsgBox "It was not possible to be connected with SolidWorks"
End If

'If FileBOM Then
'Set Fs = CreateObject("Scripting.FileSystemObject")
'If Not Fs Is Nothing Then
'If Fs.FileExists(sfolderDoc & "_BOM " & CStr(I) & ".xls") Then
'iRet = MsgBox("Do you want to open the generated file?", vbQuestion Or vbYesNo, "swPeter")
'If iRet = vbYes Then
'Set ObjExcel = GetObject(sfolderDoc & "_BOM " & CStr(I) & ".xls")
'ObjExcel.Application.Visible = True
'ObjExcel.Parent.Windows(1).Visible = True
'Set ObjExcel = Nothing
'Else
'MsgBox "Good luck and Health. Good bye. ", vbInformation, "swPeter"
'End If
'End If
'Set Fs = Nothing
'End If
'End If

If FileTxTBOM Then
Set Fs = CreateObject("Scripting.FileSystemObject")
If Not Fs Is Nothing Then
sPathFile = sfolderDoc & "_BOM " & CStr(I) & ".txt"
If Fs.FileExists(sPathFile) Then
iRet = MsgBox("Do you want to open the generated file?", vbQuestion Or vbYesNo, "swPeter")
If iRet = vbYes Then
ShellExecute 0, "open", sPathFile, vbNullString, vbNullString, 1
Else
MsgBox "Good luck and Health. Good bye. ", vbInformation, "swPeter"
End If
End If
End If
End If

End Sub

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP