I have this code. Is intended to compare the first paragraph into a table's cell, and then do something with the rest of the paragraphs inside the cell
Sub Preguntas()
Dim Tbl As Table, Cl As Cell, tipo As Integer, para As Paragraph, contador As Integer, textop As String, textor As String, aux As String
Dim switchm As String
For Each Tbl In ActiveDocument.Tables
For Each Cl In Tbl.Range.Cells
'Variables a 0
tipo = 0
contador = 0
textop = ""
textor = ""
switchm = "</div><div class=""arrastrable palabra2"">"
'Andamos loas párrafos dentro de la celda
For Each para In Cl.Range.Paragraphs
<---------- THIS COMPARISON RETURNS ME ALWAYS FALSE-------->
If para.Range.Text = "RELACIONAR " Then
tipo = 3
Else
If para.Range.Text = "ARRASTRAR " Then
tipo = 2
Else
If para.Range.Text = "MANZANA-GUSANO " Then
tipo = 1
End If
End If
End If
<-----------------------END OF COMPARISON------------------->
Select Case tipo
Case 1
'Cogemos el párrafo como texto en aux
aux = para.Range.Text
'Realizarmos la llamada a Arrastra--USAMOS CALL PARA LLAMAR A PROCEDIMIENTOS QUE NO SEAN FUNCIONES
Call Manzana(textop, aux, contador)
'Incrementamos el contador
contador = contador + 1
Case 2
'Cogemos el párrafo como texto en aux
aux = para.Range.Text
'Realizarmos la llamada a Arrastra--USAMOS CALL PARA LLAMAR A PROCEDIMIENTOS QUE NO SEAN FUNCIONES
Call Arrastra(textop, textor, aux, contador, switchm)
'Incrementamos el contador
contador = contador + 1
Case 3
'Cogemos el párrafo como texto en aux
aux = para.Range.Text
'Realizarmos la llamada a Arrastra--USAMOS CALL PARA LLAMAR A PROCEDIMIENTOS QUE NO SEAN FUNCIONES
Call Relaciona(textop, textor, aux, contador)
'Incrementamos el contador
contador = contador + 1
End Select
Next para
'El texto de la celda lo cambiamos al transformado
Cl.Range.Text = textop + textor
'Volvemos el contador a 0
contador = 0
'Volvemos el tipo a 0
tipo = 0
'Fin párrafos celdas
Next Cl
Next Tbl
End Sub
'Funcion ARRASTRAR a HTML
Sub Arrastra(textop As String, textor As String, ByVal aux As String, ByVal contador As Integer, switchm As String)
Select Case contador
Case 0
textop = "<div class=""ejercicio_arrastrar""><div class=""comenzar_ejercicio_arrastrar"">Comenzar Actividad</div><div class=""content""><div class=""num_palabras_correctas""></div><span class=""texto_arrastra"">"
Case 1
textop = textop + aux + "</span><div class=""columnas""><div class=""parrafo palabra1""><div class=""texto"">"
Case 2
textop = textop + aux + "</div><div class=""suelta"" id=""sueltapalabra1""> arrastra...</div></div><div class=""parrafo palabra2""><div class=""texto"">"
Case 3
textor = textor + "<div class=""columna_der""><div class=""arrastrable palabra1"">" + aux
Case 4
textop = textop + aux + "</div><div class=""suelta"" id=""sueltapalabra2""> arrastra...</div></div><div class=""parrafo palabra3""><div class=""texto"">"
Case 5
switchm = switchm + aux + "</div></div><div class=""clear""></div><div class=""controls""><div class=""mensaje_feedback""></div><div class=""boton"">Comprobar</div></div></div></div>"
Case 6
textop = textop + aux + "</div><div class=""suelta"" id=""sueltapalabra3""> arrastra...</div></div></div>"
Case 7
textor = textor + "</div><div class=""arrastrable palabra3"">" + aux + switchm
End Select
End Sub
'Funcion RELACIONA a HTML
Sub Relaciona(textop As String, textor As String, ByVal aux As String, ByVal contador As Integer)
Select Case contador
Case 0
textop = "<div class=""ejercicio_unir""><div class=""comenzar_ejercicio"">Comenzar Actividad</div><div class=""content""><span class=""texto_arrastra"">"
Case 1
textop = textop + aux + "</span><!--------------- COLUMNA IZQUIERDA --------------><div class=""columna_izq""><!--------------- Frase --------------><div class=""frases""><div class=""texto""><span>"
Case 2
textor = textor + aux + "</span></div><div class=""clear""></div></div></div><div class=""clear""></div><div class=""controls""><div class=""mensaje_feedback""></div><div class=""boton"">Comprobar</div></div></div></div>"
Case 3
textop = textop + aux + "</span></div><div class=""cuadros""><input type=""text"" readonly=""readonly"" value=""1"" class=""pregunta match1""></div><div class=""clear""></div></div><!--------------- Frase --------------><div class=""frases""><div class=""texto""><span>"
Case 4
textor = "<!--------------------- COLUMNA DERECHA --------------------><div class=""columna_der""><!--------------- Frase --------------><div class=""frases""><div class=""cuadros""><input type=""text"" class=""respuesta match2""></div><div class=""texto""><span>" + aux + "</span></div><div class=""clear""></div></div><!--------------- Frase --------------><div class=""frases""><div class=""cuadros""><input type=""text"" class=""respuesta match1""></div><div class=""texto""><span>" + textor
Case 5
textop = textop + aux + "</span></div><div class=""cuadros""><input type=""text"" readonly=""readonly"" value=""2"" class=""pregunta match2""></div><div class=""clear""></div></div></div>"
End Select
End Sub
'Funcion MANZANA-GUSANO a HTML
Sub Manzana(textop As String, ByVal aux As String, ByVal contador As Integer)
Select Case contador
Case 0
textop = "<b>Arrastra la solución correcta al cubo</b><div class=""ee_logo""></div><div class=""ee_pregunta_arrastrar""><div class=""ee_enunciado""><b>"
Case 1
textop = textop + aux + "</b></div><div class=""ee_respuesta"">"
Case 2
textop = textop + aux + "</div><div class=""ee_respuesta ee_correcta"">"
Case 3
textop = textop + aux + "</b></div><div class=""ee_respuesta"">"
Case 4
textop = textop + aux + "</b></div><div class=""ee_feedback"">"
Case 5
textop = textop + aux + "</div></div>"
End Sub
The first paragraph(copypasted) from one of the cells is "ARRASTRAR ", so they should be true in some moment, but it's always false
Does Someone know why?
Solved. para.Range.Text comes with a weird character at the end, which resembles to an space but it isn't
So I did MID(para.Range.Text,1,Len(para.range.text)-2) for removing the last 2 characters(CR and LF I think). This way you only compare the phrase or word
Related
I am a beguinner in Access so I need your help with this.
I am try making a "Gannt Chart" and to do that I create some objects by code, but when I do that I can't get the atributes of the event, see
Option Compare Database
Function teste()
MsgBox ("Foi")
End Function
Function gannt()
Dim shpBox As Rectangle
DoCmd.OpenForm "Formulário3", acDesign
Set shpBox = Application.CreateControl("Formulário3", acRectangle, acDetail, "", "", 500, 500, 2000, 500)
shpBox.name = "Objeto1"
shpBox.Visible = True
shpBox.onMouseDown = "=teste()"
DoCmd.OpenForm "Formulário3", acNormal
End Function
The procedure of event has this declaration:
Private Sub Objeto1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
I think that one of solution is getting a mouse position by code, but I don't have a code to do this and probabily this code will bring an absolute position of the mouse.
after thinking a lot I came up with a solution.
First I had create the objects by code assigment public functions to events of MouseDown, MouseUp and MouveMove.
I've declared the public Vars
drag: The object received MouseDown Event
cod_manut: Name of the object
data_manut: Date of the start of maintenance
Option Compare Database
Option Explicit
Public drag(500) As Long
Public cod_manut(500) As Integer
Public data_manut(500, 2) As Date
Public valorX As Long '
Public valorY As Long '
Public clickX As Long '
Public clickY As Long '
Public offset As Long '
Function to populate the Form with the Gannt Objects:
Function gant()
Dim shpBox As Rectangle
Dim inicio As Integer
Dim distancia As Integer
Dim i As Integer
Dim d As Date
Dim aux As Integer
Dim entrada As Integer
Dim largura As Integer
Dim tabela As Recordset
Dim sql As String * 2048
sql = "SELECT [Programadas + status].Código, [Programadas + status].Entrada, [Programadas + status].Saida " _
& "FROM [Programadas + status] " _
& "WHERE ((([Programadas + status].Entrada) < #12/31/2020#) And (([Programadas + status].Saida) >= #1/1/2020#) And (([Programadas + status].Local) = 'SOD')) " _
& "ORDER BY [Programadas + status].Entrada, [Programadas + status].Saida;"
Set tabela = CurrentDb.OpenRecordset(sql)
i = 100
While (Not tabela.EOF)
cod_manut(i) = tabela.Fields("Código").value
d = tabela.Fields("Entrada").value
If (d < #1/1/2020#) Then
d = #1/1/2020#
End If
data_manut(i, 0) = d
d = tabela.Fields("Saida").value
If (d > #12/31/2020#) Then
d = #12/31/2020#
End If
data_manut(i, 1) = d
i = i + 1
tabela.MoveNext
Wend
DoCmd.OpenForm "Formulário4", acDesign
inicio = 1350
distancia = 408
'Set shpBox = Forms!Formulário4!Caixa0
For i = 100 To 173
aux = DateDiff("d", #1/1/2020#, data_manut(i, 0))
entrada = (aux \ 7) * 510 + (aux Mod 7) * 72
aux = DateDiff("d", data_manut(i, 0), data_manut(i, 1))
largura = aux * 72
Set shpBox = Application.CreateControl("Formulário4", acRectangle, acDetail, "", "", entrada, inicio + distancia * (i - 100), largura, 300)
shpBox.name = Replace(Str(i), " ", "")
shpBox.BackColor = 13998939
shpBox.BackStyle = 1
shpBox.Visible = True
shpBox.onMouseDown = Replace("=funcA(""" & Str(i) & """)", " ", "")
shpBox.onMouseUp = Replace("=funcB(""" & Str(i) & """)", " ", "")
shpBox.OnMouseMove = Replace("=funcC(""" & Str(i) & """)", " ", "")
Next i
DoCmd.OpenForm "Formulário4", acNormal
End Function
Function Events
Function funcA(id As String)
Dim b As Integer
Dim i As Integer
Dim nome As String
For i = 0 To 200
nome = (Forms!Formulário4.Controls(i).name)
If nome = id Then
Exit For
End If
Next
b = Get_Cursor_Pos()
clickX = ((valorX - offset) * 15) - Forms!Formulário4.Controls(i).Left
'clickY = (valorX - offset) * 15
drag(i) = True
End Function
Function funcB(id As String)
Dim b As Integer
Dim i As Integer
Dim nome As String
b = Get_Cursor_Pos()
For i = 0 To 200
nome = (Forms!Formulário4.Controls(i).name)
If nome = id Then
Exit For
End If
Next
drag(i) = False
End Function
Function funcC(id As String)
Dim aux As Integer
Dim i As Integer
Dim posX As Integer
Dim posX2 As Integer
Dim nome As String
Dim inicio As Integer
Dim fim As Integer
Dim X As Integer
Dim Y As Integer
inicio = 0
fim = 28720 - 1180
aux = Get_Cursor_Pos()
X = (valorX - offset) * 15
Y = (valorX - offset) * 15
For i = 0 To 200
nome = (Forms!Formulário4.Controls(i).name)
If nome = id Then
Exit For
End If
Next
aux = 0
If drag(i) = True Then 'And Button = acLeftButton Then
'If Shift = acShiftMask Then
posX2 = X - clickX
If Abs(posX2 - posX) > 72 Then
posX = ((posX2 - posX) \ 72) * 72 + posX + 3
posX = posX + (posX \ 504) * 6
End If
'Else
' posX = X - clickX
'End If
If posX < inicio Then
posX = inicio
ElseIf (posX + Forms!Formulário4.Controls(i).Width) > fim Then
posX = fim - Forms!Formulário4.Controls(i).Width
End If
Forms!Formulário4.Controls(i).Left = posX
Forms!Formulário4.mouse1.Caption = ((posX \ 510)) * 7 + (posX - ((posX \ 510) * 510) - 3) \ 72
Forms!Formulário4.Mouse2.Caption = (posX \ 510) + 1
End If
End Function
I had to use this code to get the absolute mouse position, but was necessary do the conversion to use this value
Note.: This value was in pixel, I need to multiply to 15 to get it in twips.
' Access the GetCursorPos function in user32.dll
Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
' Access the GetCursorPos function in user32.dll
Declare PtrSafe Function SetCursorPos Lib "user32" (ByVal X As Long, ByVal Y As Long) As Long
' GetCursorPos requires a variable declared as a custom data type
' that will hold two integers, one for x value and one for y value
Type POINTAPI
X_Pos As Long
Y_Pos As Long
End Type
' Main routine to dimension variables, retrieve cursor position,
' and display coordinates
Function Get_Cursor_Pos()
' Dimension the variable that will hold the x and y cursor positions
Dim Hold As POINTAPI
' Place the cursor positions in variable Hold
GetCursorPos Hold
' Display the cursor position coordinates
valorX = Hold.X_Pos ' \ 15 ' Transform to twips
valorY = Hold.Y_Pos ' \ 15 ' Transform to twips
End Function
And finally I create an object with the defalt arguments of the MouseEvent to the the incremental value of the X and calculate the necessary offset to use:
Private Sub calibracao_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim aux As Integer
aux = Get_Cursor_Pos()
offset = valorX - (X \ 15) ' To Twips
Forms!Formulário4!mouse1.Caption = X ' Twips
Forms!Formulário4.Mouse2.Caption = (valorX - offset) * 15 ' - offset
End Sub
This was the final result:
Gannt Chart
After I drag the manut
Note: I can not make to the file available, because there are confidentially informations.
Thanks for everone that have read and probabily think about a solution, excuse me for some English mistakes.
I want to convert selected item in combobox into a number and calculate it.
I got message like this when i try to start my vb.net program.
Conversion from string "< 20 " to type 'Integer' is not valid
Any help is greatly appreciated.
this is my code:
Private Sub SaveBtn_Click(sender As Object, e As EventArgs) Handles SaveBtn.Click
Dim LHR As Integer
Dim TipeRetak As Integer
Dim LbRetak As Integer
Dim LuKer As Integer
Dim Alur As Integer
Dim Tambal As Integer
Dim Kasar As Integer
Dim amblas As Integer
Select Case ComboLHR.SelectedIndex
Case "< 20 "
LHR = 0
Case "20 - 50"
LHR = 1
Case "50 - 200"
LHR = 2
Case "200 - 500"
LHR = 3
Case "500 - 2000"
LHR = 4
Case "2000 - 5000"
LHR = 5
Case "5000 - 20000"
LHR = 6
Case "20000 - 50000"
LHR = 7
Case "> 50000"
LHR = 8
End Select
Select Case ComboTipeRetak.SelectedIndex
Case "Buaya"
TipeRetak = 5
Case "Acak"
TipeRetak = 4
Case "Melintang"
TipeRetak = 3
Case "Memanjang"
TipeRetak = 1
Case "Tidak Ada"
TipeRetak = 1
End Select
Select Case ComboLebarRetak.SelectedIndex
Case "> 2 mm"
LbRetak = 3
Case "1 - 2 mm"
LbRetak = 2
Case "< 1 mm"
LbRetak = 1
Case "Tidak Ada"
LbRetak = 0
End Select
Select Case ComboLuasKerusakan.SelectedIndex
Case "> 30%"
LuKer = 3
Case "10 - 30%"
LuKer = 2
Case "< 10%"
LuKer = 1
Case "0"
LuKer = 0
End Select
Select Case ComboKedalamanAlur.SelectedIndex
Case "> 20 mm"
Alur = 7
Case "11 - 20 mm"
Alur = 5
Case "6 - 10 mm"
Alur = 3
Case "0 - 5 mm"
Alur = 1
Case "Tidak Ada"
Alur = 0
End Select
Select Case ComboTambal.SelectedIndex
Case ">30 %"
Tambal = 3
Case "20 - 30 %"
Tambal = 2
Case "10 - 20%"
Tambal = 1
Case "< 10%"
Tambal = 0
End Select
Select Case ComboKekasaran.SelectedIndex
Case "Desintegration"
Kasar = 4
Case "Pelepasan Butir"
Kasar = 3
Case "Rough(Hungry)"
Kasar = 2
Case "Fatty"
Kasar = 1
Case "Close Texture"
Kasar = 0
End Select
Select Case ComboAmblas.SelectedIndex
Case "> 5/100 m"
amblas = 4
Case "2 - 5/100 m"
amblas = 2
Case "0 - 2/100 m"
amblas = 1
Case "Tidak Ada"
amblas = 0
End Select
Dim comand As New MySqlCommand("INSERT INTO `tb_bnkt`(`nomor`, `Nama`, `kondisi prioritas`) VALUES (#nomor,#NamaRuas,#kondisi)", Connector)
comand.Parameters.Add("#nomor", MySqlDbType.VarChar).Value = TextNomor.Text
comand.Parameters.Add("#NamaRuas", MySqlDbType.VarChar).Value = ComboNamaRuas.Text
comand.Parameters.Add("#kondisi", MySqlDbType.VarChar).Value = 17 - (Val(LHR + TipeRetak + LbRetak + LuKer + Alur + Tambal + Kasar + amblas))
If comand.ExecuteNonQuery() = 1 Then
MessageBox.Show("Data disimpan")
Loading()
TextNomor.Clear()
ComboNamaRuas.Text = String.Empty
ComboLHR.Text = String.Empty
ComboTipeRetak.Text = String.Empty
ComboLebarRetak.Text = String.Empty
ComboLuasKerusakan.Text = String.Empty
ComboKedalamanAlur.Text = String.Empty
ComboTambal.Text = String.Empty
ComboKekasaran.Text = String.Empty
ComboAmblas.Text = String.Empty
Else
MessageBox.Show("Error")
End If
End Sub
With simple class and data-binding you can simplify your code a little bid and get rid of current problem as well.
Public Class MyItem
Public ReadOnly Name As String
Public ReadOnly Value As Integer
Public Sub New(name As String, value As Integer)
Me.Name = name
Me.Value = value
End Sub
End Class
' Then in constructor create collection of values and bind it ot the combobox
Dim LHRValues As New List(Of MyItem) From
{
New MyItem("< 20 ", 0),
New MyItem("20 - 50", 1),
New MyItem("50 - 200", 2),
New MyItem("200 - 500", 3),
New MyItem("500 - 2000", 4),
New MyItem("2000 - 5000", 5),
New MyItem("5000 - 20000", 6),
New MyItem("20000 - 50000", 7),
New MyItem("> 50000", 8)
}
ComboLHR.DisplayMember = "Name" ' Property Name will be used as a text
ComboLHR.ValueMember = "Value" ' Property Value will be used as a value
ComboLHR.DataSource = LHRValues
' Then in the code where you need selected value
Private Sub SaveBtn_Click(sender As Object, e As EventArgs) Handles SaveBtn.Click
Dim selectedLHR As Integer = DirectCast(ComboLHR.SelectedValue, Integer)
' Other selected values
End Sub
You only need to cast ComboLHR.SelectedValue to the type you expect (Integer), because SelectedValue is of type object. I hope you have Option Strict set On.
I hope my title is clear. Let me explain. I have 4 buttons that do pretty much the same.
Private Sub Button2_Click(sender As Object, e As EventArgs) Handles Button2.Click
LimiteGlobalSeparador = InputBox("Introduzca la distancia máxima entre huecos en el tubo", "Cuadro de Datos, Separaciones", "")
Dim a, b, c, d, f, g As New Label
Dim o, p, q, r, s, t As New Label
a.Text = "Medida del Tubo"
b.Text = "Espacio 1"
c.Text = "Espacio 2"
d.Text = "Espacio 3"
f.Text = "Espacio 4"
g.Text = "Espacio 5"
For i = 0 To 5
TableLayoutPanel1.Controls.Add(a, 0, i)
Next
If TextBox1.Text <> 0 Then
For j = 1 To Int(TextBox1.Text)
Dim x As New List(Of Decimal)
x = MedTuboFuncPCT()
For i = 0 To x.Count - 1
Dim lbl As New Label
lbl.Text = Math.Round(x(i), 2)
TableLayoutPanel1.Controls.Add(lbl, j, i)
Next
ContadorGlobal = ContadorGlobal + 1
Next
Else
End If
ContadorGlobal = 0
Dim h As Integer
h = Int(TextBox2.Text - TextBox1.Text)
If TextBox2.Text <> 0 Then
If h = Int(TextBox2.Text) Then
For j = 1 To Int(TextBox2.Text)
Dim x As New List(Of Decimal)
x = MedTuboFunCTCT()
For i = 0 To x.Count - 1
Dim lbl As New Label
lbl.Text = Math.Round(x(i), 2)
TableLayoutPanel1.Controls.Add(lbl, j, i)
Next
ContadorGlobal = ContadorGlobal + 1
Next
Else
ContadorGlobal = 0
For j = Int(1) + Int(TextBox1.Text) To (Int(TextBox1.Text) + Int(TextBox2.Text))
Dim x As New List(Of Decimal)
x = MedTuboFunCTCT()
For i = 0 To x.Count - 1
Dim lbl As New Label
lbl.Text = Math.Round(x(i), 2)
TableLayoutPanel1.Controls.Add(lbl, j, i)
Next
ContadorGlobal = ContadorGlobal + 1
Next
End If
End If
ContadorGlobal = 0
If TextBox3.Text <> 0 Then
Dim x As New List(Of Decimal)
x = MedTuboFuncPP()
For i = 0 To x.Count - 1
Dim lbl As New Label
lbl.Text = Math.Round(x(i), 2)
TableLayoutPanel1.Controls.Add(lbl, 1, i)
Next
End If
If Te180 > 0 Then
o.Text = "Medida del Tubo"
p.Text = "Espacio 1"
q.Text = "Espacio 2"
r.Text = "Espacio 3"
s.Text = "Espacio 4"
t.Text = "Espacio 5"
For i = 6 To 11
TableLayoutPanel1.Controls.Add(o, 0, i)
Next
End If
End Sub
So I'm trying to create a Sub and then each button call that sub, so I don't have repeating code in each button like I have now. The only change is here:
One button calls this function. x = MedTuboFuncPCT().
Another one calls x = MedTuboFuncPCTVid()
Another one calls x = MedTuboFuncPCTVidBB()
I don't know how to make a Sub in which I can make this difference. Hope I'm clear enough. Thanks in advance.
Create your function and send a value in it so you can change the x function
Private Sub Button1_Click(sender As Object, e As EventArgs) Handles Button1.Click
VFunction = 1
RepeatedCode(VFunction)
End Sub
On Button2 VFunction = 2 and so on. Then create your function.
Public Sub RepeatedCode (ByVal VFunction as integer)
If VFunction = 1 Then
x = MedTuboFuncPCT()
ElseIf VFunction = 2 Then
x = MedTuboFuncPCTVid()
ElseIf VFunction = 3 Then
x = MedTuboFuncPCT()
End If
'The Rest of your code
I belive the If condition must be placed inside your If TextBox1.Text <> 0
Since it its the only place where I see you used one of the Functions you mentioned
I am new to VBA, I am getting this Error 13 - types mismtached but I have no idea why and I found nothing helpful...
any hint ? (Sorry it's in french)
Function EIDPA(Coût_actif, Tx_dépréciation, Tx_marginal, Coût_opportunité)
EIDPA = ((Coût_actif * Tx_dépréciation * Tx_marginal) / (Coût_opportunité + Tx_dépréciation)) * ((1 + (0.5 * Coût_opportunité)) / (1 + Coût_opportunité))
End Function
Sub EIDPA2()
Coût_actif = InputBox("Entrez le coût de l'actif SVP", "Calculateur", "100000")
Tx_dépréciation = InputBox("Entrez le taux de dépréciation pour ammortissement SVP", "Calculateur", "0.30")
Tx_marginal = InputBox("Entrez le taux marginal d'imposition SVP", "Calculateur", "0.50")
Coût_opportunité = InputBox("Entrez le coût d'opportunité applicable SVP", "Calculateur", "0.05")
MsgBox "La valeur actuelle des économies d'impôts est de: " _
& Module1.EIDPA(Coût_actif, Tx_dépréciation, Tx_marginal, Coût_opportunité) & "$", vbInformation, "Calculateur"
End Sub
You should be properly Dimming your variables; otherwise you're attempting to use string variables as numerics:
Function EIDPA(Coût_actif As Double, Tx_dépréciation As Double, Tx_marginal As Double, Coût_opportunité As Double) As Double
EIDPA = ((Coût_actif * Tx_dépréciation * Tx_marginal) / (Coût_opportunité + Tx_dépréciation)) * ((1 + (0.5 * Coût_opportunité)) / (1 + Coût_opportunité))
End Function
Sub EIDPA2()
Dim Coût_actif As Double
Dim Tx_dépréciation As Double
Dim Tx_marginal As Double
Dim Coût_opportunité As Double
Coût_actif = CDbl(InputBox("Entrez le coût de l'actif SVP", "Calculateur", "100000"))
Tx_dépréciation = CDbl(InputBox("Entrez le taux de dépréciation pour ammortissement SVP", "Calculateur", "0.30"))
Tx_marginal = CDbl(InputBox("Entrez le taux marginal d'imposition SVP", "Calculateur", "0.50"))
Coût_opportunité = CDbl(InputBox("Entrez le coût d'opportunité applicable SVP", "Calculateur", "0.05"))
MsgBox "La valeur actuelle des économies d'impôts est de: " _
& Module1.EIDPA(Coût_actif, Tx_dépréciation, Tx_marginal, Coût_opportunité) & "$", vbInformation, "Calculateur"
End Sub
You're getting an error because InputBox returns strings, and you're trying to multiply strings together here:
EIDPA = ((Coût_actif * Tx_dépréciation * Tx_marginal) / (Coût_opportunité + Tx_dépréciation)) * ((1 + (0.5 * Coût_opportunité)) / (1 + Coût_opportunité)).
Try declaring your French variables as integers/floating point to see if that helps. More info
I've implemented two functions in VBA
formatAddress()
gets an address (String) and returns an array of Strings, each of these has a section of street address. xample: [via] [n:civico][citta].. ecc
getPoint
it use the returned array of formatAddress() function for calculate geographics coordinates that will put on a courrent cells. the 2. calls the 1. every street address to calculate.
While script is running, every call of 2. the RAM used by MapPoint encrease like as exponential, until to freeze the script execution with 810MB RAM used, and return an error code as Tipical Microsoft style, generic error without documentation. "Si è verificato un errore generato dal sistema o da un componente esterno" "An error ocurred, it was generated by system or by an external component"
I looked for in to Microsoft references http://msdn.microsoft.com/en-us/library/aa723478
if exist a way to manage this error ( I guess that every call, the courrent calculus doesn't dischard of the memory ) without results.
Option Explicit
MIMO V 1.0 project Script VBA Data Manager Script
' Script Purpose
'
' This script was implemented for merge two specific Tables of in one.
' the methods and functions use a supplementary software is called
' Microsoft MapPoint 2010, fundamental to calculate extra data that
' will add at the merged table.
'
' Scopo dello script
'
' questo script è stato scritto per fondere due tabelle specifiche in una.
' i metodi e le funzioni usano un software supplementare chiamato
' Microsoft Map Point 2010, fondamentale percalcolare i dati aggiuntivi che
' verranno aggiunti alla tabella prodotta.
Const startColumn As Integer = 1
Const rowStart As Integer = 3 'per passare dagli'indici agli elementi
Const cellBlank As String = "" 'per identificare le celle vuote
' le seguenti te istruzioni avviano MapPoint
Dim App As New MapPoint.Application
Dim map As MapPoint.map
Dim route As MapPoint.route
'index of the columns to copy: function joinTables()
Const ADDR As Integer = 11 ' indirizzo tab clienti
Const ID2 As Integer = 6 ' codice Agenzia tab Agenzie
Const ADDA As Integer = 9 ' indirizzo tab agenzia
Const CAPA As Integer = 10 ' CAP Agenzia
Const CITTA As Integer = 12 ' Citta Agenzia
Const PROVA As Integer = 14 'Provincia Agenzia
Const LONA As Integer = 25 ' Logitudine agenzia
Const LATA As Integer = 26 ' latitudine agenzia
Const CID As Integer = 1 'colonne di destinazione per la copia
Const CADDR As Integer = 2
Const CCAP As Integer = 3
Const CCOM As Integer = 4
Const CPRO As Integer = 5
Const CLON As Integer = 6
Const CLAT As Integer = 7
Const CID2 As Integer = 8
Const CADDA As Integer = 9
Const CCAPA As Integer = 10
Const CCITTA As Integer = 11
Const CPROVA As Integer = 12
Const CLONA As Integer = 13
Const CLATA As Integer = 14
Const SPAZIO As Integer = 15
Const TEMPO As Integer = 16
'distanceST()
Dim pointA As MapPoint.Location
Dim pointB As MapPoint.Location
Dim spT(2) As String ' (0)space ; (1)time
'getPoint()
Dim pt(7) As String ' array temporaneo
Dim lPoint As MapPoint.Location
Dim fAddress() As String
'formatAddress()
Const faLenght As Integer = 5 ' dimenzione dell'array string di ritorno
Dim tempASrt() As String
Dim lenght As Integer
Dim counter As Integer
Dim FAIndex As Integer
Dim tmpFmtAdd(faLenght) As String
' metodo prinipale dal quale parte l'esecuzione dell'intero programma
Sub main()
Const rowOffsetSh1 As Integer = 3 ' start point record of clienti's table
Const rowOffsetSh2 As Integer = 2 ' start point record of agenzie's table
Const offsetRecord As Integer = 0 ' starting record to work
' initialize application
App.Visible = False
App.UserControl = True
Set map = App.ActiveMap
Set route = map.ActiveRoute
MsgBox joinTables(rowOffsetSh1 + offsetRecord, rowOffsetSh2)
' le seguenti tre istruzioni terminano il programma MapPoint
map.Saved = True
App.Quit
Set App = Nothing
End Sub
'join input tables in output sheet with additional data
Private Function joinTables(orsh1 As Integer, orsh2 As Integer) As String
Dim i As Integer ' indice generico
Dim link As Integer 'join fra le tabelle, necessario per la simulazione di join
' variabili temporanee per il calcolo dei dati
'Dim fADDR() As String
Dim point() As String ' conterra tutti i dati relativi ad un certo indirizzo
Dim dist() As String
Dim Sh3Off As Integer
i = orsh1 ' imposto l'indice con il valore della riga di partenza
passato come parametro di funz
' la tab clienti parte dalla 3 riga mentre la tab ottenuta da 2
Sh3Off = i - 1 ' offset necessario per lasciare spazio alla riga prima
di titolo nella tab uscita
' proseguo mentre la riga corrente della tabella 1 non è vuota
Do While Worksheets(1).Cells(i, startColumn) <> "" And
Worksheets(1).Cells(i, startColumn) <> " "
Worksheets(3).Cells(Sh3Off, CID) = Worksheets(1).Cells(i, startColumn)
'copio CDO cliente del foglio 1 nel foglio 3
'Worksheets(3).Cells(Sh3Off, CID).Interior.Color = RGB(255, 0, 0)
'MsgBox "prima"
point = getPoint(Worksheets(1).Cells(i, ADDR))
'calcolo le coordinate per l'indirizzo passato
'MsgBox "dopo"
'Worksheets(3).Cells(Sh3Off, CADDR) = point(0)
'copio gl'indirizzi formattati del foglio 1 nel foglio 3
'Worksheets(3).Cells(Sh3Off, CCAP) = point(2)
'copio i CAP formattati del foglio 1 nel foglio 3
'Worksheets(3).Cells(Sh3Off, CCOM) = point(3)
'copio i Comuni formattati del foglio 1 nel foglio 3
'Worksheets(3).Cells(Sh3Off, CPRO) = point(4)
'copio le Provincie formattati del foglio 1 nel foglio 3
'Worksheets(3).Cells(Sh3Off, CLON) = point(5)
'copio la longitudine per l'indirizzo passato
'Worksheets(3).Cells(Sh3Off, CLAT) = point(6)
'copio la latitudine per l'indirizzo passato
'Worksheets(3).Cells(Sh3Off, CID2) = Worksheets(1).Cells(i, ID2)
'copio l'id dell'agenzia nella nuova tabella
' calcolo la distanza spazio-temporale
'dist = distanceST(point(5), point(6), Worksheets(2).Cells(link,
LONA), Worksheets(2).Cells(link, LATA))
'Worksheets(3).Cells(Sh3Off, SPAZIO) = dist(0)
'Worksheets(3).Cells(Sh3Off, TEMPO) = dist(1)
'link = linkForeingKey(Worksheets(1).Cells(i, ID2), orsh2, 2,
startColumn) 'calcolo la posizione dell'ID agenzia in tab agenz.
relazionata al cliente
'Worksheets(3).Cells(Sh3Off, CADDA) = Worksheets(2).Cells(link, ADDA)
'Worksheets(3).Cells(Sh3Off, CCAPA) = Worksheets(2).Cells(link, CAPA)
'Worksheets(3).Cells(Sh3Off, CCITTA) = Worksheets(2).Cells(link, CITTA)
'Worksheets(3).Cells(Sh3Off, CPROVA) = Worksheets(2).Cells(link, PROVA)
'Worksheets(3).Cells(Sh3Off, CLONA) = Worksheets(2).Cells(link, LONA)
'Worksheets(3).Cells(Sh3Off, CLATA) = Worksheets(2).Cells(link, LATA)
i = i + 1
Sh3Off = Sh3Off + 1
Loop
joinTables = "Done. (^.^) "
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'funzione che prende un indirizzo (string) in un certo formato valido
'e ritorna un array (String) con le relative informazioni seguenti
'
' VIA | N_CIVICO | CAP | CITTA | PROVINCIA | LONG | LAT
' (0) | (1) | (2) | (3) | (4) | (5) | (6)
'
Private Function getPoint(address As String) As String()
If address <> "" And address <> " " Then
fAddress = formatAddress(address) ' converte l'indirizzo in un array
Set lPoint = map.FindAddressResults(fAddress(0), fAddress(3), , ,
fAddress(2), geoCountryItaly).Item(1)
'MsgBox fAddress(0) & ", " & fAddress(2) & " " & fAddress(3) & " " & fAddress(4)
'Set lPoint = map.findResults(fAddress(0) & ", " & fAddress(2) & " " &
fAddress(3) & " " & fAddress(4)).Item(1)
pt(0) = fAddress(0)
pt(1) = fAddress(1)
pt(2) = fAddress(2)
pt(3) = fAddress(3)
pt(4) = fAddress(4)
pt(5) = Format(lPoint.Longitude, "#,##0.000000")
pt(6) = Format(lPoint.Latitude, "#,##0.000000")
getPoint = pt
Else
MsgBox " Warning! Function getGPSPoint():: NO INPUT DATA"
getPoint = pt
End If
getPoint = pt
End Function
' funzione che prende un ID di un foglio e ritorna la sua
' posizione in Integer nella colonna del altro foglio passata
' come indice parametro di funzione
Private Function linkForeingKey(Target As String, offset As Integer,
sheet As Integer, column As Integer) As Integer
Dim i As Integer
If Target <> "" And Target <> " " And offset > 0 And sheet > 0 And
column > 0 Then
i = offset
Do While Worksheets(sheet).Cells(i, column) <> "" And
Worksheets(sheet).Cells(i, column) <> " "
If Worksheets(sheet).Cells(i, column) = Target Then
'MsgBox "foreingKey[" & Worksheets(sheet).Cells(i, column) & "] row["
& i & "]" '[ pass ]
linkForeingKey = i
End If
i = i + 1
Loop
Else
MsgBox " Warning! Function linkForeingKey():: NO CORRECTLY DATA"
linkForeingKey = 0
End If
End Function
' funzione che prende come parametri le coordinate GPS dei punti da valutare
' restituisce un array di stringhe con distanza in KM e tempo in min tra i punti
' distanceST(...)(0) // space
' distanceST(...)(1) // time
Private Function distanceST(LONA As String, LATA As String, lonB As
String, latB As String) As String()
If LATA <> " " And LONA <> " " And latB <> " " And lonB <> " " Then
'calcolo i punti nella mappa
Set pointA = map.GetLocation(LATA, LONA)
Set pointB = map.GetLocation(latB, lonB)
'calcolo la rotta
route.Waypoints.Add pointA
route.Waypoints.Add pointB
route.Calculate
'calcolo della distanza in KM
spaceTime(0) = route.Distance
'calcolo della distanza in Min
spaceTime(1) = Left(route.DrivingTime / geoOneMinute, 5)
'MsgBox "distanza: A[LO " & LONA & "LA " & LATA & "] B[ LO " & lonB &
"LA " & latB & "] KM[" & spaceTime(0) & "] T[" & spaceTime(1) & "]"
'route.Waypoints.Item(2).Delete
'route.Waypoints.Item(1).Delete
route.Clear
Set pointA = Nothing
Set pointB = Nothing
map.Saved = False
distanceST = spT
Else
MsgBox " Warning! Function distanceST():: NO INPUT DATA"
distanceST = spT
End If
'distanceST = spaceTime
End Function
'funzione che prende una stringa che è un indirizzo
'e ritorna le componenti dell'indirizzo nella forma
' VIA | N_CIVICO | CAP | CITTA | PROVINCIA
' (0) | (1) | (2) | (3) | (4)
Private Function formatAddress(address As String) As String()
If address <> "" Then
FAIndex = faLenght - 1
counter = 4 ' perche 4 sono bs citta cap n_civico, la cui posizione non varia
address = Replace(address, ";", " ") ' elimina dall'indirizzo il fastidioso ';'
address = Replace(address, ",", " ") ' elimina dall'indirizzo il fastidioso ','
tempASrt = Split(address, " ")
lenght = UBound(tempASrt)
Do While lenght > -1
If tempASrt(lenght) <> "" Then
If counter > 0 Then ' sistemo subito le ultime quattro n_civico cap
citta provincia
tmpFmtAdd(FAIndex) = tempASrt(lenght)
FAIndex = FAIndex - 1
counter = counter - 1
Else ' sistemo le rimanenti parole, cioè la via
tmpFmtAdd(0) = tempASrt(lenght) + " " + tmpFmtAdd(0)
End If
End If
lenght = lenght - 1
Loop
formatAddress = tmpFmtAdd
Else
MsgBox " Warning! Function formatAddress():: NO INPUT DATA"
End If
formatAddress = tmpFmtAdd
End Function
the original code is plased on
https://docs.google.com/document/d/161srj6Zz0B2x_BHQV85QQft-JY55RK8oFwj3SLlUo9A/edit
I commented some code to show the function only while work and generate freeze
Thanks
On the road with only an iPad, so I can't see most of that code; but what you describe is known behavior with MapPoint's API. Basically the garbage collector is optimized for GUI users, and not programming usage. A simple garbage collection method would be a good solution, but one has not been implemented. Manually minimizing and maximizing MapPoint is a known workaround, but to do this programmatically you have to send Windows messages to the main MapPoint window (difficult in Win7/Vista) - the API minimize/maximize methods are insufficient.
If you are using MapPoint as an external application, then restarting it periodically is another solution - this is what my MPMileage product does.
The other important thing is to be very clean with your MapPoint object handling. Clean up, free objects, etc as rapidly as possible. The garbage collection that does occur will never reclaim an object whilst there is a reference to it, so set all references to 0 or NULL as soon as you have finished with them. This can make a big difference to MapPoint's memory growth, but for really big batch jobs it only delays the inevitable.