TheSwamp
Code Red => VB(A) => Topic started by: ML on April 25, 2008, 10:35:33 AM
-
Hi
Let me see if I can explain this;
Does anyone happen to have any code that will find the absolute mid point of a blockref?
For instance, I know a block has an insertion point, obviously but within the block are tons of entities, obviously
I guess this could be done a few ways, that is find the most centered entity within the blockref and get its point or get the most lower left and most upper right points of the lowest left and upper right entities in the block, then find the mid point based off of those points.
Does that make sense?
I could try to work on it later but this code would really benefit me right now if anyone has something that could get it done.
I'd appreciate it
Thanks
Mark
-
Question, are you after the centroid of a shape that tightly conforms to the objects in the block, or the center of the bounding box for the block?
-
Yes! Precisely Bob!
-
I'm sorry,
I guess I would want the midpoint of the centroid
M
-
Have you looked into .GetBoundingBox??
<EDIT>
I suppose I should read a little bit closer next time.
Question, are you after the centroid of a shape that tightly conforms to the objects in the block, or the center of the bounding box for the block?
-
No Matt
I never used BoundBox
I guess it could be a centroid or bounding box, if the bounding box is what I think it is.
I just need that midpoint.
I am being lazy, I need to insert about 75 blocks into a drawing using the midpoint of the blockref and I am a bit tired of drawing rectangles.
Unfortunately, I don't have time right now to dive in and try to program it myself.
M
-
It makes a pretty large difference in complexity. If the centroid(~midpoint) of the bounding box, which is a rectangle from the minimum x&y of elements in the block to the maximum x&y, will work, it's fairly simple. If you need the centroid of the geometry, the easiest way to get a close approximation that I can think of is to place a region for the bounding box of each entity in the block, then find the centroid with massprop. Sounds to me like the former is what you're after.
-
I see
Thanks Bob
It makes a pretty large difference in complexity. If the centroid(~midpoint) of the bounding box, which is a rectangle from the minimum x&y of elements in the block to the maximum x&y, will work, it's fairly simple.
Yes, it is the first method that I would be after.
I like simple :)
M
-
as usual, quick, dirty, untested. Own risk, blahblahblah
Option Explicit
Public Sub blkCent()
Dim minExt As Variant
Dim maxExt As Variant
Dim pntCent(0 To 2) As Double
lineObj.GetBoundingBox minExt, maxExt
Dim strSet As String
Dim strSetName As String
Dim intGroup(0) As Integer
Dim varGroup(0) As Variant
Dim objSelSet As AcadSelectionSet
Dim objSelSets As AcadSelectionSets
Dim strBlkName As String
Dim objBlkRef As AcadBlockReference
Dim objEnt As AcadEntity
Dim intCnt As Integer
Set objSelSets = ThisDrawing.SelectionSets
strSetName = 1
intGroup(0) = 0
varGroup(0) = "insert"
KillSet strSetName
Set objSelSet = objSelSets.Add(strSetName)
objSelSet.Select acSelectionSetAll, , , intGroup, varGroup
For Each objEnt In objSelSet
If TypeOf objEnt Is AcadBlockReference Then
objBlkRef = objEnt
objBlkRef.GetBoundingBox minExt, maxExt
pntCent(0) = (minExt(0) + maxExt(0)) / 2
pntCent(1) = (minExt(1) + maxExt(1)) / 2
pntCent(2) = (minExt(2) + maxExt(2)) / 2
End If
Next objEnt
End Sub
Function KillSet(strSet As String)
Dim objSelSet As AcadSelectionSet
Dim objSelSets As AcadSelectionSets
Set objSelSets = ThisDrawing.SelectionSets
For Each objSelSet In objSelSets
If objSelSet.Name = strSet Then
ThisDrawing.SelectionSets.Item(strSet).Delete
Exit For
End If
Next
End Function
-
Wouldn't have it any other way :)
We can always clean it up later
Well, here goes nothing
Thanks so much Bob
I will let you know if it gets the job done
M
-
Bob
The lineobj variable is not set
lineObj.GetBoundingBox minExt, maxExt
I'm not sure what the line is for?
Shoud I declare the variable as an acadline?
Mark
-
Or is the intent blockref.GetBoundingBox ?
-
Bob
I did not see how the line fit in; it is the blkref.boundingbox that we are after
I am not totally sure how you code is suppose to work.
I have like 50 blocks in this drawing, so I did some quick tweaking so that I can pick the blockref that I want, then I tried to print out the results and still nothing.
Here is my quick, down and dirty attempt
M
Option Explicit
Public Sub blkCent()
Dim minExt As Variant
Dim maxExt As Variant
Dim pntCent(0 To 2) As Double
'lineObj.GetBoundingBox minExt, maxExt
Dim strSet As String
Dim strSetName As String
Dim intGroup(0) As Integer
Dim varGroup(0) As Variant
Dim objSelSet As AcadSelectionSet
Dim objSelSets As AcadSelectionSets
Dim strBlkName As String
Dim objBlkRef As AcadBlockReference
Dim objEnt As AcadEntity
Dim intCnt As Integer
Set objSelSets = ThisDrawing.SelectionSets
strSetName = 1
intGroup(0) = 0
varGroup(0) = "insert"
KillSet strSetName
Set objSelSet = objSelSets.Add(strSetName)
objSelSet.Select acSelectionSetAll, , , intGroup, varGroup
objSelSet.SelectOnScreen intGroup, varGroup
For Each objEnt In objSelSet
'If TypeOf objEnt Is AcadBlockReference Then
If objEnt.ObjectName = "AcDbBlockreference" Then
objBlkRef = objEnt
objBlkRef.GetBoundingBox minExt, maxExt
pntCent(0) = (minExt(0) + maxExt(0)) / 2
pntCent(1) = (minExt(1) + maxExt(1)) / 2
pntCent(2) = (minExt(2) + maxExt(2)) / 2
End If
Debug.Print pntCent(0); pntCent(1)
Next objEnt
End Sub
-
yeah, that one. I snagged the bounding box code from help and pasted it into something else I had so I wouldn't have to do any more typing than absolutely necessary. Yeah, that's how lazy I am.
-
Hey
We all do it man
Being resource (in my opinion) far outweighs accumulative knowledge.
Why re invent the wheel, right?
Unfortunately this is not going to get me what I beed right now but may be I will look at it later.
Thanks again
Mark
-
try this
Option Explicit
Public Sub blkCent()
Dim minExt As Variant
Dim maxExt As Variant
Dim pntCent(0 To 2) As Double
'lineObj.GetBoundingBox minExt, maxExt
Dim strSet As String
Dim strSetName As String
Dim intGroup(0) As Integer
Dim varGroup(0) As Variant
Dim objSelSet As AcadSelectionSet
Dim objSelSets As AcadSelectionSets
Dim strBlkName As String
Dim objBlkRef As AcadBlockReference
Dim objEnt As AcadEntity
Dim intCnt As Integer
Set objSelSets = ThisDrawing.SelectionSets
strSetName = 1
intGroup(0) = 0
varGroup(0) = "insert"
Set objSelSet = objSelSets.Add(strSetName)
'objSelSet.Select acSelectionSetAll, , , intGroup, varGroup
objSelSet.SelectOnScreen intGroup, varGroup
For Each objEnt In objSelSet
If TypeOf objEnt Is AcadBlockReference Then
' If objEnt.ObjectName = "AcDbBlockreference" Then
Set objBlkRef = objEnt
objBlkRef.GetBoundingBox minExt, maxExt
pntCent(0) = (minExt(0) + maxExt(0)) / 2
pntCent(1) = (minExt(1) + maxExt(1)) / 2
pntCent(2) = (minExt(2) + maxExt(2)) / 2
End If
Debug.Print pntCent(0); pntCent(1)
Next objEnt
End Sub
-
Bob
That did not quite get it, then I looked at the acad example as well
I started to screw with it a bit then thought I best just finish "this time" manually
I had to do it with 77 blocks
OK, so I finished that task, next time, I need to have an automated way of getting it.
If I get a few minutes this afternoon, I will look at it more.
Bob, would the bound box be similar to drawing a rectangle around the whole blockref?
If so, that is precisely what I need.
I see that you did the required math to capture the midpoint, I will need to expound; I think it would be good if when I select the blockref, that midpint will become my picked point, then I can move the blockref right into place.
Think it can be done?
Any help is certainly (as always) appreciated
Thanks!
Mark
-
Bob
That did not quite get it, then I looked at the acad example as well
I started to screw with it a bit then thought I best just finish "this time" manually
I had to do it with 77 blocks
hmm. ok.
OK, so I finished that task, next time, I need to have an automated way of getting it.
If I get a few minutes this afternoon, I will look at it more.
OK, shout if you get stumped.
Bob, would the bound box be similar to drawing a rectangle around the whole blockref?
If so, that is precisely what I need.
yep, precisely.
I see that you did the required math to capture the midpoint, I will need to expound; I think it would be good if when I select the blockref, that midpint will become my picked point, then I can move the blockref right into place.
Think it can be done?
yep. You can, after selection, prompt for a "move to point," then move it programatically.
-
Thanks Bob!
I will take a look at it.
Unfortunately, we are under the gun to get this done by Monday.
I will definitively look at it next week. If I get jammed up, may be you could lend me a hand.
Thanks Bob
Have a good weekend
M
-
I only tried it once, and the block was fairly simple, but this worked for me.
Option Explicit
Public Sub blkCent()
Dim minExt As Variant
Dim maxExt As Variant
Dim pntCent(0 To 2) As Double
Dim strSet As String
Dim strSetName As String
Dim intGroup(0) As Integer
Dim varGroup(0) As Variant
Dim objSelSet As AcadSelectionSet
Dim objSelSets As AcadSelectionSets
Dim objBlkRef As AcadBlockReference
Dim objEnt As AcadEntity
Dim pntMoveTo As Variant
Set objSelSets = ThisDrawing.SelectionSets
strSetName = 1
intGroup(0) = 0
varGroup(0) = "insert"
KillSet strSetName
Set objSelSet = objSelSets.Add(strSetName)
objSelSet.SelectOnScreen intGroup, varGroup
For Each objEnt In objSelSet
If TypeOf objEnt Is AcadBlockReference Then
Set objBlkRef = objEnt
objBlkRef.GetBoundingBox minExt, maxExt
pntCent(0) = (minExt(0) + maxExt(0)) / 2
pntCent(1) = (minExt(1) + maxExt(1)) / 2
pntCent(2) = (minExt(2) + maxExt(2)) / 2
objBlkRef.Highlight True
pntMoveTo = ThisDrawing.Utility.GetPoint(, "Select Destination Point: ")
objBlkRef.Move pntCent, pntMoveTo
End If
Next objEnt
End Sub
Function KillSet(strSet As String)
Dim objSelSet As AcadSelectionSet
Dim objSelSets As AcadSelectionSets
Set objSelSets = ThisDrawing.SelectionSets
For Each objSelSet In objSelSets
If objSelSet.Name = strSet Then
ThisDrawing.SelectionSets.Item(strSet).Delete
Exit For
End If
Next
End Function
-
Hey Bob
Are you still in work also?
Man! No rest for the weary...shewwww
Hey, I just tried the code, it seems to be working perfectly
Good job!
I really appreciate it
I will "definitely" look at it closer on Monday
Mark
-
BOB
That kicks Ass!
Man I could have used that 7 hours ago
It will certainly come in handy for the next batch that I do
I never want to see a rectangle again :)
Thanks again!!!
Mark
-
Glad you like it. I would still throw in some error handling if I was you. I stripped out what was in the one I started with though don't ask me why. I had a couple of minutes before class started this evening and was able to knock it out. It actually wouldn't hurt to rewrite the whole thing if you get the time. Having come from a larger, screwier routine, it could be more clean.
-
Yes, it works very well, thanks Bob!
I tried it on like 4 examples and it was exactly what I needed
I did not get any errors but if I encounter any, I will certainly address them
I will definitely look at it closer next week.
I will clean it or shorten up a bit but the method is dead on.
Before class huh?
Like I said, no rest for the weary :)
The next thing I am going to do is have ACAD write out the script files for me, then I think I will be in great shape for creating slides.
Not sure that I told you that is what I was doing?
I made a template with 75 viewports in Model, with center ticks.
1 viewport per slide.
Defined the viewport boundaries for each one.
Then wrote a script that basically repeats 75 times
view
r
5
mslide
Slidename
Then from Dos, using Slidelib, I created the slide library
We are creating image tiles for all of our symbol libraries
A lot of work upfront but worth it in the end.
Thanks again Bob
I appreciate all of the help!
M
-
I've got a vba routine at the office that writes scripts, or purports to at any rate, I don't think I ever tried it. My counterpart in one of our other offices turned it up a while back. I always do mine manually.
- I go to a command prompt
- dir *.dwg/b>whatever.scr
- open it in notepad
- paste
- down arrow
- paste
- down arrow
- lather
- rinse
- repeat
Not the most efficient way, but it works and it's one of those old dog/new trick things. PM me monday morning and I'll dig it up, if you want it.
Side Note:How many people here have ever written a text file with copy con>filename.txt then editted it with edlin?
Them was the days. Not necessarily the good days, but the days.
-
Hey Bob
Yes, I would like to see that code
Bob, are you kidding? DOS is still alive and well as far as I am concerned.
I write out from DOS all of the time, to get a printout of directories and files
It is priceless
A matter of fact, to do slidelib, you must use DOS, I believe
Ever use it?
As far as scripts, that is a cool way to get all your drawings into an scr file but what about this stuff:
view
r
5
mslide
Slidename
I guess I would just output my blocknames to an scr file from DOS, then paste the rest down like you said.
Still, I think I can do something here.....
If I show you the template and you are interested, we could probably grab each viewport
Pseudo code:
Thisdrawing.Sendcommand "view" & VbCr & "r" & viewport.name & "mslide" & VbCr & blkref.name & VbCr
So, for each viewport, we could just write it out to the debugger window or better yet, I could write it out to an external .scr file from VBA....
OMG...is my brain still functioning? I can't believe it.
Hey Bob
This is not the most effective tool but at one point I was trying to expound on it, just got stuck.
Dim FSO,WshNetwork,WshShell,svDialog
Dim objFile,intReturn
Dim txtsv 'String Variables
Set FSO = CreateObject("Scripting.FileSystemObject")
Set WshNetwork = CreateObject("WScript.Network")
Set WshShell = CreateObject ("WScript.shell")
Set svDialog = CreateObject("SAFRCFileDlg.FileSave")
'Open File Save Dialog Box
svDialog.FileName = "Temp.txt"
svDialog.FileType = "Text Files (*.txt)"
intReturn = svDialog.OpenFileSaveDlg
txtsv = svDialog.FileName
'Create, save and close file
If intReturn Then
Set objFile = FSO.CreateTextFile(txtsv)
objFile.Close
Else
Wscript.Quit
End If
'Output Current Directory:
'/k is a cmd.exe switch, it means keep the command prompt window open and wait for the next instruction.
'/c closes the command prompt window before you see it
WshShell.Run "cmd /C CD & dir *.dwg > dwg.txt /s /b &"
Set WshShell = Nothing
I think you know vbs?
Just copy that code into a txt file, saveas a .vbs file and double click
It needs work but do you think I use DOS? LOL
OK, I'll message you on Monday
Mark
-
BOB,
If you want to try to use that vbs file, don't rename the file, just browse to the directory that you want to write from/to and the temp file will get overwritten with a file from DOS called temp.
As I said, it needs work but it gets the job done.
After the data is written out, you can then rename the file to whatever
Mark
-
re: slidelib, yes I use it
re: vbscript - I've done a bit of stuff but not a lot
re: the template, send it to me. Not sure if I'll have any time to mess with it next week but I might.
I don't see a way to make a slide via vba other than sendcommand and mslide which is unfortunate.
-
Yes, that is a share that you can not do mslides from VBA, via the API but at least we can do something with the sendcommand
I think acad considers image tiles legacy when in fact, I think they are still a great asset
Once the symbol library is done, if you want to add a slide, you just mslide the new block out, add the slide name to the .txt file and run slidelib again from DOS to re create the library.
I think you probably assumed by now that the code that you wrote for me was to center each blockref into the respective vport.
With that code, you can insert all of your blocks into the template I have, then quickly center each block into its respective vport.
The very first vport was created by doing a zoom extents, then drawing the viewport.
After that, I just arrayed the vport across and down.
After you freeze the viewports, you have to go into each one and select update layers, then acad will remember that the frozen state is the current layer state. This way when you make the slides via a script or however, the vports will be frozen in each slide.
The only time you would really need to do an update layers on a vport again is if you add one ( I think) but definitely if you have to re scale the vports for a new batch of blocks. I had to do that once and an update layers was necessary.
Hmmmm.there may be a way in VBA to update all vports at once; didn't think of that.
vb-scripting:
As far as vb-scripting, I love it. It has so many great uses.
I think the cool thing is that you can incorporate it into VBA as well as using it stand alone in a .vbs file.
In which case only a double click is necessary.
Off topic a bit:
Myself and CM have had a few debates with vbs.
I know that VBA has a way to write out to .txt files but I love the The textstream method in The File SystemObject of vbs.
I would not say that one way is better then the other but I will say that the textstream method with FSO is certainly a lot more flexible as I can employ it from outside of AutoCAD. Anyone that has seen some of my code has seen that I like to mix it up.
Not to mention that, if I do the vbs code in ACAD-VBA, I can copy the code snippets to vbs and do some things.
Again, that is all a personal preference.
Hey Bob,
I found a great "free" program on line; it is called vbsedit
If you want to buy it, I think it is like $47 but you can also just keep hitting evaluate if you'd like.
www.vbsedit.com
(http://www.vbsedit.com)
It has a built in debugger, tons of examples that you can use immediately plus it uses intellisense like VBA which is outstanding.
It also allows you to put your own code snippets in to be saved for later use.
There is also an output window that works just like locals does in VBA.
For anyone that wants to learn VB-Scripting quickly, this program is great.
To get around the evaluate message, I use the program for code examples, getting methods and debugging, then I switch over to another editor for easy tweaks, that don't require me to run the code from vbsedit.
It is certainly worth the $47, I may even go ahead and buy it.
Anyhow, I would definitely strongly suggest any serious programmer to at least check it out
I am not sure about Visual Studio because I do not own it but these features for Vb-scripting be built into there as well.
Mark
-
If you go to vbsedit, there is a flash tutorial; I was just watching it again
Man! Hats off to whomever developed that program; it is brilliant
M
-
Hey this is nice. I'm currently having to place many blocks centered in a grid so this will come in handy for me as well. The only problem I was having is not being able to specify the midpoint between 2 points as my destination so I don't need to draw lines on my grid. I'm using 2002 and have created a button with this in it but it doesn't work:
_non;'cal (cur + cur)/2;
-
sub PickAWinner()
Dim pntOne as variant
dim pntTwo as variant
dim pntFriendsNose(0 to 2) as double
pntone=thisdrawing.getpoint(,"You can pick your friends: ")
pnttwo=thisdrawing.getpoint(,"You can pick your nose: ")
pntFriendsNose(0) = (pntone(0) + pnttwo(0)) / 2
pntFriendsNose(1) = (pntone(1) + pnttwo(1)) / 2
pntFriendsNose(2) = (pntone(2) + pnttwo(2)) / 2
end sub
-
hEY mARK,
cHECK THIS OUT AND SEE IF IT'S WHAT YOU'RE AFTER. sfcl, sorry
Option Explicit
Public Sub blkCent()
Dim minExt As Variant
Dim maxExt As Variant
Dim strSetName As String
Dim intGroup(0) As Integer
Dim varGroup(0) As Variant
Dim objSelSet As AcadSelectionSet
Dim objSelSets As AcadSelectionSets
Dim objBlkRef As AcadBlockReference
Dim objEnt As AcadEntity
Dim strName As String
Dim sysFileDia As Integer
Dim strFileName As String
Dim strWriteLine As String
Dim intFile As Integer
Set objSelSets = ThisDrawing.SelectionSets
strSetName = 1
intGroup(0) = 0
varGroup(0) = "insert"
KillSet strSetName
Set objSelSet = objSelSets.Add(strSetName)
objSelSet.Select acSelectionSetAll, , , intGroup, varGroup
sysFileDia = ThisDrawing.GetVariable("FILEDIA")
ThisDrawing.SetVariable "FILEDIA", 0
For Each objEnt In objSelSet
If TypeOf objEnt Is AcadBlockReference Then
Set objBlkRef = objEnt
strName = objBlkRef.Name
objBlkRef.GetBoundingBox minExt, maxExt
ZoomWindow minExt, maxExt
ThisDrawing.SendCommand "MSLIDE c:\tempslide\" & strName & vbCr
strFileName = "C:\tempslide\" & ThisDrawing.GetVariable("dwgname") & ".lst"
'*****MAKE SURE THIS FOLDER EXISTS*****
intFile = FreeFile
Open strFileName For Append As #intFile
Print #intFile, strName & ".sld"
Close #intFile
End If
Next objEnt
ZoomExtents
ThisDrawing.SetVariable "FILEDIA", sysFileDia
End Sub
Function KillSet(strSet As String)
Dim objSelSet As AcadSelectionSet
Dim objSelSets As AcadSelectionSets
Set objSelSets = ThisDrawing.SelectionSets
For Each objSelSet In objSelSets
If objSelSet.Name = strSet Then
ThisDrawing.SelectionSets.Item(strSet).Delete
Exit For
End If
Next
End Function
-
Hey Bob
I was at a company wide meeting for 2 days
Checking my e-mail from home
From looking at it, it looks good, Iwill need to try it when I get in the office tomorrow
Mark
PS: Did you take a look at that vbsedit link?
-
Not yet. Haven't had huge amounts of free time.
-
Bob
I am back in the office
I think that is a good thing..hmmmmm :-(
I have to do a few things this morning but I will definetely look at the code this afternoon
M
PS: Have you ever used the proper function? :)
hEY mARK,
cHECK THIS OUT AND SEE IF IT'S WHAT YOU'RE AFTER. sfcl, sorry
-
Bob
I still need to try it but I think you will like this, if you haven't used this method yet.
In the part of the code where it says, make sure folder exists...
Incorporate this code:
Note: First, Set a reference in VBA to
Microsoft Shell Controls and Automation
Sub TryMeBob ()
'Create new folder and get the path to the new folder
Dim oShell As Shell32.Shell
Dim oFolder As Shell32.Folder
Dim oItems As Shell32.FolderItems
Dim Item As Shell32.FolderItem
Dim Path As String
Set oShell = New Shell 'Get the ActiveX interface to shell32.dll
Set oFolder = oShell.BrowseForFolder(0, "Select a path ", 0)
If oFolder Is Nothing Then
MsgBox "Path not selected... Exiting!!"
Exit Sub
End If
Set oItems = oFolder.Items
Set Item = oItems.Item
Path = Item.Path & "\"
End Sub
-
To try this code in a real example, we could write out our layers (txt file) to a folder that we create on the fly
M
Sub CreateFolderWriteLayers()
'Create new folder and get the path to the new folder
Dim oShell As Shell32.Shell
Dim oFolder As Shell32.Folder
Dim oItems As Shell32.FolderItems
Dim Item As Shell32.FolderItem
Dim Path As String
Set oShell = New Shell 'Get the ActiveX interface to shell32.dll
Set oFolder = oShell.BrowseForFolder(0, "Select a path ", 0)
If oFolder Is Nothing Then
MsgBox "Path not selected... Exiting!!"
Exit Sub
End If
Set oItems = oFolder.Items
Set Item = oItems.Item
Path = Item.Path & "\"
'-------------------------------------------------
'For demonstration, write out your ACAD drawing layers to a .txt file (using drawing name = filename) and place it in your new folder
Dim MyFile As Variant
Dim Dwgname As String
Set FSO = CreateObject("Scripting.FileSystemObject")
Set WshNetwork = CreateObject("WScript.Network")
Dwgname = UCase(Left$(ThisDrawing.Name, Len(ThisDrawing.Name) - 4))
Set MyFile = FSO.CreateTextFile(Path & Dwgname & ".Txt", True)
For Each Layr In ThisDrawing.Layers
MyFile.WriteLine Layr.Name
Next Layr
MyFile.Close
End Sub
-
BOB
I tried your code for making the slides
Awesome!!!!!!!!
Now, I see that the lst (text file) of each slide was created with all of the slides in the directory C:\tempslide
However I did not do a vslide on any of them yet.
Have you created a slide library with them?
If so, how did it look?
I need to examine your code further.
OK, I think what you did was used the bounding box of each blkref to create the slides;
If so, that will not work for me.
I need to get the extmin and extmax of each viewport as then are defining my boundaries for each slide.
Did you get that template that I sent to you?
As far as naming the slides, the was perfect, using the blkref names.
Also, I have seen freefile but I never quite understood how it worked?
Thanks!
Mark
-
Yea, got t and used it. Didn't see any viewports which is why I didn't use them. What you've got are named views, not viewports. Different animals. Do you want the slides named the same as the block name, or the view name?
-
I'm sorry
The named views are on layer temp, they may have been frozen, I apologize
Naming the slides with the blockrefs names is perfect but the points need to be grabbed from the min and max of each named views
Some people may use rectangles, that is fine too
Where the named views will come in handy is when we write the script.
Because we can do something like this:
view
r
3
mslide
Blkref name
So, if we go left to right, top to bottom, and grabbed the min and max of each named view, that would be perfect.
Then
the script is saying
restore
view 3
mslide
blkref.name
There is a good reason why I prefer named views or rectangles; the blocks just look a lot more centered that way.
I thought it was a good idea to use named views so that we have a name to grab when writing out scripts
If we are interating through the named views, then it will be # 1 through whatever
What do you think?
Mark
-
Bob
Forget this line
So, if we go left to right, top to bottom
If the views are named in numeric order, then it will be fine
The code will just iterate through the named view collection accordingly
Mark
-
It's not hard to name them by the view name, or the block name, just need to know which you prefer. I don't really see the point in scripting this, seems as easy, easier actually, just to make them programatically.
-
Yes, yes
You have a great point as you just demonstrated
Why script them when you can do it as you previously demonstrated.
I would definitely prefer the the blkref name as the name of the slide
For the text file, I did this:
Dwgname = UCase(Left$(ThisDrawing.Name, Len(ThisDrawing.Name) - 4))
strFileName = "C:\tempslide\" & Dwgname & ".txt"
Just to get the extension out of the text file name; that is so minor though
Mark
-
what do you think about this?
Option Explicit
Public Sub blkCent()
Dim minExt As Variant
Dim maxExt As Variant
Dim pntLL(0 To 2) As Double
Dim pntUR(0 To 2) As Double
Dim strSetName As String
Dim intGroup(0) As Integer
Dim varGroup(0) As Variant
Dim objSelSet As AcadSelectionSet
Dim objSelSets As AcadSelectionSets
Dim objBlkRef As AcadBlockReference
Dim objEnt As AcadEntity
Dim strName As String
Dim sysFileDia As Integer
Dim strFileName As String
Dim strWriteLine As String
Dim intFile As Integer
Set objSelSets = ThisDrawing.SelectionSets
strSetName = 1
intGroup(0) = 0
varGroup(0) = "insert"
KillSet strSetName
Set objSelSet = objSelSets.Add(strSetName)
objSelSet.Select acSelectionSetAll, , , intGroup, varGroup
sysFileDia = ThisDrawing.GetVariable("FILEDIA")
ThisDrawing.SetVariable "FILEDIA", 0
For Each objEnt In objSelSet
If TypeOf objEnt Is AcadBlockReference Then
Set objBlkRef = objEnt
strName = objBlkRef.Name
objBlkRef.GetBoundingBox minExt, maxExt
pntLL(0) = ((minExt(0) + maxExt(0)) / 2) - 67.93
pntLL(1) = (minExt(1) + maxExt(1)) / 2 - 43.04
pntLL(2) = (minExt(2) + maxExt(2)) / 2
pntUR(0) = ((minExt(0) + maxExt(0)) / 2) + 67.93
pntUR(1) = (minExt(1) + maxExt(1)) / 2 + 43.04
pntUR(2) = (minExt(2) + maxExt(2)) / 2
ZoomWindow pntLL, pntUR
ThisDrawing.SendCommand "MSLIDE c:\tempslide\" & strName & vbCr
strFileName = "C:\tempslide\" & ThisDrawing.GetVariable("dwgname") & ".lst"
'*****MAKE SURE THIS FOLDER EXISTS*****
intFile = FreeFile
Open strFileName For Append As #intFile
Print #intFile, strName & ".sld"
Close #intFile
End If
Next objEnt
ZoomExtents
ThisDrawing.SetVariable "FILEDIA", sysFileDia
End Sub
Function KillSet(strSet As String)
Dim objSelSet As AcadSelectionSet
Dim objSelSets As AcadSelectionSets
Set objSelSets = ThisDrawing.SelectionSets
For Each objSelSet In objSelSets
If objSelSet.Name = strSet Then
ThisDrawing.SelectionSets.Item(strSet).Delete
Exit For
End If
Next
End Function
-
Bob
I will need to try it but I am wondering about this part
pntLL(0) = ((minExt(0) + maxExt(0)) / 2) - 67.93
pntLL(1) = (minExt(1) + maxExt(1)) / 2 - 43.04
pntLL(2) = (minExt(2) + maxExt(2)) / 2
pntUR(0) = ((minExt(0) + maxExt(0)) / 2) + 67.93
pntUR(1) = (minExt(1) + maxExt(1)) / 2 + 43.04
pntUR(2) = (minExt(2) + maxExt(2)) / 2
I'm not sure why you have the trailing numbers? The +/- 's
The reason I say this is because the scale of that template can change as per what I am doing
For example, if I am doing symbols, then the views will be smaller
If I am doing label type symbols, the views will be larger.
I'm sorry, I should have told you that I may scale the template up or down
The views are nothing more then closed polylines
For each boundary
get the llpnt and the urpnt
Make the slide
Next boundary
Wouldn't that work?
Let me try the code
Thanks!
Mark
-
Bob
Good try but still not quite right
I think it would be fine to just be prompted for 2 points
llpnt and urpnt
After you pick the points, the slide gets created with all the rest of your code
So, if I have to pick 2 points 75 times, that is still not the end of the world
Mark
-
meh. Knew that was a chance, tried to cheat it because it was less code change. I'll do it the other way but probably not before tomorrow.
-
Bob
If you incorporated this in
restore, view 3 (respective number), mslide blkref.name
That would do it
You see, I define the boundaries for each view upfront
If you restore each view, then grab the minext and maxext pnts of that boundary, then the slide would get created exactly as inteneded
Or a zoom window of each closed boundary (polyline), that would also do it
Thanks!
Mark
-
LOL
I'm sorry man!
You're doing a great job, you probably just didn't know all of my manual methodologies upfront.
If you nail this the way I am suggesting, then it would work with rectangles as well as named views
It would be very cool
Mark
-
I think that this
For each boundary
get the llpnts and the urpnts
Make the slide
Next boundary
Would be the best and most flexible method by far.
This would work with closed plines, named views and rectangles...as they are all treted the same, I believe
Mark
-
What are your criteria for setting the view size?
-
It is a good old fashion method called eye balling it :lmao:
Seriously!
Think of each rectangle (view, respectively) as an image in an image tile
So, if you were to do a zoom extents and draw a box, then you would have your first image tile
If the block looks good centered in that box, then you zoom out and array that box as many times as necessary.
I really do think by grabbing the ll and ur points of each boundary would be the most dynamic way to hit it
So, for each rectangle, you are msliding whatever is inside each rectangle
The question then is how do you retreive the block name inside of each rectangle
Man! i don't know that answer
Mark
-
Bob
Let's simplify this
Prompt the user to select the blockref, then you prompt them to pick two points; that is the lower left and upper right points of the closed pline.
After the user selects the blkref, we store that blkref name in a variable, get the points and create the slide using the blkref name
What do you think?
Between the code you did for centering the blocks (bounding box code) and the code I am suggesting here, we would move right through 75 mslides.
Mark
-
The question then is how do you retreive the block name inside of each rectangle
That's not hard but I still don't like one click each, much less two. What about zooming in on the bounding box, then zooming out .9x (or whatever) to give a little buffer?
-
Really?
I like the idea of picking the blockref then the two boundary points.
I guess that can really screw up the works if you miss.
Bob, I need the whole rectangle, point to point.
No zoom involved, unless you do a zoom window on the lower and upper corner of each closed polyline (boundary) then grab the blkref name, then do the mslide.
Think of each corner of the rectangle as a corner in the image tile box.
However the block looks inside the rectangle is exactly how it will look in the image tile.
This is why we scale up or down for different block types
Mark
-
What about zooming in on the bounding box, then zooming out .9x (or whatever) to give a little buffer?
No buffer necessary
Bob, suing that template that I sent to you, type -view at the command line, then select r for restore, then type in 1.
It will restore view 1. The way you see it there is exactly how I will need the slide to look
Each view is created by defining the boudary, end point to end point
Does that make sense?
Thanks
Mark
-
Hey Bob
I decided to try to write out a script in the debugging window, for now.
If all works out, I may even write it out to an .scr file
The code seems to be working well:
Sub WriteScript()
Dim BlkRef As AcadBlockReference
Dim Ent As AcadEntity
Dim NView As AcadView
For Each Ent In ThisDrawing.ModelSpace
If TypeOf Ent Is AcadBlockReference Then
Set BlkRef = Ent
For Each NView In ThisDrawing.Views
Debug.Print "view" & vbCrLf & "r" & vbCrLf & NView.Name & vbCrLf & "mslide" & vbCrLf & Ent.Name
Next NView
End If
Next Ent
End Sub
Except that I have 73 named views and it is only writing out 34 to 73
Any idea why?
Thanks!
Mark
-
OK
I've answered my own question :laugh:
Evidentally, the debugging window has a limitation to how many lines can be written to it
I just threw together this code real quick
Sub TestCode()
Dim BlkRef As AcadBlockReference
Dim Ent As AcadEntity
Dim NView As AcadView
Dim FSO, MyFile
Set FSO = CreateObject("Scripting.FileSystemObject")
Set MyFile = FSO.CreateTextFile("c:\test.scr", True)
For Each Ent In ThisDrawing.ModelSpace
If TypeOf Ent Is AcadBlockReference Then
Set BlkRef = Ent
For Each NView In ThisDrawing.Views
MyFile.WriteLine "view" & vbCrLf & "r" & vbCrLf & NView.Name & vbCrLf & "mslide" & vbCrLf & Ent.Name
Next NView
End If
Next Ent
MyFile.Close
End Sub
And it successfully wrote out all of the info to a .scr file
That is pretty cool
The only thing I am still unsure about is why some of the numbers (named view names) are not all in order in the scr file?
Also, I need to make sure that each block is getting assigned to the right named view in the script.
Any help here would be appreciated
Thanks
Mark