Mas info: http://es.wikipedia.org/wiki/Configuraci%C3%B3n_electr%C3%B3nica
Código
' //////////////////////////////////////////////////////////////// ' // *Autor: *PsYkE1* [vbpsyke1@mixmail.com] // ' // *Fecha: 20/7/10 // ' // *Podeis agrandar o reducir el codigo, siempre y cuando se // ' // respete la autoria y se me comuniquen esos cambios. // ' // *Agradecimientos a raul338 // ' // *Visita http://foro.rthacker.net // ' //////////////////////////////////////////////////////////////// Option Explicit Public Function Get_Electronic_Configuration(ByVal bElementValence As Byte) As Collection Const ELECTRONIC_CONF As String = "1s,2s,2p,3s,3p,4s,3d,4p,5s,4d,5p,6s,4f,5d,6p,7s,5f,6d" Const EXCEPTION_VALENCES_A As String = "24,29" '# Cr & Cu Const EXCEPTION_VALENCES_B As String = "41,42,44,45,46,47" '# Zr, Nb, Tc, Ru, Rh, Pd & Ag Const EXCEPTION_VALENCES_C As String = "78,79" '# Pt & Au Const LIMIT_SUBLEVEL_S As Byte = 2 Const LIMIT_SUBLEVEL_P As Byte = 6 Const LIMIT_SUBLEVEL_D As Byte = 10 Const LIMIT_SUBLEVEL_F As Byte = 14 Dim cTemp As New Collection Dim sSubLevel() As String Dim sActualItem As String * 2 Dim bInvalidValenceA As Boolean Dim bInvalidValenceB As Boolean Dim bInvalidValenceC As Boolean Dim bElectron As Byte Dim bActualLimit As Byte Dim x As Byte Dim n As Byte Dim y As Byte If bElementValence > 0 And bElementValence < 112 Then '# Hasta el elemento Roentgenio [Uuu] sSubLevel() = Split(ELECTRONIC_CONF, ",") '# Compruebo si la valencia introducida es una excepción bInvalidValenceA = CBool (InStr(EXCEPTION_VALENCES_A, CStr(bElementValence))) bInvalidValenceB = CBool (InStr(EXCEPTION_VALENCES_B, CStr(bElementValence))) bInvalidValenceC = CBool (InStr(EXCEPTION_VALENCES_C, CStr(bElementValence))) For x = 0 To UBound(sSubLevel()) sActualItem = sSubLevel(x) '# Reviso el subnivel en el que me encuentro Select Case Right$(sActualItem, 1) Case "s": bActualLimit = LIMIT_SUBLEVEL_S Case "p": bActualLimit = LIMIT_SUBLEVEL_P Case "d": bActualLimit = LIMIT_SUBLEVEL_D Case "f": bActualLimit = LIMIT_SUBLEVEL_F End Select '# Relleno cada capa de eletrones For y = 1 To bActualLimit If n <> bElementValence Then n = n + 1 Else Exit For '# Hay excepciones: Si la configuración electrónica acaba en d4 o en d9 '# el subnivel anterior cede un electrón para estabilizarlo (en la mayoria de los casos) If (sActualItem = "4s" And bInvalidValenceA = True) Or (sActualItem = "5s" And bInvalidValenceB = True) Or _ sActualItem = "6s" And bInvalidValenceC = True Then bElectron = 1 Exit For Else bElectron = bElectron + 1 End If Next y '# Añado el Item con los electrones que tenga cTemp.Add sActualItem & CStr(bElectron) If n = bElementValence Then Exit For bElectron = 0 Next x Set Get_Electronic_Configuration = cTemp End If End Function
Para que veais, un ejemplo:
Código
Private Sub Form_Load() Dim sResult As String Dim vItem As Variant Dim z As Byte z = 29 '# El Cobre [Cu] For Each vItem In Get_Electronic_Configuration(z) sResult = sResult & vItem & " " Next vItem Debug.Print sResult End Sub
Me devuelve esto:
Citar
1s2 2s2 2p6 3s2 3p6 4s1 3d10
Si en la variable z pongo 97 (Berkelio [Bk]) me da esto:
Citar
1s2 2s2 2p6 3s2 3p6 4s2 3d10 4p6 5s2 4d10 5p6 6s2 4f14 5d10 6p6 7s2 5f9
Bueno esto es todo...
PD: Saludo a mi profesora de clases Marta Suarez
DoEvents¡!