I have this macro that one of our previous designers wrote in SW2005 and now find that part of it will not work in SW2007. The macro creates a new tab in a drawing called laser and places the laser profile on the sheet. This part works file. The next part of the macro inserts two SolidWorks blocks (from a file location) onto the laser sheet and this is where the macro crashes due to changes in the API on inserting blocks. I have been through the API help and have attempted to make the changes to the new way of inserting blocks but I still cannot get the macro to fully work.

Any help with getting this macro to work would be greatly appreciated.


Option Explicit
Dim Ann As SldWorks.Annotation
Dim BlockInst As SldWorks.BlockInstance
Dim BlockName As String
Dim boolstatus As Boolean
Dim CenterMark As SldWorks.CenterMark
Dim Cursor As String
Dim DimArray As Variant
Dim DrawView As Object
Dim ErrorCheck As Boolean
Dim Feature As Object
Dim FileName As String
Dim i As Integer
Dim LaserSheetHeight As Variant
Dim LaserSheetWidth As Variant
Dim ModelName As String
Dim Part As Object
Dim pBlock As Object
Dim Response As Integer
Dim SelData As SldWorks.SelectData
Dim SelMgr As SldWorks.SelectionMgr
Dim swApp As Object
Dim swSheet As Object
Dim vSheetNames As Variant
Dim vSheetProps As Variant
Dim xPos As Variant
Dim yPos As Variant

Sub main()

Set swApp = Application.SldWorks
Set Part = swApp.ActiveDoc
Set SelMgr = Part.SelectionManager
Set SelData = SelMgr.CreateSelectData
'****BEGIN ERROR CHECKING****

ErrorCheck = False 'Set to True to output Debug.Print values to Immediate Window

If Part.GetType() < 3 Then 'Make sure the current document is a drawing, otherwise, end the macro
Response = MsgBox(" Laser tab can only be added to Drawing document. ", vbCritical, "Wrong Document Type")
GoTo Finish
End If

vSheetNames = Part.GetSheetNames 'Check that the LASER tab doesn't already exist
For i = 0 To UBound(vSheetNames)
If ErrorCheck Then
Debug.Print "Sheet List: Sheet " & i + 1 & ": "; vSheetNames(i)
End If
If vSheetNames(i) = "LASER" Then
Response = MsgBox(" Laser Tab already exists. Do you want to update the Profile block?", vbYesNo + vbQuestion, "Duplicate Sheet")
If Response = vbYes Then
GoTo UpdateBlocks
Else
GoTo Finish 'If it does, end the macro
End If
End If
Next i

Set Feature = Part.GetFirstView
Set Feature = Feature.GetNextView 'Get the first View
If ErrorCheck Then
Debug.Print "First view: " & Feature.Name
End If
If Feature Is Nothing Then 'If there is no view in the current sheet, end the macro
boolstatus = MsgBox("Insert a drawing view into this sheet before creating a laser tab.", vbCritical, "No Drawing View")
GoTo Finish
End If

'****GET ATTRIBUTES FROM FIRST TAB & ADD LASER NOTE****

ModelName = Feature.GetReferencedModelName 'Get the filename of the referenced model for later use
If ErrorCheck Then
Debug.Print "Referenced Filename: " & ModelName
End If
Set swSheet = Part.GetCurrentSheet
vSheetProps = swSheet.GetProperties
LaserSheetWidth = vSheetProps(3) * vSheetProps(5) 'Set the width of the laser sheet to the width of Sheet1 multiplied by the scale
LaserSheetHeight = vSheetProps(3) * vSheetProps(6) 'Set the height of the laser sheet to the height of Sheet1 multiplied by the scale
If ErrorCheck Then
Debug.Print "Laser Sheet Width: " & LaserSheetWidth * 1000 & "mm"
Debug.Print "Laser Sheet Height: " & LaserSheetHeight * 1000 & "mm"
End If

FileName = Part.GetTitle
i = 0
Cursor = ""
Do While Cursor <> "-"
i = i + 1
Cursor = Left(Right(FileName, i), 1)
Loop

FileName = Left(Part.GetTitle, Len(Part.GetTitle) - i - 1) + "-L.DWG"


Part.CreateText2 "LASER PROFILE SAVED AS " & FileName, vSheetProps(5) - 0.115, (0.04 + vSheetProps(6) / 15), 0, 0.005, 0

'****ADD LASER SHEET AND INSERT FLAT PATTERN VIEW****
boolstatus = Part.SetUserPreferenceToggle(6, False) 'Turn off Origins

Part.NewSheet3 "LASER", 12, 13, 1, 1, False, "", LaserSheetWidth, LaserSheetHeight, "Default"
Set swSheet = Part.GetCurrentSheet

vSheetProps = swSheet.GetProperties
xPos = vSheetProps(5) * 0.6 'Set position of blocks relative to the sheet size
yPos = vSheetProps(6) * 0.7

On Error Resume Next
Part.CreateFlatPatternViewFromModelView2 ModelName, "Default", (xPos / 2.5), (yPos / 2.5), 0, True 'Insert the flat pattern
boolstatus = Part.Extension.SelectByID2("LASER", "SHEET", 0, 0, 0, False, 0, Nothing, 0) 'Select the sheet to make sure the blocks are note moved with the view

'****DELETE DIMENSIONS AND CENTREMARKS****

Set Feature = Part.GetFirstView
Set Feature = Feature.GetNextView

If ErrorCheck Then
Debug.Print "Laser Profile Drawing view Name: " & Feature.Name
End If

Part.ClearSelection2 True
Set CenterMark = Feature.GetFirstCenterMark 'Select All Centremarks
Do While Not Nothing Is CenterMark
Set Ann = CenterMark.GetAnnotation
boolstatus = Ann.Select3(True, SelData)
If ErrorCheck Then
Debug.Print "Centremark: " & Ann.GetName
End If
Set CenterMark = CenterMark.GetNext
Loop
Part.EditDelete
Part.ClearSelection2 True
DimArray = Feature.GetDimensionIds4() 'Select & Delete all dimensions
For i = 0 To UBound(DimArray)
boolstatus = Part.Extension.SelectByID2(DimArray(i), "DIMENSION", 0, 0, 0, True, 0, Nothing, 0)
Next i
Part.EditDelete

'****INSERT STANDARD LASER TAB BLOCKS AND FILL WITH ATTRIBUTES****

Set pBlock = Part.InsertBlock("F:\SolidWorks\MJE Templates\Profile.SLDBLK", xPos, yPos, 0, 1) 'Insert the profile & scale blocks
Set pBlock = Part.InsertBlock("F:\SolidWorks\MJE Templates\Scales.SLDBLK", xPos, 0, 0, 1)

UpdateBlocks:
boolstatus = False 'Reset Boolstatus
i = 0 'Reset i

Do While (boolstatus = False And i < 100) 'Loop to find the instance of the Profile block inserted
BlockName = i & "@Profile@LASER"
boolstatus = Part.Extension.SelectByID2(BlockName, "BLOCKINST", 0, 0, 0, False, 0, Nothing, 0)
i = i + 1
Loop

If ErrorCheck Then
Debug.Print "Number of loops to find Profile Block= " & i
End If

If i = 100 Then 'If the loop completes 100 times without finding the block, it quits and sends a message
boolstatus = MsgBox("Cannot Find Block 'Profile' ", 16, "Error")
GoTo Finish
End If

Set BlockInst = SelMgr.GetSelectedObject5(1) 'If the block is found, select it
boolstatus = BlockInst.SetAttributeValue("Drawing No:", Part.CustomInfo2("", "Drawing No:")) 'Fill the attributes
boolstatus = BlockInst.SetAttributeValue("Revision:", Part.CustomInfo2("", "Current Revision:"))
boolstatus = BlockInst.SetAttributeValue("Material:", Part.CustomInfo2("", "Material Line 1:") & " " & Part.CustomInfo2("", "Material Line 2:"))
boolstatus = BlockInst.SetAttributeValue("Date:", Str(Date))
boolstatus = BlockInst.SetAttributeValue("Notes:", " ")

boolstatus = Part.ForceRebuild3(False) 'Rebuild the drawing to see changes to attributes

Finish:
End Sub