PIECE OF CAKE - MS Excel - Zipando - Compactando a Planilha Atual - Zip the ActiveWorkbook

Este script faz uma cópia do Activeworkbook e o compacta em "C: \ Bernardes \" com um carimbo de data e hora. Altere esta pasta ou use seu caminho padrão Application.DefaultFilePath

Sub Zip_ActiveWorkbook()
    Dim strDate As String, DefPath As String
    Dim FileNameZip, FileNameXls
    Dim oApp As Object
    Dim FileExtStr As String

    DefPath = "C:\Bernardes\"    '<< Change
    If Right(DefPath, 1) <> "\" Then
        DefPath = DefPath & "\"
    End If

    'Create date/time string and the temporary xl* and Zip file name
    If Val(Application.Version) < 12 Then
        FileExtStr = ".xls"
    Else
        Select Case ActiveWorkbook.FileFormat
        Case 51: FileExtStr = ".xlsx"
        Case 52: FileExtStr = ".xlsm"
        Case 56: FileExtStr = ".xls"
        Case 50: FileExtStr = ".xlsb"
        Case Else: FileExtStr = "notknown"
        End Select
        If FileExtStr = "notknown" Then
            MsgBox "Sorry unknown file format"
            Exit Sub
        End If
    End If

    strDate = Format(Now, " yyyy-mm-dd h-mm-ss")
    
    FileNameZip = DefPath & Left(ActiveWorkbook.Name, _
    Len(ActiveWorkbook.Name) - Len(FileExtStr)) & strDate & ".zip"
    
    FileNameXls = DefPath & Left(ActiveWorkbook.Name, _
    Len(ActiveWorkbook.Name) - Len(FileExtStr)) & strDate & FileExtStr

    If Dir(FileNameZip) = "" And Dir(FileNameXls) = "" Then

        'Make copy of the activeworkbook
        ActiveWorkbook.SaveCopyAs FileNameXls

        'Create empty Zip File
        NewZip (FileNameZip)

        'Copy the file in the compressed folder
        Set oApp = CreateObject("Shell.Application")
        oApp.Namespace(FileNameZip).CopyHere FileNameXls

        'Keep script waiting until Compressing is done
        On Error Resume Next
        Do Until oApp.Namespace(FileNameZip).items.Count = 1
            Application.Wait (Now + TimeValue("0:00:03"))
        Loop
        On Error GoTo 0
        'Delete the temporary xls file
        Kill FileNameXls

        MsgBox "Your Backup is saved here: " & FileNameZip

    Else
        MsgBox "FileNameZip or/and FileNameXls exist"

    End If
End Sub

#A&A #PIECEOFCAKE #POC #VBA #RondeBruin #MS #Excel

Veja também:

• MS Excel - Zipando - Abra uma Janela e Escolha os Arquivos que deseja Compacatar
• MS Excel - Zipando - Escolha uma Pasta e Compacte Tudo Nela
• MS Excel - Zipando - Compacte Todos os Arquivos Contidos na Pasta Informada no Código
• MS Excel - Zipando - Compactando a Planilha Atual
• MS Excel - Zipando - Compactando e Enviando por e-Mail

Consulte-nos

⬛◼◾▪ Social Media ▪◾◼⬛

• FACEBOOK • TWITTER • INSTAGRAM • TUMBLR • GOOGLE+ • LINKEDIN • PINTEREST

⬛◼◾▪ Blogs ▪◾◼⬛ 

• VBA Specialist® • VBA Excel Specialist®

• VBA Access Specialist® • VBA Dashboards Specialist®

• VBA Infografics Specialist® • VBA Pharma Specialist® 

⬛◼◾▪ CONTATO ▪◾◼⬛

brazilsalesforceeffectiveness@gmail.com

PIECE OF CAKE - MS Excel - Zipando - Compactando e Enviando por e-Mail - Zip and mail the ActiveWorkbook

Este código foi escrito para que estiver usando o Outlook como seu programa de e-mail.

Este código enviará a planilha recém-criada (cópia do seu Activeworkbook). Guardará o zip na pasta de trabalho antes de enviá-lo com um carimbo de data | hora. Depois que o arquivo zip for enviado, o arquivo zip e a pasta de trabalho serão excluídos.

Sub Zip_Mail_ActiveWorkbook()
    Dim strDate As String, DefPath As String, strbody As String
    Dim oApp As Object, OutApp As Object, OutMail As Object
    Dim FileNameZip, FileNameXls
    Dim FileExtStr As String

    DefPath = Application.DefaultFilePath
    If Right(DefPath, 1) <> "\" Then
        DefPath = DefPath & "\"
    End If

    'Create date/time string and the temporary xl* and zip file name
    If Val(Application.Version) < 12 Then
        FileExtStr = ".xls"
    Else
        Select Case ActiveWorkbook.FileFormat
        Case 51: FileExtStr = ".xlsx"
        Case 52: FileExtStr = ".xlsm"
        Case 56: FileExtStr = ".xls"
        Case 50: FileExtStr = ".xlsb"
        Case Else: FileExtStr = "notknown"
        End Select
        If FileExtStr = "notknown" Then
            MsgBox "Sorry unknown file format"
            Exit Sub
        End If
    End If

    strDate = Format(Now, " yyyy-mm-dd h-mm-ss")

    FileNameZip = DefPath & Left(ActiveWorkbook.Name, _
    Len(ActiveWorkbook.Name) - Len(FileExtStr)) & strDate & ".zip"

    FileNameXls = DefPath & Left(ActiveWorkbook.Name, _
    Len(ActiveWorkbook.Name) - Len(FileExtStr)) & strDate & FileExtStr


    If Dir(FileNameZip) = "" And Dir(FileNameXls) = "" Then

        'Make copy of the activeworkbook
        ActiveWorkbook.SaveCopyAs FileNameXls

        'Create empty Zip File
        NewZip (FileNameZip)

        'Copy the file in the compressed folder
        Set oApp = CreateObject("Shell.Application")
        oApp.Namespace(FileNameZip).CopyHere FileNameXls

        'Keep script waiting until Compressing is done
        On Error Resume Next
        Do Until oApp.Namespace(FileNameZip).items.Count = 1
            Application.Wait (Now + TimeValue("0:00:01"))
        Loop
        On Error GoTo 0

        'Create the mail
        Set OutApp = CreateObject("Outlook.Application")
        Set OutMail = OutApp.CreateItem(0)
        strbody = "Hi there" & vbNewLine & vbNewLine & _
                  "This is line 1" & vbNewLine & _
                  "This is line 2" & vbNewLine & _
                  "This is line 3" & vbNewLine & _
                  "This is line 4"

        On Error Resume Next
        With OutMail
            .To = "ron@debruin.nl"
            .CC = ""
            .BCC = ""
            .Subject = "This is the Subject line"
            .Body = strbody
            .Attachments.Add FileNameZip
            .Send   'or use .Display
        End With
        On Error GoTo 0

        'Delete the temporary Excel file and Zip file you send
        Kill FileNameZip
        Kill FileNameXls
    Else
        MsgBox "FileNameZip or/and FileNameXls exist"
    End If
End Sub

#A&A #PIECEOFCAKE #POC #VBA #RondeBruin #MS #Excel

Veja também:

• MS Excel - Zipando - Abra uma Janela e Escolha os Arquivos que deseja Compacatar
• MS Excel - Zipando - Escolha uma Pasta e Compacte Tudo Nela
• MS Excel - Zipando - Compacte Todos os Arquivos Contidos na Pasta Informada no Código
• MS Excel - Zipando - Compactando a Planilha Atual
• MS Excel - Zipando - Compactando e Enviando por e-Mail

Consulte-nos

⬛◼◾▪ Social Media ▪◾◼⬛

• FACEBOOK • TWITTER • INSTAGRAM • TUMBLR • GOOGLE+ • LINKEDIN • PINTEREST

⬛◼◾▪ Blogs ▪◾◼⬛ 

• VBA Specialist® • VBA Excel Specialist®

• VBA Access Specialist® • VBA Dashboards Specialist®

• VBA Infografics Specialist® • VBA Pharma Specialist® 

⬛◼◾▪ CONTATO ▪◾◼⬛

brazilsalesforceeffectiveness@gmail.com

VBA Excel - Apagando um módulo utilizando o VBA - Delete a module using VBA

Dificilmente as senhas das planilhas hoje não são quebradas com grande facilidade. Poucos de nós sabemos resguardar a segurança das nossas planilhas.

Às vezes quando disponibilizamos alguma aplicação à distância para alguém, geralmente datamos a utilização desta para testes, apagando o seus módulos a partir de certo número de utilizações, ou mesmo após certa data.

Que técnica posso utilizar para apagar o módulo da minha aplicação utilizando o VBA?

Sub DelVBComponent (ByVal wb As Workbook, ByVal CompName As String)
    Let Application.DisplayAlerts = False
   
    On Error Resume Next ' ignora qualquer erro
   
    wb.VBProject.VBComponents.Remove wb.VBProject.VBComponents(CompName)
   
    ' Deleta o componente
    On Error GoTo 0
   
    Let Application.DisplayAlerts = True
End Sub

Exemplo:
DelVBComponent ActiveWorkbook, "tstBernardes"


Tags: Bernardes, MS, Microsoft, Office, Excel, copy, module, code, activeWorkbook, workbook, create, realtime


André Luiz Bernardes
A&A® - Work smart, not hard in any place.
bernardess@gmail.com

Esta opção envolve mais aqueles que já têm alguma experiência com o desenvolvimento VBA. Esta funcionalidade permite desenvolver o funcionalidade inexistentes a partir da necessidade da aplicação. Isso implica na criação de códito em tempo real.

De que modo posso criar um novo módulo usando o próprio VBA?

Sub CreateNewMod _
(ByVal wb As Workbook, ByVal ModuleTypeIndex As Integer, _
ByVal NewModuleName As String)

' Cria um novo modulo a partir do ModuleTypeIndex
' (1=standard module, 2=userform, 3=class module) in wb
' Renomeie o module para NewModuleName (se possivel)
 
Dim VBC As VBComponent, mti As Integer
 
Set VBC = Nothing

Let mti = 0

Select Case ModuleTypeIndex
Case 1: mti = vbext_ct_StdModule ' standard module
Case 2: mti = vbext_ct_MSForm     ' userform      
Case 3: mti = vbext_ct_ClassModule ' class module
End Select

If mti <> 0 Then
On Error Resume Next  
 
Set VBC = wb.VBProject.VBComponents.Add(mti)
       
If Not VBC Is Nothing Then    
If NewModuleName <> "" Then
Let VBC.Name = NewModuleName
End If
End If      

On Error GoTo 0      

Set VBC = Nothing
End If
End Sub

Como usar:
  CreateNewModule ActiveWorkbook, 1, "mdl_TESTE"

Tags: Bernardes, MS, Microsoft, Office, Excel, copy, module, code, activeWorkbook, workbook, create, realtime

André Luiz Bernardes
A&A® - In Any Place.
bernardess@gmail.com

MS Excel – Navegando entre as pastas na planilhas

Existem diversos modos para se navegar entre as pastas de uma planilha.

Estou postando uma das maneiras mais simples de se fazer isso.

Function SelectSheet()

' Inicia as variáveis.

Dim ThisShts As Variant

Dim mySht As Single

Dim MyList As Variant

' Obtém o número de pastas na planilha.

Let ThisShts = ActiveWorkbook.Sheets.Count

' Carrega o nome das pastas .

For i = 1 To ThisShts

Let MyList = MyList & i & " - " & ActiveWorkbook.Sheets(i).Name & " " & vbCr

Next i

' Mostra os nomes das pastas para serem escolhidas, através dos seus respectivos posicionamentos.

Let mySht = InputBox("Selecione o Nº da pasta e pressione OK:" & vbCr & vbCr & MyList)

Sheets(mySht).Select

End Function