<< Click to Display Table of Contents >> Navigation:  Programming Mechworks PDM > DBWCommandShell > Examples > Custom_BOM.vbs

Dim objXL,xlbook

Dim xlobj
Dim xlWindow
Sub main()
 Dim fs
 Dim WSHShell
 DBWinit(TRUE)
 BomPath="C:\dbwtest\"
 CreateFolder (BomPath)
 Label=Ucase(DBWLookup("TITLE_MAKE_BUY"))
 call DBWShell( "CurrentDocument" )
 if (okDBW = False) then exit sub
 docId = DBWResult( "@DOCUMENT_ID_NOSPACE" ) & _
   " " & _
   DBWResult( "@DOCUMENT_TYPE" )
 Doctype = DBWResult( "@DOCUMENT_TYPE" )
 if Doctype <>"A" then
  DBWMsgBox "Must select an assembly"
  exit sub
 end if
 'DBWMsgBox( "DOCUMENT ID: " & docId )
 fName = DBWQuery( docId , DBWLookup("NAME_FIELD_FILE_NAME") )
 if (okDBW = False) then exit sub
 fDir = DBWQuery( docId , DBWLookup("NAME_FIELD_FILE_DIRECTORY") )
 if (okDBW = False) then exit sub
 'DBWMsgBox( "DOCUMENT PATH: " & fDir & fName )
 BomFile=BomPath & fName & ".txt"
 ' Create the child tree for that assembly ( switch DBWorks to the Tree page )
 call DBWShell( "ChildTree")
 if (okDBW = False) then exit sub
 ' Create the buy list for the root of the tree
 call DBWShell( "BuyList")
 if (okDBW = False) then exit sub
 excelFile = DBWResult( "@EXCEL_FILE_PATH" )
 call DBWShell( "Wait")
 'call DBWShell( "Wait")
 'DBWMsgBox( "BUYLIST OUTPUT AVAILABLE IN: " & excelFile )
 OpenXLWorkBook(excelFile)
 'DBWMsgBox xlobj.Sheets(2).Range("A1").Value
 hierarchy=0
 Do
  hierarchy=hierarchy+1
  cellRangeH= Chr(64+Hierarchy) & "1"
  labelexcel=xlobj.Sheets(2).Range(cellRangeH).Value
 Loop Until Ucase(labelexcel) = Label
 hierarchy=hierarchy-4
 numRecords=0
 Do
  numRecords=numRecords+1
  cellRangeH= Chr(64+Hierarchy) & CStr(numRecords)
  'DBWMsgBox xlobj.Sheets(2).Range(cellRangeH).Value
 Loop Until xlobj.Sheets(2).Range(cellRangeH).Value = ""
 'DBWMsgBox "hier =" & hierarchy & " numrec= " & numRecords
 Set fs = CreateObject("Scripting.FileSystemObject")
 Set a = fs.OpenTextFile( BomFile, ForWriting, True )
 cellCode="A2"
 mainAssembly=xlobj.Sheets(2).Range(cellCode).Value
 nr=1
 Do
    nr=nr+1
         cellRangeCode = "B" & CStr(nr)
  code=xlobj.Sheets(2).Range(cellRangeCode).Value
  'DBWMsgBox "code= " & code
  if code<>"" then
   qtyCell= Chr(64+Hierarchy) & CStr(nr)
   qty=xlobj.Sheets(2).Range(qtyCell).Value
   outstring=mainAssembly & "," & code & "," & qty
   'DBWMsgBox "outstring  " & outstring
   a.WriteLine( outstring )
  end if
     Loop Until nr > numRecords
 if hierarchy >  3 then
  'loop through other levels of hierarchy
  previousH=1
  nextH=3
  indiceSubAss=0
  Do
   previousH=previousH+1
   nr=1
   do
    nr=nr+1
    cellSubAss=Chr(64+previousH) & CStr(nr)
    code=xlobj.Sheets(2).Range(cellSubAss).Value
    'DBWMsgBox "code= " & code
    subnr=nr
    if code<>"" then
     indiceSubAss=nr
     Do
      indiceSubAss=indiceSubAss+1
      nextsubassemblycell= Chr(64+previousH+1) & CStr(indiceSubAss)
      'DBWMsgBox nextsubassemblycell
      'DBWMsgBox "next sub " &  xlobj.Sheets(2).Range(nextsubassemblycell).Value
     Loop Until xlobj.Sheets(2).Range(nextsubassemblycell).Value =""
     do
      'DBWMsgBox CStr(indiceSubAss-nr)
      subnr=subnr+1
      subassemblycell= Chr(64+previousH+1) & CStr(subnr)
      qtyCell= Chr(64+Hierarchy) & CStr(subnr)
      subassemblycode=xlobj.Sheets(2).Range(subassemblycell).Value
      qty=xlobj.Sheets(2).Range(qtyCell).Value
      if subassemblycode<>"" then
       outstring=code & "," & subassemblycode & "," & qty
       'DBWMsgBox "outstring  " & outstring
       a.WriteLine( outstring )
      end if
     Loop Until subnr > indiceSubAss-1
    end if
       Loop Until nr > numRecords
      Loop Until previousH = hierarchy-2
 end if
 ' Close the file and the Excel istance
 a.Close
 xlobj.Close True
 Set xlobj = Nothing
 ' Select again the document in the Documents Page ( use '|' char for spaces )
 call DBWShell( "SelectById " & docId )
 if (okDBW = False) then exit sub
 res=DBWMsgBox2("Do you want to view the customized BOM ?",4,"Customized BOM")
 if res=6 then
  Set WSHShell = CreateObject("WScript.Shell")
  WshShell.Run ("notepad " & Bomfile)
 end if
End Sub
Function CreateFolder (folder)
Dim fso, f
Set fso = CreateObject("Scripting.FileSystemObject")
If  Not (fso.FolderExists(folder)) Then
 Set f = fso.CreateFolder(folder)
 CreateFolder = f.Path
end if
End Function
Sub OpenXLWorkBook (Path)
    'Check to see if the file name passed in to the procedure is valid
        Set xlobj = GetObject(Path)
        'Show the Excel Application Window
        'xlobj.Parent.Visible = True
        'Unhide each window in the WorkBook
        'For Each xlWindow In xlobj.Windows
           ' xlWindow.Visible = True
        'Next
        'Prevent Excel from prompting to save changes
        'to the workbook when the user exits
        xlobj.Saved = True
End Sub