cll
2004-06-18, 08:51 AM
Hi VBA Forum,
I have written a code that inserts my logo.dwg in the right place depending on papersize and scale.
I works out fine, but when the code comes to InsRef it takes about 20 sec to execute.
The full code is shown below - can anyone spot the problem?
---------------------------------code begin (take care of wordwrap)
Option Explicit
Public Sub InsLogo()
Dim BlockObj As Object
Dim BlockObj1 As Object
Dim BlockObjName As String
Dim BlockObjName1 As String
Dim L1BlockObjAttributes
Dim colLayOuts As AcadLayouts
Dim objLayoutName As String
Dim objLayOut As AcadLayout
Dim UserName As String
Dim InsRef As AcadExternalReference
Dim PathName As String
Dim InsertPoint(0 To 2) As Double
Dim Scf As Double
PathName = "\\Data\Afdelinger\Teknik\Dokumentation\Mechanical\GEN\DWG\FORMAT\Logo.dwg"
For Each BlockObj In ThisDrawing.ModelSpace
On Error Resume Next
BlockObjName = BlockObj.Name
Select Case BlockObjName
Case "PMC"
GoTo Ramme
Case "Pmc"
GoTo Ramme
End Select
Next
GoTo IngenTitel
Ramme:
For Each BlockObj1 In ThisDrawing.ModelSpace
On Error Resume Next
BlockObjName1 = BlockObj1.Name
Select Case BlockObjName1
Case "A4-V"
Scf = BlockObj1.XScaleFactor
InsertPoint(0) = 209 * Scf: InsertPoint(1) = 21.77 * Scf: InsertPoint(2) = 0
Set InsRef = ThisDrawing.ModelSpace.AttachExternalReference(PathName, _
"Logo", InsertPoint, Scf, Scf, Scf, 0, False)
End
Case "A4-H"
Scf = BlockObj1.XScaleFactor
InsertPoint(0) = 120 * Scf: InsertPoint(1) = 27.77 * Scf: InsertPoint(2) = 0
Set InsRef = ThisDrawing.ModelSpace.AttachExternalReference(PathName, _
"Logo", InsertPoint, Scf, Scf, Scf, 0, False)
End
Case "A3"
Scf = BlockObj1.XScaleFactor
InsertPoint(0) = 326 * Scf: InsertPoint(1) = 23.07 * Scf: InsertPoint(2) = 0
Set InsRef = ThisDrawing.ModelSpace.AttachExternalReference(PathName, _
"Logo", InsertPoint, Scf, Scf, Scf, 0, False)
End
Case "A2"
Scf = BlockObj1.XScaleFactor
InsertPoint(0) = 484 * Scf: InsertPoint(1) = 21.27 * Scf: InsertPoint(2) = 0
Set InsRef = ThisDrawing.ModelSpace.AttachExternalReference(PathName, _
"Logo", InsertPoint, Scf, Scf, Scf, 0, False)
End
Case "A1"
Scf = BlockObj1.XScaleFactor
InsertPoint(0) = 751 * Scf: InsertPoint(1) = 21.57 * Scf: InsertPoint(2) = 0
Set InsRef = ThisDrawing.ModelSpace.AttachExternalReference(PathName, _
"Logo", InsertPoint, Scf, Scf, Scf, 0, False)
End
Case "A0"
Scf = BlockObj1.XScaleFactor
InsertPoint(0) = 1089 * Scf: InsertPoint(1) = 26.27 * Scf: InsertPoint(2) = 0
Set InsRef = ThisDrawing.ModelSpace.AttachExternalReference(PathName, _
"Logo", InsertPoint, Scf, Scf, Scf, 0, False)
End
End Select
Next
GoTo IngenRamme
IngenTitel:
MsgBox "Der er ikke en standard titelblok"
GoTo Manuel
IngenRamme:
MsgBox "Der er ikke nogen standard tegningsramme"
GoTo Manuel
Manuel:
Dim Msg, Style, Title, Response, MyString
Msg = "Vil du indsætte Logo manuelt?" ' Define message.
Style = vbYesNo + vbQuestion + vbDefaultButton1 ' Define buttons.
Title = "Indsæt Logo..." ' Define title.
Response = MsgBox(Msg, Style, Title)
If Response = vbYes Then ' User chose Yes.
MyString = "Yes" ' Perform some action.
SendKeys "_xattach" & "{ENTER}"
Else ' User chose No.
MyString = "No" ' Perform some action.
End
End If
End Sub
-----------------------------code end
Thanks
Claus
I have written a code that inserts my logo.dwg in the right place depending on papersize and scale.
I works out fine, but when the code comes to InsRef it takes about 20 sec to execute.
The full code is shown below - can anyone spot the problem?
---------------------------------code begin (take care of wordwrap)
Option Explicit
Public Sub InsLogo()
Dim BlockObj As Object
Dim BlockObj1 As Object
Dim BlockObjName As String
Dim BlockObjName1 As String
Dim L1BlockObjAttributes
Dim colLayOuts As AcadLayouts
Dim objLayoutName As String
Dim objLayOut As AcadLayout
Dim UserName As String
Dim InsRef As AcadExternalReference
Dim PathName As String
Dim InsertPoint(0 To 2) As Double
Dim Scf As Double
PathName = "\\Data\Afdelinger\Teknik\Dokumentation\Mechanical\GEN\DWG\FORMAT\Logo.dwg"
For Each BlockObj In ThisDrawing.ModelSpace
On Error Resume Next
BlockObjName = BlockObj.Name
Select Case BlockObjName
Case "PMC"
GoTo Ramme
Case "Pmc"
GoTo Ramme
End Select
Next
GoTo IngenTitel
Ramme:
For Each BlockObj1 In ThisDrawing.ModelSpace
On Error Resume Next
BlockObjName1 = BlockObj1.Name
Select Case BlockObjName1
Case "A4-V"
Scf = BlockObj1.XScaleFactor
InsertPoint(0) = 209 * Scf: InsertPoint(1) = 21.77 * Scf: InsertPoint(2) = 0
Set InsRef = ThisDrawing.ModelSpace.AttachExternalReference(PathName, _
"Logo", InsertPoint, Scf, Scf, Scf, 0, False)
End
Case "A4-H"
Scf = BlockObj1.XScaleFactor
InsertPoint(0) = 120 * Scf: InsertPoint(1) = 27.77 * Scf: InsertPoint(2) = 0
Set InsRef = ThisDrawing.ModelSpace.AttachExternalReference(PathName, _
"Logo", InsertPoint, Scf, Scf, Scf, 0, False)
End
Case "A3"
Scf = BlockObj1.XScaleFactor
InsertPoint(0) = 326 * Scf: InsertPoint(1) = 23.07 * Scf: InsertPoint(2) = 0
Set InsRef = ThisDrawing.ModelSpace.AttachExternalReference(PathName, _
"Logo", InsertPoint, Scf, Scf, Scf, 0, False)
End
Case "A2"
Scf = BlockObj1.XScaleFactor
InsertPoint(0) = 484 * Scf: InsertPoint(1) = 21.27 * Scf: InsertPoint(2) = 0
Set InsRef = ThisDrawing.ModelSpace.AttachExternalReference(PathName, _
"Logo", InsertPoint, Scf, Scf, Scf, 0, False)
End
Case "A1"
Scf = BlockObj1.XScaleFactor
InsertPoint(0) = 751 * Scf: InsertPoint(1) = 21.57 * Scf: InsertPoint(2) = 0
Set InsRef = ThisDrawing.ModelSpace.AttachExternalReference(PathName, _
"Logo", InsertPoint, Scf, Scf, Scf, 0, False)
End
Case "A0"
Scf = BlockObj1.XScaleFactor
InsertPoint(0) = 1089 * Scf: InsertPoint(1) = 26.27 * Scf: InsertPoint(2) = 0
Set InsRef = ThisDrawing.ModelSpace.AttachExternalReference(PathName, _
"Logo", InsertPoint, Scf, Scf, Scf, 0, False)
End
End Select
Next
GoTo IngenRamme
IngenTitel:
MsgBox "Der er ikke en standard titelblok"
GoTo Manuel
IngenRamme:
MsgBox "Der er ikke nogen standard tegningsramme"
GoTo Manuel
Manuel:
Dim Msg, Style, Title, Response, MyString
Msg = "Vil du indsætte Logo manuelt?" ' Define message.
Style = vbYesNo + vbQuestion + vbDefaultButton1 ' Define buttons.
Title = "Indsæt Logo..." ' Define title.
Response = MsgBox(Msg, Style, Title)
If Response = vbYes Then ' User chose Yes.
MyString = "Yes" ' Perform some action.
SendKeys "_xattach" & "{ENTER}"
Else ' User chose No.
MyString = "No" ' Perform some action.
End
End If
End Sub
-----------------------------code end
Thanks
Claus