I've run this code and click draw I've found a out of range problem And Debugger give me a highlight to this line Set coneobject = ThisDrawing.ModelSpace.AddCone(conecenter, coneradius, coneheight)
But this is no mistake for me
Can you suggest me ,please ?
Private Sub cmd_draw_Click()
UserForm1.Hide
Dim coneangle As Double
Select Case comboboxangle.Text
Case 0
coneangle = 15
Case 1
coneangle = 30
Case 2
coneangle = 45
Case 3
coneangle = 60
End Select
Drawcone coneangle
UserForm1.show
End Sub
Public Sub Drawcone(coneangle As Double)
Dim coneobject As Acad3DSolid
Dim conecenter As Variant
Dim coneheight As Double
'Dim coneangle As Double
Dim coneradius As Double
coneheight = UserForm1.TextBox1.Text
With ThisDrawing.Utility
conecenter = .GetPoint(, vbCr & "select position for Top of cone:")
End With
conecenter(2) = conecenter(2) - coneheight / 2#
coneradius = coneheight * Tan(coneangle)
'Set coneobject = ThisDrawing.ModelSpace.AddCone(conecenter, coneradius, coneheight)
Set coneobject = ThisDrawing.ModelSpace.AddCone(conecenter, coneradius, coneheight)
coneobject.Update
ThisDrawing.ChangeViewDirection
End Sub
Private Sub cmd_finish_Click()
Unload Me
End Sub
''Private Sub cmd_pickpoint_Click()
''UserForm1.Hide
''Dim conecenter As Variant
'With ThisDrawing.Utility
'conecenter = .GetPoint(, vbCr & "select position for Top of cone:")
'End With
'UserForm1.show
'End Sub
Private Sub UserForm_Initialize()
With comboboxangle
.AddItem "15"
.AddItem "30"
.AddItem "45"
.AddItem "60"
.Text = "Empty"
End With
End Sub
One possible issue is your use of the tan function: trigonomonetric functions such tan operate using angular values expressed in radians, not degrees.
As such, you will need to change:
coneradius = coneheight * Tan(coneangle)
to:
coneradius = coneheight * Tan(pi * (coneangle / 180#))
Using degrees will not cause the function to error (since you are still supplying a numerical value), but the value will be interpreted in radians and so will yield unexpected results (e.g. 15 degrees will be interpreted as 15 radians = 139.4 degrees).
Related
I have this code in a class module
Public WithEvents evtHandler As VBIDE.CommandBarEvents
Private Sub evtHandler_Click(ByVal CommandBarControl As Object, _
handled As Boolean, CancelDefault As Boolean)
On Error Resume Next
Application.Run CommandBarControl.OnAction
handled = True
CancelDefault = True
End Sub
I have this code in a module
Sub CommandBarComboBox_Create()
Dim cmdBar As commandBar: Set cmdBar = Application.VBE.CommandBars("Custom")
Dim arr As Variant: arr = Array("item_1", "item_2", "item_3")
Dim i As Byte
Dim newCtrl As CommandBarControl: Set newCtrl = cmdBar.Controls.Add(msoControlComboBox)
With newCtrl
.caption = "myList"
For i = LBound(arr) To UBound(arr)
.AddItem arr(i), i + 1
Next i
.OnAction = "'processSelection'"
.tag = "myTag"
End With
' Create event handler
Set MenuEvent = New VBE_cmdHandler
Set MenuEvent.evtHandler = Application.VBE.Events.CommandBarEvents(newCtrl)
EventHandlers.Add MenuEvent
End Sub
Sub processSelection()
Dim cmdBar As commandBar: Set cmdBar = Application.VBE.CommandBars("Custom")
Dim userChoice As Long: userChoice = cmdBar.Controls(2).ListIndex
Select Case userChoice
Case 1
Debug.Print "OPTION 1"
Case 2
Debug.Print "OPTION 2"
Case Else
Debug.Print "OPTION 3"
End Select
End Sub
This works just fine but I would like to change it, so when sub processSelection is called, it implicit knows the calling control, so I don't have to specify it.
How can it be done?
Regards
Elio Fernandes
I just found a way to solve my problem, using the tag property of the control.
I replaced the first 2 lines of code of the sub processSelecion with 3 new lines, but without the need to identify with command bar and which control was last used.
With tag property, I can find which control was last used and consequently which ListIndex item was selected by the user.
Sub processSelection()
Dim curTag$: curTag = Application.VBE.CommandBars.ActionControl.tag
Dim myControls As Object: Set myControls = Application.VBE.CommandBars.FindControls(tag:=curTag$)
Dim userChoice As Long: userChoice = myControls.item(1).ListIndex
Select Case userChoice
Case 1
Debug.Print "OPTION 1"
Case 2
Debug.Print "OPTION 2"
Case 3
Debug.Print "OPTION 3"
Case Else
Debug.Print "OTHER"
End Select
End Sub
I have created a user form that allows the user to change the various variables involved in pricing an option (Exercise Price, volatility..etc) along with allowing the user to change the simulations needed to arrive at the Price (or mean price in this case). However, I am unable to call the public subs within my code once I click the OK Button. Any suggestions on what I'm doing wrong would be greatly appreciated. [I have also included a picture of my user form below]
Option Explicit
Private cancel As Boolean
Public Function ShowInputsDialog(currentPrice As Single, _
exercisePrice As Single, riskfreeRate As Double, _
volatility As Single, duration As Single, simulation As Double) As Boolean
Call Initialize
Me.Show
If Not cancel Then
'Capture the other inputs.
currentPrice = txtCurrentPrice.Text
exercisePrice = txtExercisePrice.Text
riskfreeRate = txtRiskfreeRate.Text
volatility = txtVolatility.Text
duaration = txtDuration.Text
simulation = txtSimulation.Text
ShowInputsDialog = Not cancel
Unload Me
End Function
Public Sub ErrorCheck()
' Perform error checking for user inputs.
If IsNumeric(currentPrice) = False Or currentPrice < 0 Then
MsgBox ("Please enter a numeric value for the Current Price")
End If
If IsNumeric(exercisePrice) = False Or exercusePrice < 0 Then
MsgBox ("Please enter a positive numeric value for the exercise price")
End If
If IsNumeric(riskfreeRate) = False Then
MsgBox ("Please enter a numerical value for the risk-free rate")
End If
If IsNumeric(volatility) = False Then
MsgBox ("Please enter a numerical value for the Standard deviation")
End If
If IsNumeric(duration) = False Then
MsgBox ("Please enter a numerical valye for duration")
End If
End Sub
Public Sub Call_Eur(currentPrice As Single, _
exercisePrice As Single, riskfreeRate As Double, _
volatility As Single, duration As Single, simulation As Double)
Dim stockPrice As Single
Dim CallcashflowTermination As Single
Dim PutcashflowTermination As Single
Dim CalldiscountedValue As Double
Dim PutdiscountedValue As Double
Dim i As Integer
Dim CallMean As Double
Dim PutMean As Double
Dim arrayCallPrice() As Integer
Dim arrayPutPrice() As Integer
For i = 1 To simulation
' stock price
stockPrice = currentPrice * Exp((riskfreeRate - 0.5 * volatility ^ 2) * duration + volatility * Application.WorksheetFunction.Norm_Inv(Rnd(), 0, 1) * Sqr(duration))
' option cash flow at termination
CallcashflowTermination = Application.WorksheetFunction.Max(0, stockPrice - exercisePrice)
PutcashflowTerminatio = Application.WorksheetFunction.Funciton.Max(0, exercisePrice - stockPrice)
' discounted value of the option
CalldiscountedValue = CallcashflowTermination * Exp(-duration * riskfreeRate)
PutdiscountedValue = PutcashflowTermination * Exp(-duration * riskfreeRate)
arrayCallPrice(i) = CalldiscountedValue
arrayPutPrice(i) = PutdiscountedValue
CallMean = Application.WorsheetFunction.Average(arrayCallPrice)
PutMean = Application.WorksheetFunction.Average(arrayPutPrice)
Next i
MsgBox "The Call option price is " & CallMean & " the Put option price is " & PutMean
End Sub
Private Sub CmdCancel_Click()
Me.Hide
cancel = True
End Sub
Private Sub CmdOK_Click() '<--- ERROR!!!
Call Call_Eur(currentPrice As Single, _
exercisePrice As Single, riskfreeRate As Double, _
volatility As Single, duration As Single, simulation As Double)
End Sub
Private Sub UserForm_Click()
End Sub
BIG RED FLAG!!!!
When calling a subroutine. you need to pass values into it. Not redefine it's parameters.
Private Sub CmdOK_Click() '<--- ERROR!!!
Call Call_Eur(12.50, 13.43, 14, 33.56, 100, 13.67)
End Sub
I prefer removing the parenthesis and not using Call at all.
Private Sub CmdOK_Click() '<--- ERROR!!!
Call_Eur 12.50, 13.43, 14, 33.56, 100, 13.67
End Sub
I have a button and I pass String as parameter. If string parameter increase more that 255 characters, it doesn't get any value. If string parameter is less than 255 characters, it is working fine.
Here is my code:
Dim parameterText As String
parameterText = "First Parameter Value | Third Parameter Value | Third Parameter Value"
Dim AdviceItem As CommandBarButton
Set AdviceItem = CategoryItem.Controls.Add(msoControlButton, , , , True)
With AdviceItem
.Caption = adviceText
.Visible = True
.Parameter = strParameter
.OnAction = "myFunction"
End With
Sub myFunction()
Dim parameters() As String
ReDim parameters(3)
Dim parameterText As String
parameterText = Application.CommandBars.ActionControl.Parameter
'parameterText is blank if there are more than 255 characters passed from above function
MsgBox ("parameterText" & parameterText)
parameters() = Split(parameterText, "|")
End Sub
Can anybody suggest me how to achieve it?
Assuming that there is a limitation on the .parameter, you can bypass this by using an array to store the string you want to display.
Option Explicit
Public AllParameters(100) As String
Public AllAdviceTexts(100) as String
Sub defineParameters()
AllParameters(0) = "First Parameter Value"
AllParameters(1) = "Third Parameter Value "
AllParameters(2) = "Third Parameter Value "
'etc
'set advice texts here too
End Sub
Private Sub Workbook_Open()
Dim AdviceItem As CommandBarButton
Dim i As Integer
Call defineParameters
For i = 0 To 100
Set AdviceItem = CategoryItem.Controls.Add(msoControlButton, , , , True)
With AdviceItem
.Caption = AllAdviceTexts(i)
.Visible = True
.Parameter = i
.OnAction = "myFunction"
End With
Next i
End Sub
Sub myFunction()
Dim parameterText As String
Dim index As Integer
index = Application.CommandBars.ActionControl.Parameter
parameterText = AllParameters(index)
MsgBox ("parameterText" & parameterText)
End Sub
No its not. VB string type can hold data more than 255 character.
A variable-length string can contain up to approximately 2 billion (2^31) characters
A fixed-length string can contain 1 to approximately 64K (2^16) characters.
and for SPLIT you can try like below
Dim LString As String
Dim LArray() As String
LString = "foobar.com"
LArray = Split(LString, ".")
MsgBox LArray(0)
MsgBox LArray(1)
Note: https://msdn.microsoft.com/en-us/library/6x627e5f(v=vs.90).aspx
Try to use below code if you get some idea.
Function Over255()
Dim myArray(3) As String '<<<<< not variant
myArray(0) = String(300, "a")
myArray(1) = String(300, "b")
myArray(2) = String(300, "c")
myArray(3) = String(300, "d")
'Over255 = Application.Transpose(myArray())
Over255 = TR(myArray)
End Function
'like Application.Transpose...
Function TR(arrIn) As String()
Dim arrOut() As String, r As Long, ln As Long, i As Long
ln = (UBound(arrIn) - LBound(arrIn)) + 1
ReDim arrOut(1 To ln, 1 To 1)
i = 1
For r = LBound(arrIn) To UBound(arrIn)
arrOut(i, 1) = arrIn(r)
i = i + 1
Next r
TR = arrOut
End Function
I'm currently working on a project where I'll be selecting up to 5 items to compare to each other, with the results being displayed in up to a 5x5 dynamic grid. My objective is to have this grid be composed of command buttons such that the caption of each button is the percent similarity between the row and column items, and on clicking the button, the units that are common between the row and column items will be displayed in a message box.
I more or less know how to generate the actual array of buttons. However, everything I've read suggests that I need to create a class to handle the button clicks, since I don't feel like making 20 subroutines that all have the same code in them. I have not been able to get this class to work properly, and I could use some tips. Here's what I have so far.
In a class module named DynButton:
Public Withevents CBevents as MSForms.CommandButton
Private Sub CBevents_Click()
DisplayOverlappedUnits 'Sub that will display the units that are the same
'between items i and j- may use Application.Caller
End Sub
And in the userform itself:
Private Sub Userform_Initialize()
Dim NumItems as integer
Dim ComparisonArray() as DynButton
Dim ctlButton as MSForms.CommandButton
'QuestionList() is a public type that stores various attributes of the
'items I'm comparing.
'This code determines how many items were selected for comparison
'and resets the item array accordingly.
NumItems=0
For i=1 to 5
If QuestionList(i).Length>0 Then
NumItems=Numitems+1
QuestionList(NumItems)=QuestionList(i)
End If
Next
Redim ComparisonArray(1 to NumItems, 1 to NumItems)
For i = 1 to NumItems
For j=1 to NumItems
Set ctlButton=Me.Controls.Add("Forms.CommandButton.1", Cstr(i) & Cstr(j) & cb)
With ctlButton
.Height= CB_HEIGHT 'These are public constants defined elsewhere.
.Width= CB_WIDTH
.Top= TOP_OFFSET + (i * (CB_HEIGHT+ V_PADDING))
If i = j Then .visible = False
.Caption= CalculateOverlap(i,j) 'Runs a sub that calculates the overlap between items i and j
End With
Set ComparisonArray(i,j).CBevents = ctlButton
Next
Next
End Sub
Currently, I get a "Object with or Block variable not set" when I hit the Set ComparisonArray line, and I'm stymied. Am I just missing something in the class module? Thanks in advance for the help.
Edited to add: I tried to model the class code in part off of this article, but again I haven't got it to work yet. http://www.siddharthrout.com/index.php/2018/01/15/vba-control-arrays/
Private Sub Userform_Initialize()
Dim NumItems as integer
Dim ComparisonArray() as DynButton '<<<< should be a Global variable
As soon as Userform_Initialize completes, ComparisonArray() will go out of scope and no longer exist: you need to make that a Global variable in your form so it will be around to handle any events.
Your code seems correct and interesting. The only (bug) I could see is:
Redim ComparisonArray(1 to NumItems, 1 to NumItems)
...
Set ComparisonArray(i,j).CBevents = ctlButton
The problem is that your array holds null references. You have not created your DynButton objects yet. You must explicitly creat the objects in your array.
Redim ComparisonArray(1 to NumItems, 1 to NumItems)
For i = 1 to NumItems
For j = 1 to NumItems
Set ComparisonArray(i,j) = new DynButton
Next
Next
...
Set ComparisonArray(i,j).CBevents = ctlButton
Also, declare the array ComparisonArray as a member object of the form, not as a local variable in Form_Initialize.
Only copy paste
Option Private Module
Option Explicit
Private Const i_total_channels As Integer = 100
Sub createArrayOfbuttons()
Application.ScreenUpdating = False
f_create_buttons 5, 5, 30, 5, True
End Sub
Sub clearArrayOfButtos()
Application.ScreenUpdating = False
f_clear_array_of_buttons
End Sub
Private Function f_create_buttons(Optional posLeft As Integer = 0, Optional posTop As Integer = 0, _
Optional sizeSquare As Integer = 20, Optional distBetween As Integer, Optional buttonColor As Boolean = False)
'create customized buttons to channel choice.
Dim i_ch_amount_x As Integer
Dim i_ch_amount_y As Integer
Dim i_size_X 'size of square button
Dim i_size_Y 'size of square button
Dim i_stp_X As Integer 'step in X
Dim i_stp_Y As Integer 'step in Y
Dim i_dist_bte_buttons As Integer 'distance between buttons, in X and Y
Dim i_pos_ini_X As Integer 'initial position
Dim i_pos_ini_Y As Integer
Dim it_x As Integer 'iterator
Dim it_y As Integer 'iterator
Dim amount As Integer 'channel acumulator
Dim FO_color As Integer 'index from 1 to 12 to change background color of button
f_clear_array_of_buttons
i_pos_ini_X = posLeft
i_pos_ini_Y = posTop
'create dimensions of square
i_size_X = sizeSquare
i_size_Y = i_size_X 'to create a square Y need same size of X
'distance between squares
i_dist_bte_buttons = i_size_X + distBetween 'to shift distance change laste value of expression
i_stp_X = i_pos_ini_X
i_stp_Y = i_pos_ini_Y
i_ch_amount_x = Int(Sqr(i_total_channels)) 'total channels in switch (i_ch_amount_y * i_ch_amount_x)
i_ch_amount_y = i_ch_amount_x
amount = 1
FO_color = 1
For it_y = 1 To i_ch_amount_x
For it_x = 1 To i_ch_amount_y
f_create_button amount, i_stp_X, i_stp_Y, CSng(i_size_X), CSng(i_size_Y), FO_color
i_stp_X = i_stp_X + i_dist_bte_buttons
amount = amount + 1
If buttonColor Then
FO_color = FO_color + 1
End If
If FO_color > 12 Then 'return FO to 1
FO_color = 1
End If
Next it_x
i_stp_X = i_pos_ini_X
i_stp_Y = i_stp_Y + i_dist_bte_buttons
Next it_y
amount = 0
i_ch_amount_x = 0
i_ch_amount_y = 0
i_size_X = 0
i_size_Y = 0
i_stp_X = 0
i_stp_Y = 0
i_pos_ini_X = 0
i_pos_ini_Y = 0
i_dist_bte_buttons = 0
FO_color = 0
End Function
Private Function f_create_button(index As Integer, posLeft As Integer, posRight As Integer, _
Box_width As Single, Box_height As Single, Optional FO As Integer)
ActiveSheet.Shapes.AddShape(msoShapeRectangle, posLeft, posRight, Box_width, Box_height). _
Select
With Selection
.Name = "ch_" & index
.Text = index
.Font.Name = "Arial"
.Font.Bold = True
If FO = 9 Then
.Font.Color = vbWhite
Else
.Font.ColorIndex = xlAutomatic
End If
.Font.Size = 10
.Interior.Color = fiber_color(FO)
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
End Function
Public Function fiber_color(Optional FO As Integer = 1) As Long
'use with a index in FO from 1 to 12
Select Case FO
Case 1
fiber_color = 65280 'green
Case 2
fiber_color = 65535 'yellow
Case 3
fiber_color = 16777215 'white
Case 4
fiber_color = 16711680 'blue
Case 5
fiber_color = 255 'red
Case 6
fiber_color = 16711823 'violt
Case 7
fiber_color = 19350 'brown
Case 8
fiber_color = 13353215 'pink
Case 9
fiber_color = 0 'black
Case 10
fiber_color = 16711680 'cinza
Case 11
fiber_color = 32767 'orange
Case 12
fiber_color = 16776960 'aqua
Case Else
fiber_color = 65280 'verde
End Select
End Function
Private Function f_clear_array_of_buttons()
Dim i_ch_amount_x As Integer
Dim it As Integer
i_ch_amount_x = i_total_channels
On Error GoTo sair
If ActiveSheet.Shapes.Count <> 0 Then
For it = 1 To i_ch_amount_x
ActiveSheet.Shapes("ch_" & it).Delete
Next it
End If
sair:
i_ch_amount_x = 0
it = 0
End Function
I am trying to display a calculation into a TextBox, but having trouble with getting it to show. I want it to show once all input fields are true.
Public Class VehicleAudit
Private Sub Calculate()
Dim validMiles As Boolean = False
Dim validPercent As Boolean = False
Dim validAvg As Boolean = False
Dim inputtedMiles As Double
Dim inputtedPercent As Double
Dim inputtedAvgCost As Double
Dim servTruck As Integer
Try
inputtedMiles = Double.Parse(txtMilesDriven.Text)
inputtedPercent = Double.Parse(txtPercent.Text)
inputtedAvgCost = Double.Parse(txtAvgCost.Text)
Catch ex As FormatException
MessageBox.Show("Please enter all values and try again")
Return
End Try
Dim cal As String = FormatCurrency(Convert.ToString(inputtedAvgCost * inputtedMiles * (1.0 + inputtedPercent))) + " dollars."
ValidateBoxes(inputtedMiles, 0, 10000, "Miles must range from 0-10000.", validMiles)
ValidateBoxes(inputtedPercent, 0.1, 0.5, "Please enter percent from .10 to .50", validPercent)
ValidateBoxes(inputtedAvgCost, 0.25, 0.75, " Please enter Average cost from .25 to .75", validAvg)
If (validAvg And validMiles And validPercent) Then
Dim totalCost As Double
If boxVehicleSelect.SelectedIndex = 9 Then
servTruck = inputtedMiles / 100 'this way we lose precision using the integer, so values below 100s are dropped.
totalCost = servTruck * 15.46
Else
totalCost = inputtedAvgCost * inputtedMiles * (1.0 + inputtedPercent)
End If
End If
End Sub
Private Sub txtTotalCost_TextChanged(ByVal Calculate As String, e As EventArgs) Handles txtTotalCost.TextChanged
End Sub
You appear to already have a block that runs when all three values are "valid". Simply output that value at the bottom of it:
If (validAvg And validMiles And validPercent) Then
Dim totalCost As Double
If boxVehicleSelect.SelectedIndex = 9 Then
servTruck = inputtedMiles / 100 'this way we lose precision using the integer, so values below 100s are dropped.
totalCost = servTruck * 15.46
Else
totalCost = inputtedAvgCost * inputtedMiles * (1.0 + inputtedPercent)
End If
' Output the computed "totalCost" some where.
' Here I'm using a Textbox called "txtTotalCost":
txtTotalCost.Text = totalCost.ToString()
End If
Edit...
Also call your Calculate() method whenever one of your textboxes changes:
Private Sub TextChanged(sender As Object, e As EventArgs) Handles txtMilesDriven.TextChanged, txtAvgCost.TextChanged, txtPercent.TextChanged
Calculate()
End Sub
Note how all three textboxes are listed after the handles keyword.