Macro to Insert a Block

Monty,

I doubt this macro already exists. Are you familar with making or editing macros?

Matt Lorono

of

Here is some code I used to insert a block It was a revision block I used it in 2003 & 4 when rev blocks weren't part of SW

Function insertBlock() As SldWorks.BlockDefinition

Dim x As Double Dim y As Double Dim Bscale As Double Dim RevLev As Object Dim RLX As Double Dim RLY As Double Dim RLHeight As Double Dim RevLevTxt As String Dim SheetSize As String Dim blockDef As SldWorks.BlockDefinition Dim MyBlock As SldWorks.BlockInstance

SheetSize = LCase(Right(sheet.GetTemplateName, 8))

Select Case SheetSize Case "a.slddrt" x = 4.33 * 0.0254 'dimension in inches comvert to metric y = 0.2 * 0.0254 Bscale = 1 RLX = 10.36 * 0.0254 RLY = 8.05 * 0.0254 RLHeight = 0.187 * 0.0254 Case "b.slddrt" x = 8 * 0.0254 'dimension in inches comvert to metric y = 0.25 * 0.0254 Bscale = 1 RLX = 13.81 * 0.0254 RLY = 10.7 * 0.0254 RLHeight = 0.187 * 0.0254 Case "c.slddrt" x = 8.66 * 0.0254 'dimension in inches comvert to metric y = 0.4 * 0.0254 Bscale = 2 RLX = 10.36 * 2 * 0.0254 RLY = 8.05 * 2 * 0.0254 RLHeight = 0.187 * 2 * 0.0254 Case Else x = 0 * 0.0254 'dimension in inches comvert to metric y = 0 * 0.0254 Bscale = 1 RLX = 10.36 * 0.0254 RLY = 8.05 * 0.0254 RLHeight = 0.187 * 0.0254 End Select dwgdoc.EditTemplate PathName = swApp.GetCurrentMacroPathName PathOnly = Mid(PathName, 1, InStr(1, PathName, "A CHANGE.swp") -

2) 'dwgdoc.InsertNewNote2 RevLev, "", True, False, swNO_ARROWHEAD, swLS_SMART, 0#, swBS_None, swBF_Tightest, 0, 0 If RevLev Is Nothing Then RevLevTxt = "" Set RevLev = dwgdoc.CreateText2(RevLevTxt, RLX, RLY, 0, RLHeight, 0) RevLev.SetName "Revision Level" End If

Set MyBlock = dwgdoc.insertBlock(PathOnly + "\A Change.SLDBLK", x, y, 0#, Bscale)

MyBlock.SetAttributeValue "TOP LETTER", "" MyBlock.SetAttributeValue "TOP DESC", "" MyBlock.SetAttributeValue "TOP DATE", "" MyBlock.SetAttributeValue "MID LETTER", "" MyBlock.SetAttributeValue "MID DESC", "" MyBlock.SetAttributeValue "MID DATE", "" MyBlock.SetAttributeValue "BOT LETTER", "" MyBlock.SetAttributeValue "BOT DESC", "" MyBlock.SetAttributeValue "BOT DATE", ""

Set blockDef = dwgdoc.GetBlockDefinition("A CHANGE") dwgdoc.EditSheet

If blockDef Is Nothing Then MsgBox "There was a problem finding the block." & VBA.Chr(vbKeyReturn) & _ "Make sure " & VBA.Chr(34) & "A Change.SLDBLK" & VBA.Chr(34) & "is in the same directory as this macro." End End If Set insertBlock = blockDef

End Function

Regards,

Corey

Exactly what I wanted to see! Thanks Corey!!!

Stars for corey. :)

Matt Lorono