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
Related
I have the following code to create a progress bar in a PowerPoint presentation
Sub BarreDeProgression()
'Génère une barre de progression
'Valeurs à adapter selon besoin
Const Longueur As Single = 1 'Longueur totale de la barre (% de la longueur de la diapo (0.25 =25%))
Const Hauteur As Single = 0.02 'Hauteur totale de la barre (% de la hauteur de la diapo)
Const PositionX As Single = 0.1 'Position en X de la barre (% de la longueur de la diapo en partant de la gauche)
Const PositionY As Single = 0.05 'Position en Y de la barre (% de la hauteur de la diapo en partant de la gauche)
'Récupération des infos
Set Pres = ActivePresentation
H = Pres.PageSetup.SlideHeight
W = Pres.PageSetup.SlideWidth * Longueur
nb = Pres.Slides.Count
Counter = 1
'Pour chaque Slide
For Each SLD In Pres.Slides
'Supprime l'ancienne barre de progression
nbShape = SLD.Shapes.Count
del = 0
For a = 1 To nbShape
If Left(SLD.Shapes.Item(a - del).Name, 2) = "PB" Then
SLD.Shapes.Item(a - del).Delete
del = del + 1
End If
Next
'pose la nouvelle barre de progression
For i = 0 To nb - 1
Set OBJ = SLD.Shapes.AddShape(msoShapeChevron, (W * i / nb) + W / nb * (PositionX / 2), H * (1 - PositionY), (W / nb) * (1 - PositionX), H * Hauteur)
OBJ.Name = "PB" & i
OBJ.Line.Visible = msoFalse
If i + 1 = Counter Then
OBJ.Fill.ForeColor.RGB = RGB(156, 156, 156)
Else
OBJ.Fill.ForeColor.RGB = RGB(216, 32, 39)
End If
Next
Counter = Counter + 1
Next
End Sub
The problem is that code loops through all slide and create a progress bar in all slide, but I don't want the bar in the first, in the introduction and i the conclusion. How can I fix it ? I thought to add and if condition where I specify that the slide number should be greater than 4, but it did not work. Thanks in advance.
In the long run, you should get in the habit of declaring variables. An example in this code is Dim X As Integer. When you do this, the variable acquires the properties and methods of the declared object type. If you don't declare them, they are all variants, and the application must guess which properties and methods apply.
In this version of your code, I removed the variant variable SLD, since that will apply the code to all members of the slides collection. I replaced it with a count of the number of slides. Then I was able to come up with a conditional statement that leaves out the first 2 and the last slides. I also adjusted the calculation of the nb variable to reduce it by three. This ensures the number of shapes totals the number of slides that display the shapes.
Here's the revised code:
Sub BarreDeProgression()
Dim X As Integer
'Génère une barre de progression
'Valeurs à adapter selon besoin
Const Longueur As Single = 1 'Longueur totale de la barre (% de la longueur de la diapo (0.25 =25%))
Const Hauteur As Single = 0.02 'Hauteur totale de la barre (% de la hauteur de la diapo)
Const PositionX As Single = 0.1 'Position en X de la barre (% de la longueur de la diapo en partant de la gauche)
Const PositionY As Single = 0.05 'Position en Y de la barre (% de la hauteur de la diapo en partant de la gauche)
'Récupération des infos
Set Pres = ActivePresentation
H = Pres.PageSetup.SlideHeight
W = Pres.PageSetup.SlideWidth * Longueur
nb = Pres.Slides.Count
Counter = 1
'Pour chaque Slide
For X = 1 To Pres.Slides.Count
If X > 2 And X < (Pres.Slides.Count) Then
'Supprime l'ancienne barre de progression
nbShape = Pres.Slides(X).Shapes.Count
del = 0
For a = 1 To nbShape
If Left(Pres.Slides(X).Shapes.Item(a - del).Name, 2) = "PB" Then
Pres.Slides(X).Shapes.Item(a - del).Delete
del = del + 1
End If
Next
'pose la nouvelle barre de progression
For I = 0 To nb - 1
Set OBJ = Pres.Slides(X).Shapes.AddShape(msoShapeChevron, (W * I / (nb - 3)) + W / (nb - 3) * (PositionX / 2), H * (1 - PositionY), (W / (nb - 3)) * (1 - PositionX), H * Hauteur)
OBJ.Name = "PB" & I
OBJ.Line.Visible = msoFalse
If I + 1 = Counter Then
OBJ.Fill.ForeColor.RGB = RGB(156, 156, 156)
Else
OBJ.Fill.ForeColor.RGB = RGB(216, 32, 39)
End If
Next
Counter = Counter + 1
End If
Next X
End Sub
I constantly use the website below to track air miles round trip. Recently, the website stopped working in IE, so my code did as well. Since I use this on a work computer, I cannot download many of the other solutions that I have found in my searches and I cannot use another website without going through a lengthy process to get the site approved. Is there a way to perform the same task here in Chrome without any other downloads?
Dim ele As Object
Dim IE As New InternetExplorer
IE.Visible = True
IE.navigate "http://www.distancefromto.net"
Do
DoEvents
Loop Until IE.readyState = READYSTATE_COMPLETE
'step 1
With IE
.document.getElementsByName("distance")(0).Value = Range("B2").Value
.document.getElementsByName("distance")(1).Value = Range("B3").Value & Range("E3").Value
.document.getElementById("hae").Click
Do
DoEvents
Loop Until IE.readyState = READYSTATE_COMPLETE
Application.Wait (Now + TimeValue("0:00:02"))
Dim a As String
a = Trim(.document.getElementById("totaldistancemiles").Value)
Dim aa As Variant
aa = Split(a, " ")
Range("C2").Value = aa(0)
'step 2
.document.getElementsByName("distance")(0).Value = Range("B4").Value & Range("E4").Value
.document.getElementById("hae").Click
Do
DoEvents
Loop Until IE.readyState = READYSTATE_COMPLETE
Application.Wait (Now + TimeValue("0:00:02"))
Dim b As String
b = Trim(.document.getElementById("totaldistancemiles").Value)
Dim bb As Variant
bb = Split(b, " ")
Range("C3").Value = bb(0)
'step 3
.document.getElementsByName("distance")(1).Value = Range("B2").Value
.document.getElementById("hae").Click
Do
DoEvents
Loop Until IE.readyState = READYSTATE_COMPLETE
Application.Wait (Now + TimeValue("0:00:02"))
Dim c As String
c = Trim(.document.getElementById("totaldistancemiles").Value)
Dim cc As Variant
cc = Split(c, " ")
Range("C4").Value = cc(0)
End With
IE.Quit
Any help, even a definitive "no, it's not possible" would be greatly appriciated
Thanks
Chrome:
To use Chrome - no. You would need to download selenium basic or use a different programming language e.g python.
Different site:
You could switch to using a different site (appreciate there may some minor differences on your prior figures due to the website though technically the distances shouldn’t have changed that much!). I note you say that this would be problematic. At the risk of sounding stalkerish, you have used freemaptools before so that might be an acceptable choice?
API:
If you find a site offering an API service you might be able to ditch all the above and issue an XMLHTTP request. I couldn't see your site offering an API service otherwise that would have been the obvious next choice.
#RahulChalwa mentions "[the site OP is using is itself using a wrapper around google maps API: https://maps.googleapis.com/maps/api/js/GeocodeService.Search. User can register for API and do a POST request]"; so that might be the way forward. Main documentation here.
E.g. API site: Personal and small scale use API - wheretocredit.com
Current set-up debug:
Ascertain the reason for IE no longer working in your current set-up would also be advisable, perhaps by contacting the site developers and raising your issue.
Perform the calculation (as the site does) using the Vincenty's formula or, as other sites do, using Haversine formula:
Haversine:
VBA haversine formula
Vicenty's (including sample code):
How to Calculate Distance in Excel
Vicenty's code from Contextures. I have attributed but if this should not be included here I will remove.
'*************************************************************
Private Const PI = 3.14159265358979
Private Const EPSILON As Double = 0.000000000001
Public Function distVincenty(ByVal lat1 As Double, ByVal lon1 As Double, _
ByVal lat2 As Double, ByVal lon2 As Double) As Double
'INPUTS: Latitude and Longitude of initial and
' destination points in decimal format.
'OUTPUT: Distance between the two points in Meters.
'
'======================================
' Calculate geodesic distance (in m) between two points specified by
' latitude/longitude (in numeric [decimal] degrees)
' using Vincenty inverse formula for ellipsoids
'======================================
' Code has been ported by lost_species from www.aliencoffee.co.uk to VBA
' from javascript published at:
' https://www.movable-type.co.uk/scripts/latlong-vincenty.html
' * from: Vincenty inverse formula - T Vincenty, "Direct and Inverse Solutions
' * of Geodesics on the Ellipsoid with application
' * of nested equations", Survey Review, vol XXII no 176, 1975
' * https://www.ngs.noaa.gov/PUBS_LIB/inverse.pdf
'Additional Reference: https://en.wikipedia.org/wiki/Vincenty%27s_formulae
'======================================
' Copyright lost_species 2008 LGPL
' https://www.fsf.org/licensing/licenses/lgpl.html
'======================================
' Code modifications to prevent "Formula Too Complex" errors
' in Excel (2010) VBA implementation
' provided by Jerry Latham, Microsoft MVP Excel Group, 2005-2011
' July 23 2011
'======================================
Dim low_a As Double
Dim low_b As Double
Dim f As Double
Dim L As Double
Dim U1 As Double
Dim U2 As Double
Dim sinU1 As Double
Dim sinU2 As Double
Dim cosU1 As Double
Dim cosU2 As Double
Dim lambda As Double
Dim lambdaP As Double
Dim iterLimit As Integer
Dim sinLambda As Double
Dim cosLambda As Double
Dim sinSigma As Double
Dim cosSigma As Double
Dim sigma As Double
Dim sinAlpha As Double
Dim cosSqAlpha As Double
Dim cos2SigmaM As Double
Dim C As Double
Dim uSq As Double
Dim upper_A As Double
Dim upper_B As Double
Dim deltaSigma As Double
Dim s As Double ' final result, will be returned rounded to 3 decimals (mm).
'added by JLatham to break up "Too Complex" formulas
'into pieces to properly calculate those formulas as noted below
'and to prevent overflow errors when using
'Excel 2010 x64 on Windows 7 x64 systems
Dim P1 As Double ' used to calculate a portion of a complex formula
Dim P2 As Double ' used to calculate a portion of a complex formula
Dim P3 As Double ' used to calculate a portion of a complex formula
'See https://en.wikipedia.org/wiki/World_Geodetic_System
'for information on various Ellipsoid parameters for other standards.
'low_a and low_b in meters
' === GRS-80 ===
' low_a = 6378137
' low_b = 6356752.314245
' f = 1 / 298.257223563
'
' === Airy 1830 === Reported best accuracy for England and Northern Europe.
' low_a = 6377563.396
' low_b = 6356256.910
' f = 1 / 299.3249646
'
' === International 1924 ===
' low_a = 6378388
' low_b = 6356911.946
' f = 1 / 297
'
' === Clarke Model 1880 ===
' low_a = 6378249.145
' low_b = 6356514.86955
' f = 1 / 293.465
'
' === GRS-67 ===
' low_a = 6378160
' low_b = 6356774.719
' f = 1 / 298.247167
'=== WGS-84 Ellipsoid Parameters ===
low_a = 6378137 ' +/- 2m
low_b = 6356752.3142
f = 1 / 298.257223563
'====================================
L = toRad(lon2 - lon1)
U1 = Atn((1 - f) * Tan(toRad(lat1)))
U2 = Atn((1 - f) * Tan(toRad(lat2)))
sinU1 = Sin(U1)
cosU1 = Cos(U1)
sinU2 = Sin(U2)
cosU2 = Cos(U2)
lambda = L
lambdaP = 2 * PI
iterLimit = 100 ' can be set as low as 20 if desired.
While (Abs(lambda - lambdaP) > EPSILON) And (iterLimit > 0)
iterLimit = iterLimit - 1
sinLambda = Sin(lambda)
cosLambda = Cos(lambda)
sinSigma = Sqr(((cosU2 * sinLambda) ^ 2) + _
((cosU1 * sinU2 - sinU1 * cosU2 * cosLambda) ^ 2))
If sinSigma = 0 Then
distVincenty = 0 'co-incident points
Exit Function
End If
cosSigma = sinU1 * sinU2 + cosU1 * cosU2 * cosLambda
sigma = Atan2(cosSigma, sinSigma)
sinAlpha = cosU1 * cosU2 * sinLambda / sinSigma
cosSqAlpha = 1 - sinAlpha * sinAlpha
If cosSqAlpha = 0 Then 'check for a divide by zero
cos2SigmaM = 0 '2 points on the equator
Else
cos2SigmaM = cosSigma - 2 * sinU1 * sinU2 / cosSqAlpha
End If
C = f / 16 * cosSqAlpha * (4 + f * (4 - 3 * cosSqAlpha))
lambdaP = lambda
'the original calculation is "Too Complex" for Excel VBA to deal with
'so it is broken into segments to calculate without that issue
'the original implementation to calculate lambda
'lambda = L + (1 - C) * f * sinAlpha * _
(sigma + C * sinSigma * (cos2SigmaM + C * cosSigma * _
(-1 + 2 * (cos2SigmaM ^ 2))))
'calculate portions
P1 = -1 + 2 * (cos2SigmaM ^ 2)
P2 = (sigma + C * sinSigma * (cos2SigmaM + C * cosSigma * P1))
'complete the calculation
lambda = L + (1 - C) * f * sinAlpha * P2
Wend
If iterLimit < 1 Then
MsgBox "iteration limit has been reached, something didn't work."
Exit Function
End If
uSq = cosSqAlpha * (low_a ^ 2 - low_b ^ 2) / (low_b ^ 2)
'the original calculation is "Too Complex" for Excel VBA to deal with
'so it is broken into segments to calculate without that issue
'the original implementation to calculate upper_A
'upper_A = 1 + uSq / 16384 * (4096 + uSq * _
(-768 + uSq * (320 - 175 * uSq)))
'calculate one piece of the equation
P1 = (4096 + uSq * (-768 + uSq * (320 - 175 * uSq)))
'complete the calculation
upper_A = 1 + uSq / 16384 * P1
'oddly enough, upper_B calculates without any issues - JLatham
upper_B = uSq / 1024 * (256 + uSq * (-128 + uSq * (74 - 47 * uSq)))
'the original calculation is "Too Complex" for Excel VBA to deal with
'so it is broken into segments to calculate without that issue
'the original implementation to calculate deltaSigma
'deltaSigma = upper_B * sinSigma * (cos2SigmaM + upper_B / 4 * _
(cosSigma * (-1 + 2 * cos2SigmaM ^ 2) _
- upper_B / 6 * cos2SigmaM * (-3 + 4 * sinSigma ^ 2) * _
(-3 + 4 * cos2SigmaM ^ 2)))
'calculate pieces of the deltaSigma formula
'broken into 3 pieces to prevent overflow error that may occur in
'Excel 2010 64-bit version.
P1 = (-3 + 4 * sinSigma ^ 2) * (-3 + 4 * cos2SigmaM ^ 2)
P2 = upper_B * sinSigma
P3 = (cos2SigmaM + upper_B / 4 * (cosSigma * (-1 + 2 * cos2SigmaM ^ 2) _
- upper_B / 6 * cos2SigmaM * P1))
'complete the deltaSigma calculation
deltaSigma = P2 * P3
'calculate the distance
s = low_b * upper_A * (sigma - deltaSigma)
'round distance to millimeters
distVincenty = Round(s, 3)
End Function
Function SignIt(Degree_Dec As String) As Double
'Input: a string representation of a lat or long in the
' format of 10° 27' 36" S/N or 10~ 27' 36" E/W
'OUTPUT: signed decimal value ready to convert to radians
'
Dim decimalValue As Double
Dim tempString As String
tempString = UCase(Trim(Degree_Dec))
decimalValue = Convert_Decimal(tempString)
If Right(tempString, 1) = "S" Or Right(tempString, 1) = "W" Then
decimalValue = decimalValue * -1
End If
SignIt = decimalValue
End Function
Function Convert_Degree(Decimal_Deg) As Variant
'source: https://support.microsoft.com/kb/213449
'
'converts a decimal degree representation to deg min sec
'as 10.46 returns 10° 27' 36"
'
Dim degrees As Variant
Dim minutes As Variant
Dim seconds As Variant
With Application
'Set degree to Integer of Argument Passed
degrees = Int(Decimal_Deg)
'Set minutes to 60 times the number to the right
'of the decimal for the variable Decimal_Deg
minutes = (Decimal_Deg - degrees) * 60
'Set seconds to 60 times the number to the right of the
'decimal for the variable Minute
seconds = Format(((minutes - Int(minutes)) * 60), "0")
'Returns the Result of degree conversion
'(for example, 10.46 = 10° 27' 36")
Convert_Degree = " " & degrees & "° " & Int(minutes) & "' " _
& seconds + Chr(34)
End With
End Function
Function Convert_Decimal(Degree_Deg As String) As Double
'source: https://support.microsoft.com/kb/213449
' Declare the variables to be double precision floating-point.
' Converts text angular entry to decimal equivalent, as:
' 10° 27' 36" returns 10.46
' alternative to ° is permitted: Use ~ instead, as:
' 10~ 27' 36" also returns 10.46
Dim degrees As Double
Dim minutes As Double
Dim seconds As Double
'
'modification by JLatham
'allow the user to use the ~ symbol instead of ° to denote degrees
'since ~ is available from the keyboard and ° has to be entered
'through [Alt] [0] [1] [7] [6] on the number pad.
Degree_Deg = Replace(Degree_Deg, "~", "°")
' Set degree to value before "°" of Argument Passed.
degrees = Val(Left(Degree_Deg, InStr(1, Degree_Deg, "°") - 1))
' Set minutes to the value between the "°" and the "'"
' of the text string for the variable Degree_Deg divided by
' 60. The Val function converts the text string to a number.
minutes = Val(Mid(Degree_Deg, InStr(1, Degree_Deg, "°") + 2, _
InStr(1, Degree_Deg, "'") - InStr(1, Degree_Deg, "°") - 2)) / 60
' Set seconds to the number to the right of "'" that is
' converted to a value and then divided by 3600.
seconds = Val(Mid(Degree_Deg, InStr(1, Degree_Deg, "'") + _
2, Len(Degree_Deg) - InStr(1, Degree_Deg, "'") - 2)) / 3600
Convert_Decimal = degrees + minutes + seconds
End Function
Private Function toRad(ByVal degrees As Double) As Double
toRad = degrees * (PI / 180)
End Function
Private Function Atan2(ByVal X As Double, ByVal Y As Double) As Double
' code nicked from:
' https://en.wikibooks.org/wiki/Programming:Visual_Basic_Classic
' /Simple_Arithmetic#Trigonometrical_Functions
' If you re-use this watch out: the x and y have been reversed from typical use.
If Y > 0 Then
If X >= Y Then
Atan2 = Atn(Y / X)
ElseIf X <= -Y Then
Atan2 = Atn(Y / X) + PI
Else
Atan2 = PI / 2 - Atn(X / Y)
End If
Else
If X >= -Y Then
Atan2 = Atn(Y / X)
ElseIf X <= Y Then
Atan2 = Atn(Y / X) - PI
Else
Atan2 = -Atn(X / Y) - PI / 2
End If
End If
End Function
'======================================
First if this a duplicate (that I can't find) I am sorry.
I have been searching for more then a week for an answer to this.
I have an Access 2003 Database that has a Front End (fe) a Back End (be) and a third db that holds the data. I know this seems weird but its a German built Access DB from way back.
Here is the problem. From the main data entry form there is a print button that calls another form. This second form has two text boxes that have a starting and ending order number fields. The starting number is passed from the main form.
There is a another print button on the second form that when clicked creates and prints a report. The report is where the problem is. If I add ANY vba code to the report, even just making a label visible, the report prints nothing. The printer dialog window appears like it is sending something but nothing is ever printed.
I have tried sending to a PDF but nothing. Now if I go to the report code and comment out the line to that makes the label visible the report prints fine. I have been working with DB's along time and I have never seen anything like this, Hell I have never even heard of anything like this.
Be warned that this code has a lot of German in it.
Option Compare Database
Option Explicit
Private Sub Detailbereich_Format(Cancel As Integer, FormatCount As Integer) 'Detail Area Format
'On Error GoTo Err_Detailbereich_Format
Dim dbDatenbank As Database
Dim dtPPSDaten, dtEinfassung, dtToleranz As Recordset
Dim sql As String
Dim T As Double 'Angepasste Tragstablänge
'Adjusted Bearing Bar rod-length
Dim TA As Double 'Anzahl Tragstäbe
'Number of Bearing Bar rods
Dim TA_Anzahl As String 'Zwischenfeld für Tragstabanzahlberechnung ohne Rundung
'Inter-field for Bearing Bar-number-calculation of curve
Dim FA_Anzahl As String 'Zwischenfeld für Füllstabanzahlberechnung ohne Rundung
'Inter-field for Cross Bar-number-calculation of curve
Dim Komma As Byte 'Zwischenfeld zum Filtern der Dezimalzalen
'Inter-field to filtering the decimal zal en
Dim FA As Double 'Füllstabanzahl
'Cross Bar-number
Dim TEM As Double 'Tragstabendmasche
'Bearing Bar Mesh
Dim FEM As Double 'Füllstabendmasche
'Cross Bar Mesh
Dim ZFEM As Double 'Zusatzwert Füllstabendmasche
'Addition-value Cross Bar Mesh
Dim MEMT As Double 'Mindestendmasche Tragstab (Toleranz)
'Bearing Bar Mesh Tolerance
Dim MEMF As Double 'Mindestendmasche Füllstab (Toleranz)
'Cross Bar Mesh Tolerance
Dim Rand1_2 As Double 'Technologischer Abzug Rand1+2 (Toleranz)
'Technological departure edge
Dim Rand3_4 As Double 'Technologischer Abzug Rand3+4 (Toleranz)
'Technological departure edge
Dim Einfassungsdicke As Single '(aus Tabelle: Einfassung)
'Banding Thickness
Dim Einfassungsmaterial As String * 35 '(aus Tabelle: Einfassung)
'Banding Material
Dim Toleranz_Füllstab As Single '(aus Tabelle: Toleranz)
'Cross Bar Tolerance
Dim Toleranz_Tragstab As Single '(aus Tabelle: Toleranz)
'Bearing Bar Tolerance
Dim ProdAuftrag As Long '(aus Tabelle: PPS_Daten_IN)
Dim PositionsNr As String * 3 'Zwischenfeld zum auffüllen der PositionsNr mit Nullen
'Position Number with zeros
Dim Auffüllen As Long 'Zwischenfeld
Dim Barcode_ProdAuftrag As String * 9 'Zwischenfeld
Dim Artikeltyp As Byte 'Zwischenfeld
Dim Durchlauf As Byte 'Zwischenfeld
Dim Inch As Single
Dim Feet As Single
Feet = 10.764
Inch = 25.4
ZFEM = 0
Komma = 0
Durchlauf = 1
'Einfassungsbereich sichtbar machen, evtl. durch Mattenfertigung ausgeblendet
' Border-area visible does, evtl. through mat-production faded out
[Report_Fertigungszettel]![Jahreszahl].Visible = True
[Report_Fertigungszettel]![AuftragsNr].Visible = True
[Report_Fertigungszettel]![Kunde].Visible = True
[Report_Fertigungszettel]![txtEinfassung_Einfassung].Visible = True
[Report_Fertigungszettel]![Position].Visible = True
[Report_Fertigungszettel]![Rostbezeichnung].Visible = True
[Report_Fertigungszettel]![Bestellmenge].Visible = True
'********************************************************************
'Unterschiedliche Einblendung zwischen SP- und P-Rosten
[Report_Fertigungszettel]![lbl_ef_lob1].Visible = True
[Report_Fertigungszettel]![lbl_ef_lob2].Visible = True
[Report_Fertigungszettel]![lbl_ef_lob3].Visible = True
[Report_Fertigungszettel]![Einfassungslänge].Visible = True
[Report_Fertigungszettel]![EinfassungslängeTS].Visible = True
[Report_Fertigungszettel]![EinfassungslängeFS].Visible = True
[Report_Fertigungszettel]![Einfassungslänge_Inch].Visible = True
[Report_Fertigungszettel]![EinfassungslängeTS_Inch].Visible = True
[Report_Fertigungszettel]![EinfassungslängeFS_Inch].Visible = True
[Report_Fertigungszettel]![MaterialbezeichnungTS].Visible = True
[Report_Fertigungszettel]![MaterialbezeichnungEF2].Visible = True
[Report_Fertigungszettel]![lbl_ef_quantity1].Visible = True
[Report_Fertigungszettel]![lbl_ef_quantity2].Visible = True
[Report_Fertigungszettel]![lbl_ef_quantity3].Visible = True
[Report_Fertigungszettel]![Einfassungsanzahl].Visible = True
[Report_Fertigungszettel]![EinfassungsanzahlTS].Visible = True
[Report_Fertigungszettel]![EinfassungsanzahlFS].Visible = True
'********************************************************************
Set dbDatenbank = DBEngine.Workspaces(0).Databases(0)
'Technologische Werte aus Tabelle Toleranz übernehmen
' Update Tolerance Information
sql = "SELECT * FROM Toleranz WHERE Toleranz = " & Toleranz
Set dtToleranz = dbDatenbank.OpenRecordset(sql)
MEMT = dtToleranz![Tol_Tragstab_Min_Masche] 'Bearing Bar Mesh
MEMF = dtToleranz![Tol_Füllstab_Min_Masche] 'Cross Bar Mesh
Rand1_2 = dtToleranz![Tol_Rand1+2] 'Banding Thickness for sides 1 & 2
Rand3_4 = dtToleranz![Tol_Rand3+4] 'Banding Thinckness for sides 3 & 4
Toleranz_Füllstab = dtToleranz![Tol_Füllstab] 'Cross Bar
Toleranz_Tragstab = dtToleranz![Tol_Tragstab] 'Bearing Bar
dtToleranz.Close
'Einfassungswerte aus Tabelle Einfassung übernehmen
' Update Banding Information
sql = "SELECT * FROM Einfassung WHERE Einfassung = " & Einfassung
Set dtEinfassung = dbDatenbank.OpenRecordset(sql)
Einfassungsdicke = dtEinfassung![Einf_Dicke] '
Einfassungsmaterial = dtEinfassung![Einf_Materialbezeichnung]
txtEinfassung_Einfassung.Value = dtEinfassung![Einf_Bezeichnung]
txtFüllstab_Einfassung = dtEinfassung![Einf_Bezeichnung]
txtTragstab_Einfassung = dtEinfassung![Einf_Bezeichnung]
If Einfassungsdicke = 0 Then
txt_hide_banding.Visible = True
txt_hide_banding = "NO BANDING"
End If
dtEinfassung.Close
'Unterscheidung Artikeltyp/Rosttyp
' Case statement based on the part type, keyed off of the first digit of the machine part number
Artikeltyp = Left(Rosttyp, 1)
Select Case Artikeltyp
Case "1"
lblPW1.Visible = False
lblPW2.Visible = True
lblPW3.Visible = True
'Berechnung P-Rost
' Calc BB MFG Length
Tragstablänge = Tragstab - Einfassungsdicke - Einfassungsdicke - Toleranz_Tragstab
Tragstablänge_Inch = Tragstablänge / Inch
' Calc CB MFG Length
Füllstablänge = Füllstab - Toleranz_Füllstab
Füllstablänge_Inch = Füllstablänge / Inch
' MaterialbezeichnungEF1 = Einfassungsmaterial
MaterialbezeichnungEF2 = Einfassungsmaterial
' Calc CB Banding Length
EinfassungslängeFS = Füllstab - Rand3_4
EinfassungslängeFS_Inch = EinfassungslängeFS / Inch
' Calc BB Banding Length
EinfassungslängeTS = Tragstab - Rand1_2
EinfassungslängeTS_Inch = EinfassungslängeTS / Inch
' Calc Total Banding Qty (Qty * 2)
EinfassungsanzahlTS = Bestellmenge * 2
EinfassungsanzahlFS = Bestellmenge * 2
'******************************************************************
'FIX
' Add Comments for LARGE BB pieces (over 1800mm)
' If (Tragstablänge > 1800) Or (Füllstablänge > 1800) Then
' lblcommentsBand = "OVER 1800mm, ENTER BANDING MANUALLY in 2 PIECES. " & lblcommentsBand
' Else
' lblcommentsBand = Comments
' End If
'*******************************************************************
TA_Anzahl = Füllstab / Tragstabteiler
Komma = InStr(1, TA_Anzahl, ".", vbTextCompare)
If Komma <> 0 Then
TA = CInt(Left(TA_Anzahl, (Komma - 1)))
Else
TA = CInt(TA_Anzahl)
End If
Komma = 0
FA_Anzahl = Tragstab / Füllstabteiler
Komma = InStr(1, FA_Anzahl, ".", vbTextCompare)
If Komma <> 0 Then
FA = CInt(Left(FA_Anzahl, (Komma - 1)))
Else
FA = CInt(FA_Anzahl)
End If
TEM = (Tragstablänge - ((FA - 1) * Füllstabteiler)) / 2
If TEM < MEMT Then
FA = FA - 1
TEM = (Tragstablänge - ((FA - 1) * Füllstabteiler)) / 2
If TEM < MEMT Then
FA = FA - 1
TEM = (Tragstablänge - ((FA - 1) * Füllstabteiler)) / 2
End If
End If
If TEM < ((Füllstabteiler / 2) + (Füllstabteiler * 0.05)) Then
FA = FA - 1
TEM = (Tragstablänge - ((FA - 1) * Füllstabteiler)) / 2
End If
FEM = (Füllstablänge - ((TA - 1) * Tragstabteiler)) / 2
If FEM < MEMF Then
TA = TA - 1
FEM = (Füllstablänge - ((TA - 1) * Tragstabteiler)) / 2
If FEM < MEMF Then
TA = TA - 1
FEM = (Füllstablänge - ((TA - 1) * Tragstabteiler)) / 2
End If
End If
If FEM < ((Tragstabteiler / 2) + (Tragstabteiler * 0.05)) Then
TA = TA - 1
FEM = (Füllstablänge - ((TA - 1) * Tragstabteiler)) / 2
End If
Füllstabendmasche = Format(FEM, "###0.00")
Füllstabendmasche_Inch = Füllstabendmasche / Inch
füllstabendmasche_1 = Format(FEM, "###0.00")
Füllstabendmasche_1_Inch = füllstabendmasche_1 / Inch
'********************************************************************
'Unterschiedliche Einblendung zwischen SP- und P-Rosten
[Report_Fertigungszettel]![lbl_ef_lob1].Visible = False
[Report_Fertigungszettel]![Einfassungslänge].Visible = False
[Report_Fertigungszettel]![MaterialbezeichnungTS].Visible = False
[Report_Fertigungszettel]![lbl_ef_quantity1].Visible = False
[Report_Fertigungszettel]![Einfassungsanzahl].Visible = False
'Ausblendung Stückzahlen bei T-Einfassung - Wunsch von Hr. Johann wegen Verwirrung bei Produktion Ohio
If Toleranz = 1 Then
[Report_Fertigungszettel]![EinfassungsanzahlTS].Visible = False
[Report_Fertigungszettel]![EinfassungsanzahlFS].Visible = False
[Report_Fertigungszettel]![lbl_ef_quantity2].Visible = False
[Report_Fertigungszettel]![lbl_ef_quantity3].Visible = False
End If
'********************************************************************
Case 2
lblPW1.Visible = True
lblPW2.Visible = False
lblPW3.Visible = False
'Entscheidungskriterium für Mattenfertigung
'Adjournment-criterion for mat-production
If Einfassungsdicke = 0 Then
T = Tragstab - Rand3_4
Else
T = Tragstab - (Tragstabdicke * 2) - Rand3_4
End If
'Berechnung SP-Rost
'Calculation SP-Rost
'TA-Anzahl = ((CrossBar - BearingBarThickness) / BearingBarPitch
TA_Anzahl = ((Füllstab - Tragstabdicke) / Tragstabteiler)
Komma = InStr(1, TA_Anzahl, ".", vbTextCompare)
If Komma <> 0 Then
'NumberOfBearingBars = CInt(Left(TA_Anzahl, (Komma - 1))) + 2
TA = CInt(Left(TA_Anzahl, (Komma - 1))) + 2
Else
'NumberOfBearingBars = CInt(TA_Anzahl) + 2
TA = CInt(TA_Anzahl) + 2
End If
'CrossBarNumber = MFG BearingBar Length \ CrossBarPitch
FA = T \ Füllstabteiler
'CrossBarNumber = (CrossBarNumber \ 2) * 2
FA = (FA \ 2) * 2
'BearingBarMesh = (MFGBearingBarLength - (CrossBarNumber-1)*CrossBarPitch)/2
TEM = (T - (FA - 1) * Füllstabteiler) / 2
'If BearingBarMesh >= (CrossBarPitch + BearingBarMeshTolerance) Then
If TEM >= (Füllstabteiler + MEMT) Then
'CrossBarNumber = CrosbarNumber + 2
FA = FA + 2
'BearingBarMesh = (MFBearingBarLength - (CrossBarNumber - 1) * CrossBarPitch) / 2
TEM = (T - (FA - 1) * Füllstabteiler) / 2
End If
'If BearingBarMesh < BearingBarMeshTolerance then
If TEM < MEMT Then
'CrossBarNumber = CrossBarNumber - 2
FA = FA - 2
'BearingBarMesh = (MFGBearingBarLength - (CrossBarNumber - 1) * CrossBarPitch) /2
TEM = (T - (FA - 1) * Füllstabteiler) / 2
End If
Select Case Tragstabteiler 'BearingBarPitch
Case 30.15
'CrossBarMesh = CrossBarLength - (NumberofBearingBars - 2) * BearingBarPitch - Side3&4 banding thickness - (2 * Bearing Bar Thickness)
FEM = Füllstab - (TA - 2) * Tragstabteiler - Rand3_4 - (2 * Tragstabdicke)
'If CrossBarMesh < 16.6 AND CrosbarMesh > = 1 then
If FEM < 16.6 And FEM >= 1 Then
'CrossBarMesh = CrosbarMesh + 15.07
FEM = FEM + 15.07
'CrossBarMesh plus value = 15
ZFEM = 15.07
End If
'If CrossBarMesh < 1 then
If FEM < 1 Then
'CrossBarMesh = CrossBarMesh + 30.15
FEM = FEM + 30.15
'NumberOfBearingBarRods = NumberOfBearingBarRods - 1
TA = TA - 1
End If
Case 30.16
'CrossBarMesh = CrossBarLength - (NumberofBearingBars - 2) * BearingBarPitch - Side3&4 banding thickness - (2 * Bearing Bar Thickness)
FEM = Füllstab - (TA - 2) * Tragstabteiler - Rand3_4 - (2 * Tragstabdicke)
'If CrossBarMesh < 16.6 AND CrosbarMesh > = 1 then
If FEM < 16.6 And FEM >= 1 Then
'CrossBarMesh = CrosbarMesh + 15.07
FEM = FEM + 15.07
'CrossBarMesh plus value = 15
ZFEM = 15.07
End If
'If CrossBarMesh < 1 then
If FEM < 1 Then
'CrossBarMesh = CrossBarMesh + 30.15
FEM = FEM + 30.15
'NumberOfBearingBarRods = NumberOfBearingBarRods - 1
TA = TA - 1
End If
Case Else
'CrossBarMesh = 9999
FEM = 9999
TA = TA - 1
End Select
' Calc CB MFG Length
'CrossBarLength = CrossBar + CrossBarTolerance
Füllstablänge = Füllstab + Toleranz_Füllstab
'CrosBarLength = CrossBarLength / 25.4
Füllstablänge_Inch = Füllstablänge / Inch
' Calc BB MFG Length
'BearingBarLength = (BearingBar - Side3&4BandThickness - (2 * BandingThickness)
Tragstablänge = (Tragstab - Rand3_4 - (2 * Einfassungsdicke))
Tragstablänge_Inch = Tragstablänge / Inch
MaterialbezeichnungEF2 = Einfassungsmaterial
' Calc CB Banding Length
EinfassungslängeFS = Füllstab - Rand3_4
EinfassungslängeFS_Inch = EinfassungslängeFS / Inch
' Calc BB Banding Length
EinfassungslängeTS = Tragstab - Rand1_2
EinfassungslängeTS_Inch = EinfassungslängeTS / Inch
' Calc Total Banding Qty (Qty * 2)
EinfassungsanzahlTS = Bestellmenge * 2
EinfassungsanzahlFS = Bestellmenge * 2
'INCH Anpassung nicht vergessen
Füllstabendmasche = Format(FEM, "###0.00") '& " : " & Format(ZFEM, "###0.00")
füllstabendmasche_1 = Format(FEM, "###0.00") '& " : " & Format(ZFEM, "###0.00")
Füllstabendmasche_Inch = Format(FEM / Inch, "###0.00") & " : " & ZFEM
Füllstabendmasche_1_Inch = Format(FEM / Inch, "###0.00") & " : " & ZFEM
'Bei Mattenfertigung wird Einfassunsbereich nicht angedruckt
If Einfassungsdicke = 0 Then
[Report_Fertigungszettel]![Jahreszahl].Visible = False
[Report_Fertigungszettel]![AuftragsNr].Visible = False
[Report_Fertigungszettel]![Kunde].Visible = False
[Report_Fertigungszettel]![txtEinfassung_Einfassung].Visible = False
[Report_Fertigungszettel]![Position].Visible = False
[Report_Fertigungszettel]![txtTragstab].Visible = False
[Report_Fertigungszettel]![txtFüllstab].Visible = False
[Report_Fertigungszettel]![Rostbezeichnung].Visible = False
[Report_Fertigungszettel]![Bestellmenge].Visible = False
[Report_Fertigungszettel]![Einfassungslänge].Visible = False
[Report_Fertigungszettel]![Einfassungsanzahl].Visible = False
[Report_Fertigungszettel]![MaterialbezeichnungTS].Visible = False
Else
Einfassungslänge = Füllstab
Einfassungslänge_Inch = Einfassungslänge / Inch
Einfassungsanzahl = Bestellmenge * 2
End If
Case Else
FEM = 9999
TEM = 9999
End Select
'********************************************************************
'Berichtsfelder zuweisen - Bereich Füllstab
Füllstabanzahl = FA * Bestellmenge & " / " & FA
'Berichtsfelder zuweisen - Bereich Tragstab
'Report-fields assign - area filling-rod
Tragstabanzahl = TA * Bestellmenge & " / " & TA
Tragstabendmasche = Format(TEM, "###0.00")
Tragstabendmasche_Inch = Tragstabendmasche / Inch
Klinkung = FA
'Zeichnungskästchen anzeigen
'Show Drawing Boxes
If Zeichnung = -1 Then
lblZeichnungBearing = "Review Traveler / DWG"
lblZeichnungCross = "Review Traveler / DWG"
lblZeichnungBand = "Review Traveler / DWG"
Else
lblZeichnungBearing = ""
lblZeichnungCross = ""
lblZeichnungBand = ""
End If
'Barcode links ausfüllen
'Fill Barcode Links
If Len(Position) <> 3 Then
Auffüllen = 3 - Len(Position)
PositionsNr = String(Auffüllen, "0") & Position
End If
'********************************************************************
'Daten Fertigungszettel in Datenbank PPS-Daten.mdb schreiben
'Write the records to the PPS-Daten-IN db
sql = "SELECT * FROM [PPS-Daten-IN] where Projekt = " & AuftragsNr & " and Artikel = """ & Mark & """"
Set dtPPSDaten = dbDatenbank.OpenRecordset(sql)
If dtPPSDaten.RecordCount = 0 Then
' Get the Seq number
Dim db As Database
Dim rs, ros As Recordset
Dim dbSQL, rosSQL As String
Set db = DBEngine.Workspaces(0).Databases(0)
dbSQL = "SELECT SeqNum FROM [SEQNum] where ID = 1"
Set rs = db.OpenRecordset(dbSQL)
rosSQL = "SELECT HöheTS, DickeFS FROM Rostbezeichnung WHERE Rostbezeichnung = """ & Rostbezeichnung & """"
Set ros = db.OpenRecordset(rosSQL)
With rs
.Edit
!SeqNum = !SeqNum + 1
.Update
End With
OpSeqBand.Caption = rs!SeqNum
OpSeqCB.Caption = rs!SeqNum
OpSeqBB.Caption = rs!SeqNum
With dtPPSDaten
.AddNew
!Projekt = AuftragsNr
!Bez_Rost = Rostbezeichnung
!Artikel = Mark
!Arttext1 = rs!SeqNum
!Rost_TS = Tragstab
!Rost_FS = Füllstab
!Stück_S0 = Bestellmenge
!Bez_Komp_1 = Einfassungsmaterial
!Länge_1 = EinfassungslängeTS
!Länge_2 = EinfassungslängeTS
!Länge_3 = EinfassungslängeFS
!Länge_4 = EinfassungslängeFS
!Bez_Komp_5 = MaterialbezeichnungTS
!Länge_TS = Tragstablänge
!Endma_TS = Format(TEM, "###0.00")
!Stück_TS = TA
!Teilung_TS = Tragstabteiler
!Bez_Komp_6 = MaterialbezeichnungFS
!Länge_FS = Füllstablänge
!Endma_FS = Format(FEM, "###0.00")
!Stück_FS = FA
!Teilung_FS = Füllstabteiler
!Eintragsdatum = Forms![Fertigungskopf]![Datum]
!Höhe_TS = ros!HöheTS
!Stärke_FS = ros!DickeFS
ProdAuftrag = !Prodauftr
.Update
End With
dtPPSDaten.Close
rs.Close
Else
' The to take into account the looping issue. When this is the 2nd time through on the same
' Mark #, then get the Machine # for the report
dtPPSDaten.Close
sql = "SELECT Prodauftr, Arttext1 FROM [PPS-Daten-IN] where Projekt = " & AuftragsNr & " and Artikel = """ & Mark & """"
Set dtPPSDaten = dbDatenbank.OpenRecordset(sql)
ProdAuftrag = dtPPSDaten.Prodauftr
OpSeqBand.Caption = dtPPSDaten.Arttext1
OpSeqCB.Caption = dtPPSDaten.Arttext1
OpSeqBB.Caption = dtPPSDaten.Arttext1
dtPPSDaten.Close
End If
'End If
'********************************************************************
'Barcode rechts ausfüllen (nachgelagert wegen Produktionsauftragsnummer aus Tabelle PPS-Daten-IN)
If Len(Trim(ProdAuftrag)) <> 9 Then
Auffüllen = 9 - Len(Trim(ProdAuftrag))
Barcode_ProdAuftrag = String(Auffüllen, "0") & ProdAuftrag
Barcode_PA_Edgebanding = "*" & Barcode_ProdAuftrag & "*"
Barcode_PA_crossbar = "*" & Barcode_ProdAuftrag & "*"
Barcode_PA_Bearingbar = "*" & Barcode_ProdAuftrag & "*"
Else
Barcode_PA_Edgebanding = "*" & Barcode_ProdAuftrag & "*"
Barcode_PA_crossbar = "*" & Barcode_ProdAuftrag & "*"
Barcode_PA_Bearingbar = "*" & Barcode_ProdAuftrag & "*"
End If
'------------------------------------------------------------------
Me.Label444.Visible
Me.Label445.Visible
Exit_Detailbereich_Format:
Exit Sub
Err_Detailbereich_Format:
MsgBox Err.Description
Resume Exit_Detailbereich_Format
End Sub
If you scroll to the very end you will see to lines that make labels 444 and 445 visible. If i comment this lines out, as they are the only ones I added, the report will work correctly.
Oh and it does not matter where the code is placed as the end result is always the same, no output.
Does anyone have any idea as to why this is happening?? I have hit the wall on this one.
Thanks to any suggestions I can get.
The correct syntax for making a control visible is
Me.Label444.Visible = True
Me.Label445.Visible = True
The visible property is expecting a Boolean value so you have to set it to either true or false. This might solve the problem.
I am trying to perform an integration using Excel VBA. Was wondering how I would do this using an approximation method if I need to integrate a negative exponent (since x/0 is undefined, hence such approximations could not estimate it)
My current code is:
Function Integral(sExp As String, dMin As Double, dMax As Double, lBit As Long)
Dim dU As Double
Dim lU As Long
dU = (dMax - dMin) / lBit
For lU = 1 To lBit
IntegralTemp = IntegralTemp + Evaluate(Replace(sExp, "u", dMin)) * dU + 0.5 * dU * Abs(Evaluate(Replace(sExp, "u", dMin + dU)) - Evaluate(Replace(sExp, "u", dMin)))
dMin = dMin + dU
Next lU
Integral = IntegralTemp
End Function
Perhaps use a Monte Carlo technique to estimate the value?
Here's a wikipedia article for this approach:
http://en.wikipedia.org/wiki/Monte_Carlo_integration
I think this is problem with function Evaluate.
I try solve this and that has managed to make:
Look on this test function:
Function EvaluateTest(str As String)
EvaluateTest = Evaluate(str)
EvaluateTest = CStr(EvaluateTest)
End Function
debug.Print EvaluateTest("0^(-0.05)") show Error 2007 i think this is dividing by zero -> 0^(-0.05) for VBA is 0/(0^0.05)
We can catch this error and for thats case accept results = 0
I create function using to catch this 1 error and modified a bit your function. Try this code:
Function EvaluateCheck(Exp As String)
Dim EvalCheck As Variant
EvalCheck = Evaluate(Exp)
If VarType(EvalCheck) = vbError Then 'evaluate function error
Select Case CInt(EvalCheck)
Case 2007 ' 0/x
'Debug.Print "Evaluate(" & Exp & ") error= " & CStr(EvalCheck); ""
EvaluateCheck = 0
'Case 2015 ' other problems with evaluate (power)
'Debug.Print "Evaluate(" & Exp & ") error= " & CStr(EvalCheck); ""
'try use power function not evaluate
'FindTmp = WorksheetFunction.Find("^", Exp)
'If FindTmp > 0 Then
'number_ = CDbl(Mid(Exp, 1, FindTmp - 1))
'Power_ = Mid(Exp, FindTmp + 1, Len(Exp))
'Power_ = Replace(Power_, ".", ",") '<- i have problems with CDbl function i must replace . to , maybe you dont need this line
'Power_ = Replace(Replace(Power_, "(", vbNullString), ")", vbNullString) ' we dont need parentheses
'PowerDbl = CDbl(Power_)
'EvaluateCheck = WorksheetFunction.power(number_, PowerDbl)
'Else
'Debug.Print "Evaluate(" & Exp & ") error= " & CStr(EvalCheck); " i cant handle that case"
'End If
Case Else
Debug.Print "Evaluate(" & Exp & ") error= " & CStr(EvalCheck); " i cant handle that case"
End Select
Else ' evaluate no error
EvaluateCheck = EvalCheck
End If
End Function
Your function:
Function Integral(sExp As String, dMin As Double, dMax As Double, lBit As Long)
Dim dU As Double
Dim lU As Long
Dim eval As Long
Dim EvaluateVal1 As Double 'Evaluate(Replace(sExp, "u", dMin))
Dim EvaluateVal2 As Double 'Evaluate(Replace(sExp, "u", dMin + dU))
Dim sExpTmp As String
dU = (dMax - dMin) / lBit
For lU = 1 To lBit
'check evaluate
sExpTmp = Replace(sExp, "u", dMin)
EvaluateVal1 = EvaluateCheck(sExpTmp)
sExpTmp = Replace(sExp, "u", dMin + dU)
EvaluateVal2 = EvaluateCheck(sExpTmp)
IntegralTemp = IntegralTemp + EvaluateVal1 * dU + 0.5 * dU * Abs(EvaluateVal1 - EvaluateVal2)
dMin = dMin + dU
Next lU
Integral = IntegralTemp
End Function
Some results:
debug.print Integral("u^(-0.05)", 0, 1, 500)
1,05186339856455
debug.print Integral("u^(-0.05)", 0.05, 1, 500)
0,991802803730478
debug.print Integral("u^(-0.05)", 0.05, 1.05, 500)
1,0417624389399
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.