TheSwamp
Code Red => VB(A) => Topic started by: ML on November 13, 2007, 03:04:49 PM
-
I am having a bit of difficulty here, despite all my efforts
This is The VBA example, combined with some of my code
In the ClipPoints section, I kind of figured out what they are doing but after I insert my raster; the clip boundaries I set are not working.
I am inserting a raster at 0,0
Then I want to clip the raster to a 5', 5' Boundarie
Can someone tell me how I should correctly fill in the ClipPoints section (Points) to get that?
Thank you
Mark
Sub InstRast()
Dim InsertPnt(0 To 2) As Double
Dim scalefactor As Double
Dim RotAngle As Double
Dim Imgpth As String
Dim Imgname As String
Dim RastImg As AcadRasterImage
Imgpth = "K:\AutoCAD\Work Related\"
Imgname = "FtWashington600.tif"
InsertPnt(0) = 0#: InsertPnt(1) = 0#: InsertPnt(2) = 0#
scalefactor = 12#
rotationAngle = 0
On Error Resume Next
Set RastImg = ThisDrawing.PaperSpace.AddRaster(Imgpth & Imgname, InsertPnt, scalefactor, RotAngle)
RastImg.Name = Imgname
RastImg.Name = Left(Imgname, Len(Imgname) - 4)
If Err.Description = "Filer error" Then
MsgBox ImageName & " could not be found."
Exit Sub
End If
ZoomAll
' Establish the clip boundary with an array of points
Dim clipPoints(0 To 9) As Double
clipPoints(0) = 6: clipPoints(1) = 6.75
clipPoints(2) = 7: clipPoints(3) = 6
clipPoints(4) = 6: clipPoints(5) = 5
clipPoints(6) = 5: clipPoints(7) = 6
clipPoints(8) = 6: clipPoints(9) = 6.75
' Clip the image
RastImg.ClipBoundary clipPoints
' Enable the display of the clip
RastImg.ClippingEnabled = True
ThisDrawing.Regen acActiveViewport
End Sub
-
5'sq. centered on the image, from the insertion point, or something else?
From the insertion point would basically beSub InstRast()
Dim InsertPnt(0 To 2) As Double
Dim scalefactor As Double
Dim RotAngle As Double
Dim Imgpth As String
Dim Imgname As String
Dim RastImg As AcadRasterImage
Imgpth = "K:\AutoCAD\Work Related\"
Imgname = "FtWashington600.tif"
InsertPnt(0) = 0#: InsertPnt(1) = 0#: InsertPnt(2) = 0#
scalefactor = 12#
rotationAngle = 0
On Error Resume Next
Set RastImg = ThisDrawing.PaperSpace.AddRaster(Imgpth & Imgname, InsertPnt, scalefactor, RotAngle)
RastImg.Name = Imgname
RastImg.Name = Left(Imgname, Len(Imgname) - 4)
If Err.Description = "Filer error" Then
MsgBox ImageName & " could not be found."
Exit Sub
End If
ZoomAll
' Establish the clip boundary with an array of points
Dim clipPoints(0 To 9) As Double
clipPoints(0) = 0: clipPoints(1) = 0
clipPoints(2) = 0: clipPoints(3) = 60
clipPoints(4) = 60: clipPoints(5) = 60
clipPoints(6) = 60: clipPoints(7) = 0
clipPoints(8) = 0: clipPoints(9) = 0
' Clip the image
RastImg.ClipBoundary clipPoints
' Enable the display of the clip
RastImg.ClippingEnabled = True
ThisDrawing.Regen acActiveViewport
End Sub
-
Bob;
Yes from insertion is fine.
I noticed you handled it in inches, I just changed the 60 to 5 as we are working in feet.
That is great! Thank you
Now I see how it is working!
It is going in a rect. direction bottom to top, left to right.
And that is where they get the 10 points from.
2 (points(x+y) x 4 sides = 8 + back to 0,0 = 10
Dim clipPoints(0 To 9) As Double
clipPoints(0) = 0: clipPoints(1) = 0
clipPoints(2) = 0: clipPoints(3) = 5
clipPoints(4) = 5: clipPoints(5) = 5
clipPoints(6) = 5: clipPoints(7) = 0
clipPoints(8) = 0: clipPoints(9) = 0
Thanks you
Mark
-
Wasn't sure what flavor you were so I went with inches. I figured Civil would be smart enough to figure out the difference between feet and inches, Architects, probably not.
I don't think that it matters if you go clockwise or counter(anti)clockwise and I think it can be an irregular shape. That's just a guess though, I haven't actually looked into it. All you need to do is list XY coordinates to define a shape where the last point is the same as the first point. The easiest way to do that is to think about how you would put a pline in without touching the mouse.
-
Yes you can do an irregular shape
Try VBA's Example, it is strange
Mark
Sub Example_ClippingEnabled()
' This example adds a raster image in model space.
' It then clips the image based on a clip boundary,
' and toggles the display of the clipping.
Dim insertionPoint(0 To 2) As Double
Dim scalefactor As Double
Dim rotationAngle As Double
Dim imageName As String
Dim rasterObj As AcadRasterImage
imageName = "C:\AutoCAD\sample\downtown.jpg"
insertionPoint(0) = 5#: insertionPoint(1) = 5#: insertionPoint(2) = 0#
scalefactor = 2#
rotationAngle = 0
On Error Resume Next
' Creates a raster image in model space
Set rasterObj = ThisDrawing.ModelSpace.AddRaster(imageName, insertionPoint, scalefactor, rotationAngle)
If Err.Description = "Filer error" Then
MsgBox imageName & " could not be found."
Exit Sub
End If
ZoomAll
MsgBox "Clip the image?", , "ClipBoundary Example"
' Establish the clip boundary with an array of points
Dim clipPoints(0 To 9) As Double
clipPoints(0) = 6: clipPoints(1) = 6.75
clipPoints(2) = 7: clipPoints(3) = 6
clipPoints(4) = 6: clipPoints(5) = 5
clipPoints(6) = 5: clipPoints(7) = 6
clipPoints(8) = 6: clipPoints(9) = 6.75
' Clip the image
rasterObj.clipBoundary clipPoints
' Enable the display of the clip
rasterObj.ClippingEnabled = True
ThisDrawing.Regen acActiveViewport
MsgBox "Turn off the display of the clipped image.", , "ClippingEnabled Example"
' Disable the display of the clip
rasterObj.ClippingEnabled = False
ThisDrawing.Regen acActiveViewport
MsgBox "Display off.", , "ClippingEnabled Example"
End Sub
-
True. Didn't actually mean irregular shape when I said it. I meant more than four sided thingy.
-
Oh good point
Evidentially 4 sides are 10 points.
I would imagine you can do more but not sure
In ACAD, you can try the imageclip command if you are realy curious and see what it gives you
Mark
-
Actually, 4 sides is 5 points.
1--------2
5 |
| |
| |
4--------3
Each point is defined by a coordinate. Each coordinate is two ordinates (numbers), an X ordinate and a Y ordinate, so 0,1 is the first point, 2,3 the second, 4,5, the third, 6,7 the fourth, and 8,9 is the fifth which duplicates the first so that the boundary is closed. Does that make sense to you?
-
Yes, of course it does and you are absolutely right
It is 5 point and 10 coorinates.
Thanks Bob! :)
-
Bob,
Let me ask you or anyone else this
I have this code
Dim llpnt As Variant 'lower left point
Dim urpnt As Variant 'upper right point
With ThisDrawing.Utility
llpnt = .GetPoint(, vbCrLf & "Select Lower Left Point: ")
urpnt = .GetPoint(, vbCrLf & "Select Upper Right Point: ")
End With
And I somehow need to make the lower left point and the upper right (picked) points of the raster = my 5' x 5' boundary that I defined with the clipboundary.
Any idea how I can make this happen?
Thank you
Mark
-
Sure. What you want to do is basically this
Dim llpnt As Variant 'lower left point
Dim urpnt As Variant 'upper right point
With ThisDrawing.Utility
llpnt = .GetPoint(, vbCrLf & "Select Lower Left Point: ")
urpnt = .GetPoint(, vbCrLf & "Select Upper Right Point: ")
End With
Dim clipPoints(0 To 9) As Double
clipPoints(0) = llpnt(0): clipPoints(1) = llpnt(1)
clipPoints(2) = llpnt(0): clipPoints(3) = urpnt(1)
clipPoints(4) = urpnt(0): clipPoints(5) = urpnt(1)
clipPoints(6) = urpnt(0): clipPoints(7) = llpnt(1)
clipPoints(8) = llpnt(0): clipPoints(9) = llpnt(1)
-
Yes sir!
That was the ticket!
Thank you so much Bob!
Mark
-
Bob,
If you don't mind one more question?
That method works great for making the clip boundary your picked points.
Now check this out:
Dim llpnt As Variant 'lower left point
Dim urpnt As Variant 'upper right point
With ThisDrawing.Utility
llpnt = .GetPoint(, vbCrLf & "Select Lower Left Point: ")
urpnt = .GetPoint(, vbCrLf & "Select Upper Right Point: ")
End With
mdpnt(0) = llpnt(0) + ((urpnt(0) - llpnt(0)) / 2) 'Midpoint (X) = The point in the far left direction - the point in the far right direction / 2
mdpnt(1) = llpnt(1) + ((urpnt(1) - llpnt(1)) / 2) 'Midpoint (Y) = The point in the far top direction - the point in the far bottom direction / 2
mdpnt(2) = 0
I have my midpoint of the two picked points calculated;
Now I would like to make my clip boundary 5' from the midpoint in the x and y direction
Giving me a 5' x 5' clipboundary from the midpoint of the two picked points
I tried using your method to get it but no luck so far
Any ideas?
Thank you again
Mark
-
Do I still need 9 points?
Mark
-
Ooops sorry
It is midpoint +/- 30 in each direction
Mark
-
Yes, 30 +- in each direction, All 4 directions for calcing the points
-
Do I still need 9 points?
Mark
and yes, you still need an array (0 to 9), ten numbers for a 4 sided shape. You need to close AFAIK*
*caveat - everything I'm giving you here is from reading what you have and typing a response that seems logical to me. I'm not playing along on the home version. Everything I'm giving you, I'm giving as guidelines. It is most definitely NOT test and most likely not functioning code.
-
Cool
Thanks again guys!
Unfortunately I got pulled away for other things but I will certainly get back to it tomorrow
This is very cool stuff.
I appreciate all the help!
Mark
-
I thought I would give it a shot tonight but still no luck.
Starting from the midpoint, this is what I used but it did not work as I hoped
'Clip boundary = 2.5' from mdpnt to edges. 5' boundary
clipPoints(0) = mdpnt(0) + 2.5: clipPoints(1) = mdpnt(1) + 2.5
clipPoints(2) = mdpnt(0): clipPoints(3) = mdpnt(1)
clipPoints(4) = mdpnt(0): clipPoints(5) = mdpnt(1) + 5
clipPoints(6) = mdpnt(0) + 5: clipPoints(7) = mdpnt(1) + 5
clipPoints(8) = mdpnt(0) + 5: clipPoints(9) = mdpnt(1)
Can someone please tell me where I am going wrong?
Thank you
Mark
-
what did u declare ClipPoints as? Integer, double ?
-
Im also assuming your working in feet not inches
-
Hey CM,
I declared them as:
Dim clipPoints(0 To 9) As Double
And yes, you are correct; I am working in feet.
-
Can someone please tell me where I am going wrong?
It looks like you are close, but you need to use some negative numbers as well to get the left side of the MidPt
OK, lets say for arguments sake, your user picks 10,10 for LL and 90,80 for UR
The midpoint of those 2 points is (X1+X2)/2 , (Y1+Y2)/2 = 10+90=100/2=50, 10+80=90/2=45 so the MP is 50,45 (with me so far?)
Now to center a 60x60 clip boundary on the point 50,45 you need to add 30 and subtract 30 from the appropriate points
So LL is going to be 20,15 and UR is 80,75 Does this make sense so far?
Given those 2 points, we can derive UpperLeft= 20,75 and LowerRight=80,15
thus the ClipBoundary points are from LL counterclockwise in order of X & Y=
LL pt (20,15)
LR pt (80,15)
UR pt (80,75)
UL pt (20,75)
LL again to close (20,15)
-
CM,
Let me give you more info;
This is not the entire module but the critical part:
OK, assume that the raster is already inserted,scaled and all of that stuff
Now we move onto prompting the user to pick two point on the raster
Dim llpnt As Variant 'lower left point
Dim urpnt As Variant 'upper right point
Dim mdpnt(0 To 2) As Double
Dim clipPoints(0 To 9) As Double
With ThisDrawing.Utility
llpnt = .GetPoint(, vbCrLf & "Select Lower Left : ")
urpnt = .GetPoint(, vbCrLf & "Select Upper Right: ")
End With
mdpnt(0) = llpnt(0) + ((urpnt(0) - llpnt(0)) / 2) 'Midpoint (X) = (The point in the far left direction) - (The point in the far right direction) / 2
mdpnt(1) = llpnt(1) + ((urpnt(1) - llpnt(1)) / 2) 'Midpoint (Y) = (The point in the far top direction) - (The point in the far bottom direction) / 2
mdpnt(2) = 0 'Z = 0
[b]'Here is where I need help:[/b]
'Clip boundary = 2.5' from mdpnt to edges. 5' boundary
' clipPoints(0) = mdpnt(0) - 2.5: clipPoints(1) = mdpnt(1) - 2.5
' clipPoints(2) = mdpnt(0) + 0: clipPoints(3) = mdpnt(1) + 5
' clipPoints(4) = mdpnt(0) + 5: clipPoints(5) = mdpnt(1) + 0
' clipPoints(6) = mdpnt(0) + 0: clipPoints(7) = mdpnt(1) - 5
' clipPoints(8) = mdpnt(0) - 5: clipPoints(9) = mdpnt(1) + 0
'Clip the image
RastImg.ClipBoundary clipPoints
'Enable the display of the clip
RastImg.ClippingEnabled = True
ThisDrawing.Regen acActiveViewport
Thanks
Mark
-
...
mdpnt(0) = llpnt(0) + ((urpnt(0) - llpnt(0)) / 2) 'Midpoint (X) = (The point in the far left direction) - (The point in the far right direction) / 2
mdpnt(1) = llpnt(1) + ((urpnt(1) - llpnt(1)) / 2) 'Midpoint (Y) = (The point in the far top direction) - (The point in the far bottom direction) / 2
mdpnt(2) = 0 'Z = 0
.....
Thanks
Mark
This is where I see a problem. I am having trouble following your logic in deriving the MP. You just need (X1+X2)/2 Not (X1+(X2-X1))/2
I think your creating to small a number there. Try changing to just (X1+X2)/2
-
Here is another thought, AND I dont know if this can be done through code!! What if you just "drew" a rectangle through code, Which would need the MP and width/height both of which would be 60. Can you pick existing rectangle and make a clipping window?
-
OK,
I do understand your explanations CM and thank you.
As far as the midpoint; it seems to be working fine.
I'm not sure if you tried that code that I sent you yesterday; but here it is again.
Using this code, pick 2 simple points, like a 5' x 5' rectangle, lower left and upper right points, then look at your immediate window.
I think you will find that the midpoint is being calculated fine.
I will also try again to make sure
Mark
Sub Getpoints()
Dim llpnt As Variant 'lower left point
Dim urpnt As Variant 'upper right point
Dim xpnts As Variant
Dim ypnts As Variant
Dim mdpnt(0 To 2) As Double
With ThisDrawing.Utility
llpnt = .GetPoint(, vbCrLf & "Select Lower Left Limits of your Project Area: ")
urpnt = .GetPoint(, vbCrLf & "Select Upper Right Limits of your Project Area: ")
End With
xpnts = llpnt(0) + urpnt(0)
ypnts = llpnt(1) + urpnt(1)
mdpnt(0) = llpnt(0) + ((urpnt(0) - llpnt(0)) / 2) 'Midpoint (X) = (The point in the far left direction) - (The point in the far right direction) / 2
mdpnt(1) = llpnt(1) + ((urpnt(1) - llpnt(1)) / 2) 'Midpoint (Y) = (The point in the far top direction) - (The point in the far bottom direction) / 2
mdpnt(2) = 0 'Z = 0
Debug.Print "Lower left point: "; llpnt(0) & "," & llpnt(1)
Debug.Print "Upper right point: "; urpnt(0) & "," & urpnt(1)
Debug.Print "Xpoints: "; xpnts
Debug.Print "Ypoints: "; ypnts
Debug.Print "Midpoint: "; mdpnt(0) & "," & mdpnt(1)
End Sub
-
I think what you are suggesting is this:
NewMidpnt = llpnt(0) + urpnt(0)\2
NewMidpnt = llpnt(1) + urpnt(1)\2
-
This is pretty cool too for getting points returned to you in the immediate window
Sub GetpointsAll()
Dim pnt1 As Variant
Dim pnt2 As Variant
Dim pnt3 As Variant
Dim pnt4 As Variant
Dim pnt5 As Variant
Dim pnt6 As Variant
Dim pnt7 As Variant
Dim pnt8 As Variant
Dim pnt9 As Variant
On Error Resume Next
With ThisDrawing.Utility
pnt1 = .GetPoint(, vbCrLf & "pnt1 ")
pnt2 = .GetPoint(, vbCrLf & "pnt2 ")
pnt3 = .GetPoint(, vbCrLf & "pnt3 ")
pnt4 = .GetPoint(, vbCrLf & "pnt4 ")
pnt5 = .GetPoint(, vbCrLf & "pnt5 ")
pnt6 = .GetPoint(, vbCrLf & "pnt6 ")
pnt7 = .GetPoint(, vbCrLf & "pnt7 ")
pnt8 = .GetPoint(, vbCrLf & "pnt8 ")
pnt9 = .GetPoint(, vbCrLf & "pnt9 ")
End With
Debug.Print "Pnt1: "; pnt1(0) & "," & pnt1(1)
Debug.Print "Pnt2: "; pnt2(0) & "," & pnt2(1)
Debug.Print "Pnt3: "; pnt3(0) & "," & pnt3(1)
Debug.Print "Pnt4: "; pnt4(0) & "," & pnt4(1)
Debug.Print "Pnt5: "; pnt5(0) & "," & pnt5(1)
Debug.Print "Pnt6: "; pnt6(0) & "," & pnt6(1)
Debug.Print "Pnt7: "; pnt7(0) & "," & pnt7(1)
Debug.Print "Pnt8: "; pnt8(0) & "," & pnt8(1)
Debug.Print "Pnt9: "; pnt9(0) & "," & pnt9(1)
End Sub
The On Error Resume Next takes care of un picked points, you will just need to enter through any points you don't pick
So, for example; if you pick Pnt1,Pnt2,Pnt3 and Pnt4; you will need to press enter 5 times to get to the end of the sub.
I'm sure I could do more to address un picked points but this was just down and dirty to get some results
Mark
-
Try this on for size.
Sub GetpointsAll()
Dim pnt As Variant
Dim i As Integer
On Error GoTo Boom
i = 1
Do
pnt = ThisDrawing.Utility.GetPoint(, vbCrLf & "pnt" & i)
Debug.Print "Pnt" & i & ": "; pnt(0) & "," & pnt(1)
i = i + 1
Loop
Boom:
Select Case Err.Number
Case Else
Debug.Print Err.Number
Err.Clear
Exit Sub
End Select
End Subwill work if you need 1 or 100
-
Very Cool Bob, thank you!
I still need to figure out this clipboundary from midpoint problem but I appreciate you modifying the pnt code; it works great and it will be very useful for some things,
I changed the label Boom to NoPoint
On Error Goto NoPoint LOL
Make sense? :)
Mark
-
I think what you are suggesting is this:
NewMidpnt = llpnt(0) + urpnt(0)\2
NewMidpnt = llpnt(1) + urpnt(1)\2
yes and no
you need () around the LL and UR to prevent UR(0)/2 + LL(0) from happening
NewMidpnt = (llpnt(0) + urpnt(0))\2
NewMidpnt = (llpnt(1) + urpnt(1))\2
-
Also look at / vs \
One of those is integer division which will round off your answer to a whole number
-
OK CM
With your method
You want this:
mdpnt(0) = (llpnt(0) + urpnt(0)) / 2
mdpnt(1) = (llpnt(1) + urpnt(1)) / 2
To get your actual value
It looks like the \ operator will round to a whole number
Mark
-
Sorry, just went to the last post, missed a few, but was under the impression you had that taken care of.
Dim llpnt As Variant 'lower left point
Dim urpnt As Variant 'upper right point
Dim mdpnt(0 To 1) As Double
Dim clipPoints(0 To 9) As Double
With ThisDrawing.Utility
llpnt = .GetPoint(, vbCrLf & "Select Lower Left : ")
urpnt = .GetPoint(, vbCrLf & "Select Upper Right: ")
End With
mdpnt(0) = (urpnt(0) + llpnt(0)) / 2 'Midpoint (X) = (The point in the far left direction) - (The point in the far right direction) / 2
mdpnt(1) = llpnt(1) + llpnt(1)) / 2 'Midpoint (Y) = (The point in the far top direction) - (The point in the far bottom direction) / 2
[b]'Here is where I need help:[/b]
'Clip boundary = 2.5' from mdpnt to edges. 5' boundary
clipPoints(0) = mdpnt(0) - 2.5: clipPoints(1) = mdpnt(1) - 2.5
clipPoints(2) = mdpnt(0) - 2.5: clipPoints(3) = mdpnt(1) + 2.5
clipPoints(4) = mdpnt(0) + 2.5: clipPoints(5) = mdpnt(1) + 2.5
clipPoints(6) = mdpnt(0) + 2.5: clipPoints(7) = mdpnt(1) - 2.5
clipPoints(8) = mdpnt(0) - 2.5: clipPoints(9) = mdpnt(1) + -2.5
'Bob Note
'It looks from what you had there, that you still don't understand what you're after
'it looks like you are giving directions for the shape relative to the last point
'That's not what you need to do here. What you need are the absolute ordinates for each one
'Don't think of it as drawing lines, think of it as plotting points on a graph that
'the command will connect like a dot to dot. All you are supplying are the dots.
'Clip the image
RastImg.ClipBoundary clipPoints
'Enable the display of the clip
RastImg.ClippingEnabled = True
ThisDrawing.Regen acActiveViewport
[edit]Duh's got the right of it \ gives you an integer / gives you a floating point.
-
BOB!
You are the man!
Oh I see! :-o
I read your note, thank you for that too! In this case, you are defining (as you said "like plotting points on a graph") "all" points from the midpoint and building the boundary around the midpoint.
As you said, I am treating it like I am drawing a series of lines to build my boundary.
Whereas the way (proper way) you are doing it is giving the absolute coords from the midpoint and acad is connecting the dots to make the boundary (rectangle)
Very cool indeed!
Thank you again :-)
Mark
-
Glad you're getting it.
-
Yes sir!
Thank you and thank you for the points code as well.
I like the way you handled that, looping through and incrementing the pnt variable by 1 each time.
Mark
-
Thanks
-
No thank you :)
-
You know what would be cool would be to make a function that had 3 arguments, 2 pts and 1 size. You could pick your points, pass those to the function, and ask user how big the clipping should be, and have the function return the array of points back to your main function
-
Conceptually I had the right idea; that was to use the midpoint to build the boundary but getting there was a B***H LOL
Thanks guys!
Mark
-
CM
That sounds cool but I think we hit that already, only not with a function
Wouldn't this method kind of do that?
User just picks points on the raster and it is clipped accordingly
'Clip boundary = picked points (llpnt and urpnt)
clipPoints(0) = llpnt(0): clipPoints(1) = llpnt(1)
clipPoints(2) = llpnt(0): clipPoints(3) = urpnt(1)
clipPoints(4) = urpnt(0): clipPoints(5) = urpnt(1)
clipPoints(6) = urpnt(0): clipPoints(7) = llpnt(1)
clipPoints(8) = llpnt(0): clipPoints(9) = llpnt(1)
-
Yes, but we have hard coded the 5x5. what if we want to change the size of the clipping on the fly
-
Your idea is really cool but this code here
'Clip boundary = picked points (llpnt and urpnt)
clipPoints(0) = llpnt(0): clipPoints(1) = llpnt(1)
clipPoints(2) = llpnt(0): clipPoints(3) = urpnt(1)
clipPoints(4) = urpnt(0): clipPoints(5) = urpnt(1)
clipPoints(6) = urpnt(0): clipPoints(7) = llpnt(1)
clipPoints(8) = llpnt(0): clipPoints(9) = llpnt(1)
Is not hardcoding a 5 x5; it is creating the clip boundary based off of the lower left and upper right picked points.
So, bascially your function only needs to fill in the values for the variables llpnt and urpnt; I think
So; if the user inputs 10 x 10; then we need to retrieve that data and do the math on llpnt and urpnt
-
By selecting the lower left and upper right; we already have all the coords that we need
So again, it is just filling in
'Clip boundary = picked points (llpnt and urpnt)
clipPoints(0) = llpnt(0): clipPoints(1) = llpnt(1)
clipPoints(2) = llpnt(0): clipPoints(3) = urpnt(1)
clipPoints(4) = urpnt(0): clipPoints(5) = urpnt(1)
clipPoints(6) = urpnt(0): clipPoints(7) = llpnt(1)
clipPoints(8) = llpnt(0): clipPoints(9) = llpnt(1)
with the proper coords
User inputs 10 x 10
We grab that and do 10 -/+ llpnt and urpnt to get the clip boundary, I think :)
I am loosing my ability to think at this point :-(
Mark
-
I think what we really need is VBAnonymous Meetings LOL
-
Beware the pseudocodiness of it
numbah = thisdrawing.utility.getreal ("How big a square ya after, Bucko?: ")
clipPoints(0) = mdpnt(0) - numbah/2: clipPoints(1) = mdpnt(1) - numbah/2
clipPoints(2) = mdpnt(0) - numbah/2: clipPoints(3) = mdpnt(1) + numbah/2
clipPoints(4) = mdpnt(0) + numbah/2: clipPoints(5) = mdpnt(1) + numbah/2
clipPoints(6) = mdpnt(0) + numbah/2: clipPoints(7) = mdpnt(1) - numbah/2
clipPoints(8) = mdpnt(0) - numbah/2: clipPoints(9) = mdpnt(1) + -numbah/2
-
Bob; if you keep this up; I will be asking for your phone number LOL; just kidding :-D
Of course, now I need to go try this :-)
Mark
-
Bob; if you keep this up; I will be asking for your phone number LOL; just kidding :-D
Of course, now I need to go try this :-)
Mark
It's going to take some tweaking, that was just a nudge. You'll need to bump up your error handling so that it knows what to do when somebody types in something that's not a number. You might want to put in a default size so they can hit enter to get the default. You might also want to give them an option to do a rectangle instead of square. Then again, maybe not.
-
That's funny; using the midpoint was my idea originally although I needed your guys help on how to build around it; however I failed to think of that in this (CM's idea) application.
I keep getting stuck on the upper and lower points.
The midpoint is definetely THE most logical place to work from.
So, Hats off to Bob again! :-)
Mark
-
Bob; if you keep this up; I will be asking for your phone number
Like that hasn't been on how many bar napkins and toilet stalls west of the Mississippi.
-
A couple of other thoughts to throw out to you. with the two point selection method, you could just check the distance, round to the nearest whole number, and clip. For a midpoint centered clip, you can just get them to pick a center point and distance instead of two points.
-
Bob; if you keep this up; I will be asking for your phone number
Like that hasn't been on how many bar napkins and toilet stalls west of the Mississippi.
West of the Mississippi? I've got national renown.
-
WAIT!
Bob
With your code
numbah = thisdrawing.utility.getreal ("How big a square ya after, Bucko?: ")
clipPoints(0) = mdpnt(0) - numbah/2: clipPoints(1) = mdpnt(1) - numbah/2
clipPoints(2) = mdpnt(0) - numbah/2: clipPoints(3) = mdpnt(1) + numbah/2
clipPoints(4) = mdpnt(0) + numbah/2: clipPoints(5) = mdpnt(1) + numbah/2
clipPoints(6) = mdpnt(0) + numbah/2: clipPoints(7) = mdpnt(1) - numbah/2
clipPoints(8) = mdpnt(0) - numbah/2: clipPoints(9) = mdpnt(1) + -numbah/2
We will still need
Dim llpnt As Variant 'lower left point
Dim urpnt As Variant 'upper right point
Dim mdpnt(0 To 2) As Double
Dim clipPoints(0 To 9) As Double
With ThisDrawing.Utility
llpnt = .GetPoint(, vbCrLf & "Select Lower Left Point: ")
urpnt = .GetPoint(, vbCrLf & "Select Upper Right Point: ")
End With
mdpnt(0) = (llpnt(0) + urpnt(0)) / 2 'Midpoint (X) = (The far left picked point + the far right picked point) / 2
mdpnt(1) = (llpnt(1) + urpnt(1)) / 2 'Midpoint (Y) = (The far bottom picked point + the far top picked point) / 2
mdpnt(2) = 0
To get our midpoint; based off of the picked points in the above code, correct?
So, we get our picked points, figure out the midpnt (all done), then with Bob's "new" code, we get the boundary size;
the boundary size gets divided by 2 and gets built around the midpoint in all 4 directions at that (the divided) size
Very clever!
Mark
Mark
-
Bob is on the right track of what I was thinking. Bob, how do you do the default thing??? In LISP I know you use <> to define it, but I never learned how in VBA
-
Did everyone hear the click as the pieces fell into place?
-
Bob
Thankfully, I don't swing that way, but I will work for code :-D
Also, your above idea is also very clever.
Pick center point and get size.
Mark
-
Bob is on the right track of what I was thinking. Bob, how do you do the default thing??? In LISP I know you use <> to define it, but I never learned how in VBA
You use error handling with VBA I throw the <crap> into my prompt so it looks familiar to Johnny Caduserguy but it's handle with the error trapping.
-
Did everyone hear the click as the pieces fell into place?
I'm sorry I must have missed it but I hear the click in my e-mail every time there is a new post :-)
-
A couple of other thoughts to throw out to you. with the two point selection method, you could just check the distance, round to the nearest whole number, and clip. For a midpoint centered clip, you can just get them to pick a center point and distance instead of two points.
This actually is less coding, and allows the user to "center" the clipping box based on a selected point. Much easier and cleaner if you ask me
-
Bob is on the right track of what I was thinking. Bob, how do you do the default thing??? In LISP I know you use <> to define it, but I never learned how in VBA
You use error handling with VBA I throw the <crap> into my prompt so it looks familiar to Johnny Caduserguy but it's handle with the error trapping.
So you trap NULL?
-
do you use a form of initget? and set bits to allow null entry, and then trap for the null?
-
This actually is less coding, and allows the user to "center" the clipping box based on a selected point. Much easier and cleaner if you ask me
It is actually a very clever idea but it still all boils down to "what" is the need
In my application; it needs to be fitted into a 5 x 5 box on a title block; so yes, they could have said I prefer to have this area centered but that is ok; then can still pick a very small or specific area on the raster and the 5 x 5 will get made with that area is basically centered.
I think this offers a lot of flexibility as they have the window option.
I am curious to try that dynamic boundary code though
Mark
-
ill write something up for you
-
OK Guys
Here is the total accumulation of what we had done; hopefully others can benefit from it.
Bob, your last method is the last one in the code; the rest are commented out
It is really cool!
The user can type in the size and it is created.
The only thing I noticed is that it did not regenerate on bigger sizes; not sure why.
Mark
Sub InstRast()
Dim RastImg As AcadRasterImage
Dim Imgpth As String
Dim Imgname As String
Dim InsertPnt(0 To 2) As Double, scalefactor As Double, RotAngle As Double
Imgpth = "Path"
Imgname = "filename"
InsertPnt(0) = 0#: InsertPnt(1) = 0#: InsertPnt(2) = 0#
scalefactor = 1
RotAngle = 0
On Error GoTo Errorhandler
Set RastImg = ThisDrawing.PaperSpace.AddRaster(Imgpth & Imgname, InsertPnt, scalefactor, RotAngle)
RastImg.Name = Imgname
RastImg.Name = Left(Imgname, Len(Imgname) - 4)
RastImg.scalefactor = 12
'Move Points
Dim Point1(0 To 2) As Double
Dim Point2(0 To 2) As Double
Point1(0) = 8: Point1(1) = 0: Point1(2) = 0
Point2(0) = 0: Point2(1) = 0: Point2(2) = 0
'Move Raster
RastImg.Move Point1, Point2
Errorhandler:
If Err.Description = "File access error" Then
If MsgBox("Can not find image file") Then
Exit Sub
End If
End If
Dim llpnt As Variant 'lower left point
Dim urpnt As Variant 'upper right point
Dim mdpnt(0 To 2) As Double
Dim clipPoints(0 To 9) As Double
With ThisDrawing.Utility
llpnt = .GetPoint(, vbCrLf & "Select Lower Left Point: ")
urpnt = .GetPoint(, vbCrLf & "Select Upper Right Point: ")
End With
mdpnt(0) = (llpnt(0) + urpnt(0)) / 2 'Midpoint (X) = (The far left picked point + the far right picked point) / 2
mdpnt(1) = (llpnt(1) + urpnt(1)) / 2 'Midpoint (Y) = (The far bottom picked point + the far top picked point) / 2
mdpnt(2) = 0
'FINITE
'Create a 5 x 5 clip boundary
' clipPoints(0) = 0: clipPoints(1) = 0
' clipPoints(2) = 0: clipPoints(3) = 5
' clipPoints(4) = 5: clipPoints(5) = 5
' clipPoints(6) = 5: clipPoints(7) = 0
' clipPoints(8) = 0: clipPoints(9) = 0
'Clip boundary = 2.5 from the mdpnt of the raster's picked points to the boundary coords.
' clipPoints(0) = mdpnt(0) - 2.5: clipPoints(1) = mdpnt(1) - 2.5
' clipPoints(2) = mdpnt(0) - 2.5: clipPoints(3) = mdpnt(1) + 2.5
' clipPoints(4) = mdpnt(0) + 2.5: clipPoints(5) = mdpnt(1) + 2.5
' clipPoints(6) = mdpnt(0) + 2.5: clipPoints(7) = mdpnt(1) - 2.5
' clipPoints(8) = mdpnt(0) - 2.5: clipPoints(9) = mdpnt(1) + -2.5
'DYNAMIC
'Clip boundary = picked points (llpnt + urpnt)
' clipPoints(0) = llpnt(0): clipPoints(1) = llpnt(1)
' clipPoints(2) = llpnt(0): clipPoints(3) = urpnt(1)
' clipPoints(4) = urpnt(0): clipPoints(5) = urpnt(1)
' clipPoints(6) = urpnt(0): clipPoints(7) = llpnt(1)
' clipPoints(8) = llpnt(0): clipPoints(9) = llpnt(1)
'Clip boundary = user defined size
Dim Bndsize As Integer
Bndsize = ThisDrawing.Utility.GetReal("What size boundary would you like?: ")
clipPoints(0) = mdpnt(0) - Bndsize / 2: clipPoints(1) = mdpnt(1) - Bndsize / 2
clipPoints(2) = mdpnt(0) - Bndsize / 2: clipPoints(3) = mdpnt(1) + Bndsize / 2
clipPoints(4) = mdpnt(0) + Bndsize / 2: clipPoints(5) = mdpnt(1) + Bndsize / 2
clipPoints(6) = mdpnt(0) + Bndsize / 2: clipPoints(7) = mdpnt(1) - Bndsize / 2
clipPoints(8) = mdpnt(0) - Bndsize / 2: clipPoints(9) = mdpnt(1) + -Bndsize / 2
'Clip the image
RastImg.ClipBoundary clipPoints
'Enable the display of the clip
RastImg.ClippingEnabled = True
ThisDrawing.Regen acActiveViewport
End Sub
-
guess you beat me to it, Ill just chec thru yours
-
the only thing I see, which has no effect on the running of the code b/c order of operation is correct is
clipPoints(0) = mdpnt(0) - Bndsize / 2While it is correct, I would personally use () to make it clearer to someone reading it that Bndsize/2 comes before MP-
-
clipPoints(0) = mdpnt(0) - (Bndsize / 2)
-
The only thing I noticed is that it did not regenerate on bigger sizes; not sure why.
what if you place a breakpoint, does it stop there?
-
You might try thowing a RastImg.Update in there, not sure if it will help.
-
Haven't tried that but I certainly can
Here you go sir
clipPoints(0) = mdpnt(0) - (Bndsize / 2): clipPoints(1) = mdpnt(1) - (Bndsize / 2)
clipPoints(2) = mdpnt(0) - (Bndsize / 2): clipPoints(3) = mdpnt(1) + (Bndsize / 2)
clipPoints(4) = mdpnt(0) + (Bndsize / 2): clipPoints(5) = mdpnt(1) + (Bndsize / 2)
clipPoints(6) = mdpnt(0) + (Bndsize / 2): clipPoints(7) = mdpnt(1) - (Bndsize / 2)
clipPoints(8) = mdpnt(0) - (Bndsize / 2): clipPoints(9) = mdpnt(1) + -(Bndsize / 2)
-
Bob
RastImg.Update
Did not help
Mark
-
You're gonna make me open autocad, aren't you?
-
LOL
No, I'm sure not
I think we have worked you enough today LOL
Tomorrow is a new day! :-)
Mark
-
Actually
I opened ACAD LOL
I think (not sure) it has something to do with the getreal method but I am not sure.
I tried Declaring the variable as Integer then I realized that is only good if where want a whole number.
Then I tried as Variant and it works sometimes but not others.
So, I'm sure we will get it
Mark
-
The opening acad wasn't a knock on you. I'm working in Revit at the moment so I've just been guessing. I'm 98% sure that getreal returns a double.
-
yes
-
GetInteger gets an Integer whilst GetReal gets a Double
-
Then I tried as Variant and it works sometimes but not others.
I think it might be here Dim Bndsize As Integer
Bndsize = ThisDrawing.Utility.GetReal("What size boundary would you like?: ")You are declaring an Integer, but asking for a Double
I would change it to Dim BndSize as Double
-
Hey Bob
It wasn't taken as such :-)
I thought you were on your way home but still curious.
I know I have closed down, went to the men's room, got all my stuff together and said, hummmm, let me turn CAD on real quick; then 2 hours went by. So, once I shutdown; I really do try to "shutdown" :-)
Revit huh? That sounds really cool! So you do 3D Modeling then?
CM, thank you for that little tip, I will use getreal and try using Double as my data type.
Do you think that is what is causing this method
clipPoints(0) = mdpnt(0) - (Bndsize / 2): clipPoints(1) = mdpnt(1) - (Bndsize / 2)
clipPoints(2) = mdpnt(0) - (Bndsize / 2): clipPoints(3) = mdpnt(1) + (Bndsize / 2)
clipPoints(4) = mdpnt(0) + (Bndsize / 2): clipPoints(5) = mdpnt(1) + (Bndsize / 2)
clipPoints(6) = mdpnt(0) + (Bndsize / 2): clipPoints(7) = mdpnt(1) - (Bndsize / 2)
clipPoints(8) = mdpnt(0) - (Bndsize / 2): clipPoints(9) = mdpnt(1) + -(Bndsize / 2)
To work sometimes and not others?
Have you tried this method yet?
Mark
-
Yes sir (CM) my friend,
You nailed it! It seems to be wroking perfect now
We want Bndsize as Double
Dim Bndsize As Double
Bndsize = ThisDrawing.Utility.GetReal("What size boundary would you like?: ")
Bob, that method was a really cool idea!
Mark
-
To work sometimes and not others?
Mark
Yes, but you know that b/c you just posted faster than me. By having it as integer you had a 50% chance it would round off to the correct number, and 50% it didn't. By using Double, you are getting the correct number and processing it from there
-
Yep
Very cool indeed!
So, you guys rastered out or what?
Mark
-
trying to get more work done today. Where are you at now in terms of things working/not working?
-
Bob! You mean you don't work for us? LOL J/K
Everything as far as I can see is working A OK.
Very nice indeed.
I am really impressed by the dynamic boundary creations.
This discussion has really helped me learn more about getting, using and manipulating points.
And creating boundaries of course.
Now, I am thinking about putting the raster into a selection set in case I need to do something with after the user exits the sub or whatever.
After that, I think I will leave good enough alone.
Mark
-
Hey guys,
Let me throw this out there.
I noticed if I pick 2 points on the raster and the slection is less then 5' x 5' then only an image frame will display.
I know, "NO S**T, right?
Well, I am not sure that the user would understand why this is happening; so I am wondering if we can do something that will say, if picked boundary is less then 5' x 5' or in Bob's other code where the user types in the boundary size, can we catch that error?
I don't think we can say:
Select Case ClipPoints
etc. etc.
End Select
However I could be wrong
THanks
Mark
Thanks
Mark
-
I am going to attempt to answer my own question here:
"After" or "when" the raster is inserted; I believe we can get the height and width of the raster.
After we have that, we can write some code that will say: If the boundary is > then the height and width of the inserted raster, then
Handle Error
-
ACtually, I noticed an error is not returned, you are just left with an imageframe with none of the image showing, so we would probably need to return a message to the user:
Msgbox " The specified boundary is too large etc. etc."
Mark
-
I would say post the image you are working with so we can all play along
-
You're a trooper my friend :)
We'll do
-
Just for the sake of completion, maybe the image and the dwg. Oh, and the most upest to date code
-
Hey guys,
I am posting the lastest code, but in all due respect; wouldn't the same errors occur on your machines once you have the latest code?
If you really want to simulate what I am doing, all you need to do is draw a 5' X 5' rectangle in paperspace; then point the path (imgpath) in the code to a known raster on your machine and we should all then be on the same page.
Actually, I just changed the variable imgpath = ThisDrawing.Path & "\"
So now you can just place any raster in the same directory as your .dwg file and it should be found.
Variable imgname needs to equal your file name
Also, I think the best example to use is the first one under Dynamic; it is the only one "not" commented out
Thanks,
Mark
Public Sub InstRast()
Dim Imgpth As String
Dim Imgname As String
Dim InsertPnt(0 To 2) As Double, scalefactor As Double, RotAngle As Double
ThisDrawing.ActiveSpace = acPaperSpace
Imgpth = ThisDrawing.Path & "\"
Imgname = "FtWashington600.tif"
InsertPnt(0) = 0#: InsertPnt(1) = 0#: InsertPnt(2) = 0#
scalefactor = 1
RotAngle = 0
On Error GoTo Errorhandler
Set RastImg = ThisDrawing.PaperSpace.AddRaster(Imgpth & Imgname, InsertPnt, scalefactor, RotAngle)
RastImg.Name = Imgname
RastImg.Name = Left(Imgname, Len(Imgname) - 4)
RastImg.scalefactor = 12
'Move Points
Dim MPointN(0 To 2) As Double 'Negative
Dim MPointP(0 To 2) As Double 'Positive
MPointN(0) = 8: MPointN(1) = 0: MPointN(2) = 0
MPointP(0) = 0: MPointP(1) = 0: MPointP(2) = 0
'Move Raster
RastImg.Move MPointN, MPointP
Dim llpnt As Variant 'lower left point
Dim urpnt As Variant 'upper right point
Dim mdpnt(0 To 2) As Double
Dim ClipPoints(0 To 9) As Double
With ThisDrawing.Utility
llpnt = .GetPoint(, vbCrLf & "Select Lower Left Point: ")
urpnt = .GetPoint(, vbCrLf & "Select Upper Right Point: ")
End With
mdpnt(0) = (llpnt(0) + urpnt(0)) / 2 'Midpoint (X) = (The far left picked point + the far right picked point) / 2
mdpnt(1) = (llpnt(1) + urpnt(1)) / 2 'Midpoint (Y) = (The far bottom picked point + the far top picked point) / 2
mdpnt(2) = 0
'FINITE
'Create a 5 x 5 clip boundary
' clipPoints(0) = 0: clipPoints(1) = 0
' clipPoints(2) = 0: clipPoints(3) = 5
' clipPoints(4) = 5: clipPoints(5) = 5
' clipPoints(6) = 5: clipPoints(7) = 0
' clipPoints(8) = 0: clipPoints(9) = 0
'Clip boundary = 2.5 from the mdpnt of the raster's picked points to the boundary coords.
'ClipPoints(0) = mdpnt(0) - 2.5: ClipPoints(1) = mdpnt(1) - 2.5
'ClipPoints(2) = mdpnt(0) - 2.5: ClipPoints(3) = mdpnt(1) + 2.5
'ClipPoints(4) = mdpnt(0) + 2.5: ClipPoints(5) = mdpnt(1) + 2.5
'ClipPoints(6) = mdpnt(0) + 2.5: ClipPoints(7) = mdpnt(1) - 2.5
'ClipPoints(8) = mdpnt(0) - 2.5: ClipPoints(9) = mdpnt(1) + -2.5
'DYNAMIC
'Clip boundary = picked points (llpnt and urpnt)
ClipPoints(0) = llpnt(0): ClipPoints(1) = llpnt(1)
ClipPoints(2) = llpnt(0): ClipPoints(3) = urpnt(1)
ClipPoints(4) = urpnt(0): ClipPoints(5) = urpnt(1)
ClipPoints(6) = urpnt(0): ClipPoints(7) = llpnt(1)
ClipPoints(8) = llpnt(0): ClipPoints(9) = llpnt(1)
'Clip boundary = user defined (uniform) size
' Dim Bndsize As Double
' Bndsize = ThisDrawing.Utility.GetReal("What size boundary would you like?: ")
'
' ClipPoints(0) = mdpnt(0) - (Bndsize / 2): ClipPoints(1) = mdpnt(1) - (Bndsize / 2)
' ClipPoints(2) = mdpnt(0) - (Bndsize / 2): ClipPoints(3) = mdpnt(1) + (Bndsize / 2)
' ClipPoints(4) = mdpnt(0) + (Bndsize / 2): ClipPoints(5) = mdpnt(1) + (Bndsize / 2)
' ClipPoints(6) = mdpnt(0) + (Bndsize / 2): ClipPoints(7) = mdpnt(1) - (Bndsize / 2)
' ClipPoints(8) = mdpnt(0) - (Bndsize / 2): ClipPoints(9) = mdpnt(1) + -(Bndsize / 2)
'Clip the image
RastImg.ClipBoundary ClipPoints
'Enable the display of the clip
RastImg.ClippingEnabled = True
'Create Selection Set for Raster
Dim Sset As AcadSelectionSet
Set Sset = ThisDrawing.SelectionSets.Add("Image")
Sset.Select acSelectionSetLast
Debug.Print "Selection Set " & "("; Sset.Name; ")" & " was created"
With Sset
End With
ThisDrawing.SelectionSets.Item("Image").Delete
Errorhandler:
If Err.Description = "File access error" Then
If MsgBox("Can not find image file") Then
Exit Sub
End If
End If
End Sub
-
Hey guys,
I am posting the lastest code, but in all due respect; wouldn't the same errors occur on your machines once you have the latest code?
Yes, but its much easier to trouble shoot when we can "SEE" the error instead of relying on you to explain it. (NoOffense but a pic is worth....)
-
ok, so far I ahve made 2 changes. 1-I hardpathed my imgpath var to c:\ where I put image, No big deal. 2-I am dropping line 1 of
RastImg.Name = Imgname
RastImg.Name = Left(Imgname, Len(Imgname) - 4)
to just have the second line as the first is not helpful
-
I understand CM but there is no error being generated.
If you pick off the raster, the imageframe will still appear but no image will be visible "unless" you drag the imageframe manually.
Do me a favor CM; try to pick 2 points on your raster; make sure one point is off the raster and please tell me if the same thing happens to you?
It could possibly be a setting that I am not aware of
Thank you,
Mark
-
Good catch
I probably only need the second one correct?
I def. need the second one as I am trimming off the .tif extension
Mark
-
OK, so if the image is inserted at a scale of 1 the corner to corner dist is
Delta X = 7.6500, Delta Y = 11.6033
Why are we inserting it at -8,0,0?
Scaled up 12 times yields
Delta X = 91.8000, Delta Y = 139.2400 for distances
So is this image in Feet or Inches? Looks like it should be feet, but we scaled it up so Im not sure now
-
This also goes back to our early discussion as to why ACAD gives rasters a unique/weird name on insert using VBA
When you manually insert a raster, it will adopt the default file name but you can then change the raster name after it is inserted.
Same with xrefs
This is why we "need" to say
RastImg.Name = Imgname
or
RastImg.Name = Left(Imgname, Len(Imgname) - 4)
Mark
-
The image is clipped on what ever points we pick, even if off the page. what you need to do is check the 2 points and make sure they are B/T ins and UR of image
-
This also goes back to our early discussion as to why ACAD gives rasters a unique/weird name on insert using VBA
When you manually insert a raster, it will adopt the default file name but you can then change the raster name after it is inserted.
Same with xrefs
This is why we "need" to say
RastImg.Name = Imgname
or
RastImg.Name = Left(Imgname, Len(Imgname) - 4)
Mark
yes, but not both. Just the second is needed
-
Do a IF LLpnt(0) > ImageIns AND LLpnt(0)< UR(0) then
If LL(1)>ImgIns(1) and LL(1)<UR(1) then
proceed to second point
-
I moved it over 8' to get it off of 0,0 and to the side of the title block.
After the user does their thing, they can move it to the nec. (5' x 5' square) spot on the tblock.
Once we are certain where this rectangle will permanently reside, then I will make the adjustments.
As far as the scale; it is what my boss asked me to do, so I did it.
I believe it is to bring the image up to feet.
We do work in feet as we are a Civil Firm
Mark
-
That will help you guarentee the picked points are "on" the raster, not off the pic
-
Just out of curiousity, what are the dims of x and y on your image before its clipped? is it close to the numbers I posted above? I just measured the dist between 2 streets, and its like 2 units, so are we dealing with a scaled up scaled raster?
-
The grid measures ~10x13
-
CM
I am not sure where you are going with that method?
I like the idea of grabbing the height and width of the raster on insert, then we can say:
If llpnt + urpnt > then The height + width of the inserted raster x The scale
Then What do you think?
End If
Mark
-
Ok the raster that I e-mailed you is the unscaled version.
Yes we are scaling that raster up by 12
Mark
I am also trying to fugure something out in Excel VBA AHHHHHHHHHHHH
LOL
Mark
-
Oh yes,
You have the exact same distance on the raster that I get
Mark
-
So basically, what I see is that we need to make sure LL and UR points are ON the raster, regardless of the size of the clip window, and if not, reprompt for new points. I'll try to work something up for that tomorrow
-
Yes sir
Actually the user needs to make sure they pick on the raster but yes, you got it.
We need to account for the fact that they did not.
It sounds like you are on the right track exactly.
There is no hurry my friend. It is just an added bonus, nice to have type thing
Mark
-
ML, give this a shot, pick everywhere you can think of. The msgboxs will come out of the finished code, just there for testing purposes. Also, you will need to edit the image name and path b/c I hardcoded mine
Option Explicit
Public Sub InstRast()
Dim Imgpth As String
Dim Imgname As String
Dim InsertPnt(0 To 2) As Double, scalefactor As Double, RotAngle As Double
Dim RastImg As AcadRasterImage
ThisDrawing.ActiveSpace = acPaperSpace
[color=red] Imgpth = "c:\"
Imgname = "FtWashington600.tif"[/color]
InsertPnt(0) = 0#: InsertPnt(1) = 0#: InsertPnt(2) = 0#
scalefactor = 1
RotAngle = 0
On Error GoTo Errorhandler
Set RastImg = ThisDrawing.PaperSpace.AddRaster(Imgpth & Imgname, InsertPnt, scalefactor, RotAngle)
'RastImg.Name = Imgname
RastImg.Name = Left(Imgname, Len(Imgname) - 4)
'RastImg.scalefactor = 1
RastImg.scalefactor = 12
'Move Points
Dim MPointN(0 To 2) As Double 'Negative
Dim MPointP(0 To 2) As Double 'Positive
MPointN(0) = 8: MPointN(1) = 0: MPointN(2) = 0
MPointP(0) = 0: MPointP(1) = 0: MPointP(2) = 0
'Move Raster
RastImg.Move MPointN, MPointP
[color=red]Dim ImgUR(2) As Double
ImgUR(0) = RastImg.Origin(0) + RastImg.ImageWidth: ImgUR(1) = RastImg.Origin(1) + RastImg.ImageHeight: ImgUR(2) = 0[/color]
Dim llpnt As Variant 'lower left point
Dim urpnt As Variant 'upper right point
Dim mdpnt(0 To 2) As Double
Dim ClipPoints(0 To 9) As Double
PickPoints:
With ThisDrawing.Utility
llpnt = .GetPoint(, vbCrLf & "Select Lower Left Point: ")
urpnt = .GetPoint(, vbCrLf & "Select Upper Right Point: ")
End With
[color=red] If llpnt(0) > RastImg.Origin(0) And llpnt(0) < ImgUR(0) Then
If llpnt(1) > RastImg.Origin(1) And llpnt(1) < ImgUR(1) Then
If urpnt(0) > RastImg.Origin(0) And urpnt(0) < ImgUR(0) Then
If urpnt(1) > RastImg.Origin(1) And urpnt(1) < ImgUR(1) Then
MsgBox "Good picks"
Else
MsgBox "Please repick inside Raster IMage"
GoTo PickPoints
End If
Else
MsgBox "Please repick inside Raster IMage"
GoTo PickPoints
End If
Else
MsgBox "Please repick inside Raster IMage"
GoTo PickPoints
End If
Else
MsgBox "Please repick inside Raster IMage"
GoTo PickPoints
End If
[/color]
mdpnt(0) = (llpnt(0) + urpnt(0)) / 2 'Midpoint (X) = (The far left picked point + the far right picked point) / 2
mdpnt(1) = (llpnt(1) + urpnt(1)) / 2 'Midpoint (Y) = (The far bottom picked point + the far top picked point) / 2
mdpnt(2) = 0
'FINITE
'Create a 5 x 5 clip boundary
' clipPoints(0) = 0: clipPoints(1) = 0
' clipPoints(2) = 0: clipPoints(3) = 5
' clipPoints(4) = 5: clipPoints(5) = 5
' clipPoints(6) = 5: clipPoints(7) = 0
' clipPoints(8) = 0: clipPoints(9) = 0
'Clip boundary = 2.5 from the mdpnt of the raster's picked points to the boundary coords.
'ClipPoints(0) = mdpnt(0) - 2.5: ClipPoints(1) = mdpnt(1) - 2.5
'ClipPoints(2) = mdpnt(0) - 2.5: ClipPoints(3) = mdpnt(1) + 2.5
'ClipPoints(4) = mdpnt(0) + 2.5: ClipPoints(5) = mdpnt(1) + 2.5
'ClipPoints(6) = mdpnt(0) + 2.5: ClipPoints(7) = mdpnt(1) - 2.5
'ClipPoints(8) = mdpnt(0) - 2.5: ClipPoints(9) = mdpnt(1) + -2.5
'DYNAMIC
'Clip boundary = picked points (llpnt and urpnt)
ClipPoints(0) = llpnt(0): ClipPoints(1) = llpnt(1)
ClipPoints(2) = llpnt(0): ClipPoints(3) = urpnt(1)
ClipPoints(4) = urpnt(0): ClipPoints(5) = urpnt(1)
ClipPoints(6) = urpnt(0): ClipPoints(7) = llpnt(1)
ClipPoints(8) = llpnt(0): ClipPoints(9) = llpnt(1)
'Clip boundary = user defined (uniform) size
' Dim Bndsize As Double
' Bndsize = ThisDrawing.Utility.GetReal("What size boundary would you like?: ")
'
' ClipPoints(0) = mdpnt(0) - (Bndsize / 2): ClipPoints(1) = mdpnt(1) - (Bndsize / 2)
' ClipPoints(2) = mdpnt(0) - (Bndsize / 2): ClipPoints(3) = mdpnt(1) + (Bndsize / 2)
' ClipPoints(4) = mdpnt(0) + (Bndsize / 2): ClipPoints(5) = mdpnt(1) + (Bndsize / 2)
' ClipPoints(6) = mdpnt(0) + (Bndsize / 2): ClipPoints(7) = mdpnt(1) - (Bndsize / 2)
' ClipPoints(8) = mdpnt(0) - (Bndsize / 2): ClipPoints(9) = mdpnt(1) + -(Bndsize / 2)
'Clip the image
RastImg.ClipBoundary ClipPoints
'Enable the display of the clip
RastImg.ClippingEnabled = True
'Create Selection Set for Raster
Dim Sset As AcadSelectionSet
Set Sset = ThisDrawing.SelectionSets.Add("Image")
Sset.Select acSelectionSetLast
Debug.Print "Selection Set " & "("; Sset.Name; ")" & " was created"
With Sset
End With
ThisDrawing.SelectionSets.Item("Image").Delete
Errorhandler:
If Err.Description = "File access error" Then
If MsgBox("Can not find image file") Then
Exit Sub
End If
End If
End Sub
-
Also you will need to remove the COLOR code from above to make it work. I highlighted (DUH) the parts I changed
-
This brings up a good question for you guys, how to NOT use the GoTo as I know its the bain of good programming. I have seen a way to not use it, but I just cant remember where it was. Maybe 808 remembers, cuz I think he gave it to me
-
This brings up a good question for you guys, how to NOT use the GoTo as I know its the bain of good programming. I have seen a way to not use it, but I just cant remember where it was. Maybe 808 remembers, cuz I think he gave it to me
I vaguely remember what you're talking about but not in detail. I'll try to remember. Pretty crazy busy this week though.
-
I'm not so sure, even though I would never claim to be a great programmer (or even formally trained) by any stretch however I have been using Go to for a longtime and it has always been a reliable source for me.
I did notice that you are using it 4 times, in which case I may consider having a separate Sub for The Go to which is only the Pickpoints in this case; so, do we, don't we?
Is calling a sub 4 possible times any better or different then using Go to 4 times ????
I just tried your code CM, it seems to be working real well; I do need to put it through some more tests.
That is cool that there is a Raster.origin method
So far it looks good
Mark
-
CM
The color coding did not effect the code at all; nor should it.
When copying and pasting, we are only grabbing the text, not the text formatting.
Therefore what you did is fine :)
Mark
-
I have an easy answer to The Goto question;
It is called Google :)
Let me see what I can find
Mark
-
CM
Good Job Man! It looks like it is working really well.
I might clean it up a bit and do a few things but you did a nice job.
It is definitely working as i hoped, thank you!
Oh, here is some bonus code if you want it?
I like to see these little things, it helps me to know what is going on.
'These coords are prior to picking your points
Debug.Print "Raster Origin X = " & RastImg.Origin(0)
Debug.Print "Raster Origin Y = " & RastImg.Origin(1)
Debug.Print "Raster Width = " & RastImg.ImageWidth
Debug.Print "Raster Height = " & RastImg.ImageHeight
I placed it under your
Dim ImgUR(2) As Double
ImgUR(0) = RastImg.Origin(0) + RastImg.ImageWidth: ImgUR(1) = RastImg.Origin(1) + RastImg.ImageHeight: ImgUR(2) = 0
code
Mark
-
I did notice that you are using it 4 times, in which case I may consider having a separate Sub for The Go to which is only the Pickpoints in this case; so, do we, don't we? Is calling a sub 4 possible times any better or different then using Go to 4 times ????
we are not calling it 4 times, only once IF one of the X or Y values falls outside the image boundary
-
Yes, that is true
Sorry
Did you figure out the alternative to Go To?
We could put
With ThisDrawing.Utility
llpnt = .GetPoint(, vbCrLf & "Select Lower Left Point: ")
urpnt = .GetPoint(, vbCrLf & "Select Upper Right Point: ")
End With
in place of each Go To but does that make anymore sense?
Maybe?
Not sure
Mark
-
we cant put that in instead of the goto b/c if that second set of picks were also bogus, we would be past the checking of coords, and it wouldn't know it
-
I'm sorry
I have been trying to study your code but I keep getting distracted :)
Let me take a closer look
Mark
-
OK, I just put all of about 30 seconds thought into this but what about somefin like
[psueudocode]
do until pntsValid
With ThisDrawing.Utility
llpnt = .GetPoint(, vbCrLf & "Select Lower Left Point: ")
urpnt = .GetPoint(, vbCrLf & "Select Upper Right Point: ")
End With
If llpnt(0) > RastImg.Origin(0) And llpnt(0) < ImgUR(0) Then
If llpnt(1) > RastImg.Origin(1) And llpnt(1) < ImgUR(1) Then
If urpnt(0) > RastImg.Origin(0) And urpnt(0) < ImgUR(0) Then
If urpnt(1) > RastImg.Origin(1) And urpnt(1) < ImgUR(1) Then
pntsvalid = true
Else
ThisDrawing.utility.prompt "At least one of those points was teh suck." & vbcrlf
end if
end if
end if
end if
loop[/psuedocode]
-
I like the idea, let me code that up
-
This is what I came up with. Comments to improve it welcome
PickPoints:
' With ThisDrawing.Utility
' llpnt = .GetPoint(, vbCrLf & "Select Lower Left Point: ")
' urpnt = .GetPoint(, vbCrLf & "Select Upper Right Point: ")
' End With
Dim Check As Boolean
Check = False
Do While Check = False
With ThisDrawing.Utility
llpnt = .GetPoint(, vbCrLf & "Select Lower Left Point: ")
urpnt = .GetPoint(, vbCrLf & "Select Upper Right Point: ")
End With
If llpnt(0) > RastImg.Origin(0) And llpnt(0) < ImgUR(0) Then
If llpnt(1) > RastImg.Origin(1) And llpnt(1) < ImgUR(1) Then
If urpnt(0) > RastImg.Origin(0) And urpnt(0) < ImgUR(0) Then
If urpnt(1) > RastImg.Origin(1) And urpnt(1) < ImgUR(1) Then
Check = True
Else
MsgBox "Please repick inside Raster IMage"
Check = False
End If
Else
MsgBox "Please repick inside Raster IMage"
Check = False
End If
Else
MsgBox "Please repick inside Raster IMage"
Check = False
End If
Else
MsgBox "Please repick inside Raster IMage"
Check = False
End If
Loop
-
I left the PickPoints: and the old pick points there while testing. Those can be removed from final code
-
CM
It is prompting me twice for my points with The Boolean Method
Mark
-
CM,
Check this out
I modified your code slightly
Hope you don't mind
It makes a lot more sense to me now
Mark
If llpnt(0) > RastImg.Origin(0) And llpnt(0) < RastImg.ImageWidth Then
If llpnt(1) > RastImg.Origin(1) And llpnt(1) < RastImg.ImageHeight Then
If urpnt(0) > RastImg.Origin(0) And urpnt(0) < RastImg.ImageWidth Then
If urpnt(1) > RastImg.Origin(1) And urpnt(1) < RastImg.ImageHeight Then
MsgBox "Good picks"
Else
MsgBox "Please repick inside Raster IMage"
GoTo PickPoints
End If
Else
MsgBox "Please repick inside Raster IMage"
GoTo PickPoints
End If
Else
MsgBox "Please repick inside Raster IMage"
GoTo PickPoints
End If
Else
MsgBox "Please repick inside Raster IMage"
GoTo PickPoints
End If
-
This gets rid of the goto s
Option Explicit
Public Sub InstRast()
Dim Imgpth As String
Dim Imgname As String
Dim InsertPnt(0 To 2) As Double, scalefactor As Double, RotAngle As Double
Dim RastImg As AcadRasterImage
ThisDrawing.ActiveSpace = acPaperSpace
Imgpth = "c:\"
Imgname = "FtWashington600.tif"
InsertPnt(0) = 0#: InsertPnt(1) = 0#: InsertPnt(2) = 0#
scalefactor = 1
RotAngle = 0
On Error GoTo Errorhandler
Set RastImg = ThisDrawing.PaperSpace.AddRaster(Imgpth & Imgname, InsertPnt, scalefactor, RotAngle)
RastImg.Name = Left(Imgname, Len(Imgname) - 4)
RastImg.scalefactor = 12
'Move Points
Dim MPointN(0 To 2) As Double 'Negative
Dim MPointP(0 To 2) As Double 'Positive
MPointN(0) = 8: MPointN(1) = 0: MPointN(2) = 0
MPointP(0) = 0: MPointP(1) = 0: MPointP(2) = 0
'Move Raster
RastImg.Move MPointN, MPointP
Dim ImgUR(2) As Double
ImgUR(0) = RastImg.Origin(0) + RastImg.ImageWidth: ImgUR(1) = RastImg.Origin(1) + RastImg.ImageHeight: ImgUR(2) = 0
Dim llpnt As Variant 'lower left point
Dim urpnt As Variant 'upper right point
Dim mdpnt(0 To 2) As Double
Dim ClipPoints(0 To 9) As Double
Dim Check As Boolean
Check = False
Do While Check = False
llpnt = ThisDrawing.Utility.GetPoint(, vbCrLf & "Select Lower Left Point: ")
urpnt = ThisDrawing.Utility.GetCorner(llpnt, vbCrLf & "Select Upper Right Point: ")
If llpnt(0) > RastImg.Origin(0) And llpnt(0) < ImgUR(0) Then
If llpnt(1) > RastImg.Origin(1) And llpnt(1) < ImgUR(1) Then
If urpnt(0) > RastImg.Origin(0) And urpnt(0) < ImgUR(0) Then
If urpnt(1) > RastImg.Origin(1) And urpnt(1) < ImgUR(1) Then
Check = True
Else
MsgBox "Please repick inside Raster IMage"
Check = False
End If
Else
MsgBox "Please repick inside Raster IMage"
Check = False
End If
Else
MsgBox "Please repick inside Raster IMage"
Check = False
End If
Else
MsgBox "Please repick inside Raster IMage"
Check = False
End If
Loop
mdpnt(0) = (llpnt(0) + urpnt(0)) / 2 'Midpoint (X) = (The far left picked point + the far right picked point) / 2
mdpnt(1) = (llpnt(1) + urpnt(1)) / 2 'Midpoint (Y) = (The far bottom picked point + the far top picked point) / 2
mdpnt(2) = 0
'FINITE
'Create a 5 x 5 clip boundary
' clipPoints(0) = 0: clipPoints(1) = 0
' clipPoints(2) = 0: clipPoints(3) = 5
' clipPoints(4) = 5: clipPoints(5) = 5
' clipPoints(6) = 5: clipPoints(7) = 0
' clipPoints(8) = 0: clipPoints(9) = 0
'Clip boundary = 2.5 from the mdpnt of the raster's picked points to the boundary coords.
'ClipPoints(0) = mdpnt(0) - 2.5: ClipPoints(1) = mdpnt(1) - 2.5
'ClipPoints(2) = mdpnt(0) - 2.5: ClipPoints(3) = mdpnt(1) + 2.5
'ClipPoints(4) = mdpnt(0) + 2.5: ClipPoints(5) = mdpnt(1) + 2.5
'ClipPoints(6) = mdpnt(0) + 2.5: ClipPoints(7) = mdpnt(1) - 2.5
'ClipPoints(8) = mdpnt(0) - 2.5: ClipPoints(9) = mdpnt(1) + -2.5
'DYNAMIC
'Clip boundary = picked points (llpnt and urpnt)
ClipPoints(0) = llpnt(0): ClipPoints(1) = llpnt(1)
ClipPoints(2) = llpnt(0): ClipPoints(3) = urpnt(1)
ClipPoints(4) = urpnt(0): ClipPoints(5) = urpnt(1)
ClipPoints(6) = urpnt(0): ClipPoints(7) = llpnt(1)
ClipPoints(8) = llpnt(0): ClipPoints(9) = llpnt(1)
'Clip boundary = user defined (uniform) size
' Dim Bndsize As Double
' Bndsize = ThisDrawing.Utility.GetReal("What size boundary would you like?: ")
'
' ClipPoints(0) = mdpnt(0) - (Bndsize / 2): ClipPoints(1) = mdpnt(1) - (Bndsize / 2)
' ClipPoints(2) = mdpnt(0) - (Bndsize / 2): ClipPoints(3) = mdpnt(1) + (Bndsize / 2)
' ClipPoints(4) = mdpnt(0) + (Bndsize / 2): ClipPoints(5) = mdpnt(1) + (Bndsize / 2)
' ClipPoints(6) = mdpnt(0) + (Bndsize / 2): ClipPoints(7) = mdpnt(1) - (Bndsize / 2)
' ClipPoints(8) = mdpnt(0) - (Bndsize / 2): ClipPoints(9) = mdpnt(1) + -(Bndsize / 2)
'Clip the image
RastImg.ClipBoundary ClipPoints
'Enable the display of the clip
RastImg.ClippingEnabled = True
'Create Selection Set for Raster
Dim Sset As AcadSelectionSet
Set Sset = ThisDrawing.SelectionSets.Add("Image")
Sset.Select acSelectionSetLast
Debug.Print "Selection Set " & "("; Sset.Name; ")" & " was created"
With Sset
End With
ThisDrawing.SelectionSets.Item("Image").Delete
Errorhandler:
If Err.Description = "File access error" Then
If MsgBox("Can not find image file") Then
Exit Sub
End If
End If
End Sub
-
Twice? very interesting. I just tested and I can do 1 set of picks if I play by the rules. Of course if I pick anywhere outside the boundary, it will prompt me til I make 2 good picks inside the boundary
-
If llpnt(0) > RastImg.Origin(0) And llpnt(0) < RastImg.ImageWidth Then
If llpnt(1) > RastImg.Origin(1) And llpnt(1) < RastImg.ImageHeight Then
llpnt(1) < RastImg.ImageHeight is only comparing the Y of LLpnt against the height of the image. Assume image was 10x10 and origin was 60,60,0?
your LL of image is 60,60,0 and UR of image is 70,70,0 right? now if you test a point picked at 65,65,0, your test llpnt(1) < RastImg.ImageHeight
will fail b/c 65 is not < 10
-
Basically, if your image is ALWAYS inserted at 0,0,0 the code will work b/c image.width and the X value of image.width are equal. If your image is ever moved from 0,0,0 then you will need to add Image.width + Image.Origin(X)
-
If you copy the code from 4 posts up, and change the hard coded paths only, does it work or crash? If it crashes, can you F8 thru it and tell me where it crashes.
-
I also made a few more changes highlighted below
Option Explicit
Public Sub InstRast()
Dim Imgpth As String
Dim Imgname As String
Dim InsertPnt(0 To 2) As Double, scalefactor As Double, RotAngle As Double
Dim RastImg As AcadRasterImage
ThisDrawing.ActiveSpace = acPaperSpace
Imgpth = "c:\"
Imgname = "FtWashington600.tif"
InsertPnt(0) = 0#: InsertPnt(1) = 0#: InsertPnt(2) = 0#
scalefactor = 1
RotAngle = 0
On Error GoTo Errorhandler
Set RastImg = ThisDrawing.PaperSpace.AddRaster(Imgpth & Imgname, InsertPnt, scalefactor, RotAngle)
RastImg.Name = Left(Imgname, Len(Imgname) - 4)
RastImg.scalefactor = 12
'Move Points
Dim MPointN(0 To 2) As Double 'Negative
Dim MPointP(0 To 2) As Double 'Positive
MPointN(0) = 8: MPointN(1) = 0: MPointN(2) = 0
MPointP(0) = 0: MPointP(1) = 0: MPointP(2) = 0
'Move Raster
RastImg.Move MPointN, MPointP
Dim ImgUR(2) As Double
ImgUR(0) = RastImg.Origin(0) + RastImg.ImageWidth: ImgUR(1) = RastImg.Origin(1) + RastImg.ImageHeight: ImgUR(2) = 0
Dim llpnt As Variant 'lower left point
Dim urpnt As Variant 'upper right point
Dim mdpnt(0 To 2) As Double
Dim ClipPoints(0 To 9) As Double
Dim Check As Boolean
Check = False
Do While Check = False
[color=red] llpnt = ThisDrawing.Utility.GetPoint(, vbCrLf & "Select Lower Left Point: ")
urpnt = ThisDrawing.Utility.GetCorner(llpnt, vbCrLf & "Select Upper Right Point: ")[/color]
If llpnt(0) > RastImg.Origin(0) And llpnt(0) < ImgUR(0) Then
If llpnt(1) > RastImg.Origin(1) And llpnt(1) < ImgUR(1) Then
If urpnt(0) > RastImg.Origin(0) And urpnt(0) < ImgUR(0) Then
If urpnt(1) > RastImg.Origin(1) And urpnt(1) < ImgUR(1) Then
Check = True
Else
MsgBox "Please repick inside Raster IMage"
Check = False
End If
Else
MsgBox "Please repick inside Raster IMage"
Check = False
End If
Else
MsgBox "Please repick inside Raster IMage"
Check = False
End If
Else
MsgBox "Please repick inside Raster IMage"
Check = False
End If
Loop
mdpnt(0) = (llpnt(0) + urpnt(0)) / 2 'Midpoint (X) = (The far left picked point + the far right picked point) / 2
mdpnt(1) = (llpnt(1) + urpnt(1)) / 2 'Midpoint (Y) = (The far bottom picked point + the far top picked point) / 2
mdpnt(2) = 0
'FINITE
'Create a 5 x 5 clip boundary
' clipPoints(0) = 0: clipPoints(1) = 0
' clipPoints(2) = 0: clipPoints(3) = 5
' clipPoints(4) = 5: clipPoints(5) = 5
' clipPoints(6) = 5: clipPoints(7) = 0
' clipPoints(8) = 0: clipPoints(9) = 0
'Clip boundary = 2.5 from the mdpnt of the raster's picked points to the boundary coords.
'ClipPoints(0) = mdpnt(0) - 2.5: ClipPoints(1) = mdpnt(1) - 2.5
'ClipPoints(2) = mdpnt(0) - 2.5: ClipPoints(3) = mdpnt(1) + 2.5
'ClipPoints(4) = mdpnt(0) + 2.5: ClipPoints(5) = mdpnt(1) + 2.5
'ClipPoints(6) = mdpnt(0) + 2.5: ClipPoints(7) = mdpnt(1) - 2.5
'ClipPoints(8) = mdpnt(0) - 2.5: ClipPoints(9) = mdpnt(1) + -2.5
'DYNAMIC
'Clip boundary = picked points (llpnt and urpnt)
ClipPoints(0) = llpnt(0): ClipPoints(1) = llpnt(1)
ClipPoints(2) = llpnt(0): ClipPoints(3) = urpnt(1)
ClipPoints(4) = urpnt(0): ClipPoints(5) = urpnt(1)
ClipPoints(6) = urpnt(0): ClipPoints(7) = llpnt(1)
ClipPoints(8) = llpnt(0): ClipPoints(9) = llpnt(1)
'Clip boundary = user defined (uniform) size
' Dim Bndsize As Double
' Bndsize = ThisDrawing.Utility.GetReal("What size boundary would you like?: ")
'
' ClipPoints(0) = mdpnt(0) - (Bndsize / 2): ClipPoints(1) = mdpnt(1) - (Bndsize / 2)
' ClipPoints(2) = mdpnt(0) - (Bndsize / 2): ClipPoints(3) = mdpnt(1) + (Bndsize / 2)
' ClipPoints(4) = mdpnt(0) + (Bndsize / 2): ClipPoints(5) = mdpnt(1) + (Bndsize / 2)
' ClipPoints(6) = mdpnt(0) + (Bndsize / 2): ClipPoints(7) = mdpnt(1) - (Bndsize / 2)
' ClipPoints(8) = mdpnt(0) - (Bndsize / 2): ClipPoints(9) = mdpnt(1) + -(Bndsize / 2)
'Clip the image
RastImg.ClipBoundary ClipPoints
'Enable the display of the clip
RastImg.ClippingEnabled = True
'Create Selection Set for Raster
Dim Sset As AcadSelectionSet
Set Sset = ThisDrawing.SelectionSets.Add("Image")
Sset.Select acSelectionSetLast
Debug.Print "Selection Set " & "("; Sset.Name; ")" & " was created"
With Sset
End With
ThisDrawing.SelectionSets.Item("Image").Delete
Errorhandler:
If Err.Description = "File access error" Then
If MsgBox("Can not find image file") Then
Exit Sub
End If
End If
End Sub
-
I got rid of the extra 2 lines from the With, and changed to GetCorner so the user can "see" where they are picking
-
CM,
I just copied the whole thing down from your post
All seems to be working really well now
Very nice job!
Mark
-
I'm sorry?
What 2 withs?
Mark
-
[color=red]With ThisDrawing.Utility[/color]
llpnt = .GetPoint(, vbCrLf & "Select Lower Left Point: ")
urpnt = .GetPoint(, vbCrLf & "Select Upper Right Point: ")
[color=red]End With[/color]became
llpnt = ThisDrawing.Utility.GetPoint(, vbCrLf & "Select Lower Left Point: ")
urpnt = ThisDrawing.Utility.[color=red]GetCorner(llpnt[/color], vbCrLf & "Select Upper Right Point: ")
-
I just eliminated 2 lines of code, the first was the start of the With statement, the second was the EndWith
-
Very good idea!
That works really well!
CM, have you notice that if you pick on the upper right endpoint that you get an error?
The endpoint should be considered part of the image
Mark
-
That's because it testing for </> not =</=>
-
CM
Please correct me if I am wrong:
Can't we get away with this?
Do While Check = False
llpnt = ThisDrawing.Utility.GetPoint(, vbCrLf & "Select Lower Left Point: ")
urpnt = ThisDrawing.Utility.GetCorner(llpnt, vbCrLf & "Select Upper Right Point: ")
If llpnt(0) > RastImg.Origin(0) And llpnt(0) < ImgUR(0) Then
If llpnt(1) > RastImg.Origin(1) And llpnt(1) < ImgUR(1) Then
If urpnt(0) > RastImg.Origin(0) And urpnt(0) < ImgUR(0) Then
If urpnt(1) > RastImg.Origin(1) And urpnt(1) < ImgUR(1) Then
Pnts = True
Else
MsgBox "Pick points inside the raster image"
Check = False
End If
End If
End If
End If
Loop
I would think we only need these lines of code
Else
MsgBox "Pick points inside the raster image"
Pnts = False
Once ?
Mark
-
Sorry I meant check = False
-
Bob
So you are saying
If I put the = sign in, then that will take care of the endpoint problem?
Mark
-
I would think we only need these lines of code
Else
MsgBox "Pick points inside the raster image"
Pnts = False
Once ?
Mark
Nope. If you only have it once, it will only work if it fails in that place. You need to account for failure on each of you IF statements.
Bob
So you are saying
If I put the = sign in, then that will take care of the endpoint problem?
Mark
More like If llpnt(0) > RastImg.Origin(0) And llpnt(0) < ImgUR(0) ElseIf llpnt(0) = RastImg.Origin(0) And llpnt(0) = ImgUR(0) Then
-
Yes Bob you were correct, great catch!
CM,
You need the = sign in your operations in case the user picks on an endpoint in which case the condition would be <> or = to the far (end) points else (as is) you get an error if they pick an endpoint.
If llpnt(0) >= RastImg.Origin(0) And llpnt(0) <= ImgUR(0) Then
If llpnt(1) >= RastImg.Origin(1) And llpnt(1) <= ImgUR(1) Then
If urpnt(0) >= RastImg.Origin(0) And urpnt(0) <= ImgUR(0) Then
If urpnt(1) >= RastImg.Origin(1) And urpnt(1) <= ImgUR(1) Then
Also, I did see why we need the message 3 times in case either one of those conditions are not met.
Mark
-
Bob
You beat me to the draw but I think the method I posted works fine too
Please correct me if I am wrong
Thank you
Mark
-
One last note guys; then my brain is effectively done for the day.
If you place the selection set code
'Create Selection Set for Raster
Dim Sset As AcadSelectionSet
Set Sset = ThisDrawing.SelectionSets.Add("Image")
Sset.Select acSelectionSetLast
Debug.Print "Selection Set " & "("; Sset.Name; ")" & " was created"
With Sset
'Do whatever you'd like here
End With
Right after CM's loop but "before" the clip boundaries are created, it makes the undo feature in ACAD very effective.
Still, delete the selection set
ThisDrawing.SelectionSets.Item("Image").Delete
Right before the Error handler code, unless of course you need it for some reason.
Even though the selection set is deleted, it is still looked at as the last selected item in ACAD and if the user wanted to undo the clip, just do an undo.
Pretty cool
Mark
-
I thought it might help to post the code as it stands right now so that we can all be on the same page
CM, I changed a few minor things, just the formatting to the way I use to having it and may be a variable name but all of your methods are exactly the same. I added the = sign in your conditions also.
Please take note of where I placed the selection set code also
Mark
Public Sub InstRast()
Dim RastImg As AcadRasterImage
Dim Imgpth As String
Dim Imgname As String
Dim InsertPnt(0 To 2) As Double, scalefactor As Double, RotAngle As Double
ThisDrawing.ActiveSpace = acPaperSpace
Imgpth = ThisDrawing.Path & "\"
Imgname = "FtWashington600.tif"
InsertPnt(0) = 0#: InsertPnt(1) = 0#: InsertPnt(2) = 0#
scalefactor = 1
RotAngle = 0
On Error GoTo Errorhandler
Set RastImg = ThisDrawing.PaperSpace.AddRaster(Imgpth & Imgname, InsertPnt, scalefactor, RotAngle)
RastImg.Name = Left(Imgname, Len(Imgname) - 4)
RastImg.scalefactor = 12
'Move Points
Dim MPointN(0 To 2) As Double 'Negative
Dim MPointP(0 To 2) As Double 'Positive
MPointN(0) = 8: MPointN(1) = 0: MPointN(2) = 0
MPointP(0) = 0: MPointP(1) = 0: MPointP(2) = 0
'Move Raster
RastImg.Move MPointN, MPointP
Dim ImgUR(2) As Double
ImgUR(0) = RastImg.Origin(0) + RastImg.ImageWidth
ImgUR(1) = RastImg.Origin(1) + RastImg.ImageHeight
ImgUR(2) = 0
Dim llpnt As Variant 'lower left point
Dim urpnt As Variant 'upper right point
Dim mdpnt(0 To 2) As Double
Dim ClipPoints(0 To 9) As Double
'Getpoints on raster and check if the user picks within the raster boundaries
Dim Pnts As Boolean
Pnts = False
Do While Pnts = False
llpnt = ThisDrawing.Utility.GetPoint(, vbCrLf & "Select Lower Left Point: ")
urpnt = ThisDrawing.Utility.GetCorner(llpnt, vbCrLf & "Select Upper Right Point: ")
If llpnt(0) >= RastImg.Origin(0) And llpnt(0) <= ImgUR(0) Then
If llpnt(1) >= RastImg.Origin(1) And llpnt(1) <= ImgUR(1) Then
If urpnt(0) >= RastImg.Origin(0) And urpnt(0) <= ImgUR(0) Then
If urpnt(1) >= RastImg.Origin(1) And urpnt(1) <= ImgUR(1) Then
Pnts = True
Else
MsgBox "Pick points inside the raster image"
Pnts = False
End If
Else
MsgBox "Pick points inside the raster image"
Pnts = False
End If
Else
MsgBox "Pick points inside the raster image"
Pnts = False
End If
Else
MsgBox "Pick points inside the raster image"
Pnts = False
End If
Loop
mdpnt(0) = (llpnt(0) + urpnt(0)) / 2 'Midpoint (X) = (The far left picked point + the far right picked point) / 2
mdpnt(1) = (llpnt(1) + urpnt(1)) / 2 'Midpoint (Y) = (The far bottom picked point + the far top picked point) / 2
mdpnt(2) = 0
'Create Selection Set for Raster
Dim Sset As AcadSelectionSet
Set Sset = ThisDrawing.SelectionSets.Add("Image")
Sset.Select acSelectionSetLast
Debug.Print "Selection Set " & "("; Sset.Name; ")" & " was created"
With Sset
End With
'FINITE
'Create a 5 x 5 clip boundary
'clipPoints(0) = 0: clipPoints(1) = 0
'clipPoints(2) = 0: clipPoints(3) = 5
'clipPoints(4) = 5: clipPoints(5) = 5
'clipPoints(6) = 5: clipPoints(7) = 0
'clipPoints(8) = 0: clipPoints(9) = 0
'Clip boundary = 2.5 from the mdpnt of the raster's picked points to the boundary coords.
ClipPoints(0) = mdpnt(0) - 2.5: ClipPoints(1) = mdpnt(1) - 2.5
ClipPoints(2) = mdpnt(0) - 2.5: ClipPoints(3) = mdpnt(1) + 2.5
ClipPoints(4) = mdpnt(0) + 2.5: ClipPoints(5) = mdpnt(1) + 2.5
ClipPoints(6) = mdpnt(0) + 2.5: ClipPoints(7) = mdpnt(1) - 2.5
ClipPoints(8) = mdpnt(0) - 2.5: ClipPoints(9) = mdpnt(1) + -2.5
'DYNAMIC
'Clip boundary = picked points (llpnt and urpnt)
' ClipPoints(0) = llpnt(0): ClipPoints(1) = llpnt(1)
' ClipPoints(2) = llpnt(0): ClipPoints(3) = urpnt(1)
' ClipPoints(4) = urpnt(0): ClipPoints(5) = urpnt(1)
' ClipPoints(6) = urpnt(0): ClipPoints(7) = llpnt(1)
' ClipPoints(8) = llpnt(0): ClipPoints(9) = llpnt(1)
'Clip boundary = user defined (uniform) size
'Dim Bndsize As Double
'Bndsize = ThisDrawing.Utility.GetReal("What size boundary would you like?: ")
'ClipPoints(0) = mdpnt(0) - (Bndsize / 2): ClipPoints(1) = mdpnt(1) - (Bndsize / 2)
'ClipPoints(2) = mdpnt(0) - (Bndsize / 2): ClipPoints(3) = mdpnt(1) + (Bndsize / 2)
'ClipPoints(4) = mdpnt(0) + (Bndsize / 2): ClipPoints(5) = mdpnt(1) + (Bndsize / 2)
'ClipPoints(6) = mdpnt(0) + (Bndsize / 2): ClipPoints(7) = mdpnt(1) - (Bndsize / 2)
'ClipPoints(8) = mdpnt(0) - (Bndsize / 2): ClipPoints(9) = mdpnt(1) + -(Bndsize / 2)
'Clip the image
RastImg.ClipBoundary ClipPoints
'Enable the display of the clip
RastImg.ClippingEnabled = True
ThisDrawing.SelectionSets.Item("Image").Delete
Errorhandler:
If Err.Description = "File access error" Then
If MsgBox("Can not find image file") Then
Exit Sub
End If
End If
End Sub
-
OK
I stand corrected by myself :-(
The selection set is not why the undo feature is working; it works regardless. DALP!
Of course there may be other reasons to keep it in there; it is completely up to your guys
Kirk out
-
Wow, you guys stayed late last night.
-
Yes sir
No rest for the weary
-
Hey guys,
I know this is a little bit obsessive but I am just curious;
If I select the lower left (llpnt) and the upper right (urpnt) points of the raster,
I have the results printing to the Immediate Window -->
Take note of the results, which are the correct points
'Return picked points
Debug.Print "The lower left picked points = " & llpnt(0) & ", " & llpnt(1)
Debug.Print "The upper right picked points = " & urpnt(0) & ", " & urpnt(1)
'From Immediate Window
The lower left picked points = -8, 0
The upper right picked points = -0.3500000000012, 11.6033333333333
However, if I use the code that Bob gave me:
Sub Getpoints()
Dim Pnt As Variant
Dim i As Integer
On Error GoTo NoPoint
Do
Pnt = ThisDrawing.Utility.GetPoint(, vbCrLf & "Pnt" & i)
Debug.Print "Pnt" & i & ": "; Pnt(0) & "," & Pnt(1)
i = i + 1
Loop
NoPoint:
If Err.Number Then
Err.Clear
Exit Sub
End If
End Sub
To get my points;
The lower left points (llpnt) are being returned as
-8,-1.34354333214404E-15
Does anybody know why this is happening?
In Bob's code, do we need to have a round function?
In both modules; the same exact method is being used but the results are different?
Mark
-
In this example:
Sub Getpoints_xymid()
Dim llpnt As Variant 'lower left point
Dim urpnt As Variant 'upper right point
Dim xpnts As Variant
Dim ypnts As Variant
Dim mdpnt(0 To 2) As Double
With ThisDrawing.Utility
llpnt = .GetPoint(, vbCrLf & "Select Lower Left Point: ")
urpnt = .GetCorner(llpnt, vbCrLf & "Select Upper Right Point: ")
End With
mdpnt(0) = (llpnt(0) + urpnt(0)) / 2 'Midpoint (X) = (The far left picked point + the far right picked point) / 2
mdpnt(1) = (llpnt(1) + urpnt(1)) / 2 'Midpoint (Y) = (The far bottom picked point + the far top picked point) / 2
mdpnt(2) = 0
xpnts = llpnt(0) + urpnt(0)
ypnts = llpnt(1) + urpnt(1)
Debug.Print "Lower left points: "; llpnt(0) & "," & llpnt(1)
Debug.Print "Upper right points: "; urpnt(0) & "," & urpnt(1)
Debug.Print "Midpoints: "; mdpnt(0) & "," & mdpnt(1) & vbCrLf
Debug.Print "Xpoints (0) + (1) = "; xpnts
Debug.Print "Ypoints (0) + (1) = "; ypnts
End Sub
Check out the results:
Lower left points: -8,-1.34354333214404E-15
Upper right points: -0.3500000000012,11.6033333333333
Midpoints: -4.1750000000006,5.80166666666667
Xpoints (0) + (1) = -8.3500000000012
Ypoints (0) + (1) = 11.6033333333333
The Y Points are being calculated correctly as Xpoint (1) should = 0
Still, look here, look at Lower left points:
It is giving me -1.34354333214404E-15 instead of 0
WTF!
The question is why?
Mark
-
Sorry guys
The code should read like this
Debug.Print "Lower left points: "; llpnt(0) & "," & llpnt(1)
Debug.Print "Upper right points: "; urpnt(0) & "," & urpnt(1) & vbCrLf
Debug.Print "Xpoints (0) + (0) = "; xpnts
Debug.Print "Ypoints (1) + (1) = "; ypnts & vbCrLf
Debug.Print "Midpoints: "; mdpnt(0) & "," & mdpnt(1)
The correction is:
Xpoints (0) + (0) = "; xpnts
Ypoints (1) + (1) = "; ypnts
Still the prior post does has the correct numbers, it was just the way I was displaying the string (in the immediate window) that was wrong
Mark
-
Hey guys
Just when you thought it was OVER; I have yet one more idea
OK,
If the raster already exists in the drawing, then we can still utilize this code.
I have most of it written
I just need help with the line in red.
Thanks
Mark
Sub InstRast3()
Dim RastImg As AcadRasterImage
Dim Obj As AcadObject
Dim Objname As String
For Each Obj In ThisDrawing.PaperSpace
If Obj.ObjectName = "AcDbRasterImage" Then
[color=red]'Objname = 'Need this code[/color]
Set RastImg = ThisDrawing.PaperSpace.Item(Objname)
End If
Next Obj
Dim ImgLmts(2) As Double
ImgLmts(0) = RastImg.Origin(0) + RastImg.ImageWidth
ImgLmts(1) = RastImg.Origin(1) + RastImg.ImageHeight
ImgLmts(2) = 0
Dim llpnt As Variant 'lower left point
Dim urpnt As Variant 'upper right point
Dim mdpnt(0 To 2) As Double
Dim ClipPoints(0 To 9) As Double
'Prompt for pick points on raster and check if the user picks within the raster boundaries
Dim PntLmts As Boolean
PntLmts = False
Do While PntLmts = False
llpnt = ThisDrawing.Utility.GetPoint(, vbCrLf & "Select Lower Left Point: ")
urpnt = ThisDrawing.Utility.GetCorner(llpnt, vbCrLf & "Select Upper Right Point: ")
If llpnt(0) >= RastImg.Origin(0) And llpnt(0) <= ImgLmts(0) Then
If llpnt(1) >= RastImg.Origin(1) And llpnt(1) <= ImgLmts(1) Then
If urpnt(0) >= RastImg.Origin(0) And urpnt(0) <= ImgLmts(0) Then
If urpnt(1) >= RastImg.Origin(1) And urpnt(1) <= ImgLmts(1) Then
PntLmts = True
Else
MsgBox "The pick points must be on the raster image " & vbCrLf & _
"Please try again"
PntLmts = False
End If
Else
MsgBox "The pick points must be on the raster image " & vbCrLf & _
"Please try again"
PntLmts = False
End If
Else
MsgBox "The pick points must be on the raster image " & vbCrLf & _
"Please try again"
PntLmts = False
End If
Else
MsgBox "The pick points must be on the raster image " & vbCrLf & _
"Please try again"
PntLmts = False
End If
Loop
mdpnt(0) = (llpnt(0) + urpnt(0)) / 2 'Midpoint (X) = (The far left picked point + the far right picked point) / 2
mdpnt(1) = (llpnt(1) + urpnt(1)) / 2 'Midpoint (Y) = (The far bottom picked point + the far top picked point) / 2
mdpnt(2) = 0
'Create Selection Set for Raster
Dim Sset As AcadSelectionSet
Set Sset = ThisDrawing.SelectionSets.Add("Image")
Sset.Select acSelectionSetLast
'Debug.Print "Selection Set " & "("; Sset.Name; ")" & " was created"
With Sset
'Do whatever
End With
'Clip boundary = picked points (llpnt and urpnt)
ClipPoints(0) = llpnt(0): ClipPoints(1) = llpnt(1)
ClipPoints(2) = llpnt(0): ClipPoints(3) = urpnt(1)
ClipPoints(4) = urpnt(0): ClipPoints(5) = urpnt(1)
ClipPoints(6) = urpnt(0): ClipPoints(7) = llpnt(1)
ClipPoints(8) = llpnt(0): ClipPoints(9) = llpnt(1)
'Clip the image
RastImg.ClipBoundary ClipPoints
'Enable the display of the clip
RastImg.ClippingEnabled = True
'Delete Selection Set
ThisDrawing.SelectionSets.Item("Image").Delete
'Return picked points
Debug.Print "The lower left picked points = " & llpnt(0) & ", " & llpnt(1)
Debug.Print "The upper right picked points = " & urpnt(0) & ", " & urpnt(1)
Errorhandler:
If Err.Description = "File access error" Then
If MsgBox("Can not find image file") Then
Exit Sub
End If
End If
End Sub
-
For Each Obj In ThisDrawing.PaperSpace
If Obj.ObjectName = "AcDbRasterImage" Then
Set RastImg = ThisDrawing.PaperSpace.Item(Objname)
Objname = rastimg.name
End If
Next Obj
-
Does AcadObject work for this or should it be ACADEntity? Also, why not use a filtered selection set. Probably won't matter but if there are a bunch of thingies in your dwg it will be quicker.
-
Hi Bob
Thank you;
Yes, Acadobject or Object will work
From what I have been taught and have learned:
If we declared
Obj as AcadEntity
Then, it will literally interate through EVERY single AutoCAD entity
Lines, blocks, text, polylines, circles and on and on as opposed to just saying
Find the "object" (typeof) (typename =) I need and do something with it
I could do a filtered selection set but these two methods would work in a similar fashion i would think as with this method we are interating for a specific object type not through a drawing of entity types
Mark
-
808, I dont know, I thought it required the object
-
I could do a filtered selection set but these two methods would work in a similar fashion i would think as with this method we are interating for a specific object type not through a drawing of entity types
Actually, without the filter, you will process every object in paperspace. Given that paperspace doesn't usually have tons of items, it should go quickly. If however you were processing modelspace, a filtered selection set would be the way to go
-
Bob
This won't work
For Each Obj In ThisDrawing.PaperSpace
If Obj.ObjectName = "AcDbRasterImage" Then
Set RastImg = ThisDrawing.PaperSpace.Item(Objname)
Objname = rastimg.name
End If
Next Obj
How are we going to know what objname to set too?
I am able to confirm that there is a raster in paperspace but I need to grab its name
Mark
-
I think you want
Set RastImg = Obj
ObjName=RastImg.Name
-
doh! yep, that's what I meant.
-
I agree with that CM
Shouldn't looping through objects be quicker then looping through entities?
I am not so sure that entities and objects are looked at the same.
Myself and Keith B had this discussion once and he actually taught me to use object as opposed to entity when interating for a specific object "type"
You know me by now
"The less code the better"
When it comes to programming, if I can turn 5 lines into 3, I will do it.
Mark
-
Yes sir! CM, you are the man!
And so is Bob of course :)
Well, yet here is one more method.
If Raster already exists in drawing (Paperspace in my scenario) then prompt for clipboundary points.
Sub MkRastCBnd()
Dim RastImg As AcadRasterImage
Dim Obj As AcadObject
Dim Objname As String
For Each Obj In ThisDrawing.PaperSpace
If Obj.ObjectName = "AcDbRasterImage" Then
Set RastImg = Obj
Objname = RastImg.Name
End If
Next Obj
Dim ImgLmts(2) As Double
ImgLmts(0) = RastImg.Origin(0) + RastImg.ImageWidth
ImgLmts(1) = RastImg.Origin(1) + RastImg.ImageHeight
ImgLmts(2) = 0
Dim llpnt As Variant 'lower left point
Dim urpnt As Variant 'upper right point
Dim mdpnt(0 To 2) As Double
Dim ClipPoints(0 To 9) As Double
'Prompt for pick points on raster and check if the user picks within the raster boundaries
Dim PntLmts As Boolean
PntLmts = False
Do While PntLmts = False
llpnt = ThisDrawing.Utility.GetPoint(, vbCrLf & "Select Lower Left Point: ")
urpnt = ThisDrawing.Utility.GetCorner(llpnt, vbCrLf & "Select Upper Right Point: ")
If llpnt(0) >= RastImg.Origin(0) And llpnt(0) <= ImgLmts(0) Then
If llpnt(1) >= RastImg.Origin(1) And llpnt(1) <= ImgLmts(1) Then
If urpnt(0) >= RastImg.Origin(0) And urpnt(0) <= ImgLmts(0) Then
If urpnt(1) >= RastImg.Origin(1) And urpnt(1) <= ImgLmts(1) Then
PntLmts = True
Else
MsgBox "The pick points must be on the raster image " & vbCrLf & _
"Please try again"
PntLmts = False
End If
Else
MsgBox "The pick points must be on the raster image " & vbCrLf & _
"Please try again"
PntLmts = False
End If
Else
MsgBox "The pick points must be on the raster image " & vbCrLf & _
"Please try again"
PntLmts = False
End If
Else
MsgBox "The pick points must be on the raster image " & vbCrLf & _
"Please try again"
PntLmts = False
End If
Loop
mdpnt(0) = (llpnt(0) + urpnt(0)) / 2 'Midpoint (X) = (The far left picked point + the far right picked point) / 2
mdpnt(1) = (llpnt(1) + urpnt(1)) / 2 'Midpoint (Y) = (The far bottom picked point + the far top picked point) / 2
mdpnt(2) = 0
'Create Selection Set for Raster
Dim Sset As AcadSelectionSet
Set Sset = ThisDrawing.SelectionSets.Add("Image")
Sset.Select acSelectionSetLast
'Debug.Print "Selection Set " & "("; Sset.Name; ")" & " was created"
With Sset
'Do whatever
End With
'Clip boundary = picked points (llpnt and urpnt)
ClipPoints(0) = llpnt(0): ClipPoints(1) = llpnt(1)
ClipPoints(2) = llpnt(0): ClipPoints(3) = urpnt(1)
ClipPoints(4) = urpnt(0): ClipPoints(5) = urpnt(1)
ClipPoints(6) = urpnt(0): ClipPoints(7) = llpnt(1)
ClipPoints(8) = llpnt(0): ClipPoints(9) = llpnt(1)
'Clip the image
RastImg.ClipBoundary ClipPoints
'Enable the display of the clip
RastImg.ClippingEnabled = True
'Delete Selection Set
ThisDrawing.SelectionSets.Item("Image").Delete
'Return picked points
Debug.Print "The lower left picked points = " & llpnt(0) & ", " & llpnt(1)
Debug.Print "The upper right picked points = " & urpnt(0) & ", " & urpnt(1)
Errorhandler:
If Err.Description = "File access error" Then
If MsgBox("Can not find image file") Then
Exit Sub
End If
End If
End Sub
-
And make the boundary of course! :-P
-
I forgot:
We should also add Bob's other nice piece of code into this module
'Clip boundary = user defined (uniform) size
Dim Bndsize As Double
Bndsize = ThisDrawing.Utility.GetReal("What size boundary would you like?: ")
ClipPoints(0) = mdpnt(0) - (Bndsize / 2): ClipPoints(1) = mdpnt(1) - (Bndsize / 2)
ClipPoints(2) = mdpnt(0) - (Bndsize / 2): ClipPoints(3) = mdpnt(1) + (Bndsize / 2)
ClipPoints(4) = mdpnt(0) + (Bndsize / 2): ClipPoints(5) = mdpnt(1) + (Bndsize / 2)
ClipPoints(6) = mdpnt(0) + (Bndsize / 2): ClipPoints(7) = mdpnt(1) - (Bndsize / 2)
ClipPoints(8) = mdpnt(0) - (Bndsize / 2): ClipPoints(9) = mdpnt(1) + -(Bndsize / 2)
-
Always use enough lines of code to make it the most efficient. If that means an extra 10 to save 90% of the clock cycles, thats lines worth typing
-
CM
Did you try the code for if the raster exists?
Mark
-
So, that is cool; now we can insert and create the boundary or create the boundary after it is inserted.
I wonder if you or Bob caught my previous posts on points?
If you go back about 5 or 6, you should see them.
Mark
-
Hey Guys,
I also wanted to toss this in
Just to clarify; my initial intent was to insert the raster at -8 in the X direction so that it was off the title block for the users to pick their points. I originally used the move method for that but I changed it. Instead, I it at -8,0,0
Then you can fill in the move section when/if you know where the raster will permanently reside
Mark
Sub InstRastMkCBnd()
Dim RastImg As AcadRasterImage
Dim Imgpath as String, Imgname as String
Dim InsertPnt(0 To 2) As Double, Scalefactor As Double, RotAngle As Double
Imgpth = ThisDrawing.Path & "\" 'assumes Image File is in the same directory as your drawing
Imgname = "Filename.ext"
ThisDrawing.ActiveSpace = acPaperSpace
InsertPnt(0) = -8#: InsertPnt(1) = 0#: InsertPnt(2) = 0#
scalefactor = 1
RotAngle = 0
'On Error GoTo Errorhandler
Set RastImg = ThisDrawing.PaperSpace.AddRaster(Imgpth & Imgname, InsertPnt, Scalefactor, RotAngle)
RastImg.Name = Left(Imgname, Len(Imgname) - 4)
RastImg.scalefactor = 12
'Move Points
Dim MPointN(0 To 2) As Double 'Negative
Dim MPointP(0 To 2) As Double 'Positive
MPointN(0) = 0: MPointN(1) = 0: MPointN(2) = 0
MPointP(0) = 0: MPointP(1) = 0: MPointP(2) = 0
'Move Raster
RastImg.Move MPointN, MPointP
-
So, that is cool; now we can insert and create the boundary or create the boundary after it is inserted.
I wonder if you or Bob caught my previous posts on points?
If you go back about 5 or 6, you should see them.
Mark
Sorry, which posts on points?
-
Hey Bob
Just go back one page
I was just a little confused about something but it is no big deal.
-
Bob
Also, if I may; I have another question for you.
In the method (see top of this page) where we grab an existing raster, then picks our points
What would we do in the case that there are multiple rasters?
I suppose we could interate through paper (or opt the user for space) and ask the user which one (raster) they want to use and set obj = the user picked raster.
After they clip that one, prompt for the next one, etc. etc.
Mark
Sub MkCBnd()
Dim RastImg As AcadRasterImage
Dim Obj As AcadObject
Dim Objname As String
ThisDrawing.ActiveSpace = acPaperSpace
For Each Obj In ThisDrawing.PaperSpace
If Obj.ObjectName = "AcDbRasterImage" Then
Set RastImg = Obj
End If
Next Obj
If RastImg Is Nothing Then
MsgBox "There are no image files in this drawing"
Exit Sub
Else
'Lower left points of the raster + the image width and height
Dim ImgLmts(2) As Double
ImgLmts(0) = RastImg.Origin(0) + RastImg.ImageWidth
ImgLmts(1) = RastImg.Origin(1) + RastImg.ImageHeight
ImgLmts(2) = 0
End If
-
I'll have to look into the points thing when I have some time to play in acad. As to the most recent though, the easiest way would be to do a filtered selection set. If there's one, continue. If there's more than one, prompt for a selection. Another option would be just to let the user pick the clip boundary and iterate through the rasters, running the check for containment on each.
-
What do you think would be the best method for them to select each raster without getting into userforms and all that crazy stuff?
I could return each raster with a msgbox but then there is no method to select one; even an input box, there would have to type in the one they want.
With a combobox (if I want to go there) we could return all rasters and allow them to select one.
What do you think? Is there a way without getting into forms?
Thanks
Mark
-
You would still prefer a filtered selection set over the method I am using, huh? :)
I do realize that we are looping through all objects but the time it is taking is so miniscal that it really is fine
Mark
-
Not my program, I don't have a preference. If asked for a solution to a problem, I gave you what to me seemed the most logical and straightforward method. You could do a message box with yes/no buttons for each. Your users will hate you. You can do the form you mentioned. Lots of ways to skin a cat.
-
Absolutely and I respect your suggestions and appreciate all your help :)
I was actually pretty much done with the whole project then I ran into a situation today where no rasters exisited so I addressed that, then I thought, what if there is more then one in the drawing?
As you know, we can not account for every little thing.
At this point, I think I will leave good enough alone.
Thanks again,
Mark
-
cool dat.
-
:)
-
Hey guys
Another question:
We already have our midpoint
Dim mdpnt(0 To 2) As Double
mdpnt(0) = (llpnt(0) + urpnt(0)) / 2 'Midpoint (X)
mdpnt(1) = (llpnt(1) + urpnt(1)) / 2 'Midpoint (Y)
mdpnt(2) = 0
And the code to move the raster
'Move Points
Dim MPointN(0 To 2) As Double 'Negative
Dim MPointP(0 To 2) As Double 'Positive
MPointN(0) = 0: MPointN(1) = 0: MPointN(2) = 0
MPointP(0) = 0: MPointP(1) = 0: MPointP(2) = 0
'Move Raster
RastImg.Move MPointN, MPointP
Now, what if we want to move the raster from the midpoint that we already have to another midpoint else where, let's say in the middle of a 5'x5' square.
How would we do this:
I realize, we can have midpnt1 and a midpnt2
The question is more, how do we do the actual move with the raster.
Note: Also, this is after it has been clipped
Thanks,
Mark
-
It looks like we somehow need a way to say move FROM midpnt1
Dim mdpnt1 (0 To 2) As Double
mdpnt1(0) = (llpnt(0) + urpnt(0)) / 2 'Midpoint (X)
mdpnt1(1) = (llpnt(1) + urpnt(1)) / 2 'Midpoint (Y)
mdpnt1(2) = 0
To Midpnt2 (0 to 2) as Double 'To be determined
Mdpnt2 (0)=
Mdpnt2 (1)=
Mdpnt2 (2)=
So, how does that translate into here?
'Move Raster
RastImg.Move Midpnt1 (this is from), Midpnt2 (this is to)
Mark
-
When you look go to the end of the .move method, it prompts you for a From Point, To Point
In the scenario we originally used, we are giving it the negative and positive coords to move to.
RastImg.Move MPointN, MPointP
In the above question, I am looking to truly go from a From Point (mdpnt), to a To Point (mdpnt1)
Just not quite sure how to get it; I have tried a few things but no luck?
Anyone?
Mark
-
What have you tried?
-
Hey CM,
Good to see you back!
So far, I am just grasping for straws, time permitting.
I have tried something like this:
'Test Move Points
Dim mdpnt1N(0 To 2) As Double
Dim mdpnt1P(0 To 2) As Double
mdpnt1N(0) = 0: mdpnt1N(1) = 0: mdpnt1N(2) = 0
mdpnt1P(0) = 2.5: mdpnt1P(1) = 2.5: mdpnt1P(2) = 0
'Test Move Raster
RastImg.Move mdpnt, mdpnt1N, mdpnt1P
So, I was trying to use our existing mdpnt which we know is constant each time we define our points to a mid point of a rectangle on a title block; that is where the clipped raster will end up.
So, that would be cool; after the user chooses their points, it will magically get moved to the necessary location for them, assuming I can get it to work.
I think after the move method, we can only use 2 variables and I am using 3 above which did not work for me.
The other thing is that the mdpnt will never be the same, so how do we address that?
We could say mdpnt = RastImg.Origin then perform the move; assuming that will first shift the clipped image to the original raster origin before performing the move.
What do you think?
Thanks
Mark
-
For those who are interested:
Here is how I finally moved the clipped raster to where I needed it to be on the drawing:
Mark
'***Move the raster***
'Use the midpoint of the raster as the base point
Dim Pnt As Variant
Pnt = mdpnt
'0,0
Dim ZeroZero(0 To 2) As Double
ZeroZero(0) = 0: ZeroZero(1) = 0: ZeroZero(2) = 0
'Specify the distance you want to move the raster (midpoint) from 0,0
Dim DestPnt(0 To 2) As Double
DestPnt(0) = ZeroZero(0) + 9.83
DestPnt(1) = ZeroZero(1) + 16.83
DestPnt(2) = 0
'Move the clipped raster to it's destination
RastImg.Move Pnt, DestPnt