Ayuda con código del 27-01-05

31/01/2005 - 12:40 por Aprendiz | Informe spam
Hola pongo de nuevo este mensaje en el grupo porque se me ha quedado una
consulta sin contestar y podría ser que KL no se haya dado cuenta. es esta:
(borrar flechas de autoformas y modulos de macros automaticamente al
convertir en archivo plano de excel)
...
...
...
perdona KL, he olvidado decirte que existen flechas de bloque de Autoformas
(dibujo) y tambien hay que borrar las macros y sus modulos (6)
Saludos y gracias
José Rafael

"KL" <NOSPAMlapink2000@PLEASEhotmail.com> escribió en el mensaje
news:%236wtRRZBFHA.904@TK2MSFTNGP12.phx.gbl...

Hola Aprendiz,

Pues entonces prueba el codigo de abajo. Por si acaso le he anadido estas
lineas:

Dim OLEobj As Excel.OLEObject

'Elimina botones de formulario.
.Buttons.Delete

'Elimina todos los objetos OLE.
For Each OLEobj In .OLEObjects
OLEobj.Delete
Next OLEobj

Saludos,
KL

'--Inicio Codigo
Option Explicit
Public Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type

'Declaraciones 32-bit API
Declare Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, _
ByVal pszPath As String) As Long

Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long

'Esta funcion muestra el dialogo para eligir directorio.
'Publicada por John Walkenbach.
Function GetDirectory(Optional Msg) As String
Dim bInfo As BROWSEINFO
Dim path As String
Dim r As Long, x As Long, pos As Integer

' Directorio de raiz = Escritorio
bInfo.pidlRoot = 0&

' titulo en el dialogo
If IsMissing(Msg) Then
bInfo.lpszTitle = "Select a folder."
Else
bInfo.lpszTitle = Msg
End If

' tipo de directorio a devolver
bInfo.ulFlags = &H1

' mostrar el dialogo
x = SHBrowseForFolder(bInfo)

' extraer el resultado
path = Space$(512)
r = SHGetPathFromIDList(ByVal x, ByVal path)
If r Then
pos = InStr(path, Chr$(0))
GetDirectory = Left(path, pos - 1)
Else
GetDirectory = ""
End If
End Function

Sub archivarhojaprevisionessemanalenmisdocumentos()
Dim msje As String
Dim MiNombre As String, MiDirectorio As String
Dim MiHoja As Worksheet, s As Worksheet
Dim OLEobj As Excel.OLEObject

'Guarda el libro original para no perder
'los cambios accidentalmente.
ThisWorkbook.Save

'Crea la variable de la hoja a copiar.
Set MiHoja = ThisWorkbook.Sheets("PrevisiNn")

Application.ScreenUpdating = False

'Convierte formulas en valores, elimina las
'columnas innecesarias y activa la celda A3.
With MiHoja
.Activate
'Elimina botones de formulario.
.Buttons.Delete
'Elimina todos los objetos OLE.
For Each OLEobj In .OLEObjects
OLEobj.Delete
Next OLEobj
.Cells.Copy
.Cells.PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
.Columns("I:IV").Clear
.Range("A3").Select
End With

'Elimina la hojas innecesarias.
Application.DisplayAlerts = False
For Each s In ThisWorkbook.Sheets
If s.Name <> MiHoja.Name Then s.Delete
Next s
Application.DisplayAlerts = True

'Pide al usuario q eliga el nombre para el libro.
MiNombre = InputBox("Nombre de la hoja", _
"Indicar Semana y sin espacio el n?")

'Cambia el nombre de la hoja al q se ha eligido.
MiHoja.Name = MiNombre

'Pide al usuario q eliga el directorio para guardar el libro.
msje = "Seleccione el directorio para la copia."
MiDirectorio = GetDirectory(msje)

'Si se ha eligido un directorio guarda el libro ahi.
If MiDirectorio <> "" Then
ThisWorkbook.SaveAs MiDirectorio & "\" & MiNombre & ".xls"
MsgBox "Se ha guardado la copia en: " & MiDirectorio
'Si no, se guarda el libro en el director del libro original.
Else
ThisWorkbook.SaveAs ThisWorkbook.path & "\" & MiNombre & ".xls"
MsgBox "Se ha guardado la copia en: " & ThisWorkbook.path
End If

Application.ScreenUpdating = True
End Sub
'--Fin Codigo

"José Frasquet" <964590297@terra.es> wrote in message
news:OlBNC2YBFHA.1084@tk2msftngp13.phx.gbl...

Son de formulario
"KL" <NOSPAMlapink2000@PLEASEhotmail.com> escribió en el mensaje
news:ewAUidUBFHA.1076@TK2MSFTNGP10.phx.gbl...

Hola Aprendiz,

"Aprendiz" wrote in message...

.me faltará una linea de código? para borrar
todos los botones de macros que tiene la hoja.



?De q tipo son los botones, ActiveX o de Formularios? ?O tal vez de
ambos?

Saludos,
KL









 

Leer las respuestas

#1 KL
31/01/2005 - 15:54 | Informe spam
Hola Aprendiz,

Perdona es q no habia visto tu respuesta. Prueba el siguiente codigo.

Saludos,
KL

'--Inicio Codigo
Option Explicit
Public Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type

'Declaraciones 32-bit API
Declare Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, _
ByVal pszPath As String) As Long

Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long

'Esta funcion muestra el dialogo para eligir directorio.
'Publicada por John Walkenbach.
Function GetDirectory(Optional Msg) As String
Dim bInfo As BROWSEINFO
Dim path As String
Dim r As Long, x As Long, pos As Integer

' Directorio de raiz = Escritorio
bInfo.pidlRoot = 0&

' titulo en el dialogo
If IsMissing(Msg) Then
bInfo.lpszTitle = "Select a folder."
Else
bInfo.lpszTitle = Msg
End If

' tipo de directorio a devolver
bInfo.ulFlags = &H1

' mostrar el dialogo
x = SHBrowseForFolder(bInfo)

' extraer el resultado
path = Space$(512)
r = SHGetPathFromIDList(ByVal x, ByVal path)
If r Then
pos = InStr(path, Chr$(0))
GetDirectory = Left(path, pos - 1)
Else
GetDirectory = ""
End If
End Function

Sub archivarhojaprevisionessemanalenmisdocumentos()
Dim MiNombre As String, MiDirectorio As String
Dim MiHoja As Worksheet, s As Worksheet, msje As String

'Crea la variable de la hoja a copiar y la de destino.
Set MiHoja = ThisWorkbook.Sheets("PrevisiNn")

Application.ScreenUpdating = False
'Crea un libro nuevo, copia valores, elimina las
'columnas innecesarias y activa la celda A3.
With Application.Workbooks.Add
With .Sheets(1)
.Activate
MiHoja.Cells.Copy
.Cells.PasteSpecial Paste:=xlValues
.Cells.PasteSpecial Paste:=xlFormats
Application.CutCopyMode = False
.Columns("I:IV").Clear
.Range("A3").Select
'Pide al usuario q eliga el nombre para el libro.
MiNombre = InputBox("Nombre de la hoja", _
"Indicar Semana y sin espacio el n?")
'Cambia el nombre de la hoja al q se ha eligido.
.Name = MiNombre
End With

'Pide al usuario q eliga el directorio para guardar el libro.
msje = "Seleccione el directorio para la copia."
MiDirectorio = GetDirectory(msje)

'Si se ha eligido un directorio guarda el libro ahi.
If MiDirectorio <> "" Then
.SaveAs MiDirectorio & "\" & MiNombre & ".xls"
MsgBox "Se ha guardado la copia en: " & MiDirectorio
'Si no, se guarda el libro en el directorio del libro original.
Else
.SaveAs ThisWorkbook.path & "\" & MiNombre & ".xls"
MsgBox "Se ha guardado la copia en: " & ThisWorkbook.path
End If
End With
Application.ScreenUpdating = True
End Sub
'--Fin Codigo

Preguntas similares