SolidWorks API SelectByID2 method - vba

There is a more efficient method using the GetSelectedObjectCount() and GetSelectionPoint2() methods to obtain the points that can be used with SelectByID2 method. The issue of the method below is that creation of each point is not time efficient nor tidy in the feature tree. Will update this thread once I have time.
Thank you for understanding.
I recently started some programming in VBA in SolidWorks and I am looking to write a macro. The goal for now is to create a reference plane from selected face and point(deriving it from edge). As a reminder, method to create the reference plane is InsertRefPlane, which requires the selection to be done by SelectByID2 method.
So far I've managed to save the handle for the face and point objects, but I haven't managed to successfully use the SelectByID2 method. Objects that were selected become deselected.
value = instance.SelectByID2(Name, Type, X, Y, Z, Append, Mark, Callout, SelectOption)
I have tried select just a face, but I couldn't manage to do it. Also, I have renamed the face property using the SetEntityName method, and supplied it as well, but it did not manage to select it.
Could you please share the ideas how to do create a reference plane? It doesn't have to be necessary a face and an edge/mid-point.
Thank you in advance.
Edit 1:
For further clarification, I have added two objects (face and edge) to selection and I would like to use those to properly select objects with SelectByID2 to use for InsertRefPlane. I have added the code below.
Ideas that I have are:
I have handles to the face and the edge, but can I use those for proper selection with SelectByID2?
Can I create a reference points on the selected face and edge to identify the face somehow?
SelectByRay seems feasible, but it would require some calculations with face normals so, I would try some other "simpler" methods if available. Edit 2: I have non-planar face so I can't request Normal property of the face.
Edit 3: It seems that it all comes down to identifying an object name and type is the way to solve the problem. This is probably a solution, but I'm open for another one, easier if possible. We can create a reference points when using one of appropriate Selection methods, because their names are known, we can use those for SelectbyID2 method. Will post the solution once I am done.
Regarding the GetFaces/GetFirstFace/GetNextFace methods, InsertRefPlane requires objects to be selected by SelectByID2
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swPart As SldWorks.PartDoc
Dim swSelMgr As SldWorks.SelectionMgr
Dim swModelDocExt As SldWorks.ModelDocExtension
Dim swFeatMgr As SldWorks.FeatureManager
Dim selBool As Boolean
Dim longstatus As Long, longwarnings As Long
Sub main()
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
Set swModelDocExt = swModel.Extension
Set swPart = swModel
Set swSelMgr = swModel.SelectionManager
Set swFeatMgr = swModel.FeatureManager
' Check which file is opened
Dim filePath As String: filePath = swModel.GetPathName()
Debug.Print "File path is:" & filePath
' User has to select the face and the edge of the body to create plane and
' sketch to convert face entities
' Gets selection from SelectionManager
Dim numSelectedObjs As Long
Dim selectionMark As Long: selectionMark = -1
numSelectedObjs = swSelMgr.GetSelectedObjectCount2(selectionMark)
Debug.Print "Number of selected objects:" & numSelectedObjs
Dim faceObj As SldWorks.Face2
Dim edgeObj As SldWorks.Edge
Dim midpointObj As Object
If (numSelectedObjs > 0) Then
' Get and validate selection
Dim selObj As Object
Dim selObjIndex As Long
Dim selObjType As Long
For selObjIndex = 1 To numSelectedObjs ' This method uses 1 as first index
selObjType = swSelMgr.GetSelectedObjectType3(selObjIndex, selectionMark)
' Check selected object type and assign it to appropriate variable
If (selObjType = SwConst.swSelFACES) Then
Set faceObj = swSelMgr.GetSelectedObject6(selObjIndex, selectionMark)
Dim faceFeat As Object
Set faceFeat = faceObj.GetFeature()
ElseIf (selObjType = SwConst.swSelEDGES) Then
Set edgeObj = swSelMgr.GetSelectedObject6(selObjIndex, selectionMark)
swModel.SelectMidpoint ' With this line, we add point to selection, increasing the count to 3
Dim deselVal As Long
deselVal = swSelMgr.DeSelect2(selObjIndex, selectionMark) ' Deselect the edge
Set midpointObj = swSelMgr.GetSelectedObject6(selObjIndex, selectionMark) ' Set the object to the point
Else
MsgBox "Wrong objects selected, select only face and edge"
Exit For
End If
Next
End If
' Create reference plane using face and a point
' InsertRefPlane method requires selection using SelectByID2 Method
Dim objName, objType As String: objName = "": objType = SwConst.swSelectType_e.swSelFACES
Dim X, Y, Z As Double: X = 0: Y = 0: Z = 0
Dim selAppend As Boolean: selAppend = True
Dim objMark As Long: objMark = 0
Dim objCallout As Callout
Dim selOption As swSelectOption_e: selOption = 0
selBool = swModel.Extension.SelectByID2(objName, objType, X, Y, Z, selAppend, objMark, objCallout, selOption)
Debug.Print selBool

The most of the details are in my question and the last edit is the how I solved it. The way to do it is to:
Obtain a handle to the object (such as face or edge) from the SelectionManager
Create an Entity object of the selected object, this allows you to use Select4 methods
Now you can create reference geometry, and you obtain the Name property which you can use with SelectByID2 method
I tried it out on another model, but can't guarantee it will work for you as well.
' PREREQUISITES:
' User has to select the face and the edge of the body to create plane and
' sketch to convert face entities to it
Sub main()
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
Set swModelDocExt = swModel.Extension
Set swPart = swModel
Set swSelMgr = swModel.SelectionManager
Set swFeatMgr = swModel.FeatureManager
Set swSelData = swSelMgr.CreateSelectData
' Check which file is opened
Dim filePath As String: filePath = swModel.GetPathName()
Debug.Print "File path is:" & filePath
' Gets selection from SelectionManager
Dim numSelectedObjs As Long
Dim selectionMark As Long: selectionMark = -1
numSelectedObjs = swSelMgr.GetSelectedObjectCount2(selectionMark)
Debug.Print "Number of selected objects:" & numSelectedObjs
Dim faceObj As SldWorks.Face2
Dim edgeObj As SldWorks.Edge
Dim vEdges, vEdge As Variant
Dim nEdges As Long
Dim edgeEntityPairs(999), tempEdgeEntity(99, 99) As Variant
Dim loopObj As SldWorks.Loop2
Dim vLoops, vLoop As Variant
Dim nLoops, nLoop As Long
Dim counter(99) As Long
If (numSelectedObjs = 2) Then
' Get and validate selection
Dim selObj As Object
Dim selObjIndex As Long
Dim selObjType As Long
For selObjIndex = 1 To numSelectedObjs ' This method uses 1 as first index
selObjType = swSelMgr.GetSelectedObjectType3(selObjIndex, selectionMark)
Debug.Print "Selected obj type:" & selObjType
' Check selected object type and assign it to appropriate variable
If (selObjType = SwConst.swSelFACES) Then ' Face
Set faceObj = swSelMgr.GetSelectedObject6(selObjIndex, selectionMark)
Set faceEntity = faceObj
vLoops = faceObj.GetLoops()
nLoops = faceObj.GetLoopCount()
' This loop gets the each loop(SW) object and its edges
For Each vLoop In vLoops
' To do: Check if there's only single loop on the face
Set loopObj = vLoop
nEdges = loopObj.GetEdgeCount()
vEdges = loopObj.GetEdges()
For Each vEdge In vEdges
Set edgeObj = vEdge
Set tempEdgeEntity(nLoop, counter(nLoop)) = edgeObj
counter(nLoop) = counter(nLoop) + 1
Next
nLoop = nLoop + 1
Next
ElseIf (selObjType = SwConst.swSelEDGES) Then ' Edge
Set edgeObj = swSelMgr.GetSelectedObject6(selObjIndex, selectionMark)
Set edgeEntity = edgeObj
Else
MsgBox "Wrong type of objects selected, select only face and edge"
Exit For
End If
Next
Else
MsgBox "Wrong number of objects selected"
Stop
End If
'
swModel.ClearSelection2 (True)
Debug.Print "Selection cleared"
selBool = edgeEntity.Select4(True, swSelData)
'Debug.Print "Edge selected - " & selBool
Dim surfaceMidpoint, edgeMidpoint As Variant
Dim surfaceMidpointString, edgeMidpointString As String
edgeMidpoint = swFeatMgr.InsertReferencePoint(2, 1, 50, 1) ' Edge midpoint
edgeMidpointString = edgeMidpoint(0).Name
'''''' To create a reference plane from face and its midpoint
'''''swModel.ClearSelection2 (True)
'''''selBool = faceEntity.Select4(True, swSelData)
'''''Debug.Print "Face selected - " & selBool
'''''
'''''surfaceMidpoint = swModel.FeatureManager.InsertReferencePoint(4, 1, 50, 1) ' Surface midpoint
'''''surfaceMidpointString = surfaceMidpoint(0).Name
'' Create 3 points from 6 edges by intersection for a reference plane
' Get an edge and the one adjacent to it to create a point by InsertReferencePoint method
' Loop that traverses through lists of loop objs, edge entities to
' filter out empty elements
' To do: handle cases where the first loop is the outer one and it has odd number
' of edges, if there are inner loops such as holes that have 2 edges each
' it is not possible to find an intersection point on those edges
kk = 0 ' kk is the number of found edges
For i = 0 To nLoops
For k = 0 To 99
If (Not IsEmpty(tempEdgeEntity(i, k))) Then
Set edgeEntityPairs(kk) = tempEdgeEntity(i, k)
kk = kk + 1
End If
Next
Next
Dim intersectPoint(2) As Variant
Dim intersectPointString(2) As String
' This If statement needs to be more robust, haven't encountered issues
' but there might be some. It is possible to find the outer loop and
' obtain enough points for reference plane just from it
If (kk = 4) Then
' Case where there's only a face that contains 1 loop with 4 edges
swModel.ClearSelection2 (True)
selBool = edgeEntityPairs(0).Select4(True, swSelData)
selBool = edgeEntityPairs(1).Select4(True, swSelData)
intersectPoint(0) = swFeatMgr.InsertReferencePoint(6, 1, 50, 1) ' Edges intersection
swModel.ClearSelection2 (True)
selBool = edgeEntityPairs(1).Select4(True, swSelData)
selBool = edgeEntityPairs(2).Select4(True, swSelData)
intersectPoint(1) = swFeatMgr.InsertReferencePoint(6, 1, 50, 1) ' Edges intersection
swModel.ClearSelection2 (True)
selBool = edgeEntityPairs(2).Select4(True, swSelData)
selBool = edgeEntityPairs(3).Select4(True, swSelData)
intersectPoint(2) = swFeatMgr.InsertReferencePoint(6, 1, 50, 1) ' Edges intersection
swModel.ClearSelection2 (True)
Else
' Case when there are multiple loops and when the first loop is a
' a hole that contains two edges
swModel.ClearSelection2 (True)
selBool = edgeEntityPairs(0).Select4(True, swSelData)
selBool = edgeEntityPairs(1).Select4(True, swSelData)
intersectPoint(0) = swFeatMgr.InsertReferencePoint(6, 1, 50, 1) ' Edges intersection
swModel.ClearSelection2 (True)
selBool = edgeEntityPairs(2).Select4(True, swSelData)
selBool = edgeEntityPairs(3).Select4(True, swSelData)
intersectPoint(1) = swFeatMgr.InsertReferencePoint(6, 1, 50, 1) ' Edges intersection
swModel.ClearSelection2 (True)
selBool = edgeEntityPairs(4).Select4(True, swSelData)
selBool = edgeEntityPairs(5).Select4(True, swSelData)
intersectPoint(2) = swFeatMgr.InsertReferencePoint(6, 1, 50, 1) ' Edges intersection
swModel.ClearSelection2 (True)
End If
' Create reference plane using 3 points
intersectPointString(0) = intersectPoint(0)(0).Name
intersectPointString(1) = intersectPoint(1)(0).Name
intersectPointString(2) = intersectPoint(2)(0).Name
' Selecting the points
For p = 0 To 2
If (p = 0) Then
selBool = swModel.Extension.SelectByID2(intersectPointString(p), "DATUMPOINT", 0, 0, 0, False, 0, Nothing, 0)
Else
selBool = swModel.Extension.SelectByID2(intersectPointString(p), "DATUMPOINT", 0, 0, 0, True, p, Nothing, 0)
End If
Next
' Creating the reference plane
Dim refPlaneObj As Object
Dim firstCon As Long: firstCon = SwConst.swRefPlaneReferenceConstraint_Coincident
Dim firstConVal As Long: firstConVal = 0
Dim secondCon As Long: secondCon = SwConst.swRefPlaneReferenceConstraint_Coincident
Dim secondConVal As Long: secondConVal = 0
Dim thirdCon As Long: thirdCon = SwConst.swRefPlaneReferenceConstraint_Coincident
Dim thirdConVal As Long: thirdConVal = 0
Set refPlaneObj = swModel.FeatureManager.InsertRefPlane(firstCon, firstConVal, _
secondCon, secondConVal, _
thirdCon, thirdConVal)
' Convert face entity to the sketch on the new plane
Dim refPlaneEntity As SldWorks.Entity
Set refPlaneEntity = refPlaneObj
swModel.ClearSelection2 (True)
selBool = refPlaneEntity.Select4(True, swSelData)
swModel.SketchManager.InsertSketch (True)
selVal = faceEntity.Select4(True, swSelData)
boolstatus = swModel.SketchManager.SketchUseEdge3(False, False)
swModel.SketchManager.InsertSketch True
End Sub

Actually it looks like there might be issues because the CAD model is
imported and faces are faces are non-planar.
Hi Mario,
You can check if the selected face is planar by using:
Face.IGetSurface().IsPlane()
Eddy

There could be many reasons why I doesn't work for you.
Without your complete code, it would be difficult to help you.
If your selection get deselected, it might be because you set "Attempt" to False.
Also "Mark" needs to be "0" for the first selection, and "1" for the second.
Look at the remarks and examples in InsertRefPlane
The best way to get a base for your code is to start recording a macro, manually insert a plane then stop and edit the code.
Also SelectByID2 is not the only method to select a face, there is also SelectByRay, or cycle through all the entities with GetFirstFace / GetNextFace or GetFaces to find the one you want.

Related

Creating new sketch in a planar face

In CATIA, a new sketch can be created on a origin plane (XY, YZ, XZ) or a planar face of a object. I have a pad and want to take its top face as the support plane for the next pocket operation. I've strived to do it by the latter but without success due to the failure of Add method in Sketches collection. What was I wrong about?
Here are a piece of my code, which produces the error:
Dim reference3 As Reference
Set reference3 = product1.CreateReferenceFromName("Assembly_Two_Parts/Chi_Tiet_1.1/!Selection_RSur:(Face:(Brp:(Pad.1;0:(Brp:(Sketch.1;1)));None:();Cf11:());Pad.1_ResultOUT;Z0;G6937)")
Set Sketch2 = MyBody1.Sketches.Add(reference3)
Set MyFactory2 = Sketch2.OpenEdition()
Set Circle1 = MyFactory2.CreateClosedCircle(0, 0, 5)
Sketch2.CloseEdition
your string reference is not possible in automation... or you gonna have difficult.
If it can help you :
Sub CATMain()
Dim s ' as selection
Dim myProduct As Product
Dim myPart As Part
Dim myRef 'as reference
'selection of face
Set s = CATIA.ActiveDocument.Selection
s.Clear
Dim Filters(0)
Filters(0) = "PlanarBiDimInfinite" 'after the comment from Shrotter
Status = s.SelectElement2(Filters, "Select a face", True)
If (Status = "Cancel") Then Exit Sub
Set myRef = s.Item2(1).Value
'get your part
Set myProduct = s.Item2(1).LeafProduct
Set myPart = CATIA.Documents.Item(myProduct.PartNumber & ".CATPart").Part
s.Clear
'set your circle in sketch
myPart.InWorkObject = myPart.MainBody
Dim myCircle As Sketch
Set myCircle = myPart.MainBody.Sketches.Add(myRef)
Dim myCircle_ As Circle2D
Set myCircle_ = myCircle.OpenEdition.CreateClosedCircle(0, 0, 50)
'update your part
myPart.Update
End Sub
my website : https://www.catiavb.net/

Create two(2) edge flanges in Solidworks with VBA

Dear SolidWorks users,
I am using SW2012 and via VBA I like to create two(2) edge flanges. I have the following code, this creates one edge flange after you select one edge of the sheet metal.
I like to know how can I add(put) 2 selections edge in an array? Like that (maybe), can be created two(2) edge flanges.
In the function of .InsertSheetMetalEdgeFlange2 it is mention that this function can accept array selection and array sketch.
Thank you.
Sub Bends_2()
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swEdge As SldWorks.Edge
Dim swFeature As SldWorks.Feature
Dim swEntity As SldWorks.Entity
Dim swSketch As SldWorks.Sketch
Dim swSketchLine As SldWorks.SketchLine
Dim swStartPoint As SldWorks.SketchPoint
Dim swEndPoint As SldWorks.SketchPoint
Dim aFlangeEdges(0) As SldWorks.Edge
Dim aSketchFeats(0) As SldWorks.Sketch
Dim vFlangeEdges As Variant
Dim vSketchFeats As Variant
Dim bValue As Boolean
Dim dAngle As Double
Dim dLength As Double
Dim vSketchSegments As Variant
' Connect to SOLIDWORKS
Set swApp = Application.SldWorks
' Get active document
Set swModel = swApp.ActiveDoc
' Set the angle +length
dAngle = (90# / 180#) * 3.1415926535897
dLength = 25 / 1000
swModel.ShowNamedView2 "*Trimetric", -1
swModel.ViewZoomtofit2
' Get edge
Set swEdge = swModel.SelectionManager.GetSelectedObject6(1, -1)
' Insert a sketch for an Edge Flange
Set swFeature = swModel.InsertSketchForEdgeFlange(swEdge, dAngle, False)
' Select
bValue = swFeature.Select2(False, 0)
' Start sketch editing
swModel.EditSketch
' Get the active sketch
Set swSketch = swModel.GetActiveSketch2
' Add the edge to the sketch
Set swEntity = swEdge
' Select edge
bValue = swEntity.Select4(False, Nothing)
' Use the edge in the sketch
bValue = swModel.SketchManager.SketchUseEdge(False)
' Get the created sketch line
vSketchSegments = swSketch.GetSketchSegments
Set swSketchLine = vSketchSegments(0)
' Get start and end point
Set swStartPoint = swSketchLine.GetStartPoint2
Set swEndPoint = swSketchLine.GetEndPoint2
' Create additional lines to define sketch
swModel.SetAddToDB True
swModel.SetDisplayWhenAdded False
swModel.CreateLine2 swStartPoint.X, swStartPoint.Y, 0#, swStartPoint.X, swStartPoint.Y + dLength, 0#
swModel.CreateLine2 swStartPoint.X, swStartPoint.Y + dLength, 0#, swEndPoint.X, swStartPoint.Y + dLength, 0#
swModel.CreateLine2 swEndPoint.X, swEndPoint.Y, 0#, swEndPoint.X, swEndPoint.Y + dLength, 0#
'reset
swModel.SetDisplayWhenAdded True
swModel.SetAddToDB False
' Commit changes made to the sketch
swModel.InsertSketch2 True
Set aFlangeEdges(0) = swEdge
Set aSketchFeats(0) = swSketch
vFlangeEdges = aFlangeEdges
vSketchFeats = aSketchFeats
'create edge flange
Set swFeature = swModel.FeatureManager.InsertSheetMetalEdgeFlange2((vFlangeEdges), (vSketchFeats), 128, dAngle, 0.7 / 1000, swFlangePositionTypes_e.swFlangePositionTypeMaterialInside, dLength, swSheetMetalReliefTypes_e.swSheetMetalReliefNone, 0#, 0#, 0#, swFlangeDimTypes_e.swFlangeDimTypeInnerVirtualSharp, Nothing)
End Sub

Program closes before if statement (CATIA VBA)

I am trying to implement a minimum boundary box subroutine inside my macro. Subroutine ends before going into if statement. Can you help me find the solution?
Option Explicit
Sub bounding()
Dim partDocument1 As PartDocument
Set partDocument1 = CATIA.ActiveDocument
Dim part1 As Part
Set part1 = partDocument1.Part
Dim hybridShapeFactory1 As HybridShapeFactory
Set hybridShapeFactory1 = part1.HybridShapeFactory
Dim hybridBodies1 As HybridBodies
Set hybridBodies1 = part1.HybridBodies
Dim hybridBody1 As hybridbody
Set hybridBody1 = hybridBodies1.Item(cevap)
Dim hybridShapes1 As HybridShapes
Set hybridShapes1 = hybridBody1.HybridShapes
Dim axisSystems1 As AxisSystems
Set axisSystems1 = part1.AxisSystems
Dim axisSystem1 As AxisSystem
Set axisSystem1 = part1.FindObjectByName("axissys")
Dim direction As Long
If extindex Mod 2 = 1 Then
direction = 1
Else
direction = 0
End If
Dim reference1 As Reference
MsgBox CStr(extindex)
Select Case extindex
Case 1, 2
Set reference1 = axisSystem1.XAxisDirection
MsgBox CStr(extindex) + "1ve2"
Case 3, 4
Set reference1 = axisSystem1.YAxisDirection
MsgBox CStr(extindex) + "3ve4"
Case Else
Set reference1 = axisSystem1.YAxisDirection
MsgBox CStr(extindex) + "5ve6"
End Select
Debug.Print ("exit if check")
Dim hybridShapeDirection1 As HybridShapeDirection
Set hybridShapeDirection1 = hybridShapeFactory1.AddNewDirection(reference1)
Dim bodies1 As Bodies
Set bodies1 = part1.Bodies
Dim body1 As Body
Set body1 = bodies1.Item("PartBody")
Dim reference2 As Reference
Set reference2 = part1.CreateReferenceFromObject(body1)
Dim hybridShapeExtremum1 As HybridShapeExtremum
Set hybridShapeExtremum1 = hybridShapeFactory1.AddNewExtremum(reference2,
hybridShapeDirection1, 0)
part1.Update
hybridBody1.AppendHybridShape hybridShapeExtremum1
part1.InWorkObject = hybridShapeExtremum1
hybridShapeExtremum1.Name = "ext1" + CStr(extindex)
part1.Update
End Sub
All variables on the program are checked and they work. I don't understand what is happening an why it doesnt work. I even checked all variables. Program should go inside if statement but it doesnt
The AxisSystem properties XAxisDirection, YAxisDirection, and ZAxisDirection refer to the references from which the axis system was defined.
You can use these properties to edit the AxisSystem object itself but they are not "output" Reference objects which should be used to construct downstream geometry.
You can pull the vectors components using the GetXAxis, GetYAxis, and GetZAxis methods (which will always contain values) and then use HybridShapeFactory.AddDirectionFromCoord() method to create the direction for the extremum.
...
MsgBox CStr(extindex)
Dim vect(2)
Dim vAxis As Variant
Set vAxis = axisSystem1
Select Case extindex
Case 1, 2
vAxis.GetXAxis vect
Case 3, 4
vAxis.GetYAxis vect
Case Else
vAxis.GetYAxis vect
End Select
Dim hybridShapeDirection1 As HybridShapeDirection
Set hybridShapeDirection1 = hybridShapeFactory1.AddNewDirectionByCoord(vect(0), vect(1), vect(2))
...

Visual Basic CInt error

I am trying to make a function that looks at an image, and return the X pixel value.
When i run the code, it throws an error on the Int1=CInt(Xdim) line, saying "Type Mismatch (10080)"
If i hard-code the value i am testing into Xdim, it works fine.
Function ImgXDim(filename As String) As Integer ' Finds the X dimension in pixels of a loaded image
Dim objShell As Object
Dim objFolder As Object
Dim objFile As Object
Dim ImgSize As String
Dim Int1 As Integer
Dim Xdim As String
Dim strarray() As String
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.NameSpace(MacroDir & "\PICS\")
Set objFile = objFolder.ParseName(filename)
ImgSize = objFile.ExtendedProperty("Dimensions") ' Returns string of "700 x 923"
strarray = Split(ImgSize, " x ") ' Split into 2 strings of "700" and "923"
Xdim = CStr(strarray(0)) ' Force Xdim to be a string of "700"
Int1 = CInt(Xdim) ' Convert Xdim to an integer
ImgXDim = Int1 ' Return Integer
End Function
First check if value can be converted to an integer:
If IsNumeric(Trim(Xdim)) then
Int1 = CInt(Xdim)
else
'for debug purposes
MsgBox ("XDim non-numeric or empty")
End If
Ok, i couldnt find what character was causing the issue, so i used this loop of code to pull out only numbers, and it seems to work.
For X = 1 To Len(Xdim)
If IsNumeric(Mid(Xdim, X, 1)) = True Then
holder = holder & Mid(Xdim, X, 1)
End If
Next X
Here the WIA version:
Function ImgXDim(filename As String) As Long
Dim imgWIA as New WIA.ImageFile 'Early Binding needs a reference to Windows Image Aquisition Library in VBA-Ide->Tools->References
'Dim imgWIA as Object 'Late Bound Version
'Set imgWIA = CreateObject("WIA.ImageFile")
imgWIA.LoadFile MacroDir & "\PICS\" & filename
ImgXDim = imgWIA.Width ' use .Height for height
End Function
As you see, just three lines of code and returns a long, not a string that needs parsing.
Useful functions for resize, rotate and more.
Also useful if you want to display Tiffs in a picture control (page by page) and more.

Can't get sensible co-ordinates for note blocks

I've been trying to resurrect an existing drawing check macro, and want to find the co-ordinates of any note blocks on each sheet. I've been modifying code found here using the GetAttachPos method from this page, but for some reason any co-ordinates returned come back around (8.80942311664557E-03,2.24429295226372E-03).
I'm thinking that the problem is that I've missed a reference somewhere, but I'm not sure where. Although it's definitely finding the notes since it passes back their text. Anyway, here's the method I'm testing at the moment:
Sub Main()
Dim swApp As SldWorks.SldWorks
Set swApp = CreateObject("SldWorks.Application")
Dim NoteNumbersText As String
Dim NoteText As String
Dim NumberofSheets As Integer ' The number of sheets in this drawing
Dim NamesOfSheets As Variant ' Names of all of the sheets
Dim sheet As SldWorks.sheet ' The Sheet that we are working on
Dim LocalView As SldWorks.View ' Current View that we are looking at
Dim LocalNote As SldWorks.Note ' Current Note that we are looking at
Dim TextFormat As SldWorks.TextFormat ' Current text format object of a note
Dim Xpos As Double ' X, Y Z position on the drawing in Metres
Dim Ypos As Double
Dim SizeOfSheet As Double
Dim x As Integer ' general Loop Variables
Dim j As Integer
Dim k As Integer
Dim l As Integer
Dim vPosition As Variant
Dim vNote As Variant ' Single note
Dim swNote As SldWorks.Note ' Single Solidworks Note Object
Dim ThisAnnotation As SldWorks.Annotation
Dim swBlockInst As SldWorks.SketchBlockInstance
Dim swBlockDef As SldWorks.SketchBlockDefinition
Dim NumofNotes As Integer
Dim ArrayOfNotes() As NoteInfo
Dim LocalDrawingDoc As SldWorks.DrawingDoc ' Declared as an Object so that non Drawings can be detected!
Dim LocalPart As SldWorks.ModelDoc2 ' Declared as an Object so that non Drawings can be detected!
Dim strShtProp As Variant
Set LocalDrawingDoc = swApp.ActiveDoc
Set LocalPart = swApp.ActiveDoc
ReDim ArrayOfNotes(0)
' Get the sheet names and the number of them
NamesOfSheets = LocalDrawingDoc.GetSheetNames()
NumberofSheets = LocalDrawingDoc.GetSheetCount
' store this sheet name
Set sheet = LocalDrawingDoc.GetCurrentSheet()
strShtProp = sheet.GetProperties() ' get the sheet properties use much later for converting position into ref
SizeOfSheet = strShtProp(5)
Dim SwSketchMgr As SldWorks.SketchManager
Set SwSketchMgr = LocalDrawingDoc.SketchManager
Dim i As Integer
Dim vBlockDef As Variant
Dim vBlockInst As Variant
Dim strReturn As String
' Dim bret As Boolean
vBlockDef = SwSketchMgr.GetSketchBlockDefinitions
For x = NumberofSheets - 1 To 0 Step -1
If LocalDrawingDoc.GetCurrentSheet.GetName <> NamesOfSheets(x) Then LocalDrawingDoc.ActivateSheet NamesOfSheets(x)
Set LocalView = LocalDrawingDoc.GetFirstView
While Not LocalView Is Nothing
If Not IsEmpty(vBlockDef) Then
For i = 0 To UBound(vBlockDef)
Set swBlockDef = vBlockDef(i)
vBlockInst = swBlockDef.GetInstances
vNote = swBlockDef.GetNotes
If Not IsEmpty(vNote) Then
For j = 0 To UBound(vNote)
Set swNote = vNote(j)
NoteNumbersText = Trim(swNote.GetText)
If Left(NoteNumbersText, 1) = "n" And Len(NoteNumbersText) > 1 And Len(NoteNumbersText) < 4 Then
Set ThisAnnotation = swNote.GetAnnotation
'vPosition = swNote.GetAttachPos
vPosition = ThisAnnotation.GetPosition
Xpos = vPosition(0)
Ypos = vPosition(1)
Debug.Print ("Note " & NoteNumbersText & ": " & Xpos & "," & Ypos)
End If
Next j
End If
Next i
End If
Set LocalView = LocalView.GetNextView
Wend
Next x
End Sub
Turns out that SolidWorks is set up to return positions of blocks relative to the drawing view on which they're placed. Calling GetXForm for the view which they are placed on then provides a way of calculating the absolute position of each note.