TheSwamp
Code Red => VB(A) => Topic started by: ML on September 16, 2004, 07:16:57 PM
-
Hello
I was trying very hard to develop a VBA macro that will allow me to choose one block and apply the scale of that block to scale another block
I would want it to work similar to Match properties but only to match scale properties. The best way I can describe what I want would be having an automated routine that does what you could acheive by using scale reference.
I believe the answer lies in The x, y and z scale factor methods in VBA but I had no luck.
Can anyone help?
Thanks
Mark
-
Are these items uniformly scaled?
-
I would say yes Ron
-
The truth is that it should make no difference if the block original block is uniformly scaled. The only thing I can imagine is that you might not want to match the negative scaling of a block because it will cause a mirrored block to "unmirror"
This routine can be characterized by the following pseudocode
Select single block reference object
extract x y and z scales
convert scales to absolute values
Select blocks to apply scale to...
apply absolute value scale to blocks to be matched, taking care to make the scale positive and/or negative where required.
Given that information, we can do the following...
See if you can find where the program does what is specified in the pseudo code above.
Sub MatchBlockScale()
Dim XScale As Double
Dim YScale As Double
Dim ZScale As Double
Dim OXScale As Double
Dim OYScale As Double
Dim OZScale As Double
Dim ACBlockRef As AcadBlockReference
Dim SSet As AcadSelectionSet
Dim Code(0) As Integer
Dim Data(0) As Variant
Dim GCode As Variant
Dim GData As Variant
Dim X As Integer
Code(0) = 0
Data(0) = "INSERT"
GCode = Code
GData = Data
Set SSet = ThisDrawing.SelectionSets.Add("MatchScale")
While SSet.Count <> 1
SSet.SelectAtPoint ThisDrawing.Utility.GetPoint(, "Select block reference"), GCode, GData
Wend
Set ACBlockRef = SSet.Item(0)
XScale = Abs(ACBlockRef.XScaleFactor)
YScale = Abs(ACBlockRef.YScaleFactor)
ZScale = Abs(ACBlockRef.ZScaleFactor)
SSet.Clear
SSet.SelectOnScreen GCode, GData
For X = 0 To SSet.Count - 1
Set ACBlockRef = SSet.Item(X)
OXScale = ACBlockRef.XScaleFactor
OYScale = ACBlockRef.YScaleFactor
OZScale = ACBlockRef.ZScaleFactor
If OXScale > 0 Then
ACBlockRef.XScaleFactor = XScale
Else
ACBlockRef.XScaleFactor = 0 - XScale
End If
If OYScale > 0 Then
ACBlockRef.YScaleFactor = YScale
Else
ACBlockRef.YScaleFactor = 0 - YScale
End If
If OZScale > 0 Then
ACBlockRef.ZScaleFactor = ZScale
Else
ACBlockRef.ZScaleFactor = 0 - ZScale
End If
Next X
SSet.Delete
End Sub
-
Cool! Thanks Keith, I really appreciate that. I will give it a try tomorrow and let you know how it works
Thanks
Mark
-
Keith
You are the man!
I added an errorhandler at the end to handle the Sset already exists message and renamed the module to MatchScaleProperties but otherwise it works perfect
I like the way you did it, if I were to use scale reference to do the same thing, all blocks would scale to a specified base point but the way you did it, all blocks scale in place which is exactly what I wanted.
Thank you again
Mark
-
Keith
Here is how i tweaked it, hope you don't mind?
Note: The Errorhandler
Mark
Sub MatchScaleProperties()
On Error GoTo Errorhandler
Dim XScale As Double
Dim YScale As Double
Dim ZScale As Double
Dim OXScale As Double
Dim OYScale As Double
Dim OZScale As Double
Dim ACBlockRef As AcadBlockReference
Dim SSet As AcadSelectionSet
Dim Code(0) As Integer
Dim Data(0) As Variant
Dim GCode As Variant
Dim GData As Variant
Dim X As Integer
Code(0) = 0
Data(0) = "INSERT"
GCode = Code
GData = Data
Set SSet = ThisDrawing.SelectionSets.Add("MatchScale")
While SSet.Count <> 1
SSet.SelectAtPoint ThisDrawing.Utility.GetPoint(, "Select block reference"), GCode, GData
Wend
Set ACBlockRef = SSet.Item(0)
XScale = Abs(ACBlockRef.XScaleFactor)
YScale = Abs(ACBlockRef.YScaleFactor)
ZScale = Abs(ACBlockRef.ZScaleFactor)
SSet.Clear
SSet.SelectOnScreen GCode, GData
For X = 0 To SSet.Count - 1
Set ACBlockRef = SSet.Item(X)
OXScale = ACBlockRef.XScaleFactor
OYScale = ACBlockRef.YScaleFactor
OZScale = ACBlockRef.ZScaleFactor
If OXScale > 0 Then
ACBlockRef.XScaleFactor = XScale
Else
ACBlockRef.XScaleFactor = 0 - XScale
End If
If OYScale > 0 Then
ACBlockRef.YScaleFactor = YScale
Else
ACBlockRef.YScaleFactor = 0 - YScale
End If
If OZScale > 0 Then
ACBlockRef.ZScaleFactor = ZScale
Else
ACBlockRef.ZScaleFactor = 0 - ZScale
End If
Next X
SSet.Delete
GoTo Done
Errorhandler:
If ThisDrawing.SelectionSets.Count > 0 Then
ThisDrawing.SelectionSets.Item("MatchScale").Delete
Debug.Print "Delete"
End If
Done:
End Sub
-
Cool... I tol' ya you were gettin' better....
Of course I failed to add in error handling and in my haste forgot to tell you that it needed to be done.....
Good call...
-
Well, thank you sir!
Of course I am getting better because I have one of the best around to learn from. The Module kicks a_s!
Thanks again
Mark
-
Hey Mark... hit the "Keep me logged in" button next time... it'll make life a little better for us all ...
-
Hey Keith
Why do I need to stay logged in? Why will it make it easier for everyone? So they know it is me posting?
I hope other people can benefit from this code, it kicks a*s
Mark
-
It makes it a little easier knowing who we are talking to.
-
I see, well, I will be the guy that asks a lot of questions, particularly VBA questions :)
-
OK, Sorry bout that Keith, I am automatically logged in now.
:P