L'altra mail l'hai mandata al mio indirizzo, quindi non è arrivata in
lista...
Comunque non è un problema.
>> A me sembra che sia a buon punto
>> L' ho provata in vari modi e non si è mai inciampata
> Inciampa ancora... in situazioni importanti e normali (non in quelle
> estreme...)!
> '5.555 non lo converte e nemmeno
> '2
Piccola dimenticanza... ^_^
>> Daltronde, Bart, se ti aspetti qualcosa di perfetto, questa sub non
>> la userai mai
> Per i casi che avevo sotto i ferri ultimamente funzionava benissimo
> una macro di quelle "superate" (ma vai a sapere adesso qual'era... :-) )
>
> Alla perfezione non aspiro, ma a quel risultato della macro "superata"
> si!
Ad ogni modo, dei casi da te indicati nel file al momento 2, 3 e 4 ora
li converte.
Non ricordavo avessi parlato di spazi, quindi non li avevo considerati
(mi deve essere sfuggito), ora converte sia quello che hai messo tu
"5,555 " (spazio alla fine), sia eventuali "55 555" (ho semplicemente
fatto in modo che prima di ogni verifica elimina ogni spazio presente
nella stringa).
Per il 2% ho fatto in modo che lo riconosca come testo ed ora lo copia
intatto.
Quello che resta in sospeso è: "389'5,65", secondo te come dovrebbe
essere convertito?
Situazioni simili le ho lasciate in sospeso, perché in verità non vedo
una soluzione "pulita"...
In quel numero c'è sicuramente un errore di battitura, ma in ogni caso
io non so dire dove sia: può essere una virgola di troppo come può
essere l'apice di troppo.
In questi casi devi decidere tu cosa preferisci.
> Una domanda: il codice dentro la mail è identico a quello allegato in
> .bas?
Sì, nella mail la vedi solo perché il programma di posta lo mette in
coda al messaggio.
> Scusa il ritardo con cui rispondo, ma visti i risultati "diversi" che
> si ottenevano ho rigirato un po' lecose...
Siccome non son riuscito a capire bene cosa avevi cambiato e come, son
ritornato a quella che ti ho inviato.
> In questo modo il codice potrebbe stare dentro... senza aggiungere le
> complicazioni del taglia/incolla e del taglia a 72 caratteri con
> codice senza rientri...
> (La macro è ormai troppo complessa per continuare ad incollare il
> codice nella mail.)
Non son sicuro che tutti gradiscano ritrovarsi l'odt come allegato, il
txt è comunque (anche se di poco) più leggero.
Inoltre se apri l'allegato in un notepad qualunque anche i rientri non
hanno alcun problema ;-)
Ciao!
Ema.
Sub Che_Digerisce_Quasi_Tutto_e_Lo_Converte_In_Numeri()
' Converte da numeri in formato stringa
' a nuneri "veri"
' copiandoli su una nuova colonna a lato
' versione del 13/06/06
' da azionare dopo aver selezionato
' il range di celle da convertire
Dim d As long
Dim e As long
Dim f As long
Dim g As long
Dim Tipo As Double
Dim Tipo2 As String
dim oFoglio As Object
dim oSelections as object
Dim oMycell As Object
Dim oMyRange As Object
Dim NumCol As Integer
dim cell as object
Dim h As Integer
Dim i As Integer
Dim l As String
Dim iPosizionePrimoPunto as integer
Dim iPosizionePrimaVirgola as integer
dim sPaginaRiferimento as string
dim oTextSearch as object
dim aSearchResult as object
dim iContienePunti as integer
dim iContieneVirgole as integer
dim iContieneApici as integer
Dim aSrcOpt As New com.sun.star.util.SearchOptions
oTextSearch = CreateUnoService(_
"com.sun.star.util.TextSearch")
Set oFoglio =_
ThisComponent.Sheets.getByName(_
ThisComponent.currentcontroller.activesheet.name)
oSelections = ThisComponent.getCurrentSelection()
oMyRange=oSelections.getRangeAddress()
d = oMyRange.StartColumn 'getColonnaIniziale(a)
e = oMyRange.StartRow 'getRigaIniziale(a)
f = oMyRange.EndRow 'getRigaFinale(a)
NumCol = oMyRange.StartColumn ' definisce il numero della colonna
oFoglio.Columns.insertbyindex(d+1,1)
Dim oBarra As Object
oBarra = _
thisComponent.GetCurrentController.GetFrame.CreateStatusIndicator '''
oBarra.Start(" Inizio la Conversione", Val(f))
For g = Val(e) to Val(f) ' Inizia il ciclo
oBarra.setValue(g)'''
Cell = oFoglio.getCellByPosition(NumCol, g)
oMycell = oFoglio.getCellByPosition(NumCol+1, g )
Select Case Cell.Type
Case com.sun.star.table.CellContentType.VALUE
' Se è un valore si limita a copiarlo e
formattare la cella
Tipo = Cell.Value
oMycell.setValue(Tipo)
oMycell.NumberFormat = 4 'Valore ##.##0,00
Case com.sun.star.table.CellContentType.TEXT
' Se è di tipo testo fa una serie di controlli
per determinare
' che tipo di stringa è
' se trova dei caratteri di testo o delle celle
vuote
' salta alla cella dopo
Tipo2 = Cell.String
if not contieneTesto(Tipo2) then
Tipo2 = Trim(Tipo2)
Tipo2 = join(split(Tipo2, " "), "")
iContienePunti = contieneSimboli(Tipo2,
".")
iContieneVirgole =
contieneSimboli(Tipo2, ",")
iContieneApici = contieneSimboli(Tipo2,
"'")
if (iContienePunti > 0) and
(iContieneVirgole > 0) and (iContieneApici > 0) then
'Ci sono tutti e tre i simboli:
non so cosa fare...
errore_stringa(oMycell,Tipo2)
end if
if (iContienePunti > 0) and
(iContieneVirgole > 0) and (iContieneApici = 0) then
'Ci sono solo virgole e punti
if getPosLastSymbol(Tipo2, ",")
> getPosLastSymbol(Tipo2, ".") then
'l'ultima virgola sta
più a destra dell'ultimo punto
if iContieneVirgole > 1
then
'C'è più di una
virgola, non so cosa fare
Errore_Stringa(oMycell,Tipo2)
else
'C'è
una sola virgola copio la stringa
'Controllare la posizione
if
controllaPosizione(Tipo2, ",", ".") then
Copia_Stringa(oMycell,Tipo2)
else
Errore_Stringa(oMycell,Tipo2)
end if
end if
else
'l'ultima
virgola sta più a sinistra dell'ultimo punto
if
iContienePunti > 1 then
'C'è
più di un punto, non so cosa fare
Errore_Stringa(oMycell,Tipo2)
else
'C'è un solo punto copio la stringa
'Controllare la posizione
if controllaPosizione(Tipo2, ".", ",") then
Tipo2 = join(split(Tipo2, ","), "")
Tipo2 = join(split(Tipo2, "."), ",")
Copia_Stringa(oMycell,Tipo2)
else
Errore_Stringa(oMycell,Tipo2)
end if
end if
end if
end if
if (iContienePunti > 0) and
(iContieneVirgole = 0) and (iContieneApici > 0) then
'Ci sono solo punti ed apici
if getPosLastSymbol(Tipo2, ".")
> getPosLastSymbol(Tipo2, "'") then
'l'ultimo punto sta più
a destra dell'ultimo apice
'Controllare la
posizione
if
controllaPosizione(Tipo2, ".", "'") then
Tipo2 =
join(split(Tipo2, "."), ",")
Tipo2 =
join(split(Tipo2, "'"), "")
Copia_Stringa(oMycell,Tipo2)
else
Errore_Stringa(oMycell,Tipo2)
end if
else
'l'ultimo apice
sta più a destra dell'ultimo punto,
'non so cosa
fare...
Errore_Stringa(oMycell,Tipo2)
end if
end if
if (iContienePunti = 0) and
(iContieneVirgole > 0) and (iContieneApici > 0) then
'Ci sono solo virgole ed apici
if getPosLastSymbol(Tipo2, ",")
> getPosLastSymbol(Tipo2, "'") then
'l'ultima virgola sta
più a destra dell'ultimo apice
'Controllare la
posizione
if
controllaPosizione(Tipo2, ",", "'") then
Tipo2 =
join(split(Tipo2, "'"), "")
Copia_Stringa(oMycell,Tipo2)
else
Errore_Stringa(oMycell,Tipo2)
end if
else
'l'ultimo apice
sta più a destra dell'ultima virgola,
'non so cosa
fare...
Errore_Stringa(oMycell,Tipo2)
end if
end if
if (iContienePunti > 0) and
(iContieneVirgole = 0) and (iContieneApici = 0) then
'Ci sono solo punti
'Controllare la posizione
if iContienePunti > 1 then
'Ci sono molti punti
if
controllaPosizione(Tipo2, "", ".") then
Copia_Stringa(oMycell,Tipo2)
else
Errore_Stringa(oMycell,Tipo2)
end if
else
'C'è un solo
punto
if
controllaPosizione(Tipo2, "", ".") then
Tipo2 =
join(split(Tipo2, "."), "")
Copia_Stringa(oMycell,Tipo2)
else
if controllaPosizione(Tipo2, ".", "") then
Tipo2 = join(split(Tipo2, "."), ",")
Copia_Stringa(oMycell,Tipo2)
else
Errore_Stringa(oMycell,Tipo2)
end if
end if
end if
end if
if (iContienePunti = 0) and
(iContieneVirgole > 0) and (iContieneApici = 0) then
'Ci sono solo virgole
'Controllare la posizione
if iContieneVirgole > 1 then
'Ci sono molte virgole
if
controllaPosizione(Tipo2, "", ",") then
Tipo2 =
join(split(Tipo2, ","), "")
Copia_Stringa(oMycell,Tipo2)
else
Errore_Stringa(oMycell,Tipo2)
end if
else
'C'è una sola
virgola
if
controllaPosizione(Tipo2, ",", "") then
Copia_Stringa(oMycell,Tipo2)
else
if controllaPosizione(Tipo2, "", ",") then
Tipo2 = join(split(Tipo2, ","), "")
Copia_Stringa(oMycell,Tipo2)
else
Errore_Stringa(oMycell,Tipo2)
end if
end if
end if
end if
if (iContienePunti = 0) and
(iContieneVirgole = 0) and (iContieneApici > 0) then
'Ci sono solo apici
'Controllare la posizione
if controllaPosizione(Tipo2,
"", "'") then
Copia_Stringa(oMycell,Tipo2)
else
Errore_Stringa(oMycell,Tipo2)
end if
end if
if (iContienePunti = 0) and
(iContieneVirgole = 0) and (iContieneApici = 0) then
'apparentemente non c'è niente
che non vada, quindi la copiamo
Copia_Stringa(oMycell,Tipo2)
end if
else
Errore_Stringa(oMycell,Tipo2)
end if
Case com.sun.star.table.CellContentType.EMPTY
'MsgBox(" Dice la particella
di sodio "_
'& CHR$(10) & CHR$(10) & "
CA NON CI STA NISCIUNO!")
Case com.sun.star.table.CellContentType.FORMULA
' Questa va fatta in caso di bisogno
End Select
Next
oBarra.End
msgbox " La conversione in numeri è "_
& "terminata... "& CHR$(10) & CHR$(10)_
& "Le eventuali stringhe che non sono riuscito "_
& "ad interpretare le ho copiate tali e quali, "_
& "ma ""segnandole"" con sfondo in rosso! "_
& "( molto rosso... :-) )"
end sub
Function getPosLastSymbol(sText as string, sChar as string) as integer
dim lI as long
for lI = len(sText) to 0 step -1
if mid(sText, lI, 1) = sChar then
getPosLastSymbol = lI
exit function
end if
next lI
End Function
Function sequenzaMigliaia(sTesto as string, sExpDec as string, sExpMig as
string) as boolean
Dim iSimbPos as integer
if sExpDec = "" then
iSimbPos = len(sTesto) - 3
else
iSimbPos = len(sTesto) - 3 - (len(sTesto) -
InStr(sTesto, sExpDec)) - 1'len(sTesto) - 4
end if
do while (mid(sTesto, iSimbPos, 1) = sExpMig)
iSimbPos = iSimbPos - 4
if iSimbPos <= 0 then exit do
loop
if iSimbPos <= 0 then
sequenzaMigliaia = true
exit function
else
sequenzaMigliaia = false
exit function
end if
End Function
Function controllaPosizione(sTesto as string, sExpDec as string, sExpMig as
string) as boolean
' Dim iSimbPos as integer
' Dim bSembraOk as boolean
if sExpDec = "" and sExpMig = "" then
controllaPosizione = false
exit function
end if
if sExpDec = "" and not(sExpMig = "") then
controllaPosizione = sequenzaMigliaia(sTesto, sExpDec, sExpMig)
end if
if sExpMig = "" and not(sExpDec = "") then
if mid(sTesto, len(sTesto) - 3, 1) = sExpDec then
controllaPosizione = false
exit function
else
controllaPosizione = true
exit function
end if
end if
if not(sExpMig = "") and not(sExpDec = "") then
controllaPosizione = sequenzaMigliaia(sTesto, sExpDec,
sExpMig)' and bSembraOk)
end if
End Function
Sub errore_stringa(oMycell, Tipo2)
'If MsgBox("Non riesco ad interpretare "& "questa stringa...--> "& _
'"' " & Tipo2 & " '" & CHR$(10) & _
'" Proseguo copiando il testo tal quale ?" & "" ,36, "") = 6 then
oMycell.setString(Tipo2)
oMycell.CellBackColor = RGB(255,0,0)
'end if
End Sub
Sub Copia_Stringa(oMycell,Tipo2)
on error goto gest_errore
oMycell.setValue(cDbl(Tipo2))
oMycell.NumberFormat = 4
exit sub
gest_errore:
' lo so che è una porcata...
oMycell.setString(Tipo2)
oMycell.CellBackColor = RGB(255,0,0)
'
End Sub
function contieneTesto(sTesto as string) as boolean
dim sPaginaRiferimento as string
dim oTextSearch as object
dim aSearchResult as object
Dim aSrcOpt As New com.sun.star.util.SearchOptions
oTextSearch = CreateUnoService("com.sun.star.util.TextSearch")
With aSrcOpt
.searchFlag = com.sun.star.util.SearchFlags.REG_EXTENDED
.algorithmType = com.sun.star.util.SearchAlgorithms.REGEXP
.searchString = ".[A-Za-zéèòàçìù%&]"
End With
oTextSearch.setOptions(aSrcOpt)
'L'asterisco serve come trucco per evitare che se il testo è il primo
carattere
'il aSearchResult.subRegExpressions sia comunque uguale a zero
aSearchResult = oTextSearch.searchForward("*" & sTesto, 0,Len(sTesto)+1)
if aSearchResult.subRegExpressions > 0 then
contieneTesto = true
end if
end function
function contieneSimboli(sTesto as string, sSimbolo as string) as integer
Dim sPaginaRiferimento as string
Dim iCount as integer
Dim oTextSearch as object
Dim aSearchResult as object
Dim aSrcOpt As New com.sun.star.util.SearchOptions
oTextSearch = CreateUnoService("com.sun.star.util.TextSearch")
With aSrcOpt
.searchFlag = com.sun.star.util.SearchFlags.REG_EXTENDED
.algorithmType = com.sun.star.util.SearchAlgorithms.REGEXP
if sSimbolo = "." then
.searchString = "\" & sSimbolo 'sMigSep & ".*" &
sDecSep '"'\.[^ ]
else
.searchString = sSimbolo
end if
End With
oTextSearch.setOptions(aSrcOpt)
'L'asterisco serve come trucco per evitare che se il testo è il primo
carattere
'il aSearchResult.subRegExpressions sia comunque uguale a zero
aSearchResult = oTextSearch.searchForward("*" & sTesto, 0,Len(sTesto)+1)
if aSearchResult.subRegExpressions > 0 then
iCount = iCount + 1
end if
contieneSimboli = iCount
end function
---------------------------------------------------------------------
To unsubscribe, e-mail: [EMAIL PROTECTED]
For additional commands, e-mail: [EMAIL PROTECTED]
