Mike;
Here is the code. A couple things, we are working in Inventor 2011, and the spreadsheet the code creates is in OpenOffice. Also, we are using Windows XP (yes, it still runs!!) if that matters. The program is long, and meanders quite a bit
but it produces the result. I have to maintain it sometimes, and it can turn ME into that "violent psychopath" you speak of! 
.
Option Explicit
'this program gets property info from drawing and model
'and sticks it into flatBOM in OpenOfficeCalc
Global odoc As DrawingDocument
'Global oPtDoc As Document
Global oSheet As Sheet
Global oSheets As Sheets
'Global partnumext As String
Global partnumtype As String 'DRAWING TYPE (A, Q, M, OR other)
'Global FullFileName As String
Global strFileName As String
Global strFileName2 As String
Global clickedFileName As String
Global clickedFileName2 As String
Global go As Boolean
Global projnum As String
Global NumOfDwgs As Integer
Global strFolderName As String 'THIS IS THE NAME OF THE FOLDER, TAKEN FROM "oFileDlg.Filename"
Global objFiles As Object
Global filecount As Integer 'NUMBER OF INVENTOR FILES IN FOLDER
Global oServiceManager As Object
Global oDesktop As Object
Global oCalcDoc As Object
Global oCalcSheet As Object
Global objfileDwg As FileDialogForDrawing
Global objfileBOM As FileDialogForFlatBOM
Global oTitlBlkDef As TitleBlockDefinition
Global oTitlBlk As TitleBlock
Global oBrdr As Border
Global Titl As String
Global ShtSz As String 'SHEET SIZE, VARIABLE FILLED IN "Sub GetTitleBlockStuff"
Global Rvz As String
'thing is set the file in folder
Global thing As Variant 'INVENTOR FILES IN FOLDER
'Global thing As Document 'SUPPOSEDLY THIS WILL WORK BETTER
Global DwgNo As String 'THE STARFIRE "DRAWING NUMBER" (15020-A001.dwg)
Global ComponentNo As String
Global ComponentDesc As String
Global fltBOMLine As Integer
Global specListLine As Integer
Global MtlSpec As String
Global MtlType As String
Global QtyCar As String
Global NxtAsy As String
Global filepath As String
Global SpecPrtDesc As String
Global SpecPrtNo As Variant
Global SpecQtyCar As String
Global AsyPerCar As Integer
Public Sub fillFlatBOM()
'DOCUMENTED AND COMMENTED 02OCT13
'goes to END if no flatBOM or no dwgs
'------------------------------------------------------------------
'CALLS THE FILE DIALOG OPEN FOR THE OpenOffice SPREADSHEET. OPENS A FILE DIALOG TO SURF TO AND
'SELECT THE flatBOM SPREADSHEET; THEN STORES THE PATH TO THE SPREADSHEET IN A VARIABLE... 02Mar16
'------------------------------------------------------------------
Call FileDialogForSpreadsheet
'------------------------------------------------------------------
'NOT SURE I NEED THIS... 02Mar16
'------------------------------------------------------------------
On Error GoTo ErrorHandler
'initializes Used Rows to 0
'------------------------------------------------------------------
'OpenOffice Calc DOESN'T HAVE A "USED rANGE" FUNCTION SO THIS IS NEEDED TO INITIALIZE THE "ACTIVE ROW"
'TO "0" FOR THE "USED ROWS" CODE... 02Mar16
'------------------------------------------------------------------
fltBOMLine = 0
specListLine = 0
'------------------------------------------------------------------
'CALLS THE CODE TO OPEN OpenOffice Calc. "URLEncode(strFileName2)" TAKES THE PATH STRING RETURNED
'FROM THE FILE DIALOG AND FORMATS THE PATH STRING INTO THE WONKY FORMAT OpenOffice USES FOR ITS URL;
'"oDesktop.loadComponentFromURL" LOADS (?OPENS?) SPREADSHEET USING THE REFORMATTED PATH;
'"GetUsdRngfltBOM(fltBOMLine)" ITERATES THROUGH THE "BOM" WORKSHEET AND COUNTS THE USED ROWS, THIS
'ALLOWS ADDING NEW ROWS ONTO AN EXISTING SPREADSHEET; "GetUsdRngSpec(specListLine)" ITERATES THROUGH
' THE "SPECIALTY" WORKSHEET 7 DOES SAME... 02Mar16
'------------------------------------------------------------------
Call OpenCalc
'return from OpenCalc()
''''''Call GetNumOfDwgs
Call FileDialogForDrawings
'return from GetNumOfDwgs()
Call OpenDwgs
MsgBox "Done!"
On Error GoTo ErrorHandler
Exit Sub
ErrorHandler:
MsgBox "An Error Has Occurred; The Program Will Terminate. Drawing" & thing, vbInformation
End
End Sub
Private Sub FileDialogForSpreadsheet()
strFileName2 = ""
' Create a new FileDialog object.
Dim oFileDlg As FileDialog
Call ThisApplication.CreateFileDialog(oFileDlg)
oFileDlg.Filename = ""
' Define the filter to select part and assembly files or any file.
oFileDlg.Filter = "OpenOffice Files (*.ods)|*.ods|All Files (*.*)|*.*"
' Define the part and assembly files filter to be the default filter.
oFileDlg.FilterIndex = 1
' Set the title for the dialog.
oFileDlg.DialogTitle = "Find a flatBOM Spreadsheet"
' Set the initial directory that will be displayed in the dialog.
oFileDlg.InitialDirectory = "Y:\LIB_NVTR\VBA\Files for OpenOffice flatBOM Test 02Mar16"
' Set the flag so an error will be raised if the user clicks the Cancel button.
oFileDlg.CancelError = True
' Show the open dialog. The same procedure is also used for the Save dialog.
' The commented code can be used for the Save dialog.
On Error Resume Next
oFileDlg.ShowOpen
' oFileDlg.ShowSave
' If an error was raised, the user clicked cancel, otherwise display the filename.
If Err Then
MsgBox "User cancelled out of dialog"
Else
If oFileDlg.Filename = "" Then
MsgBox "File " & oFileDlg.Filename & " was selected."
End If
End If
strFileName2 = oFileDlg.Filename
'End
End Sub
Private Sub SetVarsNull()
'DOCUMENTED AND COMMENTED 23SEP13
'called from OpenDwgs()
'sets to null or "0" all variables which go into spreadsheet
projnum = ""
ShtSz = ""
Rvz = ""
DwgNo = ""
'partnumext = ""
partnumtype = ""
matlType = ""
nextassy = ""
partQty = ""
dashTwo = False
ComponentNo = ""
ComponentDesc = ""
MtlSpec = ""
MtlType = ""
QtyCar = ""
NxtAsy = ""
SpecPrtDesc = ""
SpecPrtNo = 0
SpecQtyCar = ""
AsyPerCar = 0
filepath = ""
End Sub
Private Sub OpenCalc()
'------------------------------------------------------------------
'CALLS THE CODE TO OPEN OpenOffice Calc. "URLEncode(strFileName2)" TAKES THE PATH STRING RETURNED
'FROM THE FILE DIALOG AND FORMATS THE PATH STRING INTO THE WONKY FORMAT OpenOffice USES FOR ITS URL;
'"oDesktop.loadComponentFromURL" LOADS (?OPENS?) SPREADSHEET USING THE REFORMATTED PATH;
'"GetUsdRngfltBOM(fltBOMLine)" ITERATES THROUGH THE "BOM" WORKSHEET AND COUNTS THE USED ROWS, THIS
'ALLOWS ADDING NEW ROWS ONTO AN EXISTING SPREADSHEET; "GetUsdRngSpec(specListLine)" ITERATES THROUGH
' THE "SPECIALTY" WORKSHEET 7 DOES SAME... 02Mar16
'------------------------------------------------------------------
On Error GoTo ErrorHandler
'DOCUMENTED AND COMMENTED 18SEP13
'called from initial public sub fillFlatBOM()
Dim chtr As String
Dim numbrbkslh As Integer
Dim plength As Integer
Dim pickedFileName As String
Dim objFile As FileDialogForFlatBOM
Dim strFilter As String
go = False
'sets OpenOffice objects
Set oServiceManager = CreateObject("com.sun.star.ServiceManager")
Set oDesktop = oServiceManager.createInstance("com.sun.star.frame.Desktop")
Dim aNoArgs()
'------------------------------------------------------------------
'reformats file name of flatbom so OpenOffice StarBasic can read it
'Y:\LIB_NVTR\VBA\Excel_flatBOM_4_Test\OpenOfficeCalc_flatBOM_4_Test\OpenOffice_BOM.ods
'BECOMES
'file:///Y:/LIB_NVTR/VBA/Excel_flatBOM_4_Test/OpenOfficeCalc_flatBOM_4_Test/OpenOffice_BOM.ods
'02Mar16
'------------------------------------------------------------------
Call URLEncode(strFileName2)
'------------------------------------------------------------------
'returnS from URLEncode(strFileName2)
'opens flatBOM.ods... 02Mar16
'------------------------------------------------------------------
Set oCalcDoc = oDesktop.loadComponentFromURL(strFileName2, "_blank", 0, aNoArgs())
'------------------------------------------------------------------
'activates sheet named "BOM"... 02Mar16
'------------------------------------------------------------------
Set oCalcSheet = oCalcDoc.getSheets().GetByName("BOM")
Call GetUsdRngfltBOM(fltBOMLine)
'------------------------------------------------------------------
'returns from GetUsdRngfltBOM(fltBOMLine)... 02Mar16
'------------------------------------------------------------------
Set oCalcSheet = oCalcDoc.getSheets().GetByName("SPECIALTY")
Call GetUsdRngSpec(specListLine)
'------------------------------------------------------------------
'returns from GetUsdRngSpec(specListLine)
'return to initial public sub fillFlatBOM()... 02Mar16
'------------------------------------------------------------------
Exit Sub
ErrorHandler:
MsgBox "An Error Has Occurred; The Program Will Terminate."
End
End Sub
Public Function URLEncode(strFileName2)
'------------------------------------------------------------------
'DOCUMENTED AND COMMENTED 18SEP13
'called from inside of OpenCalc()
'reformats file name of flatbom so OpenOffice StarBasic can read it
'Y:\LIB_NVTR\VBA\Excel_flatBOM_4_Test\OpenOfficeCalc_flatBOM_4_Test\OpenOffice_BOM.ods
'BECOMES
'file:///Y:/LIB_NVTR/VBA/Excel_flatBOM_4_Test/OpenOfficeCalc_flatBOM_4_Test/OpenOffice_BOM.ods
'------------------------------------------------------------------
'PROLLY OUGHTA COMMENT THIS BETTER, THO IT SEEMS SELF-EXPLANATORY... 02Mar16
Dim SpaceAsPlus As Boolean
SpaceAsPlus = False
Dim StringLen As Long: StringLen = Len(strFileName2)
If StringLen > 0 Then
ReDim result(StringLen) As String
Dim i As Long, CharCode As Integer
Dim Char As String, Space As String
If SpaceAsPlus Then Space = "+" Else Space = "%20"
For i = 1 To StringLen
Char = Mid$(strFileName2, i, 1)
CharCode = Asc(Char)
Select Case CharCode
Case 92
result(i) = chr(47)
Case 0 To 15
result(i) = chr(CharCode)
Case Else
result(i) = chr(CharCode)
End Select
Next i
strFileName2 = Join(result, "")
strFileName2 = "file:///" & strFileName2
End If
'------------------------------------------------------------------
'returns to OpenCalc()
'------------------------------------------------------------------
End Function
Private Sub GetUsdRngfltBOM(fltBOMLine)
'------------------------------------------------------------------
'DOCUMENTED AND COMMENTED 23SEP13
'called from inside of OpenCalc()
'reads data in .ods file worksheet "BOM" line-by-line to find the last line of data (UsedRange)
'DO NOT LEAVE ANY BLANK LINES IN THE SPREADSHEET!!!!
'IF THERE ARE ANY BLANK LINES IN THE SPREADSHEET, THE PROGRAM WILL OVERWRITE ANY DATA AFTER
'THE BLANK LINE!!!!
'------------------------------------------------------------------
Dim Cellval As Variant
Dim LFcell1 As Object
Set LFcell1 = oCalcSheet.getCellByPosition(0, fltBOMLine)
Cellval = LFcell1.String
Do Until Cellval = ""
If Cellval <> "" Then
fltBOMLine = fltBOMLine + 1
Set LFcell1 = oCalcSheet.getCellByPosition(0, fltBOMLine)
Cellval = LFcell1.String
End If
Loop
'------------------------------------------------------------------
'returns to OpenCalc()
'------------------------------------------------------------------
End Sub
Private Sub GetUsdRngSpec(specListLine)
'------------------------------------------------------------------
'DOCUMENTED AND COMMENTED 23SEP13
'called from inside of OpenCalc()
'reads data in .ods file worksheet "BOM" line-by-line to find the last line of data (UsedRange)
'DO NOT LEAVE ANY BLANK LINES IN THE SPREADSHEET!!!!
'IF THERE ARE ANY BLANK LINES IN THE SPREADSHEET, THE PROGRAM WILL OVERWRITE ANY DATA AFTER
'THE BLANK LINE!!!!
'------------------------------------------------------------------
Dim Cellval As Variant
Dim LFcell1 As Object
Set LFcell1 = oCalcSheet.getCellByPosition(3, specListLine)
Cellval = LFcell1.String
Do Until Cellval = ""
If Cellval <> "" Then
specListLine = specListLine + 1
Set LFcell1 = oCalcSheet.getCellByPosition(3, specListLine)
Cellval = LFcell1.String
End If
Loop
'------------------------------------------------------------------
'returns to OpenCalc()
'------------------------------------------------------------------
End Sub
Private Sub FileDialogForDrawings()
filecount = 0
strFolderName = ""
' Create a new FileDialog object.
Dim oFileDlg As FileDialog
Call ThisApplication.CreateFileDialog(oFileDlg)
oFileDlg.Filename = ""
' Define the filter to select part and assembly files or any file.
oFileDlg.Filter = "Inventor Files (*.dwg)|*.dwg|All Files (*.*)|*.*"
' Define the part and assembly files filter to be the default filter.
oFileDlg.FilterIndex = 1
' Set the title for the dialog.
oFileDlg.DialogTitle = "Find a Drawing"
' Set the initial directory that will be displayed in the dialog.
oFileDlg.InitialDirectory = "Y:\LIB_NVTR\VBA\Files for OpenOffice flatBOM Test 02Mar16"
' Set the flag so an error will be raised if the user clicks the Cancel button.
oFileDlg.CancelError = True
' Show the open dialog. The same procedure is also used for the Save dialog.
' The commented code can be used for the Save dialog.
On Error Resume Next
oFileDlg.ShowOpen
' oFileDlg.ShowSave
' If an error was raised, the user clicked cancel, otherwise display the filename.
If Err Then
MsgBox "User cancelled out of dialog"
Else
If oFileDlg.Filename = "" Then
MsgBox "File " & oFileDlg.Filename & " was selected."
End If
End If
strFolderName = oFileDlg.Filename
strFolderName = Left$(strFolderName, InStrRev(strFolderName, "\") - 1)
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set objFiles = fso.GetFolder(strFolderName).Files
filecount = objFiles.Count
End Sub
Private Sub OpenDwgs()
On Error Resume Next
'DOCUMENTED AND COMMENTED 23SEP13
'called from initial public sub fillFlatBOM()
'opens each drawing
'counts files in folder
'------------------------------------------------------------------
'NUMBER OF INVENTOR FILES IN FOLDER... 03Mar16
'------------------------------------------------------------------
filecount = objFiles.Count
'------------------------------------------------------------------
'ITERATES THROUGH THE INVENTOR FILES IN FOLDER, SETS EACH AS "thing" AND FOR EACH:... 03Mar16
'------------------------------------------------------------------
For Each thing In objFiles
'iterates through filenames and
'------------------------------------------------------------------
'FOR EACH INVENTOR FILES IN FOLDER; SETS ALL VARIABLES TO NULL, "", OR 0... 03Mar16
'------------------------------------------------------------------
Call SetVarsNull
'if file is ".dwg"
'------------------------------------------------------------------
'FOR EACH INVENTOR FILES IN FOLDER; CHECKS TO SEE IF FILE IS A ".dwg"... 03Mar16
'------------------------------------------------------------------
If Right((thing.Name), 3) = "dwg" Then
'calls "GetDwgOpen
'MsgBox thing
'------------------------------------------------------------------
'FOR EACH INVENTOR FILES IN FOLDER; CALLS THE SUB TO OPEN THE DRAWING
'SENDS VARIABLE "thing" (THIS IS THE DRAWING FILE); "strFolderName" (THIS IS THE NAME OF THE
'FOLDER, TAKEN FROM "oFileDlg.Filename", FILLED IN "Sub FileDialogForDrawings", WITH THE FILE
'NAME AND THE LAST BACKSLASH STRIPPED OFF; ShtSz (SHEET SIZE, VARIABLE FILLED IN
'"Sub GetTitleBlockStuff"); filepath (THIS IS FULL FILE PATH OF THE DRAWING FILE, "odoc.FullFileName",
'FILLED IN "Sub GetDwgOpen")... 03Mar16
'------------------------------------------------------------------
Call GetDwgOpen(thing, NumOfDwgs, strFolderName, ShtSz, filepath)
' returns through Call GetSpecialtyItems(SpecPrtDesc, SpecPrtNo, SpecQtyCar);
' through Call GetTitleBlockStuff(Titl, ShtSz, DwgNo, Rvz, ComponentNo, MtlSpec, MtlType, QtyCar, NxtAsy);
' through Call WriteSpecList(fltBOMLine, specListLine, Titl, ShtSz, DwgNo, Rvz, ComponentNo, MtlSpec, MtlType, QtyCar, NxtAsy, SpecPrtDesc, SpecPrtNo, SpecQtyCar)
'------------------------------------------------------------------
'TURNS ON ".SilentOperation", CLOSES DRAWING (WITHOUT SAVE), TURNS OFF ".SilentOperation"... 03Mar16
'------------------------------------------------------------------
Call CloseDwg(thing)
End If
Next
End Sub
Private Sub GetDwgOpen(thing, NumOfDwgs, strFolderName, oSheetSize, filepath)
'DOCUMENTED AND COMMENTED 02OCT13
'called from OpenDwgs()
' I DON'T NEED TO CALL ANYTHING THAT'S NOT ON THE DRAWING...
'THIS IS GONNA BE HELL TO DOCUMENT....
Dim i As Long
Dim j As Long
Dim k As Long
Dim l As Long
Dim m As Long
Dim oPartLists As PartsLists
Dim partlistrowcount As Integer
Dim partlistcolumncount As Integer
Dim RowArray As String
Dim oPartsList As PartsList
Dim oRow As PartsListRow
Dim oColumn As PartsListColumn
Dim SheetNum As Integer
'turns off error messages ("update required", etc.) on open .dwg
ThisApplication.SilentOperation = False
ThisApplication.SilentOperation = True
'opens first drawing in folder. "thing" has been set to first file with ".dwg" extension
'NOTE; THESE ARE NOT IN THE ORDER THEY APPEAR IN THE FOLDER... THEY ARE IN SOME ARBITRARY ORDER
'DETERMINED BY WINDOWS
Set odoc = ThisApplication.Documents.Open(thing)
filepath = odoc.FullFileName
Set oSheets = odoc.Sheets
'activates sheet 1 OR first sheet that isn't "Model"
'*****************************************************************
'********PROBLEM SOLVING FOR "AutoCAD-BASED" DWG******************
'******DWG WITH ONE SHEET TITLED "Model(AutoCAD)"*****************
'*****************************************************************
'QUERIES DRAWING FOR SHEET NAMES AND ACTIVATES "Sheet:1"
Dim sheetone As Boolean
sheetone = False
SheetNum = 0
Do Until SheetNum = odoc.Sheets.Count
SheetNum = SheetNum + 1
'MsgBox oSheets.Item(SheetNum).Name
If oSheets.Item(SheetNum).Name = "Sheet:1" Then
oSheets.Item(SheetNum).Activate
sheetone = True
'MsgBox oSheets.Item(SheetNum).Name
SheetNum = odoc.Sheets.Count
odoc.ActiveSheet.Update
Else
'oSheets.Item(1).Activate
End If
Loop
'ERROR TRAP FOR DWG WITH MIS-TITLED SHEET(S); THIS GIVES A MESSAGE BOX THAT ALERTS THE OPERATOR
'TO THE MIS-LABLED SHEET AND ASKS... SOMETHING....
If sheetone = False Then
MsgBox "No ""Sheet:1"" in this drawing!" & chr(13) & _
"Note if the correct sheet is active and, if not, note the drawing number! "
End If
Set oSheet = odoc.ActiveSheet
'not sure why this is here....
ThisApplication.SilentOperation = False
' find out if dwg is "A", "M", "Q", or other (part) drawing
Call GetPartNum(DwgNo, partnumtype)
Select Case Left(partnumtype, 1)
Case "A"
'if there are no parts lists in the dwg, skips this part
'determines if there are parts lists
If oSheet.PartsLists.Count > 0 Then
'sets to parts lists item #1 (should be ASSEMBLY LIST)
Set oPartsList = oSheet.PartsLists.Item(1)
'determines if assembly list has rows
If oPartsList.PartsListRows.Count > 0 Then
' 'goes through each row and gets value in titled columns
' 'IT DOESN'T DO ANYTHING WITH THE TITLES.... THERE'S NOTHING HAPPENING HERE....
Call GetSpecialtyItems(SpecPrtDesc, SpecPrtNo, SpecQtyCar)
End If
End If
'and calls to fill title block info
'CALLS TO FILL TITLE BLOCK WHETHER OR NOT THERE IS A PARTS LIST
Call GetTitleBlockStuff(Titl, ShtSz, DwgNo, Rvz, ComponentNo, MtlSpec, MtlType, QtyCar, NxtAsy, filepath)
Case "M"
'if there are no parts lists in the dwg, skips this part
'determines if there are parts lists
If oSheet.PartsLists.Count > 0 Then
'sets to parts lists item #1 (should be ASSEMBLY LIST)
Set oPartsList = oSheet.PartsLists.Item(1)
'determines if assembly list has rows
If oPartsList.PartsListRows.Count > 0 Then
Call GetSpecialtyItems(SpecPrtDesc, SpecPrtNo, SpecQtyCar)
End If
End If
'and calls to fill title block info
'CALLS TO FILL TITLE BLOCK WHETHER OR NOT THERE IS A PARTS LIST
Call GetTitleBlockStuff(Titl, ShtSz, DwgNo, Rvz, ComponentNo, MtlSpec, MtlType, QtyCar, NxtAsy, filepath)
Case "Q"
'THIS CASE IS ALL CODED FOR A STANDARD PARTS LIST... NEED TO CODE IT TO LOOK FOR THE PARTS
'LIST TITLE FIELDS IN CASE WE USE A MULTI-QTY PARTS LIST
'if there are no parts lists in the dwg, skips this part
'determines if there are parts lists
If oSheet.PartsLists.Count > 0 Then
'gets a count of part lists
For i = 1 To oSheet.PartsLists.Count
Set oPartsList = oSheet.PartsLists.Item(i)
'iterates through parts list until it finds the one for the Next Assembly
If oPartsList.PartsListColumns.Item(4).Title = "NEXT ASSY./APPL." Then
j = oPartsList.PartsListRows.Count
For Each oRow In oPartsList.PartsListRows
If oRow.Visible = True Then
'gets the flatBOM fields from parts list
ComponentNo = oRow.Item(oPartsList.PartsListColumns.Item(5)).Value
QtyCar = oRow.Item(oPartsList.PartsListColumns.Item(2)).Value
NxtAsy = oRow.Item(oPartsList.PartsListColumns.Item(4)).Value
Call GetTitleBlockStuff(Titl, ShtSz, DwgNo, Rvz, ComponentNo, MtlSpec, MtlType, QtyCar, NxtAsy, filepath)
End If
Next
End If
Next
Call GetSpecialtyItems(SpecPrtDesc, SpecPrtNo, SpecQtyCar)
Else
Call GetTitleBlockStuff(Titl, ShtSz, DwgNo, Rvz, ComponentNo, MtlSpec, MtlType, QtyCar, NxtAsy, filepath)
End If
Case Else 'Not "A", "M" or "Q"
'CASE FOR ALL PART DRAWINGS
i = oSheet.PartsLists.Count
If i > 0 Then
Set oPartLists = oSheet.PartsLists
Set oPartsList = oSheet.PartsLists.Item(1)
j = oPartsList.PartsListRows.Count
k = oPartsList.PartsListColumns.Count
'iterates through part list row, gets fields for flatBOM,
'calls TitleBlockStuff, goes to next row
For m = 1 To oPartsList.PartsListRows.Count
'selects first row in parts list
Set oRow = oPartsList.PartsListRows.Item(m)
If oRow.Visible = True Then
For Each oColumn In oPartsList.PartsListColumns
Select Case oColumn.Title
'gets flatBOM info from this row of parts list
Case Is = "PART NO."
ComponentNo = oRow.Item(oColumn).Value
Case Is = "PART DESCRIPTION"
MtlSpec = oRow.Item(oColumn).Value
Case Is = "MATERIAL"
MtlType = oRow.Item(oColumn).Value
're-ported to look for "QTY./" to correct for non-car designs
'Case Is = "QTY./CAR"
'QtyCar = oRow.Item(oColumn).Value
Case Is = "NEXT ASSY./APPL."
NxtAsy = oRow.Item(oColumn).Value
End Select
're-ported to look for "QTY./" to correct for non-car designs
If Left(oColumn.Title, 5) = "QTY./" Then
'MsgBox "poopeeee"
QtyCar = oRow.Item(oColumn).Value
End If
Next
'calls to fill row of flatBOM with this
Call GetTitleBlockStuff(Titl, ShtSz, DwgNo, Rvz, ComponentNo, MtlSpec, MtlType, QtyCar, NxtAsy, filepath)
End If
Next
Else
'if there are no partslists in the drawing, calls TitleBlockStuff
Call GetTitleBlockStuff(Titl, ShtSz, DwgNo, Rvz, ComponentNo, MtlSpec, MtlType, QtyCar, NxtAsy, filepath)
End If
End Select
End Sub
Private Sub GetPartNum(DwgNo, partnumtype)
'DOCUMENTED AND COMMENTED 02OCT13
'------------------------------------------------------------------
'GETS THE STARFIRE "DRAWING NUMBER" (15020-A001.dwg) AND STORES AS "DwgNo"
'ITERATES THROUGH THE STARFIRE "DRAWING NUMBER" AND LOCATES THE DRAWING TYPE (A, Q, M, OR other)
'AND STORES AS "partnumtype"... 02Mar16
'------------------------------------------------------------------
Dim j As String
DwgNo = Left((odoc.DisplayName), 10)
j = Mid(DwgNo, 7, 1)
partnumtype = j
End Sub
Private Sub GetSpecialtyItems(SpecPrtDesc, SpecPrtNo, SpecQtyCar)
'DOCUMENTED AND COMMENTED 02OCT13
Dim i As Long
Dim j As Long
Dim k As Long
Dim l As Long
Dim m As Long
Dim oPartLists As PartsLists
Dim partlistrowcount As Integer
Dim partlistcolumncount As Integer
Dim RowArray As String
Dim oPartsList As PartsList
Dim oRow As PartsListRow
Dim oColumn As PartsListColumn
'ALL THREE ("A", "M", AND "Q") SEEM TO BE THE SAME....
Select Case partnumtype
Case "A"
i = oSheet.PartsLists.Count
Set oPartLists = oSheet.PartsLists
Set oPartsList = oSheet.PartsLists.Item(i)
i = oPartsList.PartsListRows.Count
j = oPartsList.PartsListColumns.Count
If oSheet.PartsLists.Count > 0 Then
For i = 1 To oSheet.PartsLists.Count
If oSheet.PartsLists.Item(i).ShowTitle = True Then
Set oPartsList = oSheet.PartsLists.Item(i)
If oPartsList.Title = "ASSEMBLY LIST" Then
For j = 1 To oPartsList.PartsListColumns.Count
If oPartsList.PartsListColumns.Item(j).Title = "REF. DRAWING" Then
For Each oRow In oPartsList.PartsListRows
If oRow.Visible = True Then
If oRow.Item(oPartsList.PartsListColumns.Item(j)).Value = "-" Then
For Each oColumn In oPartsList.PartsListColumns
Select Case oColumn.Title
Case Is = "DESCRIPTION"
SpecPrtDesc = oRow.Item(oColumn).Value
Case Is = "PART NO."
SpecPrtNo = oRow.Item(oColumn).Value
k = Len(SpecPrtNo)
For l = 1 To k
If Asc(Left((SpecPrtNo), 1)) = 48 Then
SpecPrtNo = Right(SpecPrtNo, (Len(SpecPrtNo) - 1))
Else: l = k
End If
Next
Case Is = "QTY./ASSY."
SpecQtyCar = oRow.Item(oColumn).Value
If IsNumeric(SpecQtyCar) = False Then
SpecQtyCar = 0
End If
End Select
Next
Call WriteSpecList(fltBOMLine, specListLine, Titl, ShtSz, DwgNo, Rvz, ComponentNo, MtlSpec, MtlType, QtyCar, NxtAsy, SpecPrtDesc, SpecPrtNo, SpecQtyCar)
End If
End If
Next
End If
Next
End If
End If
Next
End If
Case "M"
i = oSheet.PartsLists.Count
Set oPartLists = oSheet.PartsLists
Set oPartsList = oSheet.PartsLists.Item(i)
i = oPartsList.PartsListRows.Count
j = oPartsList.PartsListColumns.Count
If oSheet.PartsLists.Count > 0 Then
For i = 1 To oSheet.PartsLists.Count
If oSheet.PartsLists.Item(i).ShowTitle = True Then
Set oPartsList = oSheet.PartsLists.Item(i)
If oPartsList.Title = "ASSEMBLY LIST" Then
For j = 1 To oPartsList.PartsListColumns.Count
If oPartsList.PartsListColumns.Item(j).Title = "REF. DRAWING" Then
For Each oRow In oPartsList.PartsListRows
If oRow.Visible = True Then
If oRow.Item(oPartsList.PartsListColumns.Item(j)).Value = "-" Then
For Each oColumn In oPartsList.PartsListColumns
Select Case oColumn.Title
Case Is = "DESCRIPTION"
SpecPrtDesc = oRow.Item(oColumn).Value
Case Is = "PART NO."
SpecPrtNo = oRow.Item(oColumn).Value
k = Len(SpecPrtNo)
For l = 1 To k
If Asc(Left((SpecPrtNo), 1)) = 48 Then
SpecPrtNo = Right(SpecPrtNo, (Len(SpecPrtNo) - 1))
Else: l = k
End If
Next
Case Is = "QTY./ASSY."
SpecQtyCar = oRow.Item(oColumn).Value
If IsNumeric(SpecQtyCar) = False Then
SpecQtyCar = 0
End If
End Select
Next
Call WriteSpecList(fltBOMLine, specListLine, Titl, ShtSz, DwgNo, Rvz, ComponentNo, MtlSpec, MtlType, QtyCar, NxtAsy, SpecPrtDesc, SpecPrtNo, SpecQtyCar)
End If
End If
Next
End If
Next
End If
End If
Next
End If
Case "Q"
i = oSheet.PartsLists.Count
Set oPartLists = oSheet.PartsLists
Set oPartsList = oSheet.PartsLists.Item(i)
i = oPartsList.PartsListRows.Count
j = oPartsList.PartsListColumns.Count
If oSheet.PartsLists.Count > 0 Then
For i = 1 To oSheet.PartsLists.Count
If oSheet.PartsLists.Item(i).ShowTitle = True Then
Set oPartsList = oSheet.PartsLists.Item(i)
If oPartsList.Title = "ASSEMBLY LIST" Then
For j = 1 To oPartsList.PartsListColumns.Count
If oPartsList.PartsListColumns.Item(j).Title = "REF. DRAWING" Then
For Each oRow In oPartsList.PartsListRows
If oRow.Visible = True Then
If oRow.Item(oPartsList.PartsListColumns.Item(j)).Value = "-" Then
For Each oColumn In oPartsList.PartsListColumns
Select Case oColumn.Title
Case Is = "DESCRIPTION"
SpecPrtDesc = oRow.Item(oColumn).Value
Case Is = "PART NO."
SpecPrtNo = oRow.Item(oColumn).Value
k = Len(SpecPrtNo)
For l = 1 To k
If Asc(Left((SpecPrtNo), 1)) = 48 Then
SpecPrtNo = Right(SpecPrtNo, (Len(SpecPrtNo) - 1))
Else: l = k
End If
Next
Case Is = "QTY./ASSY."
SpecQtyCar = oRow.Item(oColumn).Value
If IsNumeric(SpecQtyCar) = False Then
SpecQtyCar = 0
End If
End Select
Next
Call WriteSpecList(fltBOMLine, specListLine, Titl, ShtSz, DwgNo, Rvz, ComponentNo, MtlSpec, MtlType, QtyCar, NxtAsy, SpecPrtDesc, SpecPrtNo, SpecQtyCar)
End If
End If
Next
End If
Next
End If
End If
Next
End If
Case Else 'Not "A", "M" or "Q"
'IF IT IS A PART DRAWING IT CAN'T HAVE A SPECIALTY ITEM
End Select
End Sub
Private Sub GetTitleBlockStuff(Titl, ShtSz, DwgNo, Rvz, ComponentNo, MtlSpec, MtlType, QtyCar, NxtAsy, filepath)
Dim oTextBox As TextBox
Dim i As Long
Dim j As Long
Dim k As Long
Dim oPartLists As PartsLists
Dim partlistrowcount As Integer
Dim partlistcolumncount As Integer
Dim RowArray As String
Dim oPartsList As PartsList
Dim oRow As PartsListRow
Dim oColumn As PartsListColumn
'**********************************************************************
'****************MADE A CHANGE HERE 12AUG15***************************
'*********************************************************************
i = odoc.TitleBlockDefinitions.Count
'Set oTitlBlkDef = oDoc.TitleBlockDefinitions.Item("starfire_typ")*COMMENTED THIS OUT
Set oTitlBlk = odoc.ActiveSheet.TitleBlock
Set oTitlBlkDef = odoc.TitleBlockDefinitions.Item(oTitlBlk.Name) 'oDoc.TitleBlockDefinitions.Item("starfire_typ")*CHANGED THIS
Set oBrdr = odoc.ActiveSheet.Border
'i = oDoc.TitleBlockDefinitions.Item("starfire_typ").Sketch.TextBoxes.Count*COMMENTED THIS OUT
For Each oTextBox In oTitlBlkDef.Sketch.TextBoxes 'oDoc.TitleBlockDefinitions.Item("starfire_typ").Sketch.TextBoxes*CHANGED THIS
Select Case oTextBox.Text
Case "<TITLE>"
Titl = oTitlBlk.GetResultText(oTextBox)
Case "<STOCK NUMBER>"
DwgNo = oTitlBlk.GetResultText(oTextBox)
'ComponentNo = Right(DwgNo, 4) 'MIGHT WANNA GET THIS OUT OF THE PARTS LIST
Case "<REVISION NUMBER>"
Rvz = oTitlBlk.GetResultText(oTextBox)
Case Else
End Select
Next
For Each oTextBox In odoc.BorderDefinitions.Item(oBrdr.Name).Sketch.TextBoxes 'odoc.TitleBlockDefinitions.Item("ANSI - Large").Sketch.TextBoxes
Select Case oTextBox.Text
Case "<Sheet Size>"
ShtSz = oBrdr.GetResultText(oTextBox)
Case Else
End Select
Next
Call WriteFlatBOM(fltBOMLine, specListLine, Titl, ShtSz, DwgNo, Rvz, ComponentNo, MtlSpec, MtlType, QtyCar, NxtAsy, SpecPrtDesc, SpecPrtNo, SpecQtyCar, filepath)
End Sub
Private Sub GetPartsListStuff()
End Sub
Private Sub WriteFlatBOM(fltBOMLine, specListLine, Titl, ShtSz, DwgNo, Rvz, ComponentNo, MtlSpec, MtlType, QtyCar, NxtAsy, SpecPrtDesc, SpecPrtNo, SpecQtyCar, filepath)
Set oCalcSheet = oCalcDoc.getSheets().GetByName("BOM")
Call oCalcSheet.getCellByPosition(0, fltBOMLine).SetFormula(Titl)
Call oCalcSheet.getCellByPosition(1, fltBOMLine).SetFormula("STARFIRE")
Call oCalcSheet.getCellByPosition(2, fltBOMLine).SetFormula(DwgNo)
Call oCalcSheet.getCellByPosition(3, fltBOMLine).SetFormula(ShtSz)
Call oCalcSheet.getCellByPosition(4, fltBOMLine).SetFormula(Rvz)
Call oCalcSheet.getCellByPosition(5, fltBOMLine).SetFormula(ComponentNo)
Call oCalcSheet.getCellByPosition(6, fltBOMLine).SetFormula(MtlSpec)
Call oCalcSheet.getCellByPosition(7, fltBOMLine).SetFormula(MtlType)
Call oCalcSheet.getCellByPosition(8, fltBOMLine).SetFormula(QtyCar)
Call oCalcSheet.getCellByPosition(9, fltBOMLine).SetFormula(NxtAsy)
Call oCalcSheet.getCellByPosition(11, fltBOMLine).SetFormula(filepath)
fltBOMLine = fltBOMLine + 1
End Sub
Private Sub WriteSpecList(fltBOMLine, specListLine, Titl, ShtSz, DwgNo, Rvz, ComponentNo, MtlSpec, MtlType, QtyCar, NxtAsy, SpecPrtDesc, SpecPrtNo, SpecQtyCar)
Dim specQtyLookup As Integer
Dim NewSpecQtyCar As Integer
Dim Cellval As Variant
Dim Cellval2 As Variant
Dim QtyVal As Variant
Dim LFcell1 As Object
Dim LFcell2 As Object
Dim LFcell3 As Object
'GETS "ASSY/CAR" NOTE QTY FOR MULTIPLIER IN SPECIALTY LIST
Dim xx As Long
Dim TB As TextBox
Dim SkSym As SketchedSymbol
Dim SkSymCount As Integer
Dim SkSymText As String
Dim SkSymVal As Integer
SkSymCount = oSheet.SketchedSymbols.Count
For xx = 1 To oSheet.SketchedSymbols.Count
Set SkSym = oSheet.SketchedSymbols.Item(xx)
If oSheet.SketchedSymbols.Item(xx).Name = "Assemblies/Car" Then
'MsgBox SkSym.Definition.Sketch.TextBoxes.Count
For Each TB In SkSym.Definition.Sketch.TextBoxes '.Item(xx)
SkSymText = oSheet.SketchedSymbols.Item(xx).GetResultText(TB)
If SkSymText <> "ASSEMBLIES/CAR:" Then
'MsgBox SkSymText
SkSymVal = oSheet.SketchedSymbols.Item(xx).GetResultText(TB)
'MsgBox SkSymVal
'MsgBox Asc(Left(SkSymVal, 1))
If Asc(Left(SkSymVal, 1)) >= 48 And Asc(Left(SkSymVal, 1)) <= 57 Then
'OUT!!! SkSymVal = SkSymVal + 1
'MsgBox Asc(Left(SkSymVal, 1))
'MsgBox SkSymVal
AsyPerCar = SkSymVal
End If
End If
Next
End If
Next
'GETS "QTY/CAR" QUANTITY FROM SECOND ASSEMBLY LIST FOR MULTIPLIER IN SPECIALTY LIST
Dim oPartLists As PartsLists
Dim oPartsList As PartsList
Dim oRow As PartsListRow
Dim oColumn As PartsListColumn
Dim QtyNxtAsy As Integer
Dim RowsNxtAsy As Integer
Dim PrtLstNxtAsy As Integer
If oSheet.PartsLists.Count > 0 Then
'gets a count of part lists
For PrtLstNxtAsy = 1 To oSheet.PartsLists.Count
Set oPartsList = oSheet.PartsLists.Item(PrtLstNxtAsy)
'iterates through parts list until it finds the one for the Next Assembly
If oPartsList.PartsListColumns.Item(4).Title = "NEXT ASSY./APPL." Then
RowsNxtAsy = oPartsList.PartsListRows.Count
For Each oRow In oPartsList.PartsListRows
If oRow.Visible = True Then
QtyNxtAsy = QtyNxtAsy + oRow.Item(oPartsList.PartsListColumns.Item(2)).Value
AsyPerCar = QtyNxtAsy
End If
Next
End If
Next
Else
End If
If AsyPerCar <> 0 Then
SpecQtyCar = SpecQtyCar * AsyPerCar
End If
Set oCalcSheet = oCalcDoc.getSheets().GetByName("SPECIALTY") '.GetByIndex(0)
For specQtyLookup = 0 To specListLine
Set LFcell1 = oCalcSheet.getCellByPosition(2, specQtyLookup)
Set LFcell2 = oCalcSheet.getCellByPosition(1, specQtyLookup)
Cellval = LFcell1.String
Cellval2 = LFcell2.String
If Cellval = SpecPrtDesc And Cellval2 = SpecPrtNo Then
Set LFcell3 = oCalcSheet.getCellByPosition(3, specQtyLookup)
QtyVal = LFcell3.Value
NewSpecQtyCar = QtyVal + SpecQtyCar
Call oCalcSheet.getCellByPosition(3, specQtyLookup).SetFormula(NewSpecQtyCar)
specQtyLookup = specListLine
End If
Next
If NewSpecQtyCar = 0 Then
Call oCalcSheet.getCellByPosition(2, specListLine).SetFormula(SpecPrtDesc)
Call oCalcSheet.getCellByPosition(1, specListLine).SetFormula(SpecPrtNo)
Call oCalcSheet.getCellByPosition(3, specListLine).SetFormula(SpecQtyCar)
specListLine = specListLine + 1
Else
End If
End Sub
Private Sub CloseDwg(thing)
'MsgBox " "
ThisApplication.SilentOperation = True
odoc.Close
ThisApplication.SilentOperation = False
End Sub