I'm trying to make a label move from one cell to another. I figured out the position offsets and created 3 "tweens" as animators call them. But when I run the code, the Label doesn't display until the sub has ended. If I comment out the last position the label is in the right spot. How do I make Excel update the screen to show the label before I move it again?
xo and yo are integers either -1, 0, or 1. playerLocation is a range, might as well be ActiveCell.
Sub moveAnimation()
Dim moveAnim As OLEObject
Set moveAnim = Worksheets(currentSheet).OLEObjects(currentSheet & "player")
moveAnim.Left = playerLocation.Left - 0.5 + yo * (playerLocation.Width / 4)
moveAnim.Top = playerLocation.Top + 0.25 + xo * (playerLocation.Width / 4)
Sleep (25)
moveAnim.Left = playerLocation.Left - 0.5 + yo * (playerLocation.Width / 2)
moveAnim.Top = playerLocation.Top + 0.25 + xo * (playerLocation.Width / 2)
Sleep (25)
moveAnim.Left = playerLocation.Left - 0.5 + yo * 3 * (playerLocation.Width / 4)
moveAnim.Top = playerLocation.Top + 0.25 + xo * 3 * (playerLocation.Width / 4)
Sleep (25)
moveAnim.Left = 0
moveAnim.Top = 0
I've figured it out. ActiveSheet.Calculate will force an update so i put it between each position
Related
I just wrote this code to perform an iterative calculation. It finds the X,Y coordinates where an unknown parabola is tangent to a known circle. It is based on other iterative functions I've written that have worked flawlessly. I'm stumped as to what the issue is. Here is the code:
Public Function Jext(PA As Double, Xcl As Double, Ycl As Double, Ctr As Double, Rnl As Double, Finl As Double) As Double
Pi = 3.14159265358979
tol = 0.00000001
Dim x(20) As Double
Dim Yc(20) As Double
Dim Yp(20) As Double
Dim A(20) As Double
Dim Diff(20) As Double
Dim It As Integer
Dim hF As Double
Dim Sf As Double
'Xcl is the horizontal position of the root radius center line
'Ycl is the vertical position of the root radius center line
'Ctr is root radius. It's an approximation of the trochoid and is typically the cutter tip radius
'Rnl is the radius to the point where the load line intersects the tooth centerline. It is the apex of the parabola
'x is the horizontal position that is common to the parabola and circle. It is the independent variable
'Yc is the vertical position on the circle at point x
'Yp is the vertical position on the parabola at point x
'A is the leading term of the parabolic equation
'Diff is the calculated difference in vertical positions of circle and parabola
'Set initial guess values. x(0) is 5% of the radius (left edge of circle) and x(1) is 95% of the radius(bottom of the circle)
x(0) = (Xcl - Ctr) + 0.05 * Ctr
x(1) = (Xcl - Ctr) + 0.95 * Ctr
Yc(0) = Ycl - (Ctr ^ 2 - (x(0) - Xcl) ^ 2) ^ 0.5
Yc(1) = Ycl - (Ctr ^ 2 - (x(1) - Xcl) ^ 2) ^ 0.5
A(0) = Tan(WorksheetFunction.Acos((Xcl - x(0)) / Ctr) + Pi / 2) / (2 * x(0))
A(1) = Tan(WorksheetFunction.Acos((Xcl - x(1)) / Ctr) + Pi / 2) / (2 * x(1))
Yp(0) = A(0) * x(0) ^ 2 + Rnl
Yp(1) = A(1) * x(1) ^ 2 + Rnl
Diff(0) = Yp(0) - Yc(0)
Diff(1) = Yp(1) - Yc(1)
For It = 1 To 19 Step 1
x(It + 1) = x(It) - (Diff(It) - 0) * (x(It - 1) - x(It)) / (Diff(It - 1) - Diff(It))
Yc(It + 1) = Ycl - (Ctr ^ 2 - (x(It + 1) - Xcl) ^ 2) ^ 0.5
A(It + 1) = Tan(WorksheetFunction.Acos((Xcl - x(It + 1)) / Ctr) + Pi / 2) / (2 * x(It + 1))
Yp(It + 1) = A(It + 1) * x(It + 1) ^ 2 + Rnl
Diff(It + 1) = Yp(It + 1) - Yc(It + 1)
If Abs(Diff(It + 1)) < tol Then Exit For
Debug.Print Diff(It + 1)
Next It
hF = Rnl - Yp(t + 1)
Sf = 2 * x(t + 1)
Jext = 1 / (Cos(Finl) / Cos(PA) * (6 * hF / Sf ^ 2 - Tan(Finl) / Sf))
End Function
I put a stop at the "Next It" line to check the values as it went through the iterative loops. When I execute the code, all of the values are as expected and the value of Abs(Diff(It+1)) is not small enough to exit the for loop in the IF statement. I put the Debug.Print statement in there to make sure it was getting that far in the code and it did print Diff(It+1). So it executes everything to that point. Then when I continue the function it just stops and returns a #VALUE error in the spreadsheet. I've no idea why it won't continue the for loop. Anyone see something I've missed?
I have a list of lat long coordinates each with corresponding azimuths (directions) such as:
Site | Cell | Lat | Long | Azimuth (degrees) | Beamwidth
CE0001 | CE0001U09A1 | X | Y | 0 | 65
CE0001 | CE0001U09B1 | X | Y | 120 | 65
CE0001 | CE0001U09C1 | X | Y | 240 | 65
For each unique cell, I would like to create a triangular polygon that is oriented in the direction of the azimuth for the corresponding cell with a width of 65degs and a radius of say 2km. I would like to generate shapes similar to what is shown below.
Can anyone point me in the direction as to how I could begin coding this up to loop through each entry in my file and how to generate a single google earth file that contains a polygon for each one? There are approx 9000 or so cells that require a polygon but if I can get this working for a small sample I would be very happy.
Here is and old post I made to a forum of a script to build hexagon tiles. Some of the calls are to the GIS API but I think you can probably extracted the needed VBA code:
.. VB script to create some hexagon tiles.
It creates tiles of a given radius (circle around a tile), not side length. If you want side length you will need to do the math and updte the code.
Here is the Comments from the .map file:
Creating a drawing of hexagon tiles:
R - radius
Radius of circumscribed circle around tile
a - Apothem:
Distance from centroid perpendicular to a side
a = R * cos(1/2 * 360/n) (n=6 for a hexagon
A set of hexagon tiles would be a series of six sided
"circles" centered on two point grids (1 & 2). Both grids
would have the spacing of:
in X --- 3R
in Y --- 2a
Grid 2 would be offset from grid 1 by:
in X ---- 3R/2
in Y ---- 2a/2
To test script delete all objects in A then
run the script.
This sample was only tested with a lat/long drawing. I'm not
sure of all the ramifications of using a projected drawing.
To use with your data set the start point (upper left) in the script and desired radius.
Set precision and run Normailize Topology when done to join
the tiles.
Code was based on the FreeStuff sample scripts ScriptRandomPoints
and ScriptSpatialOperations.
Please post any problems you find with this code.
Hmmm.. the attachments option is gone? :-?
Send me your address via email and send the .map file if you'd like.
Here's the code:
Sub Main
' test lat/long drawing
' ** ** delete all objects in A to test
set drawing = Application.ActiveDocument.ComponentSet("A")
set objects = drawing.ObjectSet
sides = 6
pi = 3.14159
R = 2.5 ' radius in degrees
interiorAngle = (360/6) * (pi / 180) ' in radians
a = abs(R * cos(0.5 * interiorAngle)) ' apothem
' pick/make a start point - upper left
Set startPoint = Application.NewPoint
startPoint.X = -25
startPoint.Y = 73.6602540378444
' grid (4x3x2)
for i = 0 to 3
for j = 0 to 2
' -- create point grid 1
Set point = Application.NewPoint
point.X = startPoint.X + (i * 3 * R)
point.Y = startPoint.Y - (j * 2 * a)
' objects.Add Application.NewGeom(GeomPoint, point) ' centroid
Set pointSet = Application.NewPointSet
For k = 0 To sides -1
Set pt = Application.NewPoint
' calculate angle
angle = (k*2*Pi/sides)' - (360/sides)/2
' obtain point on circle
pt.X = point.X + R*Cos(angle)
pt.Y = point.Y + R*Sin(angle)
pointSet.Add(pt)
Next
objects.Add Application.NewGeom(GeomArea, pointSet)
' -- create point grid 2
Set point = Application.NewPoint
point.X = startPoint.X + (i * 3 * R) + ((3 * R)/2)
point.Y = startPoint.Y - (j * 2 * a) - a
' objects.Add Application.NewGeom(GeomPoint, point) ' centroid
Set pointSet = Application.NewPointSet
For k = 0 To sides -1
Set pt = Application.NewPoint
' calculate angle
angle = (k*2*Pi/sides)' - (360/sides)/2
' obtain point on circle
pt.X = point.X + R*Cos(angle)
pt.Y = point.Y + R*Sin(angle)
pointSet.Add(pt)
Next
objects.Add Application.NewGeom(GeomArea, pointSet)
next
next
msgbox "Done!"
End Sub
Here's a cleaned up version that just developes one hex tile. You should be able to modify it to do what you want.
Sub xx()
Dim startPoint As clsPoint
Dim Point As clsPoint
Dim pt As clsPoint
Dim pts As Collection
Dim s As String
' lat/long (western hemisphere?)
Dim sides, i, j, k As Integer
Dim Pi, R, interiorAngle, A, Angle As Double
sides = 6
Pi = 3.14159
R = 0.25 ' radius in degrees
interiorAngle = (360 / 6) * (Pi / 180) ' in radians
A = Abs(R * Cos(0.5 * interiorAngle)) ' apothem
' pick/make a start point - upper left
Set startPoint = New clsPoint
startPoint.X = -121.5
startPoint.Y = 35.5
s = "Longitude" & vbTab & "Latitude" & vbCrLf
s = s & startPoint.X & vbTab & startPoint.Y & vbCrLf
Set Point = New clsPoint
Point.X = startPoint.X '+ (i * 3 * R)
Point.Y = startPoint.Y '- (j * 2 * A)
Set pts = New Collection
For k = 0 To sides - 1
Set pt = New clsPoint
' calculate angle
Angle = (k * 2 * Pi / sides) ' - (360/sides)/2
' Debug.Print Angle
' obtain point on circle
pt.X = Point.X + R * Cos(Angle)
pt.Y = Point.Y + R * Sin(Angle)
pts.Add pt
Next
For Each pt In pts
s = s & pt.X & vbTab & pt.Y & vbCrLf
Next
Debug.Print s
Stop
End Sub
clsPoint just contains:
Public X As Double
Public Y As Double
I have created a function via vba and I have used this function to make an iterative table. I have set the workbook calculation to automatic and it all works fine but when I open the excel file, the cells that contain the mentioned function, give me #name error and everytime I need to recalculate. Is there a way to fix this?
Public Function FrictionFactor(relativeroughness, reynoldsnumber)
'Dim relativeroughness, reynoldsnumber As Double
fNext = 0.005 ' initial value for f
fIncrement = 0.005 ' initial step size
Convergence = 0.000001 ' sets the decimal place accuracy of the result
Do
fStart = fNext
LHSColebrookStart = 1 / (fStart ^ 0.5)
RHSColebrookStart = -2 * (Log((relativeroughness / 3.7) + (2.51 / (reynoldsnumber * (fStart ^ 0.5)))) / Log(10))
DifferenceStart = LHSColebrookStart - RHSColebrookStart
fNext = fStart + fIncrement
LHSColebrookNext = 1 / (fNext ^ 0.5)
RHSColebrookNext = -2 * (Log((relativeroughness / 3.7) + (2.51 / (reynoldsnumber * (fNext ^ 0.5)))) / Log(10))
DifferenceNext = LHSColebrookNext - RHSColebrookNext
If DifferenceStart * DifferenceNext < 0 Then ' march f in opposite direction and more slowly
fIncrement = fIncrement / -10
ElseIf DifferenceStart * DifferenceNext = 0 Then ' done
fIncrement = 0
End If ' keep marching f in same direction and at same rate
Loop While Abs(fStart - fNext) > Convergence
FrictionFactor = fStart
End Function
The usual reason this happens is that macros are not enabled when the workbook is opened. Check your Security settings.
I'm trying to write a function that changes 3 coordinates and 3 velocities in a loop using random numbers.
Although he generated numbers seem random enough. The two last values never drift apart, while the first one does go its own way.
This is the function, I will also link the excel workbook, so you can see it in action
(it's a animated colorbox using RGB and sliders for the values. Just run the 'color' sub
Function variate(ByRef x_origin As Double, ByRef y_origin As Double, ByRef offset_x As Double, ByRef offset_y As Double, Optional ByRef z_origin As Double, Optional ByRef offset_z As Double, Optional xyz_bounds) As Variant
'this function adds random number to each of the origins
'the offset is the 'drift' the object has (or velocity)
'calculate a random number
'if the number is going in the same direction, speed up
'otherwise slow down
Dim new_origin_x As Double
Dim new_origin_y As Double
Dim new_origin_z As Double
Dim velocity_x As Double
Dim velocity_y As Double
Dim velocity_z As Double
Dim speed_x As Double
Dim speed_y As Double
Dim speed_z As Double
Dim random_number_x As Double
Dim random_number_y As Double
Dim random_number_z As Double
Dim random_speed_x As Double
Dim random_speed_y As Double
Dim random_speed_z As Double
'calculate a random with the seed and make it between -0.5 and 0.5
Randomize
random_number_x = Rnd(Range("x_fact").Value) - 0.5
Randomize
random_number_y = Rnd(Range("y_fact").Value) - 0.5
Randomize
random_number_z = Rnd(Range("z_fact").Value) - 0.5
'for the speed
Randomize
random_speed_x = Rnd(1) - 0.5
Randomize
random_speed_y = Rnd(1) - 0.5
Randomize
random_speed_z = Rnd(1) - 0.5
'see how much there is a speed up
'what point would we be at with the current speed
'that is the distance travelled in time, but the time is 1 'unit' ...
'and let's add some randohohomnessss
speed_x = offset_x + (random_speed_x / Range("x_rem").Value)
speed_y = offset_y + (random_speed_y / Range("y_rem").Value)
speed_z = offset_z + (random_speed_z / Range("z_rem").Value)
'so new origin is new_origin_x = x_origin + offset_x
'but than we've travelled at the same speed, with directional changes
'we're probably not even moving
'so add some randomness to act as 'live'
new_origin_x = x_origin + offset_x + (random_number_x / Range("x_fact").Value)
new_origin_y = y_origin + offset_y + (random_number_y / Range("y_fact").Value)
new_origin_z = y_origin + offset_z + (random_number_z / Range("z_fact").Value)
'variate = [{new_origin_x;new_origin_y};{speed_x;speed_y}]
'variate = [{new_origin_x;new_origin_z};{speed_x;speed_z}]
'see if boundaries are requested and if so, not met
'should be: going to meet at the current speed
If Not IsMissing(xyz_bounds) Then
Dim distant_from_bounds_x
Dim distant_from_bounds_y
Dim distant_from_bounds_z
Dim future_pos_x
Dim previous_dist_x
Dim previous_dist_y
Dim previous_dist_z
future_pos_x = new_origin_x + 3 * speed_x
Dim future_pos_y
future_pos_y = new_origin_y + 3 * speed_y
Dim future_pos_z
future_pos_z = new_origin_z + 3 * speed_z
distant_from_bounds_x = xyz_bounds / 2 - Abs(future_pos_x - xyz_bounds / 2)
distant_from_bounds_y = xyz_bounds / 2 - Abs(future_pos_y - xyz_bounds / 2)
distant_from_bounds_z = xyz_bounds / 2 - Abs(future_pos_z - xyz_bounds / 2)
previous_dist_x = xyz_bounds / 2 - Abs((x_origin + 3 * speed_x) - xyz_bounds / 2)
previous_dist_y = xyz_bounds / 2 - Abs((y_origin + 3 * speed_y) - xyz_bounds / 2)
previous_dist_z = xyz_bounds / 2 - Abs((z_origin + 3 * speed_z) - xyz_bounds / 2)
'slow down
If (distant_from_bounds_x < 10) And (distant_from_bounds_x - previous_dist_x < 0) Then
speed_x = speed_x - speed_x / 3
If Abs(speed_x) < 1.5 Then speed_x = -speed_x * 2.9
End If
If distant_from_bounds_y < 10 And (distant_from_bounds_y - previous_dist_y < 0) Then
speed_y = speed_y - speed_y / 3
If Abs(speed_y) < 1.5 Then speed_y = -speed_y * 2.9
End If
If distant_from_bounds_z < 10 And (distant_from_bounds_z - previous_dist_z < 0) Then
speed_z = speed_z - speed_z / 3
If Abs(speed_z) < 1.5 Then speed_z = -speed_z * 2.9
End If
'speedlimits
If Abs(speed_x) > 9 Then speed_x = speed_x - Abs(speed_x / 4)
If Abs(speed_y) > 9 Then speed_y = speed_y - Abs(speed_y / 4)
If Abs(speed_z) > 9 Then speed_z = speed_z - Abs(speed_z / 4)
End If
'return the values and the new velocity to add some more stuff
x_origin = new_origin_x
y_origin = new_origin_y
z_origin = new_origin_z
offset_x = speed_x
offset_y = speed_y
offset_z = speed_z
End Function
Any suggestions would be greatly appreciated !
If you can excuse my abrasiveness, you are misusing the generator:
1) At the beginning of your function, include the line
Rnd(-1)
That is how you seed the generator.
2) Remove all your Randomize calls as they are ruining the statistical properties of the generator. I think that is the cause of your problems. You can have one Randomize call directly after Rnd(-1) above, but I think it's nice to have the same sequence generated for tractability.
3) There is no need to have a parameter in your Rnd() calls (other than the first step), as the default behaviour is to return a number in the range [0, 1). In fact this could be causing your problems, since a negative parameter value re-seeds the generator!
4) Investigate the effects of doing the above. But be aware that the VBA random sequence is a linear congruential generator of the form next = ((c * prev) mod b) + a where a, b and c are constants, prev is the previous random number and next the generated one. (As a final flourish, the integer values next and prev are scaled to floating point numbers). You can see that there is possible autocorrelation in the sequence since when prev is small, the modulus will have no effect. You can but hope that the engineers at Microsoft have assigned a large value to c to circumvent this effect. This autocorrelation can cause "sticking" when using random numbers in a multidimensional situation.
(4) could therefore be causing your problem, and if it is, you need to switch to another generator. Let me know and we can make some suggestions on that front.
I've got a set of equations which I'd like to be repeated taking variables from the next row down for each of the columns at which each variable is located. I am a beginner, so my coding is probably not to scratch:
Sub Iteration()
Dim al, ab, ae As Double
Dim as1, as2 As Double
'etc
as1 = Range("CG7")
as2 = Range("CG8")
aA1 = Range("BQ7")
'etc
intCounter = 0
For intCounter = 1 To 10000
Let x = ((aN1 * 1000) - (as1 * aA1) + (as2 * aA2)) / (al * fc * ae * ab)
Let x2 = ((aN12 * 1000) - (as12 * aA12) + (as22 * aA22)) / (al2 * fc2 * ae2 * ab2)
Next
Sheets("Sheet1").Range("CJ7").Value = x
End Sub
I've done this for several variables which I've set as the range relative to each variable value. And then for the next row I've had to redo the whole equation and set the variables again for the next row down. Is there any way to set the variables (possibly with a relative cell reference?) which will skip to the cell in the next row for the next calculation? Consider also that there are 36 rows for calculation and about 9 variables!
If I understand you correctly, how about something like this:
Sub Iteration()
Dim al, ab, ae As Double
Dim as1, as2 As Double
'etc
intCounter = 0
For intCounter = 0 To 10000
as1 = Range("CG7").Offset(intCounter)
as2 = Range("CG8").Offset(intCounter)
aA1 = Range("BQ7").Offset(intCounter)
'etc
Let x = ((aN1 * 1000) - (as1 * aA1) + (as2 * aA2)) / (al * fc * ae * ab)
Let x2 = ((aN12 * 1000) - (as12 * aA12) + (as22 * aA22)) / (al2 * fc2 * ae2 * ab2)
Next
Sheets("Sheet1").Range("CJ7").Value = x
End Sub