Related
I have written a macro which computes x and y values. I am having trouble trying to write those values to cells on Excel.
I get #VALUE error when I try to display the values on the cell.
I have added my code below. Any suggestion about what is wrong with the code will be really helpful and appreciated?
Thanks in advance!
'Compute Points
Function ComputePoints(x1, y1, x2, y2, distance) As Double
'Calculate slope m
Dim m As Double
m = (y2 - y1) / (x2 - x1)
'Calculate intercept
Dim Intercept As Double
Intercept = y1 - m * x1
'Calculate x for distFinal
Dim message As String
Dim a As Double
Dim b As Double
Dim c As Double
Dim root1 As Double
Dim root2 As Double
Dim det As Double
Dim det1 As Double
Dim wb As Workbook
Dim ws As Worksheet
Dim x1Rng As Range
Dim x2Rng As Range
Dim yRng As Range
a = (m ^ 2 + 1)
b = 2 * (Intercept * m - m * y2 - x2)
c = x2 ^ 2 + (Intercept - y2) ^ 2 - distance ^ 2
det = ((b ^ 2) - (4 * a * c))
det1 = Sqr(det)
message = "There is no solution to your equation"
If det < 0 Then
MsgBox message, vbOKOnly, "Error"
Else
root1 = Round((-b + det1) / (2 * a), 2)
root2 = Round((-b - det1) / (2 * a), 2)
End If
'Compute y
Dim y As Double
y = m * root2 + Intercept
' Trying to set cell values to root1, root2, y
Set wb = ActiveWorkbook
Set ws = wb.Sheets("Sheet9")
Set x1Rng = ws.Range("N2")
Set x2Rng = ws.Range("O2")
Set yRng = ws.Range("P2")
x1Rng.Value2 = root1
x2Rng.Value2 = root2
yRng.Value2 = y
ComputePoints = y
End Function
I modified your code slightly to get values directly in excel cells. You need to select 3 horizontal cells, press F2 / =, enter your formula and then press Ctrl Shift Enter to make it an array formula.
This will give you the three output values in the cells.
Function ComputePoints(x1, y1, x2, y2, distance)
Dim results(3) As Variant ' #nightcrawler23
'Calculate slope m
Dim m As Double
m = (y2 - y1) / (x2 - x1)
'Calculate intercept
Dim Intercept As Double
Intercept = y1 - m * x1
'Calculate x for distFinal
Dim message As String
Dim a As Double
Dim b As Double
Dim c As Double
Dim root1 As Double
Dim root2 As Double
Dim det As Double
Dim det1 As Double
a = (m ^ 2 + 1)
b = 2 * (Intercept * m - m * y2 - x2)
c = x2 ^ 2 + (Intercept - y2) ^ 2 - distance ^ 2
det = ((b ^ 2) - (4 * a * c))
det1 = Sqr(det)
message = "There is no solution to your equation"
If det < 0 Then
MsgBox message, vbOKOnly, "Error"
Else
root1 = Round((-b + det1) / (2 * a), 2)
root2 = Round((-b - det1) / (2 * a), 2)
End If
'Compute y
Dim y As Double
y = m * root2 + Intercept
results(1) = root1 ' #nightcrawler23
results(2) = root2 ' #nightcrawler23
results(3) = y ' #nightcrawler23
ComputePoints = results ' #nightcrawler23
End Function
You need to add some code to output error message, when no roots are found
I am using VBA for the first time. I started with a very basic code using Runga Kutta Method. I am not able to run it. Can I know where I am going wrong? Can you also post some solutions for this type of differential equation solvers?
Option Explicit
Dim K1 As Double
Dim K2 As Double
Dim K3 As Double
Dim K4 As Double
Dim y As Double
Dim x As Double
Dim dx As Double
Dim x0 As Integer
Dim y0 As Integer
Function f(x, y) As Double
f = 0.5 * x - 0.5 * y
End Function
Sub RK(x, y, dx)
Dim i As Integer
Dim ynew As Double
dx = 0.5
x0 = 0
y0 = 1
K1 = dx * f(x, y)
K2 = dx * f(x + dx / 2, y + K1 / 2)
K3 = dx * f(x + dx / 2, y + K2 / 2)
K4 = dx * f(x + dx, y + K3)
RK = y + ((K1 + 2 * (K2 + K3 + K4)) / 6)
For i = 0 To 6
ynew = RK(x, y, dx)
x = x + dx
y = ynew
Next i
For j = 1 To 6
Call RK(x, y, dx, ynew)
ActiveCell.Offset(i - 1, 1).Value = x
ActiveCell.Offset(i - 1, 2).Value = y
x = x + dx
y = ynew
Next
End Sub
You need to execute the RK procedure and give it the starting values of x, y and dx.
To do this from within the VBE (Visual Basic Editor) open the Immediate window. If it's not visible press Ctrl+G and it should appear at the bottom of the VBE.
In the Immediate window type something like RK 1, 3, 2 and the results will appear in the two columns to the right of the active cell and take up 6 rows.
If you want the procedure to execute on the press of a button, or when a value is updated you'll need to add an extra bit of code for that.
Edit:
Just noticed these lines - RK = y + ((K1 + 2 * (K2 + K3 + K4)) / 6) and ynew = RK(x, y, dx).
The RK procedure won't return a value and you can't set it as a value either.
This link may help explain it: http://what-when-how.com/excel-vba/vba-sub-and-function-procedures/
I'm trying to make a function in Lua or VB based code to
draw / plot an ellipse and also a filled ellipse.
I don't have much knowledge about this math and I can use some help.
I googled everything there is to google about drawing ellipses with code but I can't find a good simple working example that i can code into my Lua / VB code.
here are a few websites i visited but couldn't make the code work or couldn't convert the code to Lua or VB properly...
https://sites.google.com/site/ruslancray/lab/projects/bresenhamscircleellipsedrawingalgorithm/bresenham-s-circle-ellipse-drawing-algorithm
http://groups.csail.mit.edu/graphics/classes/6.837/F98/Lecture6/circle.html
http://www.blitzbasic.com/codearcs/codearcs.php?code=2817
http://hackipedia.org/Algorithms/Graphics/pdf/A%20Fast%20Bresenham%20Type%20Algorithm%20For%20Drawing%20Ellipses%20by%20John%20Kennedy.pdf
https://scratch.mit.edu/projects/49873666/
http://www.sourcecodesworld.com/source/show.asp?ScriptID=112
How do I draw an ellipse with arbitrary orientation pixel by pixel?
Can anyone help me make code that can draw an ellipse and a filled ellipse?
here is some code I tried to convert to Lua from here:
https://gist.github.com/Wollw/3291916
this code has some problems (missing pixels) and I think it's not converted properly but I don't know how to do it otherwise.
function plotEllipseRect(x0, y0, x1, y1)
-- values of diameter
a = math.abs(x1-x0)
b = math.abs(y1-y0)
b1 = 2.5
-- error increment
dx = 4*(1-a)*b*b
dy = 4*(b1+1)*a*a
-- error of 1.step
err = dx+dy+b1*a*a
-- e2 = 0
if (x0 > x1) then -- if called with swapped points
x0 = x1
x1 = x1 + a
end
if (y0 > y1) then -- .. exchange them
y0 = y1
end
-- starting pixel
y0 = y0 + (b+1)/2
y1 = y0-b1
a = a * 8*a
b1 = 8*b*b
repeat
dot(x1, y0) -- I. Quadrant
dot(x0, y0) -- II. Quadrant
dot(x0, y1) -- III. Quadrant
dot(x1, y1) -- IV. Quadrant
e2 = 2*err
if (e2 <= dy) then -- y step
y0 = y0 + 1
y1 = y1 - 1
dy = dy + a
err = err + dy
end
if (e2 >= dx or 2*err > dy) then -- x step
x0 = x0 + 1
x1 = x1 - 1
dx = dx + b1
err = err + dx
end
until (x0 >= x1)
while (y0-y1 < b) do -- too early stop of flat ellipses a=1
dot(x0-1, y0) -- -> finish tip of ellipse
y0 = y0 + 1
dot(x1+1, y0)
dot(x0-1, y1)
y1 = y1 - 1
dot(x1+1, y1)
end
end
[EDIT:]
I almost got it for the filled one!
see the comments in this code below to know what the problem is...
I use EGSL to test this Lua code:
http://www.egsl.retrogamecoding.org//pages/downloads.php
function DrawEllipse(xc,yc,w,h)
local w2 = w * w
local h2 = h * h
local fw2 = 4 * w2
local fh2 = 4 * h2
xc = xc + w
yc = yc + h
local x = 0
local y = h
local s = 2 * h2 + w2 * (1 - h)
while h2 * x <= w2 * y do
dot(xc + x, yc + y)
dot(xc - x, yc + y)
dot(xc + x, yc - y)
dot(xc - x, yc - y)
redraw()
inkey()
color(int(rnd()*255),int(rnd()*255),int(rnd()*255)) --random color to see changes
if s >= 0 then
s = s + fw2 * (1 - y)
y = y - 1
color(255,0,255)
line(xc + x, yc + y, xc - x, yc + y)
line(xc + x, yc - y, xc - x, yc - y)
end
s = s + h2 * ((4 * x) + 6)
x = x + 1
end
x = w
y = 0
s = 2 * w2 + h2 * (1 - w)
line(xc + x, yc + y, xc - x, yc + y) --to prevent the first line to be drawn twice
redraw()
inkey()
s = s + w2 * ((4 * y) + 6)
y = y + 1
while w2 * y < h2 * (x-2) do
line(xc + x, yc + y, xc - x, yc + y)
redraw()
inkey()
color(int(rnd()*255),int(rnd()*255),int(rnd()*255))
line(xc + x, yc - y, xc - x, yc - y)
redraw()
inkey()
color(int(rnd()*255),int(rnd()*255),int(rnd()*255))
if s >= 0 then
s = s + fh2 * (1 - x)
x = x - 1
end
s = s + w2 * ((4 * y) + 6)
y = y + 1
end
dot(xc + x, yc + y)
dot(xc - x, yc + y)
redraw()
inkey()
color(int(rnd()*255),int(rnd()*255),int(rnd()*255))
dot(xc + x, yc - y)
dot(xc - x, yc - y)
redraw()
inkey()
end
openwindow (70,70,32,"Resize Window")
color(255,255,0)
DrawEllipse(10,10,20,20) --works perfect!
inkey()
cls()
DrawEllipse(10,10,10,20) --problems with last 2 horizontal lines between the pixels!
inkey()
cls()
DrawEllipse(10,10,20,10) --works perfect to!
closewindow()
The following VB works for me, based on the first link provided; the only difference between mine here and the code at your link is I move xc and yc over, since you cannot can't have negative x or y values for the pixels in a bitmap.
Public Shared Function DrawEllipse(ByVal xc As Integer, ByVal yc As Integer, ByVal w As Integer, ByVal h As Integer, ByVal doFill As Boolean) As Drawing.Bitmap
Dim w2 As Integer = w * w
Dim h2 As Integer = h * h
Dim fw2 As Integer = 4 * w2
Dim fh2 As Integer = 4 * h2
// cheat by moving xc and yc so that we can handle quadrants
xc = w
yc = h
Dim bm As New Drawing.Bitmap(w2, h2)
// first half
Dim x As Integer = 0
Dim y As Integer = h
Dim s As Integer = 2 * h2 + w2 * (1 - h)
While h2 * x <= w2 * y
If doFill Then
For i As Integer = -y To y
bm.SetPixel(xc + x, yc + i, Drawing.Color.Red)
bm.SetPixel(xc - x, yc + i, Drawing.Color.Red)
Next
Else
bm.SetPixel(xc + x, yc + y, Drawing.Color.Red)
bm.SetPixel(xc - x, yc + y, Drawing.Color.Red)
bm.SetPixel(xc + x, yc - y, Drawing.Color.Red)
bm.SetPixel(xc - x, yc - y, Drawing.Color.Red)
End If
If s >= 0 Then
s += fw2 * (1 - y)
y -= 1
End If
s += h2 * ((4 * x) + 6)
x += 1
End While
// second half
x = w
y = 0
s = 2 * w2 + h2 * (1 - w)
While w2 * y <= h2 * x
If doFill Then
For i As Integer = -x To x
bm.SetPixel(xc + i, yc + y, Drawing.Color.Red)
bm.SetPixel(xc + i, yc - y, Drawing.Color.Red)
Next
Else
bm.SetPixel(xc + x, yc + y, Drawing.Color.Red)
bm.SetPixel(xc - x, yc + y, Drawing.Color.Red)
bm.SetPixel(xc + x, yc - y, Drawing.Color.Red)
bm.SetPixel(xc - x, yc - y, Drawing.Color.Red)
End If
If s >= 0 Then
s += fh2 * (1 - x)
x -= 1
End If
s += w2 * ((4 * y) + 6)
y += 1
End While
Return bm
End Function
(Aside: I used // instead of ' for the comments... just for readability here. If you copy to Visual Studio you'll have to fix that)
Ok, I managed to find a solution for the filled ellipse by checking
if the pixel from the second half is gonna be drawn in the x-range of the first half of the ellipse.
function drawellipse(xc, yc, w, h, dofill)
--trouble with the size, 1 pixel to large on x and y to...
w=w/2 --good solution for making it the right size?
h=h/2 --good solution for making it the right size?
local w2 = w * w
local h2 = h * h
local fw2 = 4 * w2
local fh2 = 4 * h2
-- cheat by moving xc and yc so that we can handle quadrants
xc = xc + w
yc = yc + h
-- first half
local x = 0
local y = h
local s = 2 * h2 + w2 * (1 - h)
while h2 * x <= w2 * y do
if dofill then
for i = -y , y do
color(0,255,0)
dot(xc + x, yc + i)
dot(xc - x, yc + i)
--redraw()inkey()
end
else
color(255,0,255)
dot(xc + x, yc + y)
dot(xc - x, yc + y)
dot(xc + x, yc - y)
dot(xc - x, yc - y)
--redraw()inkey()
end
if s >= 0 then
s =s+ fw2 * (1 - y)
y =y- 1
end
s =s+ h2 * ((4 * x) + 6)
x =x+ 1
end
color(255,0,255)
line(xc + x,0,xc - x,0)
test1 = xc + x
test2 = xc - x
print(test1 .. '/' .. test2)
redraw()inkey()
-- second half
x = w
y = 0
s = 2 * w2 + h2 * (1 - w)
while w2 * y <= h2 * x do
if dofill then
for i = -x , x do
if not(xc + i > test2 and xc + i < test1) then
color(255,255,0)
dot(xc + i, yc + y)
dot(xc + i, yc - y)
redraw()inkey()
end
end
else
color(0,255,255)
dot(xc + x, yc + y)
dot(xc - x, yc + y)
dot(xc + x, yc - y)
dot(xc - x, yc - y)
redraw()inkey()
end
if s >= 0 then
s =s+ fh2 * (1 - x)
x =x- 1
end
s =s+ w2 * ((4 * y) + 6)
y =y+ 1
end
end
In vb.net you have both Graphics.DrawEllipse and Graphics.DrawArc. In Lua you may be able to use Cairo which I know has a arc function.
If you where to make a ellipse in a GraphicsPath in .Net and where to reverse engineer how it is stored in memory, you would find out that it is stored as four bezier curves. I implemented my own graphics library in vb.net once, and that was how I did it. The best resource I found at the time where a implementation in Actionscript, that I unfortunately was unable to locate aswell as that graphics library I was talking about.
TLDR; You should have a look at bezier curves.
A completely different, and very simple take on this, although the ellipse doesn't seem as "pretty" as the other algorithms; this just uses the mathematical definition of an ellipse and, looping over x calculates the y coordinate given x, w, and h.
Public Shared Function DrawEllipse2(ByVal xc As Integer, ByVal yc As Integer, ByVal w As Integer, ByVal h As Integer, ByVal doFill As Boolean) As Drawing.Bitmap
Dim bm As New Drawing.Bitmap(w * w, h * h)
For x As Integer = xc - w To xc + w
Dim y As Integer = CInt((Math.Sqrt(1 - ((x * x) / (w * w)))) * h)
If doFill Then
For j As Integer = -y To y
bm.SetPixel(w + x, h + j, Drawing.Color.Red)
Next
Else
bm.SetPixel(w + x, h + y, Drawing.Color.Red)
bm.SetPixel(w + x, h - y, Drawing.Color.Red)
End If
Next
Return bm
End Function
I am a high school student working on a "home project" to animate a damped pendulum by solving differential equations using the Runge Kutta method.
(The equations can be seen here: http://www.maths.tcd.ie/~smurray/Pendulumwriteup.pdf)
I have been informed that in my code, my implementation of RK4 is not correct, and to be honest I have been struggling to understand it.
The program is written in VB.net 2010.
My code for solving the equations are as follows:
Public Sub RK4Solve(ByRef The As Decimal, ByRef Ome As Decimal, ByRef h As Decimal)
l1 = h * Ome
k1 = h * f(The, Ome, h)
l2 = h * (0.5 * l1) + Ome
k2 = f((The + (0.5 * h * k1)), (Ome + (0.5 * h * l1)), (t + (0.5 * h)))
l3 = h * (0.5 * l2) + Ome
k3 = f((The + (0.5 * h * k2)), (Ome + (0.5 * h * l2)), (t + (0.5 * h)))
l4 = h * l3 + Ome
k4 = f((The + (h * k3)), (Ome + (h * l3)), (t + h))
'Setting next step of variables
The = The + (h / 6 * (l1 + (2 * l2) + (2 * l3) + l4))
Ome = Ome + (h / 6 * (k1 + (2 * k2) + (2 * k3) + k4))
t += h
End Sub
I am aware that I am multiplying each step by too many h's - I am just lost on what is happening.
My full code:
Public Class Form1
Dim l As Decimal = 1 'Length of rod (1m)
Dim g As Decimal = 9.81 'Gravity
Dim w As Decimal = 0 ' Angular Velocity
Dim initheta As Decimal = -Math.PI / 2 'Initial Theta
Dim theta As Decimal = -Math.PI / 2 'Theta (This one changes for the simulation)
Dim t As Decimal = 0 'Current time of the simulation
Dim h As Decimal = 0.01 'Time step
Dim b As Decimal = Math.Sqrt(g / l) 'Constant used in the function for dw/dt
Dim k As Decimal = 0 'Coefficient of Damping
Dim initialx = l * Math.Sin(initheta) 'Initial Amplitude of the pendulum
Private Sub Form1_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
End Sub
'Function for dw/dt
Public Function f(ByRef the As Decimal, ByRef omega As Decimal, ByRef time As Decimal)
Return ((-b ^ 2) * Math.Sin(the)) - (k * omega) + (initheta * Math.Cos(omega * time))
End Function
Dim k1, k2, k3, k4, l1, l2, l3, l4 As Decimal 'Initialising RK4 variables
Public Sub RK4Solve(ByRef The As Decimal, ByRef Ome As Decimal, ByRef h As Decimal)
l1 = h * Ome
k1 = h * f(The, Ome, h)
l2 = h * (0.5 * l1) + Ome
k2 = f((The + (0.5 * h * k1)), (Ome + (0.5 * h * l1)), (t + (0.5 * h)))
l3 = h * (0.5 * l2) + Ome
k3 = f((The + (0.5 * h * k2)), (Ome + (0.5 * h * l2)), (t + (0.5 * h)))
l4 = h * l3 + Ome
k4 = f((The + (h * k3)), (Ome + (h * l3)), (t + h))
'Setting next step of variables
The = The + (h / 6 * (l1 + (2 * l2) + (2 * l3) + l4))
Ome = Ome + (h / 6 * (k1 + (2 * k2) + (2 * k3) + k4))
t += h
End Sub
'Timer ticking every 0.1s
'Time step is 0.01s to increase accuracy of results for testing
Private Sub Timer1_Tick(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Timer1.Tick
ComboBox1.Items.Add(theta) 'Adding theta to a drop down box to test data
RK4Solve(theta, w, h)
End Sub
Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button1.Click
Timer1.Enabled = False
End Sub
End Class
I have been trying to solve this for a while now, and I'm on my last legs so I am resorting to asking for help. Thanks to anyone that can!
It helps if you separate the differential equations from the RK4 implementation. Then you can implement RK4 as in the documentation
k1 = f1( y1, y2, x)
l1 = f2( y1, y2, x)
k2 = f1( y1 + 0.5*h*k1, y2 + 0.5*h*l1, x + 0.5*h)
l2 = f2( y1 + 0.5*h*k1, y2 + 0.5*h*l1, x + 0.5*h)
k3 = f1( y1 + 0.5*h*k2, y2 + 0.5*h*l2, x + 0.5*h)
l3 = f2( y1 + 0.5*h*k2, y2 + 0.5*h*l2, x + 0.5*h)
k4 = f1( y1 + h*k3, y2 + h*l3, x + h)
l4 = f2( y1 + h*k3, y2 + h*l3, x + h)
y1 = y1 + h/6*(k1+2*(k2+k3)+k4)
y2 = y2 + h/6*(l1+2*(l2+l3)+l4)
x = x + h
Not only does it help to avoid the duplication of the multiplication by h, but also the duplication of the addition of the base point values Ome and The.
I am getting a compile error in Excel VBA which says Expected Sub, Function or Property. The function I am using is given below which is trying to copy the rate function in Excel.
Thanks for your help.
Function rate_m(nper As Double, pmt As Double, pv As Double, fv As Double, types As Double, guess As Double) As Variant
Dim y, y0, y1, x0, x1, f, i As Double
Dim FINANCIAL_MAX_ITERATIONS As Double
Dim FINANCIAL_PRECISION As Double
If IsNull(guess) Then guess = 0.01
If IsNull(fv) Then fv = 0
If IsNull(types) Then types = 0
FINANCIAL_MAX_ITERATIONS = 128 'Bet accuracy with 128
FINANCIAL_PRECISION = 0.0000001 '1.0e-8
y , y0, y1, x0, x1, f, i = 0
rate_m = guess
If Abs(rate_m) < FINANCIAL_PRECISION Then
y = pv * (1 + nper * rate_m) + pmt * (1 + rate_m * types) * nper + fv
Else
f = Exp(nper * Log(1 + rate_m))
y = pv * f + pmt * (1 / rate_m + types) * (f - 1) + fv
y0 = pv + pmt * nper + fv
y1 = pv * f + pmt * (1 / rate_m + types) * (f - 1) + fv
End If
'find root by Newton secant method
i , x0 = 0
x1 = rate_m
While Abs(y0 - y1) > FINANCIAL_PRECISION & i < FINANCIAL_MAX_ITERATIONS
rate_m = (y1 * x0 - y0 * x1) / (y1 - y0)
x0 = x1
x1 = rate_m
If Abs(rate_m) < FINANCIAL_PRECISION Then
y = pv * (1 + nper * rate_m) + pmt * (1 + rate_m * types) * nper + fv
Else
f = Exp(nper * Log(1 + rate_m))
y = pv * f + pmt * (1 / rate_m + types) * (f - 1) + fv
End If
y0 = y1
y1 = y
i = i + 1
Wend
End Function
A couple things...
First, you have to assign each variable individually...like this:
y = 0
y0 = 0
y1 = 0
x0 = 0
x1 = 0
f = 0
i = 0
Second, you probably want to DIM your variables all as Double. Unfortunately, this line:
Dim y, y0, y1, x0, x1, f, i As Double
Only declares i as a Double, all the others will be a Variant. You need to declare each one individually, like this:
Dim y As Double
Dim y0 As Double
Dim y1 As Double
Dim x0 As Double
Dim x1 As Double
Dim f As Double
Dim i As Double
Every IF ends with a End If (unless in a single line) and While...loop. You might want to take a look at VBA's syntax:
http://msdn.microsoft.com/en-us/library/office/ee814737(v=office.14).aspx
EDIT: You have to declare variable individually, instead of:
y , y0, y1, x0, x1, f, i = 0
you could do:
y = 0
y0 = 0
y1 = 0
x0 = 0
x1 = 0
f = 0
i = 0