Autocad Cartesian Graphing Calculator

screenshot_3-16-2016_1

just the bare rectangular graphing program.

module 1


Option Explicit
Public Xmin As Double
Public Xmax As Double
Public Xinc As Double

Public xlim As Double
Public ylim As Double

Public Drawmode As String
Public bln_excelmode As Boolean

Public acadApp As AcadApplication
Public acadDoc As AcadDocument

Sub draw_rect1()
'input equation from form
Dim strfunc As String
Call init_rect
strfunc = frm_rect.txt_a1.Value
Call draw_graph(strfunc)
End Sub

Sub draw_rect2()
'input equation from excel sheet
Dim rng As Range
Dim A As String
Dim strfunc As String

Call init_rect
A = frm_rect.txt_a2.Value
Set rng = Range(A)
strfunc = rng.Value
Call draw_graph(strfunc)

End Sub

Sub test_str()
'just for testing, input comes from form
Call connect_acad
Xmin = -6
Xmax = 6
Xinc = 0.1
Drawmode = "PLine"
Call draw_graph("-x^3 + 3*x^2 -x")
End Sub

Sub draw_graph(strfunc As String)
Dim X As Double, Y As Double
Dim i As Integer, numpts As Integer
Dim pt() As Double

numpts = (Xmax - Xmin) / Xinc 'number of line segments
numpts = numpts + 1   'one more pt than line segment
ReDim pt(1 To numpts * 2)  'store x and y for one pt

For i = 1 To numpts
X = Xmin + ((i - 1) * Xinc)
Y = eval_func(strfunc, X)
pt(i * 2 - 1) = X: pt(i * 2) = Y
Next i

Call finish_draw(pt)
End Sub

Function eval_func(ByVal strfunc As String, X As Double) As Double
On Error GoTo HandlError
Static errorcounter As Integer

strfunc = Replace(strfunc, "x", X, , , vbTextCompare)
eval_func = Evaluate(strfunc)

ExitHere:
Exit Function
'runtime error 13 type mismatch
HandlError:

If Err.number = 13 Then
MsgBox "type mismatch div by zero or bad equation"
eval_func = ylim + 1
errorcounter = errorcounter + 1

If errorcounter = 3 Then
MsgBox "errorcounter at 3 - exiting"
End
End If

End If
End Function

Sub finish_draw(pt() As Double)
Select Case Drawmode
 Case "PLine"
  Call draw_pline(pt)
 Case "Lines"
  Call draw_lines(pt)
 Case "LinesWLimits"
  Call draw_lines_wlimits(xlim, ylim, pt)
 Case "Points"
  Call draw_points(pt)
 End Select

If bln_excelmode Then
Call display_pt2(pt)
End If
End Sub

Sub init_rect()
'gets the form values
Xmin = frm_rect.txt_xmin
Xmax = frm_rect.txt_xmax
Xinc = frm_rect.txt_xinc

xlim = frm_rect.txt_Xlim
ylim = frm_rect.txt_Ylim
Drawmode = frm_rect.cbo_draw_mode.Value

If frm_rect.chkbox_excel_table = True Then
bln_excelmode = True
Else
bln_excelmode = False
End If

End Sub

Sub func_draw_mode()
'to fill the combo box on form
With frm_rect.cbo_draw_mode
.AddItem "PLine"
.AddItem "Lines"
.AddItem "LinesWLimits"
.AddItem "Points"
.Value = "PLine"
End With
End Sub

module 2


Option Explicit

Sub draw_pline(ByRef pt() As Double)
Dim plineobj As AcadLWPolyline
Set plineobj = acadDoc.ModelSpace.AddLightWeightPolyline(pt)
Update
End Sub

Sub draw_lines(ByRef pt() As Double)
Dim lineobj As AcadLine
Dim i As Integer, numpts As Integer, numlines As Integer
Dim x1 As Double, x2 As Double, y1 As Double, y2 As Double
Dim pt1(0 To 2) As Double
Dim pt2(0 To 2) As Double

numpts = UBound(pt) / 2
numlines = numpts - 1

For i = 1 To numlines
x1 = pt(i * 2 - 1)
y1 = pt(i * 2)
x2 = pt(i * 2 + 1)
y2 = pt(i * 2 + 2)

pt1(0) = x1: pt1(1) = y1: pt1(2) = 0
pt2(0) = x2: pt2(1) = y2: pt2(2) = 0
Set lineobj = acadApp.ActiveDocument.ModelSpace.AddLine(pt1, pt2)

Next i
Update
End Sub

Sub draw_lines_wlimits(xlim As Double, ylim As Double, ByRef pt() As Double)
Dim lineobj As AcadLine
Dim i As Integer, numpts As Integer, numlines As Integer
Dim x1 As Double, x2 As Double, y1 As Double, y2 As Double
Dim pt1(0 To 2) As Double
Dim pt2(0 To 2) As Double

numpts = UBound(pt) / 2
numlines = numpts - 1

For i = 1 To numlines
x1 = pt(i * 2 - 1)
y1 = pt(i * 2)
x2 = pt(i * 2 + 1)
y2 = pt(i * 2 + 2)

If Abs(x1) < xlim And Abs(y1) < ylim And Abs(x2) < xlim And Abs(y2) < ylim Then
pt1(0) = x1: pt1(1) = y1: pt1(2) = 0
pt2(0) = x2: pt2(1) = y2: pt2(2) = 0
Set lineobj = acadApp.ActiveDocument.ModelSpace.AddLine(pt1, pt2)
End If
Next i

Update
End Sub

Sub draw_points(ByRef pt() As Double)
Call pointmode
Dim pointobj As AcadPoint
Dim i As Integer, numpts As Integer
Dim x1 As Double, y1 As Double

Dim pt1(0 To 2) As Double
numpts = UBound(pt) / 2

For i = 1 To numpts
x1 = pt(i * 2 - 1)
y1 = pt(i * 2)
pt1(0) = x1: pt1(1) = y1: pt1(2) = 0
Set pointobj = acadDoc.ModelSpace.AddPoint(pt1)
Next i

Update
End Sub

Sub pointmode()
acadDoc.SetVariable "PDMODE", 35
acadDoc.SetVariable "PDSIZE", -3
End Sub

Sub erase_graph()
Call erase_layer("GRAPH")
Call erase_layer("Asymptote")
Call erase_layer("Focus")
Call erase_layer("Directrix")
End Sub

Sub erase_layer(strlayername As String)
Dim ent As AcadEntity
For Each ent In acadDoc.ModelSpace
If ent.Layer = strlayername Then
ent.Delete
End If
Next
Update
End Sub

Sub connect_acad()
 'Check if AutoCAD application is open. If is not opened create a new instance and make it visible.
    On Error Resume Next
    Set acadApp = GetObject(, "AutoCAD.Application")
    If acadApp Is Nothing Then
        'Set acadApp = CreateObject("AutoCAD.Application")
        Set acadApp = New AcadApplication
        acadApp.Visible = True
    End If

    'Check (again) if there is an AutoCAD object.
    If acadApp Is Nothing Then
        MsgBox "Sorry, it was impossible to start AutoCAD!", vbCritical, "AutoCAD Error"
        Exit Sub
    End If
    On Error GoTo 0

    'If there is no active drawing create a new one.
    On Error Resume Next
    Set acadDoc = acadApp.ActiveDocument
    If acadDoc Is Nothing Then
        Set acadDoc = acadApp.Documents.Add
        acadApp.Visible = True
    End If
    On Error GoTo 0

    'Check if the active space is paper space and change it to model space.
    If acadDoc.ActiveSpace = 0 Then '0 = acPaperSpace in early binding
        acadDoc.ActiveSpace = 1     '1 = acModelSpace in early binding
    End If
End Sub

Sub display_pt2(pt() As Double)
If ((UBound(pt) - LBound(pt) + 1) Mod 2) <> 0 Then
MsgBox "array not divisible by 2"
Exit Sub
End If

NewSht ("func_data_list_2")

Dim i As Integer
Dim NumRows As Integer
'expects LBound to be 1
NumRows = UBound(pt) / 2

For i = 1 To NumRows
Cells(i, 1) = pt(i * 2 - 1)
Cells(i, 2) = pt(i * 2)
Next i
End Sub

Sub NewSht(strSheetName As String)
  Application.DisplayAlerts = False
  On Error Resume Next
  Worksheets(strSheetName).Delete
  Worksheets.Add.Name = strSheetName
  Worksheets(strSheetName).Move after:=Worksheets(Worksheets.count)
  Worksheets(strSheetName).Activate
 End Sub

Advertisements

Leave a Reply

Fill in your details below or click an icon to log in:

WordPress.com Logo

You are commenting using your WordPress.com account. Log Out / Change )

Twitter picture

You are commenting using your Twitter account. Log Out / Change )

Facebook photo

You are commenting using your Facebook account. Log Out / Change )

Google+ photo

You are commenting using your Google+ account. Log Out / Change )

Connecting to %s