how to loop through the nth slide powerpoint vba - vba

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

Related

Compute sum Odoo

I have made a custom module budget with the field Value. I would like to sum all the values for the budgets I've made today
def value_budget_day(self):
for budget in self:
# Encontrar si hoy es el mismo dia que se creo un presupuesto
c_date = datetime.strftime(budget.create_date, "%Y-%m-%d %H:%M:%S")
t_date = datetime.strftime(budget.today, "%Y-%m-%d %H:%M:%S")
create_day = c_date[:10]
today_day = t_date[:10]
if create_day == today_day:
# Sumar todos los valores de los presupuestos de ese día
total = 0.0
for val in budget:
total += val.value
budget.today_value = total
else:
budget.today_value = 35
In my code the values are not sum
def value_budget_day(self):
total = 0
for budget in self:
# Encontrar si hoy es el mismo dia que se creo un presupuesto
c_date = datetime.strftime(budget.create_date, "%Y-%m-%d %H:%M:%S")
t_date = datetime.strftime(budget.today, "%Y-%m-%d %H:%M:%S")
create_day = c_date[:10]
today_day = t_date[:10]
if create_day == today_day:
# Sumar todos los valores de los presupuestos de ese día
total += budget.value
budget.today_value = total
else:
budget.today_value = 0
today_value = fields.Float(compute='value_budget_day')

Can't loop a while loop

So I want to do a while loop just to calculate the integral of some random functions. The thing is that when I pass opción = 1 it does the first if (good) but when I pass other number it breaks. Obviously, because True = 1 and False = 0. So how can I do it to do the while loop until (1,2,3) until I press 4... Thanks you so much in advance
while opcion == True:
if opcion == 1:
print('Vamos a calcular la siguiente integral:')
f = a*x + b
integral = sp.Integral(f, x)
sp.pprint(integral)
print()
print('Que tiene como resultado:')
sp.pprint(sp.integrate(f,x))
print()
print('Introducimos los límites y valores de las'
' constantes para caluclarla')
lim_inf = int(input('Límite inferior = '))
lim_sup = int(input('Límite superior = '))
while (lim_inf == lim_sup):
print('Los límites no pueden ser iguales !! '
'Vuelve a introducir valores diferentes')
lim_inf = int(input('Límite inferior = '))
lim_sup = int(input('Límite superior = '))
a = int(input('valor a = '))
b = int(input('valor de b = '))
res = integrate.quad(grad1, lim_inf, lim_sup, args=(a,b))
print()
print('Valor de la integral',res[0])
elif opcion == 2:
print('Vamos a calcular la siguiente integral:')
f = a*x**2 + b*x + c
integral = sp.Integral(f, x)
sp.pprint(integral)
print()
print('Que tiene como resultado:')
sp.pprint(sp.integrate(f,x))
print()
print('Introducimos los límites y valores de las'
' constantes para caluclarla')
lim_inf = int(input('Límite inferior = '))
lim_sup = int(input('Límite superior = '))
while (lim_inf == lim_sup):
print('Los límites no pueden ser iguales !! '
'Vuelve a introducir valores diferentes')
lim_inf = int(input('Límite inferior = '))
lim_sup = int(input('Límite superior = '))
a = int(input('valor a = '))
b = int(input('valor de b = '))
res = integrate.quad(grad2, lim_inf, lim_sup, args=(a,b))
print()
print('Valor de la integral',res[0])
elif opcion == 3:
print('Vamos a calcular la siguiente integral:')
f = a*x**3 + b*x**2 + c*x**2 + d
integral = sp.Integral(f, x)
sp.pprint(integral)
print()
print('Que tiene como resultado:')
sp.pprint(sp.integrate(f,x))
print()
print('Introducimos los límites y valores de las'
' constantes para caluclarla')
lim_inf = int(input('Límite inferior = '))
lim_sup = int(input('Límite superior = '))
while (lim_inf == lim_sup):
print('Los límites no pueden ser iguales !! '
'Vuelve a introducir valores diferentes')
lim_inf = int(input('Límite inferior = '))
lim_sup = int(input('Límite superior = '))
a = int(input('valor a = '))
b = int(input('valor de b = '))
res = integrate.quad(grad3, lim_inf, lim_sup, args=(a,b))
print()
print('Valor de la integral',res[0])
elif opcion == 4:
break
you should just wrap it into the while true then cause the break as expected and don't depent on option. Use sys to just pass in the opcion as an argument for the script so that 4 will just cause it to break automatically... otherwise if its just generated into the script... you can have opcion generate a 1 by default to begin work.
import sys
...
opcion = sys.argv[1]
while True:
if opcion == 1:
print('Vamos a calcular la siguiente integral:')
f = a*x + b
integral = sp.Integral(f, x)
sp.pprint(integral)
print()
print('Que tiene como resultado:')
sp.pprint(sp.integrate(f,x))
print()
print('Introducimos los límites y valores de las'
' constantes para caluclarla')
lim_inf = int(input('Límite inferior = '))
lim_sup = int(input('Límite superior = '))
while (lim_inf == lim_sup):
print('Los límites no pueden ser iguales !! '
'Vuelve a introducir valores diferentes')
lim_inf = int(input('Límite inferior = '))
lim_sup = int(input('Límite superior = '))
a = int(input('valor a = '))
b = int(input('valor de b = '))
res = integrate.quad(grad1, lim_inf, lim_sup, args=(a,b))
print()
print('Valor de la integral',res[0])
elif opcion == 2:
print('Vamos a calcular la siguiente integral:')
f = a*x**2 + b*x + c
integral = sp.Integral(f, x)
sp.pprint(integral)
print()
print('Que tiene como resultado:')
sp.pprint(sp.integrate(f,x))
print()
print('Introducimos los límites y valores de las'
' constantes para caluclarla')
lim_inf = int(input('Límite inferior = '))
lim_sup = int(input('Límite superior = '))
while (lim_inf == lim_sup):
print('Los límites no pueden ser iguales !! '
'Vuelve a introducir valores diferentes')
lim_inf = int(input('Límite inferior = '))
lim_sup = int(input('Límite superior = '))
a = int(input('valor a = '))
b = int(input('valor de b = '))
res = integrate.quad(grad2, lim_inf, lim_sup, args=(a,b))
print()
print('Valor de la integral',res[0])
elif opcion == 3:
print('Vamos a calcular la siguiente integral:')
f = a*x**3 + b*x**2 + c*x**2 + d
integral = sp.Integral(f, x)
sp.pprint(integral)
print()
print('Que tiene como resultado:')
sp.pprint(sp.integrate(f,x))
print()
print('Introducimos los límites y valores de las'
' constantes para caluclarla')
lim_inf = int(input('Límite inferior = '))
lim_sup = int(input('Límite superior = '))
while (lim_inf == lim_sup):
print('Los límites no pueden ser iguales !! '
'Vuelve a introducir valores diferentes')
lim_inf = int(input('Límite inferior = '))
lim_sup = int(input('Límite superior = '))
a = int(input('valor a = '))
b = int(input('valor de b = '))
res = integrate.quad(grad3, lim_inf, lim_sup, args=(a,b))
print()
print('Valor de la integral',res[0])
elif opcion == 4:
break

Changing the color of a textbox in VBA (shading off/colour gradient)

I am trying to insert an automated summary at the beginning of my PowerPoint presentation in VBA. (I am fairly new to Visual Basic)
I have found the code that gives me the references, but I can't seem to figure out the colour gradient of one shape.
With ActivePresentation.Slides(1)
.Shapes(1).Fill.Visible = msoTrue
.Shapes(1).Fill.ForeColor.RGB = RGB(208, 30, 60)
.Shapes(1).Fill.BackColor.RGB = RGB(97, 18, 30)
.Shapes(1).Fill.TwoColorGradient msoGradientHorizontal, 2
.Shapes(1).Line.Visible = msoFalse
The doc on the internet says the method is ForeColor and BackColor, but I can't seem to get it working. I don't understand why the second color is white and not dark red as its RGB code says.
my current template has the title on the side, and vertical, text towards the right side. The textbox is colored with a shading from RGB(208, 30, 60) to RGB(97, 18, 30) linearly with an angle of 270°.
this what is given by the complete VBA code (at the end)
This what I would like to have (with the numbers as shown in the VBA Slide)
Complete code:
Sub Sommaire()
Dim Diapo As Slide
Dim titre As Shape
Dim petit_titre As Shape
Dim texte_ajout As TextRange
Dim texte_sommaire As TextRange
Dim ligne_sommaire As TextRange
Dim y As Byte
'Si le titre de la première diapo est "Sommaire", elle sera supprimée
'cela permet de relancer la macro autant de fois que l'on souhaite
'sans avoir à supprimer la diapo de sommaire
If ActivePresentation.Slides(1).Shapes(1).TextFrame.TextRange = "SOMMAIRE" Then
ActivePresentation.Slides(1).Delete
End If
' ajoute une diapo en début de présentation avec
'la disposition de mise en titre n°2 du masque
ActivePresentation.Slides.Add Index:=1, Layout:=ppLayoutText
With ActivePresentation.Slides(1)
.Shapes(1).TextFrame.TextRange = "SOMMAIRE"
.Shapes(1).TextFrame.TextRange.Font.Color.RGB = RGB(255, 255, 255)
.Shapes(1).TextFrame.TextRange.Font.Name = "Arial Black"
.Shapes(1).TextFrame.TextRange.Font.Size = 24
.Shapes(1).TextFrame2.TextRange.Font.Spacing = 3
.Shapes(1).TextFrame2.VerticalAnchor = msoAnchorBottom
.Shapes(1).TextFrame2.TextRange.ParagraphFormat.Alignment = _
msoAlignLeft
.Shapes(1).TextFrame2.MarginLeft = 14.1732283465
.Shapes(1).TextFrame2.MarginRight = 14.1732283465
.Shapes(1).TextFrame2.MarginTop = 14.1732283465
.Shapes(1).TextFrame2.MarginBottom = 28.3464566929
.Shapes(1).TextFrame2.WordWrap = msoTrue
.Shapes(1).TextFrame.Orientation = msoTextOrientationUpward
.Shapes(1).Left = 0 * 72
.Shapes(1).Top = 0 * 72
.Shapes(1).Height = ActivePresentation.PageSetup.SlideHeight
.Shapes(1).Width = 0.975 * 72
.Shapes(1).Fill.Visible = msoTrue
.Shapes(1).Fill.ForeColor.RGB = RGB(208, 30, 60)
.Shapes(1).Fill.BackColor.RGB = RGB(97, 18, 30)
.Shapes(1).Fill.TwoColorGradient msoGradientHorizontal, 2
.Shapes(1).Line.Visible = msoFalse
.Shapes(1).Shadow.Type = msoShadow25
.Shapes(1).Shadow.Visible = msoTrue
.Shapes(1).Shadow.Style = msoShadowStyleInnerShadow
.Shapes(1).Shadow.Blur = 5
.Shapes(1).Shadow.OffsetX = 3.9993907806
.Shapes(1).Shadow.OffsetY = -0.0698096257
.Shapes(1).Shadow.ForeColor.RGB = RGB(52, 9, 16)
.Shapes(1).Shadow.Transparency = 0.5
Set texte_ajout = .Shapes(2).TextFrame.TextRange
End With
With ActivePresentation.Slides(1).Shapes _
.AddShape(msoShapeRectangle, 1.5275 * 72, 32.7, 180, 29.1)
.TextFrame.TextRange.Text = "Sommaire"
.TextFrame.MarginBottom = 10
.TextFrame.MarginLeft = 10
.TextFrame.MarginRight = 10
.TextFrame.MarginTop = 10
.TextFrame.TextRange.Font.Name = "Arial Black"
.TextFrame.TextRange.Font.Size = 18
.TextFrame2.VerticalAnchor = msoAnchorMiddle
.TextFrame2.TextRange.ParagraphFormat.Alignment = _
msoAlignLeft
.Fill.Visible = msoFalse
.Line.Visible = msoFalse
.TextFrame2.TextRange.Characters(1, 1).Font.Fill.ForeColor.RGB = RGB(208, 30, 60)
.TextFrame2.TextRange.Characters(2, 7).Font.Fill.ForeColor.RGB = RGB(39, 39, 39)
.Shadow.Visible = msoFalse
End With
'boucle sur toutes les diapos à partir de la 2e
For y = 2 To ActivePresentation.Slides.Count
Set Diapo = ActivePresentation.Slides(y)
'si la diapo a un titre
If Diapo.Shapes.HasTitle Then
Set titre = Diapo.Shapes.Title
texte_ajout = texte_ajout & Format(y, "0 - ") & titre.TextFrame. _
TextRange.Text & Chr(13) & vbCrLf
End If
Next y
'ajout de liens aux items du sommaire
Set texte_sommaire = _
ActivePresentation.Slides(1).Shapes(2).TextFrame.TextRange
texte_sommaire.Font.Size = 20
texte_sommaire.Font.Color.RGB = RGB(39, 39, 39)
With ActivePresentation.Slides(1).Shapes(2)
.Left = 1.5275 * 72
.Top = 1.9 * 72
End With
End Sub
Thank you in advance
I picked that from Excel macro recorder, as Shapes and most of the objects still have a lot of commons parts between Office applications.
ActiveSheet.Shapes.Range(Array("TextBox 1")).Select
With Selection.ShapeRange
With .Fill
.ForeColor.RGB = RGB(255, 0, 0)
.BackColor.RGB = RGB(0, 0, 1)
.TwoColorGradient msoGradientHorizontal, 1
.RotateWithObject = msoTrue
.Visible = msoTrue
End With
With .TextFrame2.TextRange.Font
.BaselineOffset = 0
.Spacing = 1.6
End With
End With
You only need to "attach" (replace the Selection) it to your textbox, but I think you can handle that. I'll edit my answer to include all pointers I gave you in comments too.

VBA - Excel - Error 13

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

MapPoint Excel VBA. Why the RAM used increase until to freeze the script?

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.