Arbol caido en el naranco

Si eres aficionado al mountain bike y lo practicas en el Naranco (Oviedo), tener cuidado los que bajeis pues está detras de una curva en una zona bastante rápida, aquí teneis la foto con su ubicación exacta en EveryTrail. :

http://bit.ly/6NyGoZ

Desfiladero de La Hermida

Panoramica entre Pedroveya y Peñerudes

Vista desde un poco mas arriba de Pedroveya, por un camino que va por el monte al otro lado del valle de la carretera entre Pedrovella y Peñerudes.

Va a salir a la carretera, bajando por una cuesta de hormigón casi al inicio de la bajada.

Al fondo se ve el Naranco y Oviedo, a la derecha el embalse de los Afilorios y a la izquierda en el centro la Torre medival en ruinas y a la derecha el pueblo de El Campo

Códigos

Los códigos publicados en notas con código, están asimismo en las Notas de google que puedes consultar en mi grupo y proximamente también se podrán consultar en mi web personal

http://juank.mvps.org

Notas con código

Calculo de años, meses y días entre dos fechas

Public Function DamePeriodo(ByVal DesdeFecha As Date, _
ByVal HastaFecha As Date) As String
'---------------------------------------------------------------------------------------
' Procedimiento : DamePeriodo
' Fecha y Hora : 19/09/2007 13:36
' Autor : Ju@nK 2007
' Proposito : Función para sacar los días trabajados entre dos fechas
' cuenta el día de inicio y el de fin
'---------------------------------------------------------------------------------------
' Ju@nK 2007
'
Dim m(2) As Integer, d(2) As Integer, Y(2) As Integer
Dim X As Integer
Dim res(2) As String
On Error GoTo DamePeriodo_Error

X = 0
d(X) = Day(DesdeFecha)
m(X) = Month(DesdeFecha)
Y(X) = Year(DesdeFecha)
X = 1
d(X) = Day(HastaFecha)
m(X) = Month(HastaFecha)
Y(X) = Year(HastaFecha)
If Y(1) + 1 >= Y(0) Then
Y(2) = Y(1) - Y(0)
Else
Y(2) = 0
End If
If m(1) + 1 >= m(0) Then
m(2) = m(1) - m(0)
Else
m(2) = (m(1) + 12) - m(0)
Y(2) = Y(2) - 1
End If
If d(1) + 1 >= d(0) Then
d(2) = (d(1) - d(0)) + 1
Else
m(2) = m(2) - 1
d(2) = (d(1) + Day(DateSerial(Y(1), m(1), 1) - 1)) - d(0) + 1
End If

Select Case Y(2)
Case 0
'nada
res(0) = ""
Case 1
res(0) = Y(2) & " año"
Case Else
res(0) = Y(2) & " años"
End Select

Select Case m(2)
Case 0
'nada
res(1) = ""
Case 1
res(1) = m(2) & " mes"
Case Else
res(1) = m(2) & " meses"
End Select

Select Case d(2)
Case 0
'nada
res(2) = ""
Case 1
res(2) = d(2) & " día"
Case Else
res(2) = d(2) & " días"
End Select

DamePeriodo = res(0)
If DamePeriodo = "" Then
DamePeriodo = res(1)
Else
If res(2) = "" Then
DamePeriodo = DamePeriodo & " y " & res(1)
Else
DamePeriodo = DamePeriodo & ", " & res(1)
End If
End If

If DamePeriodo = "" Then
DamePeriodo = res(2)
Else
If res(2) <> "" Then
DamePeriodo = DamePeriodo & " y " & res(2)
Else
DamePeriodo = DamePeriodo
End If
End If

On Error GoTo 0
Exit Function

DamePeriodo_Error:

MsgBox "Error " & Err.Number & vbCrLf & _
" (" & Err.Description & vbCrLf & _
") en el procedimiento DamePeriodo de Módulo VariosCalculos"
End Function

Public Function FechaLetra(ByVal UnaFecha As Date, _
Optional ByVal Mayusculas As Boolean = True) As String
'---------------------------------------------------------------------------------------
' Procedure : FechaLetra
' DateTime : 20/07/2007 12:44
' Author : © Ju@nK ®
' Purpose : Poner Fechas en letra para fechas hasta el 31/12/2059
'---------------------------------------------------------------------------------------
' © Ju@nK
Dim d As Long
Dim m As Long
Dim y As Long

On Error GoTo FechaLetra_Error

d = Day(UnaFecha)
m = Month(UnaFecha)
y = Year(UnaFecha)

FechaLetra = NumLetra(d) & " de " & Format(UnaFecha, "mmmm") & " de " & NumLetra(y)
'no hay
If Mayusculas Then
FechaLetra = UCase(FechaLetra)
End If

On Error GoTo 0
Exit Function

FechaLetra_Error:

MsgBox "Error " & Err.Number & " (" & Err.Description & ") en procedimiento FechaLetra de Módulo Pasa_Numeros_A_Letras"

End Function

Public Function NumLetra(ByVal UnNumero As Long) As String
'---------------------------------------------------------------------------------------
' Procedure : NumLetra
' DateTime : 20/07/2007 12:43
' Author : © Ju@nK ®
' Purpose : Poner numeros en letra para fechas hasta el 31/12/2059 o números
' con la función de NumDobleLetra, devolviendo moneda en Euros
'---------------------------------------------------------------------------------------
' © Ju@nK
On Error GoTo NumLetra_Error
Dim PartLetra As String

unidades:
Select Case UnNumero
Case 0
If NumLetra = "" Then
NumLetra = "cero"
End If
Case 1
NumLetra = NumLetra & "uno" & PartLetra
Case 2
NumLetra = NumLetra & "dos" & PartLetra
Case 3
NumLetra = NumLetra & "tres" & PartLetra
Case 4
NumLetra = NumLetra & "cuatro" & PartLetra
Case 5
NumLetra = NumLetra & "cinco" & PartLetra
Case 6
NumLetra = NumLetra & "seis" & PartLetra
Case 7
NumLetra = NumLetra & "siete" & PartLetra
Case 8
NumLetra = NumLetra & "ocho" & PartLetra
Case 9
NumLetra = NumLetra & "nueve" & PartLetra
Case 10
NumLetra = NumLetra & "diez" & PartLetra
Case 11
NumLetra = NumLetra & "once" & PartLetra
Case 12
NumLetra = NumLetra & "doce" & PartLetra
Case 13
NumLetra = NumLetra & "trece" & PartLetra
Case 14
NumLetra = NumLetra & "catorce" & PartLetra
Case 15
NumLetra = NumLetra & "quince" & PartLetra
Case 16
NumLetra = NumLetra & "dieciseis" & PartLetra
Case 17
NumLetra = NumLetra & "diecisiete" & PartLetra
Case 18
NumLetra = NumLetra & "dieciocho" & PartLetra
Case 19
NumLetra = NumLetra & "diecinueve" & PartLetra
Case 20
NumLetra = NumLetra & "veinte" & PartLetra
Case 21 To 29
NumLetra = NumLetra & "venti"
UnNumero = UnNumero - 20
GoTo unidades
Case 30 To 39
NumLetra = NumLetra & "treinta"
UnNumero = UnNumero - 30
If UnNumero <> 0 Then
NumLetra = NumLetra & " y "
GoTo unidades
End If
Case 40 To 49
NumLetra = NumLetra & "cuarenta"
UnNumero = UnNumero - 40
If UnNumero <> 0 Then
NumLetra = NumLetra & " y "
GoTo unidades
End If
Case 50 To 59
NumLetra = NumLetra & "cincuenta"
UnNumero = UnNumero - 50
If UnNumero <> 0 Then
NumLetra = NumLetra & " y "
GoTo unidades
End If
Case 60 To 69
NumLetra = NumLetra & "sesenta"
UnNumero = UnNumero - 60
If UnNumero <> 0 Then
NumLetra = NumLetra & " y "
GoTo unidades
End If
Case 70 To 79
NumLetra = NumLetra & "setenta"
UnNumero = UnNumero - 70
If UnNumero <> 0 Then
NumLetra = NumLetra & " y "
GoTo unidades
End If
Case 80 To 89
NumLetra = NumLetra & "ochenta"
UnNumero = UnNumero - 80
If UnNumero <> 0 Then
NumLetra = NumLetra & " y "
GoTo unidades
End If
Case 90 To 99
NumLetra = NumLetra & "noventa"
UnNumero = UnNumero - 90
If UnNumero <> 0 Then
NumLetra = NumLetra & " y "
GoTo unidades
End If
Case 100 To 199
UnNumero = UnNumero - 100
If UnNumero <> 0 Then
NumLetra = NumLetra & "ciento "
Else
NumLetra = NumLetra & "cien "
End If
GoTo unidades
Case 200 To 299
UnNumero = UnNumero - 200
NumLetra = NumLetra & "doscientos "
GoTo unidades
Case 300 To 399
UnNumero = UnNumero - 300
NumLetra = NumLetra & "trescientos "
GoTo unidades
Case 400 To 499
UnNumero = UnNumero - 400
NumLetra = NumLetra & "cuatrocientos "
GoTo unidades
Case 500 To 599
UnNumero = UnNumero - 500
NumLetra = NumLetra & "quinientos "
GoTo unidades
Case 600 To 699
UnNumero = UnNumero - 600
NumLetra = NumLetra & "seiscientos "
GoTo unidades
Case 700 To 799
UnNumero = UnNumero - 700
NumLetra = NumLetra & "setecientos "
GoTo unidades
Case 800 To 899
UnNumero = UnNumero - 800
NumLetra = NumLetra & "ochocientos "
GoTo unidades
Case 900 To 999
UnNumero = UnNumero - 900
NumLetra = NumLetra & "novecientos "
GoTo unidades
'Parte dejada para compatibilidad en fechas, hasta el año 2999 _
**************************************************************
Case 1000 To 1999 'no definido mas, no hace falta
NumLetra = NumLetra & "mil"
UnNumero = UnNumero - 1000
If UnNumero <> 0 Then
NumLetra = NumLetra & " "
GoTo unidades
End If
Case 2000 To 2999 'no definido mas, no hace falta
NumLetra = NumLetra & "dos mil"
UnNumero = UnNumero - 2000
If UnNumero <> 0 Then
NumLetra = NumLetra & " "
GoTo unidades
End If
'**************************************************************
Case Else
NumLetra = "No definido para este número, llamar al programador :-) Ju@nK"
Stop
End Select

On Error GoTo 0
Exit Function

NumLetra_Error:

MsgBox "Error " & Err.Number & " (" & Err.Description & ") en procedimiento NumLetra de Módulo Pasa_Numeros_A_Letras"
End Function

Public Function NumDobleLetra(ByVal elNum As Double, _
Optional ByVal numDec As Long = 2) As String
'---------------------------------------------------------------------------------------
' Procedure : NumDobleLetra
' DateTime : 06/08/2007 13:09
' Author : © Ju@nK ®
' Purpose : Pasar numeros a letra hasta 1 billón menos un céntimo
' Utiliza también la función Numletra para sus cálculos.
'---------------------------------------------------------------------------------------
' © Ju@nK 2007
Dim EntNum As Double
Dim DecNum As Double
Dim entLet As String
Dim decLet As String
Dim numCal As Double
Dim x As Long

On Error GoTo NumDobleLetra_Error

x = InStr(1, CStr(elNum), ",", vbTextCompare) + 1

If x > 1 Then
DecNum = CLng(Mid(CStr(elNum), x, numDec))
Else
DecNum = 0
End If
EntNum = Int(elNum)
calculos:
'Parte entera
enteros:
x = Len(CStr(EntNum))
Select Case x
Case 1 To 3
'1 a 999
entLet = NumLetra(EntNum)
Case 4 To 6
'1000 a 999999
'parte centenas
entLet = NumLetra(Right(EntNum, 3))
'miles
If Left(EntNum, x - 3) <> 1 Then
entLet = NumLetra(Left(EntNum, x - 3)) & " mil " & entLet
Else
entLet = "mil " & entLet
End If
Case 7 To 9
'millones 1 a 999
numCal = Mid(EntNum, 1, x - 6)
entLet = IIf(numCal = 1, "un", NumLetra(numCal)) & " millon" & _
IIf(numCal <> 1, "es ", " ")
EntNum = EntNum - (numCal * 10 ^ 6)
NumDobleLetra = NumDobleLetra & entLet
GoTo enteros
Case 10 To 12
'miles de millones 1 a 999
numCal = Mid(EntNum, 1, x - 9)
entLet = LTrim(IIf(numCal = 1, "", NumLetra(numCal)) & " mil") & _
IIf(numCal <> 1, " ", " ")
EntNum = EntNum - (numCal * 10 ^ 9)
NumDobleLetra = NumDobleLetra & entLet
GoTo enteros
Case Else
'no previsto
End Select
NumDobleLetra = NumDobleLetra & entLet & " euro" & _
IIf(EntNum <> 1, "s", "")
'Parte decimal
decimales:
If DecNum = 1 Then
decLet = "un céntimo"
Else
decLet = NumLetra(DecNum) & IIf(DecNum > 0, " con " & decLet & " céntimos", "")
End If
'numero completo

NumDobleLetra = NumDobleLetra & decLet

On Error GoTo 0
Exit Function

NumDobleLetra_Error:

MsgBox "Error " & Err.Number & " (" & Err.Description & ") en procedimiento NumDobleLetra de Módulo Pasa_Numeros_A_Letras"
End Function

Funciones para convertir numeros a moneda en euros Ju@nK 2007

Fotos en Piñeres

En la casa de Piñeres