I have a issue regarding the constraints in Catia VBA, please look at the below code.
Sub catmain()
Dim CAT_documents As Documents
Set CAT_documents = CATIA.Documents
Dim prod_doc As ProductDocument
Set prod_doc = CATIA.ActiveDocument
Dim prod As Product
Set prod = prod_doc.Product
Call constraint_everything(prod)
End Sub
Sub constraint_everything(cProd As Product)
Dim constraints1 As Constraints
Set constraints1 = cProd.Connections("CATIAConstraints")
Dim temp As Product
If cProd.Products.Count > 0 Then
For i = 1 To cProd.Products.Count
Set temp = cProd.Products.Item(i)
Dim osel 'as Selection
Set osel = CATIA.ActiveDocument.Selection
'On Error Resume Next
osel.Clear
osel.Add temp
Dim dispname As String
dispname = osel.Item(1).Reference.DisplayName & "!" & osel.Item(1).Reference.DisplayName
Dim ref As Reference
Set ref = cProd.CreateReferenceFromName(dispname)
Dim constraint1 As Constraint
Set constraint1 = constraints1.AddMonoEltCst(catCstTypeReference, ref)
If (temp.Products.Count > 0) Then
Call constraint_everything(temp)
Else
End If
Next
Else
End If
End Sub
please check the below image.
here i am trying to constraint the product marked in RED but the below part is getting constrained.
i think this is because both have same Instance name. is there any thing which i can do to resolve this issue. Apart from changing the instance name which is integral to the structure.
Thanks.
Related
Can any one explain me to get the object entites count of the layer
using vba code acad
I think You should use SelectionSets
Public Sub SelsetByLayer()
Dim ss As AcadSelectionSet
Dim FilterType(0) As Integer
Dim FilterData(0) As Variant
FilterType(0) = 8 ' DXF code of Layer property
For I = 0 To ThisDrawing.Layers.Count
' ThisDrawing.SelectionSets.Item(0).Delete
Set ss = ThisDrawing.SelectionSets.Add("test") ' You need to ensure if such selection set not exist yet .
FilterData(0) = ThisDrawing.Layers.Item(I).Name
ss.Select acSelectionSetAll, , , FilterType, FilterData
Next
End Sub
Further to the original answer, about using selection sets.
Here it is slightly modified:
Public Sub SelsetByLayer()
Dim ss As AcadSelectionSet
Dim FilterType(0) As Integer
Dim FilterData(0) As Variant
FilterType(0) = 8 ' DXF code of Layer property
For I = 0 To ThisDrawing.Layers.Count
Set ss = CreateSelectionSet("test")
FilterData(0) = ThisDrawing.Layers.Item(I).Name
ss.Select acSelectionSetAll, , , FilterType, FilterData
Next
End Sub
Public Function CreateSelectionSet(SelName As String) As AcadSelectionSet
On Error Resume Next
' Create a new selection set
' Delete any existing selection set with the specified name
With ThisDrawing
Set CreateSelectionSet = .SelectionSets.Add(SelName)
If (Err.Number <> 0) Then
Err.Clear
.SelectionSets.Item(SelName).Delete
Set CreateSelectionSet = .SelectionSets.Add(SelName)
End If
End With
End Function
I have added in the missing method for managing the deletion of existing selection set.
ss.Count will have the number of entities found. But please bear in mind that you may have layers frozen off etc. in the drawing and I think these will be excluded from the totals.
To my understanding Chars have the ChartType as XlChartType property that but that is a long list of Enumerated Values. Is there a way to test if chart is using stacked Series without listing them all?
I am trying to avoid following scenario:
Select ActiveChart.ChartType
Case xlAreaStacked
....
Case xlBarStacked
....
Case xlColumnStacked
....
... 1000 more Cases ....
End Select
Some sample code below to produce a dictionary object with the members of the requested Enum.
Code adapted from dlmille's answer here: http://www.experts-exchange.com/Software/Office_Productivity/Office_Suites/MS_Office/Excel/Q_27613392.html
Sub tester()
Dim dict
Set dict = GetEnumLookup("Excel", "XlChartType")
If Not dict Is Nothing Then
'get string from numeric value and see if it contains "stacked"
Debug.Print UCase( dict(XlChartType.xl3DAreaStacked) ) Like "*STACKED*"
Debug.Print UCase( dict(XlChartType.xl3DArea) ) Like "*STACKED*"
Else
MsgBox "Enum not recognised!"
End If
End Sub
'VB Project References required:
' Microsoft Visual Basic for Applications Extensibility
' TypeLib Information
Function GetEnumLookup(LibName As String, sEnumName As String) As Object
Dim rv As Object
Dim tl As TLI.TypeLibInfo
Dim mi As TLI.MemberInfo
Dim tiEnum As TLI.TypeInfo
Dim vbProj As VBProject, oVBProjRef As Reference
Set vbProj = ThisWorkbook.VBProject
For Each oVBProjRef In vbProj.References
'Debug.Print oVBProjRef.Name, oVBProjRef.FullPath
If oVBProjRef.Name = LibName Then
Set tl = New TypeLibInfo
tl.ContainingFile = oVBProjRef.FullPath
On Error Resume Next
Set tiEnum = tl.GetTypeInfo(sEnumName)
On Error GoTo 0
If Not tiEnum Is Nothing Then
Set rv = CreateObject("scripting.dictionary")
For Each mi In tiEnum.Members
rv.Add mi.Value, mi.Name
'or if you want to map the other direction...
'rv.Add mi.Name, mi.Value
Next mi
End If
Exit For
End If
Next oVBProjRef
Set GetEnumLookup = rv
End Function
I am totally new in VBA and coding in general, am trying to get data from cells from the same workbook (get framework path ...) and then to start application (QTP) and run tests.
I am getting this error when trying to get values entered in excel cells:
Run Time Error '424' object required
I believe I am missing some basic rules but I appreciate your help. Please see below the part of code in question:
Option Explicit
Private Sub RunTest_Click()
Dim envFrmwrkPath As Range
Dim ApplicationName As Range
Dim TestIterationName As Range
'Dim wb As Workbook
'Dim Batch1 As Worksheets
Dim objEnvVarXML, objfso, app As Object
Dim i, Msgarea
Set envFrmwrkPath = ActiveSheet.Range("D6").Value ' error displayed here
Set ApplicationName = ActiveSheet.Range("D4").Value
Set TestIterationName = ActiveSheet.Range("D8").Value
The first code line, Option Explicit means (in simple terms) that all of your variables have to be explicitly declared by Dim statements. They can be any type, including object, integer, string, or even a variant.
This line: Dim envFrmwrkPath As Range is declaring the variable envFrmwrkPath of type Range. This means that you can only set it to a range.
This line: Set envFrmwrkPath = ActiveSheet.Range("D6").Value is attempting to set the Range type variable to a specific Value that is in cell D6. This could be a integer or a string for example (depends on what you have in that cell) but it's not a range.
I'm assuming you want the value stored in a variable. Try something like this:
Dim MyVariableName As Integer
MyVariableName = ActiveSheet.Range("D6").Value
This assumes you have a number (like 5) in cell D6. Now your variable will have the value.
For simplicity sake of learning, you can remove or comment out the Option Explicit line and VBA will try to determine the type of variables at run time.
Try this to get through this part of your code
Dim envFrmwrkPath As String
Dim ApplicationName As String
Dim TestIterationName As String
Simply remove the .value from your code.
Set envFrmwrkPath = ActiveSheet.Range("D6").Value
instead of this, use:
Set envFrmwrkPath = ActiveSheet.Range("D6")
You have two options,
-If you want the value:
Dim MyValue as Variant ' or string/date/long/...
MyValue = ThisWorkbook.Sheets(1).Range("A1").Value
-if you want the cell object:
Dim oCell as Range ' or object (but then you'll miss out on intellisense), and both can also contain more than one cell.
Set oCell = ThisWorkbook.Sheets(1).Range("A1")
Private Sub CommandButton1_Click()
Workbooks("Textfile_Receiving").Sheets("menu").Range("g1").Value = PROV.Text
Workbooks("Textfile_Receiving").Sheets("menu").Range("g2").Value = MUN.Text
Workbooks("Textfile_Receiving").Sheets("menu").Range("g3").Value = CAT.Text
Workbooks("Textfile_Receiving").Sheets("menu").Range("g4").Value = Label5.Caption
Me.Hide
Run "filename"
End Sub
Private Sub MUN_Change()
Dim r As Integer
r = 2
While Range("m" & CStr(r)).Value <> ""
If Range("m" & CStr(r)).Value = MUN.Text Then
Label5.Caption = Range("n" & CStr(r)).Value
End If
r = r + 1
Wend
End Sub
Private Sub PROV_Change()
If PROV.Text = "LAGUNA" Then
MUN.Text = ""
MUN.RowSource = "Menu!M26:M56"
ElseIf PROV.Text = "CAVITE" Then
MUN.Text = ""
MUN.RowSource = "Menu!M2:M25"
ElseIf PROV.Text = "QUEZON" Then
MUN.Text = ""
MUN.RowSource = "Menu!M57:M97"
End If
End Sub
I have the following code:
Sub AddSources()
Dim pubPage As Page
Dim pubShape As Shape
Dim hprlink As Hyperlink
Dim origAddress() As String
Dim exportFileName As String
exportFileName = "TestResume"
Dim linkSource As String
linkSource = "TestSource2"
Dim hyperLinkText As TextRange
For Each pubPage In ActiveDocument.Pages
For Each pubShape In pubPage.Shapes
If pubShape.Type = pbTextFrame Then
For Each hprlink In pubShape.TextFrame.TextRange.Hyperlinks
If InStr(hprlink.Address, "http://bleaney.ca") > 0 Then
hyperLinkText = hprlink.Range
origAddress = Split(hprlink.Address, "?source=")
hprlink.Address = origAddress(0) + "?source=" + linkSource
hprlink.Range = hyperLinkText
End If
Next hprlink
End If
Next pubShape
Next pubPage
ThisDocument.ExportAsFixedFormat pbFixedFormatTypePDF, "C:\" + exportFileName + ".pdf"
End Sub
I am getting the "Object variable or With block variable not set (Error 91)" error on the line with hyperLinkText = hprlink.Range. When I debug I can see that hprlink.Range does have a value. Any thoughts what I'm doing wrong?
As I wrote in my comment, the solution to your problem is to write the following:
Set hyperLinkText = hprlink.Range
Set is needed because TextRange is a class, so hyperLinkText is an object; as such, if you want to assign it, you need to make it point to the actual object that you need.
I am working on a project that joins two or more pp presentations into one new presentation.
The selection of the original pp presentations is in a webbased Lotus Notes xPage and after the submit, Lotusscript talkes to the OLE Powerpoint object.
Adding the slides into the new Presentation in the right order is no problem.
The problem is that after the adding the original connection with the slides Template(s) is lost.
To solve this I found the next codesnippet:
Sub joiner()
Dim sFileName As String
Dim oDonor As Variant
Dim otarget As Variant
Dim i As Integer
On Error GoTo errhandler
Set otarget = ActivePresentation
Do While sFileName <> ""
Set oDonor = Presentations.Open(Environ("USERPROFILE") & "\Desktop\joiner\" & sFileName, msoFalse)
For i = 1 To oDonor.Slides.Count
oDonor.Slides(i).Copy
With otarget.Slides.Paste(otarget.Slides.Count + 1)
.Design = oDonor.Slides(i).Design
.ColorScheme = oDonor.Slides(i).ColorScheme
End With
Next i
oDonor.Close
Set oDonor = Nothing
sFileName = Dir()
Loop
End Sub
I have to declare the presentations oDonor and oTarget as a Variant because lotusscript doesn't understand Dim oTarget As Presentation
This is probably the reason why the code returns a typemismatch error at:
.Design = oDonor.Slides(i).Design
My questions are:
Am I doing the join the right way or is there a better solution?
Is there a solution for the typemismatch error?
*ps: The result presentation doesn't have to be editable, so maybe it is not necessary to add templates.
Update 04-10-2012:
The next code solves the template problem.
What still is missing now is the background image used by some slides.
See: https://stackoverflow.com/questions/12731691/how-to-export-a-backgroundimage-of-a-slide-to-the-filesystem
Dim oDonor As Variant
Dim h As Integer
Dim thetmplt As Variant
Dim thetmpltname As String
Dim thetmpltnew As Variant
Dim thetmpltnamenew As String
Set oDonor = PPApplication.Presentations.Open(tempdirectory +
jobid+CStr(filenamearray (i)),False,False,False)
thetmplt = oDonor.TemplateName
Call oDonor.SaveAs(tempdirectory +jobid+CStr(i)+ thetmplt+".pot" ,5, -1)
For h = 1 To oDonor.Slides.Count
Dim oTargetSlide As Variant
oDonor.Slides(h).Copy
Set oTargetSlide = newPres.Slides.Paste()
Next
Dim theubound As Variant
theubound = oDonor.Slides.Count
ReDim thearray(1 To k + theubound) As Variant
For k = k To k + oDonor.Slides.Count-1
thearray(k) = k
Next
Call newPres.Slides.Range(thearray()).ApplyTemplate(tempdirectory +
jobid+CStr(i+thetmplt+".pot")
oDonor.Close
Set oDonor = Nothing
This is just a hunch, but try:
Dim oTargetSlide as Variant
Set oTargetSlide = otarget.Slides.Paste(otarget.Slides.Count + 1)(1)
With oTargetSlide
.Design = oDonor.Slides(i).Design
.ColorScheme = oDonor.Slides(i).ColorScheme
End With