This is de VBA code.
Option Explicit
Option Compare Text
Sub PartsnaarPDM()
Debug.Print "**** /PARTS LIST EXPORT START ****'"
' Make sure a drawing document is active.
Dim drawDoc As Document
Set drawDoc = ThisApplication.ActiveDocument
Dim activedrawing$
activedrawing$ = drawDoc.fullfilename
On Error Resume Next
'excel declaraties
Dim xls As Excel.Application
Dim wkb1 As Excel.Workbook
Dim wks1 As Excel.WorkSheet
Dim wks2 As Excel.WorkSheet
Dim wks3 As Excel.WorkSheet
'**** tekst file for debugging
'Bestandslocatie en bestandsnaam
Dim txtpath As String
txtpath = "C:\Temp\Inventor_debugfile.txt"
'tekst bestand leegmaken
Open txtpath For Output As #1: Close #1
'tekst toevoegen
Open txtpath For Append As #1
'-----------------------------------------------------------------------------------------
'Als je niet in de tekening omgeving zit
If Not (TypeOf drawDoc Is DrawingDocument) Then
MsgBox "A drawing must be active."
Exit Sub
End If
' Make sure a parts list is selected.
Dim partList As PartsList 'object
Set partList = drawDoc.SelectSet.Item(1)
'als geen parts list geselecteerd is.
If Err.Number <> 0 Then
MsgBox ("Selecteer een parts list")
'error waarde wordt gereset zodat de code weer gebruikt kan worden verderop in de code
Err.Clear
Debug.Print "parts list selecteren"
Print #1, "parts list selecteren"
Set partList = ThisApplication.CommandManager.Pick(kDrawingPartsListFilter, "Selecteer parts list")
End If
'Parts list moet in de juiste stijl staan 'PartsList.Style() As PartsListStyle
If partList.Style.Name = "KW Mono" Then
partList.Style = drawDoc.StylesManager.PartsListStyles.Item("KW_export_BOM_MONO")
Else
If partList.Style.Name <> "KW_export_BOM" Then
partList.Style = drawDoc.StylesManager.PartsListStyles.Item("KW_export_BOM")
'MsgBox ("Verander de parts list style naar:" & vbNewLine & "KW_export_BOM" & vbNewLine & "Annotate -> Format")
'Exit Sub
End If
End If
'Bij fout
If Err.Number <> 0 Then
MsgBox ("FOUT bij parts list selectie")
If Not wkb1 Is Nothing Then wkb1.Close False
If Not xls Is Nothing Then xls.Quit
Err.Clear
End
Exit Sub
End If
'-----------------------------------------------------------------------------------------
Set xls = GetObject(, "Excel.Application")
Set xls = New Excel.Application
Set wkb1 = xls.Workbooks.Open("c:\pdm2012\inventor2PDM.xls")
Set wks1 = wkb1.Worksheets(1)
Set wks2 = wkb1.Worksheets(2)
Set wks3 = wkb1.Worksheets(3)
Debug.Print "sheet1 = " & wks1.Name
Debug.Print "sheet2 = " & wks2.Name
Debug.Print "sheet3 = " & wks3.Name
Print #1, "sheet1 = " & wks1.Name
Print #1, "sheet2 = " & wks2.Name
Print #1, "sheet3 = " & wks3.Name
'Als excel bestand niet bestaat
If Err.Number <> 0 Then
MsgBox ("1) Excel tabel inventor2PDM.xls is niet gevonden")
If Not wkb1 Is Nothing Then wkb1.Close False
If Not xls Is Nothing Then xls.Quit
Err.Clear
End
Exit Sub
End If
Debug.Print "Parts list kopiëren"
Print #1, "Parts list kopiëren"
Dim Counter As Integer
Counter = 1
'Activate the destination worksheet
Debug.Print "worksheet 2 activeren en leeg maken"
Print #1, "worksheet 2 activeren en leeg maken"
wks2.Cells.Clear
'------------------------------------------------------------------------
Debug.Print " Stuklijst exporteren"
Print #1, " Stuklijst exporteren"
'Starting cell position on the Excel sheet
Dim iRowStart As Integer: iRowStart = 1
Dim iColStart As Integer: iColStart = 1
'Export headers
Dim iRow As Integer: iRow = iRowStart
Dim iCol As Integer: iCol = iColStart
Dim oCol As PartsListColumn
For Each oCol In partList.PartsListColumns
wks2.Cells(iRow, iCol).Value = oCol.Title
iCol = iCol + 1
Next
iRow = iRow + 1
' Export content
Dim oRow As PartsListRow
For Each oRow In partList.PartsListRows
If oRow.Visible Then
iCol = iColStart
Dim oCell As PartsListCell
For Each oCell In oRow
wks2.Cells(iRow, iCol).Value = oCell.Value
iCol = iCol + 1
Next
iRow = iRow + 1
End If
Next
Debug.Print " Stuklijst in Excel geplaatst"
Print #1, " Stuklijst in Excel geplaatst"
'------------------------------------------------------------------------
'Fout tijdens exporteren
If Err.Number <> 0 Then
MsgBox ("Fout tijdens exporteren")
If Not wkb1 Is Nothing Then wkb1.Close False
If Not xls Is Nothing Then xls.Quit
Err.Clear
End
Exit Sub
End If
If Err.Number <> 0 Then
MsgBox ("Fout met Excel en stuklijst")
'ActiveWorkbook.Close savechanges:=False
If Not wkb1 Is Nothing Then wkb1.Close False
If Not xls Is Nothing Then xls.Quit
Err.Clear
End
Exit Sub
End If
'-----------------------------------------------------------------------------------------
'Besteld en toeleveringen verwijderen uit stuklijst
'Alleen voorraad in stuklijst
Dim i As Integer
Dim j As Integer
Debug.Print "Alleen voorraadartikelen in stuklijst"
Print #1, "Alleen voorraadartikelen in stuklijst"
Dim LastRow1 As Long
With wks2 'Laatste rij vinden
LastRow1 = .Cells(.Rows.count, "A").End(xlUp).Row
Debug.Print "Lastrow1 = " & LastRow1
Print #1, "Lastrow1 = " & LastRow1
End With
For j = 2 To LastRow1
'Artikelnummer in hoofdletters anders leest PDM ze niet uit.
wks2.Cells(j, "C").Value = UCase(wks2.Cells(j, "C").Value)
'---------------------------
If wks2.Cells(j, "M") <> "M" Then
Debug.Print " POS: " & wks2.Cells(j, "A") & " - is Besteldeel, regel verwijderen"
Print #1, " POS: " & wks2.Cells(j, "A") & " - is Besteldeel, regel verwijderen"
wks2.Cells(j, "M").EntireRow.ClearContents
'wks2.Cells(j, "M").EntireRow.Delete xlUp
Else
Debug.Print " POS: " & wks2.Cells(j, "A") & " - is voorraaddeel"
Print #1, " POS: " & wks2.Cells(j, "A") & " - is voorraaddeel"
End If
'---------------------------
If wks2.Cells(j, "C") = "" And wks2.Cells(j, "M") <> "" Then
Debug.Print " POS: " & wks2.Cells(j, "A") & " - artikel is niet ingevuld"
Print #1, " POS: " & wks2.Cells(j, "A") & " - artikel is niet ingevuld"
MsgBox "Artikelnummer is leeg, deze moet ingevuld zijn bij voorraaddeel" & vbNewLine & "POS: " & wks2.Cells(j, "A") & vbNewLine & "Parts list niet geëxporteerd"
If Not wkb1 Is Nothing Then wkb1.Close False
If Not xls Is Nothing Then xls.Quit
Exit Sub
End If
'---------------------------
Next j
'Bij fout
If Err.Number <> 0 Then
MsgBox ("Fout bij verwijderen bestelde artikelen")
If Not wkb1 Is Nothing Then wkb1.Close False
If Not xls Is Nothing Then xls.Quit
Err.Clear
End
Exit Sub
End If
With wks2 'Laatste rij vinden
LastRow1 = .Cells(.Rows.count, "A").End(xlUp).Row
Debug.Print "Lastrow1 = " & LastRow1
Print #1, "Lastrow1 = " & LastRow1
End With
'------------------------------------------------------------------
'20x300 naar LB=0020x0300 voor export naar PDM
Debug.Print "ilogic regel uitvoeren: afmetingen_format "
Print #1, "ilogic regel uitvoeren: afmetingen_format "
'//////////////////////////////////////////////////////////////////////////////////////
'Sub Afmetingen_format()
'On Error Resume Next
Dim continue_rule As String
continue_rule = "0"
If Err.Number <> 0 Then
MsgBox ("Fout bij openen Excel workbook, inventor2PDM.xlsx")
continue_rule = "2"
If Not wkb1 Is Nothing Then wkb1.Close False
If Not xls Is Nothing Then xls.Quit
Err.Clear
Exit Sub
End If
'------------------------------------------------------------------------------
'******************** afmetingen format
Dim x As Long, LastRow As Long
Debug.Print " Unit in m of in m2, controle"
Print #1, " Unit in m of in m2, controle"
With wks2 'Laatste rij vinden
LastRow1 = .Cells(.Rows.count, "A").End(xlUp).Row
Debug.Print "Lastrow1 = " & LastRow1
Print #1, "Lastrow1 = " & LastRow1
End With
Dim foutmelding As String
foutmelding = "0"
For j = 2 To LastRow1
If Err.Number <> 0 Then
'Hier code plaatsen die uitgevoerd dient te worden bij een fout
continue_rule = "2"
MsgBox ("Fout bij afmetingen formatteren" & vbNewLine & "POS: " & wks2.Cells(j, "A"))
If Not wkb1 Is Nothing Then wkb1.Close False
If Not xls Is Nothing Then xls.Quit
Err.Clear
'Exit Sub
End If
Debug.Print " POS: " & wks2.Cells(j, "A")
Print #1, " POS: " & wks2.Cells(j, "A")
Dim LString As String
Dim LArray() As String
'Unit invullen
If wks2.Cells(j, "L") = "" Then 'Leeg
Debug.Print " 01-Unit moet ingevuld zijn met m of m2 - " & "POS:" & wks2.Cells(j, "A") & vbNewLine; "/wordt nu automatisch zelf ingevuld"
Print #1, " 01-Unit moet ingevuld zijn met m of m2 - " & "POS:" & wks2.Cells(j, "A") & vbNewLine; "/wordt nu automatisch zelf ingevuld"
Dim celltxt As String
celltxt = wks2.Cells(j, "C")
Debug.Print " celltxt = " & celltxt
Print #1, " celltxt = " & celltxt
If InStr(1, celltxt, "2P") Then
wks2.Cells(j, "L") = "M2"
Debug.Print " M2 ingevuld als unit"
Print #1, " M2 ingevuld als unit"
ElseIf wks2.Cells(j, "C") <> "" And wks2.Cells(j, "A") <> "" And wks2.Cells(j, "E") <> "" Then
wks2.Cells(j, "L") = "M"
Debug.Print " M ingevuld als unit"
Print #1, " M ingevuld als unit"
ElseIf wks2.Cells(j, "C") <> "" And wks2.Cells(j, "A") <> "" And wks2.Cells(j, "E") = "" Then
wks2.Cells(j, "L") = "ST"
Debug.Print " ST ingevuld als unit"
Print #1, " ST ingevuld als unit"
End If
End If
If wks2.Cells(j, "L") = "M" Then 'Meters gevonden
Debug.Print "POS: " & wks2.Cells(j, "A") & " - Buis/koker"
Print #1, "POS: " & wks2.Cells(j, "A") & " - Buis/koker"
LString = wks2.Cells(j, "E") 'E is afmeting
If LString = "" Then
MsgBox ("POS: " & wks2.Cells(j, "A") & "Afmetingen moeten ingevuld zijn ")
foutmelding = "1"
End If
LString = Replace(LString, " ", "") 'spaties weghalen
wks2.Cells(j, "E") = LString
Dim IsAlphabet As Boolean
Dim chkChar As String
'Dim Counter As Integer
Dim MyString As String
MyString = wks2.Cells(j, "E") 'E is afmeting
MyString = UCase(MyString) 'alles in hoofdletters
Debug.Print " Check op geen letters in de afmeting met unit: M, staan."
Print #1, " Check op geen letters in de afmeting met unit: M, staan."
For Counter = 1 To Len(MyString)
chkChar = Mid(MyString, Counter, 1)
IsAlphabet = Asc(chkChar) > 64 And Asc(chkChar) < 91
If IsAlphabet = True Then
MsgBox "POS:" & wks2.Cells(j, "A") & "Er mogen geen letters in afmeting met unit: M staan" & vbNewLine & " Parts list niet geëxporteerd"
continue_rule = "2"
If Not wkb1 Is Nothing Then wkb1.Close False
If Not xls Is Nothing Then xls.Quit
Exit Sub
End If
Next
ElseIf wks2.Cells(j, "L") = "M2" Then 'Meter2 gevonden
Debug.Print "POS " & wks2.Cells(j, "A") & " - Plaatwerk"
Debug.Print " Afmetingen kolom = E" 'E is afmeting
Print #1, " POS " & wks2.Cells(j, "A") & " - Plaatwerk"
Print #1, " Afmetingen kolom = E" 'E is afmeting
LString = wks2.Cells(j, "E") 'E is afmeting
If LString = "" Then
MsgBox ("POS: " & wks2.Cells(j, "A") & "Afmetingen moeten ingevuld zijn ")
foutmelding = "1"
End If
LString = Replace(LString, " ", "") 'spaties weghalen
LString = Replace(LString, "LB=", "")
If InStr(1, LString, "x") Then
LArray = Split(LString, "x") 'zoekstring
Debug.Print " bevat kleine x"
Print #1, " bevat kleine x"
ElseIf InStr(1, LString, "X") Then
LArray = Split(LString, "X") 'zoekstring
Debug.Print " bevat grote X"
Print #1, " bevat grote X"
Else
Debug.Print " fout bij afmetingen plaat"
Print #1, " fout bij afmetingen plaat"
MsgBox ("POS: " & wks2.Cells(j, "A") & " Fout bij afmetingen Plaat")
If Not wkb1 Is Nothing Then wkb1.Close False
If Not xls Is Nothing Then xls.Quit
Exit Sub
End If
Debug.Print " van 500x500 naar LB=0500x0500"
Print #1, " van 500x500 naar LB=0500x0500"
'van 500x500 naar LB=0500x0500
Dim lengte1 As Double
Dim breedte1 As Double
lengte1 = LArray(0)
breedte1 = LArray(1)
Dim lengte As String
Dim breedte As String
lengte = Format(lengte1, "0000")
Debug.Print " lengte = " & lengte
Print #1, " lengte = " & lengte
breedte = Format(breedte1, "0000")
Debug.Print " breedte = " & breedte
Debug.Print " LB=" & lengte & "X" & breedte
Print #1, " breedte = " & breedte
Print #1, " LB=" & lengte & "X" & breedte
wks2.Cells(j, "E") = "LB=" & lengte & "X" & breedte
'MsgBox Cells(j, "E")
End If
If Err.Number <> 0 Then
MsgBox ("Fout bij afmetingen omzetten van 500x500 naar LB=0500x0500" & vbNewLine & "POS: " & wks2.Cells(j, "A"))
continue_rule = "2"
If Not wkb1 Is Nothing Then wkb1.Close False
If Not xls Is Nothing Then xls.Quit
Err.Clear
Exit Sub
End If
Debug.Print " volgende POS"
Next j
If foutmelding = "1" Then
MsgBox "Parts list niet geëxporteerd"
Close #1
If Not wkb1 Is Nothing Then wkb1.Close False
If Not xls Is Nothing Then xls.Quit
Exit Sub
End If
'------------------------------------------------------------------------------
If Err.Number <> 0 Then
MsgBox ("Algemene Fout")
continue_rule = "2"
If Not wkb1 Is Nothing Then wkb1.Close False
If Not xls Is Nothing Then xls.Quit
Err.Clear
Exit Sub
End If
'einde afmetingen format
'---------------------------
'START Lege rijen verwijderen op basis van niet ingevulde positienummers
With wks2 'Laatste rij vinden
LastRow1 = .Cells(.Rows.count, "A").End(xlUp).Row
Debug.Print "Lastrow1 = " & LastRow1
Print #1, "Lastrow1 = " & LastRow1
End With
For j = LastRow1 To 1 Step -1
If wks2.Cells(j, 1) = "" Then
wks2.Rows(j).EntireRow.Delete
Debug.Print "Rij is leeg dus verwijderen"
Print #1, "Rij is leeg dus verwijderen"
End If
Next
'EINDE Lege rijen verwijderen op basis van niet ingevulde positienummers
'---------------------------
'als er eerder een fout gevonden is dan wordt dat nu weergegeven
Debug.Print " continue_rule is: " & continue_rule
Debug.Print " **einde - afmetingen format"
Print #1, " continue_rule is: " & continue_rule
Print #1, " **einde - afmetingen format"
If continue_rule = "2" Then
Debug.Print "continue_rule=2 ERROR"
Print #1, "continue_rule=2 ERROR"
If Not wkb1 Is Nothing Then wkb1.Close False
If Not xls Is Nothing Then xls.Quit
Exit Sub
End If
If Err.Number <> 0 Then
MsgBox ("Fout bij afmetingen_format")
If Not wkb1 Is Nothing Then wkb1.Close False
If Not xls Is Nothing Then xls.Quit
Err.Clear
Exit Sub
End If
'-----------------------------------------------------------------------------------------
'*** Uitleg
'Dit stukje code zorgt ervoor dat de gegevens van een bepaalde kolom op sheet2
'gekopieërd worden naar een bepaalde kolom op sheet1
'*************************
'*** Declare Variables ***
'*************************
Dim lLastRow As Long
Dim destRng As Range
'worksheet schoon maken en vervolgens de koppen kopieren van de BOM
wks1.Cells.Clear
wks3.Range("A1:N1").Copy Destination:=wks1.Range("A1")
Dim LastCol2 As Integer
With wks2 'Laatste rij vinden
LastCol2 = .Cells(1, .Columns.count).End(xlToLeft).Column
Debug.Print "LastCol2 = " & LastCol2
Print #1, "LastCol2 = " & LastCol2
End With
'wat in de cases staat daar wordt op gezocht en geplakt
Dim LastCol1 As Integer
With wks1 'Laatste rij vinden
LastCol1 = .Cells(1, .Columns.count).End(xlToLeft).Column
Debug.Print "LastCol1 = " & LastCol1
Print #1, "LastCol1 = " & LastCol1
End With
i = 1
j = 1
Dim columntitle2 As String
Dim columntitle1 As String
For i = 1 To LastCol2
columntitle2 = wks2.Cells(1, i).Value
For j = 1 To LastCol1
columntitle1 = wks1.Cells(1, j).Value
If columntitle2 = columntitle1 Then
wks2.Columns(i).Copy Destination:=wks1.Columns(j)
Debug.Print columntitle2
Print #1, columntitle2
End If
Next
Next
If Err.Number <> 0 Then
MsgBox ("Fout bij kopiëren kolommen; check VBA en Excel")
If Not wkb1 Is Nothing Then wkb1.Close False
If Not xls Is Nothing Then xls.Quit
Err.Clear
End
Exit Sub
End If
'-----------------------------------------------------------------------------------------
'BOM 3 regels omlaag verplaatsen
'zodat het 3 regels lager op BOM word geplaatst
wks1.Rows(2).Insert shift:=xlShiftDown
wks1.Rows(2).Insert shift:=xlShiftDown
wks1.Rows(2).Insert shift:=xlShiftDown
'-----------------------------------------------------------------------------------------
'***************** Omschrijving/datum/gebruiker in stuklijst kop zetten
'declareren
Dim Omschrijving_str$
Dim Datum$
Dim Projectleider$
'tekeningnummer en omschrijving
' Get the active document.
Dim doc As Document
Set doc = ThisApplication.ActiveDocument
' Get the custom property set.
Dim CustomPropSet As PropertySet
Set CustomPropSet = doc.PropertySets.Item( _
"Inventor User Defined Properties")
' Get the property named "tekeningnummer".
Dim customProp As Property
Set customProp = CustomPropSet.Item("02-Tekeningnummer")
Dim customProp2 As Property
Set customProp2 = CustomPropSet.Item("02-Omschrijving")
If Err.Number <> 0 Then
MsgBox ("02-Tekeningnummer & 02-Omschrijving niet gevonden")
If Not wkb1 Is Nothing Then wkb1.Close False
If Not xls Is Nothing Then xls.Quit
Err.Clear
End
Exit Sub
End If
' Display the value of the iProperty.
Dim Tekeningnummer$
Tekeningnummer$ = customProp.Value
Debug.Print "tekeningnummer = " & Tekeningnummer$
Print #1, "tekeningnummer = " & Tekeningnummer$
Dim dwgOmschrijving$
dwgOmschrijving$ = customProp2.Value
Debug.Print "dwgOmschrijving = " & dwgOmschrijving$
Print #1, "dwgOmschrijving = " & dwgOmschrijving$
'Omschrijving invullen
Omschrijving_str$ = Tekeningnummer$
wks3.Cells(2, 4) = Omschrijving_str$ & " - " & dwgOmschrijving$
'datum plakken
Datum$ = Format(Now(), "dd-mm-yyyy")
wks3.Cells(4, 4) = "Datum: " & Datum$
'gebruiker plakken
Projectleider$ = ThisApplication.GeneralOptions.UserName
wks3.Cells(3, 4) = "Projectleider: " & Projectleider$
'-----------------------------------------------------------------------------------------
Debug.Print "layout en tekst kopiëren"
Print #1, "layout en tekst kopiëren"
'layout&koptekst kopieren van bom3 naar bom
wks3.Range("A1:L4").Copy Destination:=wks1.Range("A1")
'AutoFit All Columns on Worksheet
wks1.Cells.EntireColumn.AutoFit
wks1.Cells.WrapText = False
'-----------------------------------------------------------------------------------------
'excel bestand saven/sluiten
wkb1.Close True
Set wks1 = Nothing
Set wks2 = Nothing
Set wks3 = Nothing
Set wkb1 = Nothing
xls.Quit
Set xls = Nothing
'partList.Style = drawDoc.StylesManager.PartsListStyles.Item("KW")
MsgBox "Stuklijst naar Excel geëxporteerd" & vbNewLine & "Wacht op PDM pop-up" & vbNewLine & "druk op OK"
'in pdm zetten
'START.exe uitvoeren en wachten totdat deze compleet uitgevoerd is
Dim wsh As Object
Set wsh = VBA.CreateObject("WScript.Shell")
Dim waitOnReturn As Boolean: waitOnReturn = True
Dim windowStyle As Integer: windowStyle = 1
wsh.Run "c:\pdm2012\mcadp418.exe", windowStyle, waitOnReturn
'EINDE .exe uitvoeren en wachten totdat deze compleet uitgevoerd is
If Err.Number <> 0 Then
'Hier code plaatsen die uitgevoerd dient te worden bij een fout
MsgBox ("Fout bij PDM module")
If Not wkb1 Is Nothing Then wkb1.Close False
If Not xls Is Nothing Then xls.Quit
Err.Clear
End
Exit Sub
End If
Print #1, "**** /PARTS LIST EXPORT KLAAR ****'"
Close #1 'debug tekstfile sluiten
Debug.Print "**** /PARTS LIST EXPORT KLAAR ****'"
Set drawDoc = ThisApplication.Documents.Open(activedrawing$, True)
'--------------------------------------------------------------------------
'Test
Debug.Print
Dim RuleName As String
'********************************| Locatie van de regel |Naam van regel|
RuleName = Inventor_zoeklocatie & "AuTTeK\TDV\Undo.iLogicVb" 'ilogic regel
'***** Externe regel uitvoeren*****
Dim Fname3 As String
Dim RuleName2 As String
Fname3 = ThisApplication.ActiveDocument.fullfilename
If Fname3 = "" Then
MsgBox "Document eerst opslaan"
Exit Sub
End If
Debug.Print Fname3
Call RunRule1(Fname3, RuleName)
'***** updaten *****
Line_update:
ThisApplication.ActiveView.Update
ThisApplication.ActiveDocument.Update
Debug.Print "*Reset k factor* EIND!"
End Sub
