- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report
Hello,
I create rule which copy all old drawing to new template.
The rule copies everything into the current template except the hole table (i know it's impossible by API) but the origin indicator is copied to the new drawing so I think it isn't possible to create new hole table by API.
I need help in creating a rule that finds a drawing view with a origin indicator, selects this drawing view and creates hole tables for it.
The position of the newly generated table will be set to the upper left corner of the drawing frame.
On screen cast you can see my rule in action and below my code:
Dim oDoc As DrawingDocument oDoc = ThisApplication.ActiveDocument Dim oSheet As Sheet oSheet = oDoc.ActiveSheet Dim invCustomPropertySet As PropertySet invCustomPropertySet = oDoc.PropertySets.Item("Inventor User Defined Properties") On Error Resume Next Dim NAZWAWL As String NAZWAWL = invCustomPropertySet.Item("NAZWA").Value 'MessageBox.Show(NAZWAWL, "Odczyt nazwy") If Err.Number <> 0 Then ' Failed to get the property, which means it doesn't exist ' so we'll create it. Call invCustomPropertySet.Add("", "NAZWA") Else End If 'MessageBox.Show(NAZWAWL, "Odczyt nazwy") 'odczyt wielkości arkusza Dim Size As DrawingSheetSizeEnum Size = oSheet.Size 'odczyt orientacji arkusza Orient = OSheet.Orientation 'odczyt nazwy If iProperties.Value("Summary", "Title")<> "" Then Nazwa_rys = iProperties.Value("Summary", "Title") Else Nazwa_rys=NAZWAWL End If oDoc.SelectSet.Clear ' Select all drawing views Dim oView As DrawingView For Each oView In oDoc.ActiveSheet.DrawingViews oDoc.SelectSet.Select(oView) Next Dim oCopyCmd As ControlDefinition oCopyCmd = ThisApplication.CommandManager.ControlDefinitions.Item("AppCopyCmd") oCopyCmd.Execute oDoc.SelectSet.Clear Dim oTargetDoc As DrawingDocument oTargetDoc = ThisApplication.Documents.Open("C:\Standard.idw", True) oTargetDoc.Activate Dim oTargetSheet As Sheet oTargetSheet = oTargetDoc.ActiveSheet oTargetSheet.Size = Size oTargetSheet.Orientation = Orient Dim oPasteCmd As ControlDefinition oPasteCmd = ThisApplication.CommandManager.ControlDefinitions.Item("AppPasteCmd") oPasteCmd.Execute If oTargetSheet.Size = 9997 And oTargetSheet.Orientation = 10243 Then oTargetDoc.ActiveSheet.Name = "A4 PIONOWO" ThisApplication.ActiveView.Fit Else If oTargetSheet.Size = 9997 And oTargetSheet.Orientation = 10242 Then oTargetDoc.ActiveSheet.Name = "A4 POZIOMO" ThisApplication.ActiveView.Fit Else If oTargetSheet.Size = 9996 And oTargetSheet.Orientation = 10243 Then oTargetDoc.ActiveSheet.Name = "A3 PIONOWO" ThisApplication.ActiveView.Fit Else If oTargetSheet.Size = 9996 And oTargetSheet.Orientation = 10242 Then oTargetDoc.ActiveSheet.Name = "A3 POZIOMO" ThisApplication.ActiveView.Fit Else If oTargetSheet.Size = 9995 And oTargetSheet.Orientation = 10243 Then oTargetDoc.ActiveSheet.Name = "A2 PIONOWO" ThisApplication.ActiveView.Fit Else If oTargetSheet.Size = 9995 And oTargetSheet.Orientation = 10242 Then oTargetDoc.ActiveSheet.Name = "A2 POZIOMO" ThisApplication.ActiveView.Fit Else If oTargetSheet.Size = 9994 And oTargetSheet.Orientation = 10243 Then oTargetDoc.ActiveSheet.Name = "A1 PIONOWO" ThisApplication.ActiveView.Fit Else If oTargetSheet.Size = 9994 And oTargetSheet.Orientation = 10242 Then oTargetDoc.ActiveSheet.Name = "A1 POZIOMO" ThisApplication.ActiveView.Fit Else If oTargetSheet.Size = 9993 And oTargetSheet.Orientation = 10243 Then oTargetDoc.ActiveSheet.Name = "A0 PIONOWO" ThisApplication.ActiveView.Fit Else If oTargetSheet.Size = 9993 And oTargetSheet.Orientation = 10242 Then oTargetDoc.ActiveSheet.Name = "A0 POZIOMO" ThisApplication.ActiveView.Fit End If Dim oNOWYDoc As DrawingDocument: oNOWYDoc = oTargetDoc Dim WLASCNOWEGO As PropertySet WLASCNOWEGO = oNOWYDoc.PropertySets.Item("Inventor User Defined Properties") WLASCNOWEGO.Item("NAZWA").Value = Nazwa_rys Arkusz=oNOWYDoc.Sheets.Item(1) 'aktualizacja danych Dim oControlDef as ControlDefinition = ThisApplication.CommandManager.ControlDefinitions.Item("UpdateCopiedModeliPropertiesCmd") oControlDef.Execute2(True) 'REGUŁA DLA ZAPISU If Arkusz.DrawingViews.Count <> 0 Then PNazwa=Arkusz.DrawingViews.Item(1).ReferencedFile.FullFileName 'MessageBox.Show(PNazwa, "Title") Pozycja=InStrRev(PNazwa,"\", -1) NazwaModelu=Right(PNazwa,Len(PNazwa)- Pozycja) scieżkaRysunki = ThisDoc.WorkspacePath()& "\" & "Rysunki" 'MessageBox.Show(scieżkaRysunki, "scieżka") If (Not System.IO.Directory.Exists(scieżkaRysunki))Then System.IO.Directory.CreateDirectory(scieżkaRysunki) End If NumerCzesci=iProperties.Value(NazwaModelu, "Project", "Part Number") 'MessageBox.Show(NumerCzesci, "Title") Plik=scieżkaRysunki & "\" & NumerCzesci & ".idw" 'MessageBox.Show(Plik, "PLIK") oDoc.Close(False) On Error Resume Next'Goto ZAPISZ' oNOWYDoc.SaveAs(Plik, False) 'REGUŁA DLA NAZWY RYSUNKU iProperties.Value("Custom", "NAZWA")= iProperties.Value(NazwaModelu, "Project", "Part Number") InventorVb.DocumentUpdate() 'If WLASCNOWEGO.Item("NAZWA").Value = "" 'TYTUL = InputBox("PODAJ NAZWĘ ELEMENTU", "NAZWA RYSUNKU", WLASCNOWEGO.Item("NAZWA").Value) 'WLASCNOWEGO.Item("NAZWA").Value= TYTUL 'InventorVb.DocumentUpdate() 'Else 'End If 'aktualizacja danych oControlDef.Execute2(True) i = GoExcel.FindRow("BOM.xls", "Arkusz1", "Numer części", "=", iProperties.Value("Project", "Part Number")) iProperties.Value("Custom", "SZTUKI") = GoExcel.CurrentRowValue("ILOŚĆ") InventorVb.DocumentUpdate() 'REGUŁA DLA NAZWY RYSUNKU TYTUL = InputBox("PODAJ NAZWĘ ELEMENTU", "NAZWA RYSUNKU", iProperties.Value("Custom", "NAZWA")) iProperties.Value("Custom", "NAZWA")= TYTUL InventorVb.DocumentUpdate() 'aktualizacja danych oControlDef.Execute2(True) End If
Can you help me with code to create hole table ??
Thanks in advance,
ralfmj
Solved! Go to Solution.
Link copied