Editar o código VBA Excel para agregar función
Teno este código el cual funciona al 1000% pero
Option Explicit
Dim archivos()
Private Sub CreoBath()
Dim a As String
Dim b As String
Dim c As String
Dim i As Long
Dim fold As Variant
Dim fc As Variant
Dim f As Variant
Dim xtx As String
Erase archivos
a = "Regsvr32.exe "
b = ThisWorkbook.Path & Application.PathSeparator & "Registro librerias.cmd" 'era Registrante.bat
On Error Resume Next
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Selecciona carpeta contenedora"
.Show
fold = .SelectedItems(1)
End With
If Err.Number <> 0 Then Exit Sub
If Right(fold, 1) <> Application.PathSeparator Then fold = fold & Application.PathSeparator
With CreateObject("Scripting.FileSystemObject")
With .GetFolder(fold)
Set fc = .Files
End With
For Each f In fc
c = UCase(.GetExtensionName(fold & f.Name))
If c = "OCX" Or c = "DLL" Then
ReDim Preserve archivos(i)
archivos(i) = f.Name
i = i + 1
End If
Next
c = .GetSpecialFolder(1) & Application.PathSeparator
For i = LBound(archivos) To UBound(archivos)
xtx = xtx & a & c & archivos(i) & vbNewLine
Next i
With .CreateTextFile(b, True)
.WriteLine (xtx)
.Close
End With
End With
MsgBox "Archivo Registro librerias.cmd creado", vbInformation, ""
Erase archivos
End SubEn un libro .xls con una sola hoja "hoja1". En el codigo de esta misma hoja colocar este codigo y ejecutarlo desde un boton (Forma) en Hoja1
Quisiera que dentro de este mismo codigo, auto verifique por si solo (antes de crear archivo),
1º si el sistema es de X86 o X64.
2º que al crear el archivo "Registro Librerias.cmd" lo crie para x86 o X64 segun sea el SO.detectado
Ahora crea el archivo SOLO para x86 y las lineas creadas son
%systemroot%\System32\regsvr32.exe Nombre.ocx
Para SO X64 tenian que ser
%systemroot%\SysWoW64\regsvr32.exe Nombre.ocx
O entonces algo mejor aun si se pudiera corrigir en el codigo
cd..
cd SysWOW64
Regsvr32.exe %Systemroot%\SysWOW64\nombre.ocx
Regsvr32.exe %Systemroot%\SysWOW64\nombre.ocx
Regsvr32.exe %Systemroot%\SysWOW64\nombre.ocx
Regsvr32.exe %Systemroot%\SysWOW64\nombre.ocx
La cantidad de librerias (archivos) seria la cantidad que encuentre en la carpeta.
Si el deseo es que suba el libro o envia via E-Mail, lo hare porque en la hoja tien la explicacion de como ejecutarlo para que crie dicho archivo para registrar librerias
Gracias
1 Respuesta
·
He cambiado la ubicación y visibilidad de la macro para facilitar el uso. La he metido en un módulo y le que quitado el private para que sea visible y ejecutable desde cualquier sitio.
Primero he puesto la complicada parte que averigua el sistema operativo, no es mía por supuesto, esta buscada en internet. La función Is64bit() nos dirá si el sistema de 64 bits o no y actuará en consecuencia.
Luego debes crear un módulo en VisuaBasic y copiar todo esto. Y ejecutar la macro CreoBath() con el menú macros o añadiendiendo un botón, forma o lo que sea que tenga asignada esa macro.
Private Declare Function GetProcAddress Lib "kernel32" _
(ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Declare Function GetModuleHandle Lib "kernel32" _
Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
Private Declare Function GetCurrentProcess Lib "kernel32" () As Long
Private Declare Function IsWow64Process Lib "kernel32" _
(ByVal hProc As Long, bWow64Process As Boolean) As Long
Option Explicit
Dim archivos()
Public Function Is64bit() As Boolean
Dim handle As Long, bolFunc As Boolean
bolFunc = False
' Now check to see if IsWow64Process function exists
handle = GetProcAddress(GetModuleHandle("kernel32"), "IsWow64Process")
If handle > 0 Then ' IsWow64Process function exists
' Now use the function to determine if we are running under Wow64
IsWow64Process GetCurrentProcess(), bolFunc
End If
Is64bit = bolFunc
End Function
Sub CreoBath()
Dim a As String
Dim b As String
Dim c As String
Dim i As Long
Dim fold As Variant
Dim fc As Variant
Dim f As Variant
Dim xtx As String
Erase archivos
If Is64bit Then
a = Environ("systemroot") & "SysWOW64\Regsvr32.exe "
Else
a = Environ("systemroot") & "System32\Regsvr32.exe "
End If
b = ThisWorkbook.Path & Application.PathSeparator & "Registro librerias.cmd" 'era Registrante.bat
MsgBox (b)
On Error Resume Next
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Selecciona carpeta contenedora"
.Show
fold = .SelectedItems(1)
End With
If Err.Number <> 0 Then Exit Sub
If Right(fold, 1) <> Application.PathSeparator Then fold = fold & Application.PathSeparator
With CreateObject("Scripting.FileSystemObject")
With .GetFolder(fold)
Set fc = .Files
End With
For Each f In fc
c = UCase(.GetExtensionName(fold & f.Name))
If c = "OCX" Or c = "DLL" Then
ReDim Preserve archivos(i)
archivos(i) = f.Name
i = i + 1
End If
Next
c = .GetSpecialFolder(1) & Application.PathSeparator
For i = LBound(archivos) To UBound(archivos)
xtx = xtx & a & c & archivos(i) & vbNewLine
Next i
With .CreateTextFile(b, True)
.WriteLine (xtx)
.Close
End With
End With
MsgBox "Archivo Registro librerias.cmd creado", vbInformation, ""
Erase archivos
End Sub
No te preocupes con la valoración, en eso estoy seguro.
Gracias amigo
Quiero preguntarte si entendiste mi solicitud anterior,, el 1º post
Repito: meter en el código, líneas que detecten si el SO es de x86 o x64
Meter en el código, la opción que al crear el archivo Registro.cmd l ocrie para el So x86 o x64 según sea la plataforma existente en la maquina.. Lo de meterlo en un modlo, no hay problema alguno
Voy a probar pero no hoy por lo siguiente, acabo de llegar del oftalmólogo y tengo ahora mismo dificultad en leer.y también en escribir, tengo media hora tratando de descifrar algunas palabras, y tratar de responderte para que no pienses que abandone el tema por l ocual te pido disculpas
Mañana (si no te molesta) verificaré, ¿te parece?
Pues verifícalo mañana y recupérate. La comprobación de si el sistema operativo es de 32 o 64 bits lo hace la función
Is64bit()
Que necesita unas declaraciones previas para funcionar y están puestas encima.
Es posible que si tu Excel es de 64bits haya que modificar algo en las declaraciones con respecto a la longitud de algunas variables y alguna otra cosa pero yo no puedo comprobarlo ya que mi Excel es de 32bits. Ojalá tu Excel sea también de 32 bits y te funcione directamente.
Un poco de efuerzo y curiosidad me llevo a copiar y pegar.
Hice l uq emensionas; El archivo que cria su nombre y extension estan bien como debe ser pero el registro y librerias me las coloca dentro del archivo asi:
C:\WindowsSysWOW64\Regsvr32.exe C:\Windows\System32\comctl32.dll
C:\WindowsSysWOW64\Regsvr32.exe C:\Windows\System32\mscomct2.ocx
y le pretension es esta para SO x86
%systemroot%\System32\regsvr32.exe Vsflex3.ocx
o esta para SO X64
%systemroot%\SysWOW64\regsvr32.exe Vsflex3.ocx
o tambien como pedia arriba (si se puede segun la plataforma que tenga instalada y detectada por el codigo
cd..
cd SysWOW64
Regsvr32.exe %Systemroot%\SysWOW64\mscomct2.ocx
segun sea la plataforma que tenga instalada, porque como entenderás, las librerias tienen que ser colocadas en la ruta correspondiente a la plataforma del SO (arquitectura de sistema)
que tengas, SO x86 o X64
Ruta %Systemroot%\SysWOW64 para los x64
y ruta %Systemroot%\System32 para x86.
El codigo tiene que crearme el archivo o para uno o para otro segun Plataforma usada en la maquina (arquitectura del sistema)
Mi SO es Windows x64 y Office x86
Las librerías en SO x64 (arquitectura) tienen que ser colocadas en %Systemroot%\SysWOW64, aun teniendo el Office x86 porque el SO es x64.
Si el SO fuera x86 (Arquitetura) seria en %Systemroot%\System32
Yo creía que querías que saliese el nombre del directorio de sistema en vez de el literal "%systemroot%" por eso lo hice así. Tengo dudas si quieres que los ficheros a registrar deben tener ruta o no. Yo los dejaría con la ruta, es mejor. Como la macro que tienes puede tomar los ficheros de cualquier carpeta que tú le digas es imprescindible que se guarde la ruta, asi luego puedes registrar cualquier DLL y OCX del ordenador.
Lo que tenias era un fallo por que en el fichero escribías la variable c en lugar de fold, no me di cuenta de ello.
Con las correcciones queda esto:
Private Declare Function GetProcAddress Lib "kernel32" _
(ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Declare Function GetModuleHandle Lib "kernel32" _
Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
Private Declare Function GetCurrentProcess Lib "kernel32" () As Long
Private Declare Function IsWow64Process Lib "kernel32" _
(ByVal hProc As Long, bWow64Process As Boolean) As Long
Option Explicit
Dim archivos()
Public Function Is64bit() As Boolean
Dim handle As Long, bolFunc As Boolean
bolFunc = False
' Now check to see if IsWow64Process function exists
handle = GetProcAddress(GetModuleHandle("kernel32"), "IsWow64Process")
If handle > 0 Then ' IsWow64Process function exists
' Now use the function to determine if we are running under Wow64
IsWow64Process GetCurrentProcess(), bolFunc
End If
Is64bit = bolFunc
End Function
Sub CreoBath()
Dim a As String
Dim b As String
Dim c As String
Dim i As Long
Dim fold As Variant
Dim fc As Variant
Dim f As Variant
Dim xtx As String
Erase archivos
If Is64bit Then
a = "%systemroot%\SysWOW64\Regsvr32.exe "
Else
a = "%systemroot%\System32\Regsvr32.exe "
End If
b = ThisWorkbook.Path & Application.PathSeparator & "Registro librerias.cmd" 'era Registrante.bat
On Error Resume Next
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Selecciona carpeta contenedora"
.Show
fold = .SelectedItems(1)
End With
If Err.Number <> 0 Then Exit Sub
If Right(fold, 1) <> Application.PathSeparator Then fold = fold & Application.PathSeparator
With CreateObject("Scripting.FileSystemObject")
Set fc = .GetFolder(fold).Files
For Each f In fc
c = UCase(.GetExtensionName(fold & f.Name))
If c = "OCX" Or c = "DLL" Then
ReDim Preserve archivos(i)
archivos(i) = f.Name
i = i + 1
End If
Next
c = .GetSpecialFolder(1) & Application.PathSeparator
For i = LBound(archivos) To UBound(archivos)
xtx = xtx & a & fold & archivos(i) & vbNewLine
Next i
With .CreateTextFile(b, True)
.WriteLine (xtx)
.Close
End With
End With
MsgBox "Archivo Registro librerias.cmd creado", vbInformation, ""
Erase archivos
End SubEspero que esto te sirva yo creo que sirve para registrar lo que quieras. Y si hay algo más que hacer dímelo prque no lo veo claro, escribe un fichero CMD de manera literal tal como debe quedar.
El ultimo código me dice que: Archivo Ragistro librerías.cmd creado (como debe ser) pero no encuentro en ninguna parte del disco dicho archivo.
Recurrí al buscador del sistema para buscar en toda la partición y nada encuentra, es decir, no l ocrea aunque diga que si o, l ocrea pero no lo guarda.
Cuanto a tu interrugante, el archivo creado "Registro Librerías.cmd" debe quedar así internamente:dependiendo de cuantas librerías (archivos) encuentre para registrar
Si la arquitetura del sistema encontrado es x86
%systemroot%\System32\regsvr32.exe Vsflex3.ocx
Si la arquitetura del sistema encontrado es x64
%systemroot%\SysWoW64\regsvr32.exe Vsflex3.ocx
Repito lo que deje arriba
Uso SO x64 y Office x86 pero creo que para lo que estoy pidiendo, no tiene que ver (pienso)
¿Copiaste bien todo el código con copiar y pegar?
SI me mandas tu correo te envío el fichero que tengo yo que funciona. He copiado lo que sale en la página y me funciona, aunque se que la página a veces hace mal el copiado por eso mejor si te mando el fichero.
Es que tienes una orden horrible que no he quitado
On error resume next
Esa orden tendría que estar prohibida y suprimida de Excel, hace que no se detecten errores imprevistos, por eso se llega hasta el final y completa todos los pasos incluido el de decir que se ha creado el fichero aunque no haya podido crear el fichero.
O si no quieres que salga tu correo aquí mándame un e-mail a
Y asi te lo podré mandar.
·
Si le quitas el On error resume next al cerrar la ventana sin seleccionar nada, te manda error
Es correcto lo que mensionas sobre el On Error Resume Next pero
¿Entonces qué colocar cuando cierres la ventana sin que selecciones la carpeta y le des al botón Cancelar?
Si ha producido el error 5 en tiempo ode ejecución
Elemento o llamada a procedimiento no válido
y presenta la linea fold = .SelectedItems(1)
Esto porque apretás el botón de la ventana "Cancelar"
Los mails que te he enviado, me han sido devueltos
Escríbeme acá y te envío lo que tengo
Algo esta pasando con tu mail
Para
Me
Hoy a las 6:01 P.M.
Sorry, we were unable to deliver your message to the following address.
<[email protected]>:
Remote host said:
552-5.7.0 This message was blocked because its content presents a potential
552-5.7.0 security issue. Please visit
552-5.7.0 http://support.google.com/mail/bin/answer.py?answer=6590 to review our
552 5.7.0 message content and attachment content guidelines. xh10si2000364pab.42 - gsmtp
[BODY]
--- Below this line is a copy of the message.
Received: from [127.0.0.1] by nm41.bullet.mail.gq1.yahoo.com with NNFMP; 09 Oct 2014 22:31:09 -0000
Received: from [98.137.12.175] by nm41.bullet.mail.gq1.yahoo.com with NNFMP; 09 Oct 2014 22:28:19 -0000
Received: from [212.82.98.127] by tm14.bullet.mail.gq1.yahoo.com with NNFMP; 09 Oct 2014 22:28:14 -0000
Received: from [212.82.98.86] by tm20.bullet.mail.ir2.yahoo.com with NNFMP; 09 Oct 2014 22:28:13 -0000
Received: from [127.0.0.1] by omp1023.mail.ir2.yahoo.com with NNFMP; 09 Oct 2014 22:28:13 -0000
X-Yahoo-Newman-Property: ymail-4
X-Yahoo-Newman-Id: [email protected]
Received: (qmail 65536 invoked by uid 60001); 9 Oct 2014 22:28:13 -0000
DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=yahoo.es; s=s1024; t=1412893693; bh=BRzbGzX1YAUmv3YGK/VV7eLfg7Pi5oN7C8zuYaIhXgw=; h=Message-ID:Date:From:Reply-To:Subject:To:MIME-Version:Content-Type; b=nbPuuOBc9KXoJbqyNpfXf8SWXKb/w+9fnxy3v9E25fGT3+kWOEZJx1JHNHg2ypzwxY8tySsjK8ADa3nmEeTT8ZC2E9Q5W018PiuR3iEIyNN4DiyGLrenzKm+qPQALhUf0oMJ2D04yqbePtkhyP8Om8X/yBIe+68ca/QFlPD+iNg=
X-YMail-OSG: 38gVJCoVM1nmf71enMD1lV8Az6IYpgURvGIhtjuzjMxzm0q
_WLoRKjKh_BAYneiouyHzJBzedzsOcqMepxvqTqRNrBCKW11UQ16L0HiRjTK
q7zFI_8amjdC.Ep9qQBvX_4UZ0jucd8I6aCeZ5WqiBU7F1gadiZTHDZtJ0Wr
EaAsPSH834v5mtBc6BBw0reAigZbBE79VFf5e8YSx04Okj9zwDNE_55I_z7.
g5oforPyVKmLgFHiZc_d3njb3nOIVAVe8SJi7dRYnG0Qc5WoMIyWPSxciC3r
kTkEv4NZXQJ39hDr7RSiV_I1Sws1yqD7_d969x7B0sjwScIY7I2Z62RiQYAt
X1pW9hu4NEXwh18dQTKM30O_C35z0jjc4OsMo.F1NuUDMtbmT42tp_1fo8ou
_R1RmiSpLo7CIVPRpqL5k4z2kPp79k2aILz6ejlszOWF5YpAvRoIpn.o1.jk
XhOSZuYgqQ03_RUVCQU854o61EQbOXTsNJa548H.ehIGCrd3egZ8po6F_q4k
5iEYmgjhiUbBRvj1Pu5RySWHqlu_xJz.ungetChIV8hQX1ghG7pRpRhHj9aA
3
Received: from [186.92.157.78] by web172205.mail.ir2.yahoo.com via HTTP; Thu, 09 Oct 2014 23:28:13 BST
X-Rocket-MIMEInfo: 002.001,U29sb2wgZW52aW8gMiBhIGxhIHZlcyBwYXJhIHF1ZSBubyBzZWEgdGFuIHBlc2FkbyB5IGx1ZWdvIGVudmlhcmUgZWwgWklQIHBhcmEgdmVyIHNpIHRlIGxsZWdhCgEwAQEBAQ--
X-Mailer: YahooMailWebService/0.8.203.696
Message-ID: <[email protected]>
Date: Thu, 9 Oct 2014 23:28:13 +0100
From: Joao Marques <[email protected]>
Reply-To: Joao Marques <[email protected]>
Subject: Veremos ahora
To: "[email protected]" <[email protected]>
MIME-Version: 1.0
Content-Type: multipart/mixed; boundary="-97308854-953912002-1412893693=:8975"
---97308854-953912002-1412893693=:8975
Content-Type: multipart/alternative; boundary="-97308854-831886105-1412893693=:8975"
---97308854-831886105-1412893693=:8975
Content-Type: text/plain; charset=utf-8
Content-Transfer-Encoding: quoted-printable
Solol envio 2 a la ves para que no sea tan pesado y luego enviare el ZIP pa=
ra ver si te llega=0A
---97308854-831886105-1412893693=:8975
Content-Type: text/html; charset=utf-8
Content-Transfer-Encoding: quoted-printable
<html><body><div style=3D"color:#000; background-color:#fff; font-family:He=
lveticaNeue, Helvetica Neue, Helvetica, Arial, Lucida Grande, sans-serif;fo=
nt-size:14px"><div>Solol envio 2 a la ves para que no sea tan pesado y lueg=
o enviare el ZIP para ver si te llega</div></div></body></html>
---97308854-831886105-1412893693=:8975--
---97308854-953912002-1412893693=:8975
Content-Type: application/x-rar-compressed; name="1.part01.rar"
Content-Transfer-Encoding: base64
Content-Disposition: attachment; filename="1.part01.rar"
Perdona, he tenido problemas con el ordenador de trabajo y llevo todo el día intentando arreglarlo. Ahora mismo todavía no lo he conseguido y en este otro no tengo Office y no querría tener que instalarlo.
Algunos e-mail si me han llegado, no sé si serán todos,
Ten paciencia.
