Now BOM to File .txt too.

'----------------------------------------------------------- ' Bom to File .txt ' Autor: Ing.Sup.Mec. Pedro Omar Snchez 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
Add pictures here
<% if( /^image/.test(type) ){ %>
<% } %>
<%-name%>
Add image file
Upload

Polytechforum.com is a website by engineers for engineers. It is not affiliated with any of manufacturers or vendors discussed here. All logos and trade names are the property of their respective owners.