The Ultimate Guide Worksheet in Macro - VBA @pp_92

PHOTO

Mon Feb 21 2022 13:09:56 GMT+0000 (Coordinated Universal Time)

Saved by @pharehphatah #vba

// https://www.automateexcel.com/vba/sheets-worksheets
//  Guide Worksheet update by pp_92

'Tab Name'
Sheets("Input").Activate

'VBA Code Name'
Sheet1.Activate

'Index Position'
Sheets(1).Activate
	
'Select Sheet'
Sheets("Input").Select

'Set to Variable'
Dim ws as Worksheet
Set ws = ActiveSheet

'Name / Rename'
ActiveSheet.Name = "NewName"

'Rename as In Cell'
Worksheets(1).Name = Worksheets(1).Range("B5")

'Insert Name Worksheet in Cell'
ActiveSheet.Range("A1") = ActiveSheet.Name

'Rename as In Cell Loop'
Dim rs As Worksheet
For Each rs In Sheets
rs.Name = rs.Range("B5")
Next rs

'Next Sheet'
ActiveSheet.Next.Activate

'Loop Through all Sheets'
Dim ws as Worksheet
For each ws in Worksheets
Msgbox ws.name
Next ws

'Loop Through Selected Sheets'
Dim ws As Worksheet
For Each ws In ActiveWindow.SelectedSheets
MsgBox ws.Name
Next ws

'Get ActiveSheet'
MsgBox ActiveSheet.Name

'Add Sheet'
Sheets.Add

'Add Sheet and Name'
Sheets.Add.Name = "NewSheet"

'Add Sheet With Name From Cell'
Sheets.Add.Name = range("a3").value

'Add Sheet After Another'
Sheets.Add After:=Sheets("Input")

'Add Sheet After and Name'
Sheets.Add(After:=Sheets("Input")).Name = "NewSheet"

'Add Sheet Before and Name'
Sheets.Add(Before:=Sheets("Input")).Name = "NewSheet"

'Add Sheet to End of Workbook'
Sheets.Add After:=Sheets(Sheets.Count)

'Add Sheet to Beginning of Workbook'
Sheets.Add(Before:=Sheets(1)).Name = "FirstSheet"

'Add Sheet to Variable'
Dim ws As Worksheet
Set ws = Sheets.Add

'Move Sheet to End of Workbook'
Sheets("Sheet1").Move After:=Sheets(Sheets.Count)

'To New Workbook'
Sheets("Sheet1").Copy

'Selected Sheets To New Workbook'
ActiveWindow.SelectedSheets.Copy

'Before Another Sheet'
Sheets("Sheet1").Copy Before:=Sheets("Sheet2")

'Before First Sheet'
Sheets("Sheet1").Copy Before:=Sheets(1)

'After Last Sheet'
Sheets("Sheet1").Copy After:=Sheets(Sheets.Count)

'Copy and Name'
Sheets("Sheet1").Copy After:=Sheets(Sheets.Count)
ActiveSheet.Name = "LastSheet"

'Copy and Name From Cell Value'
Sheets("Sheet1").Copy After:=Sheets(Sheets.Count)
ActiveSheet.Name = Range("A1").Value

'To Another Workbook'
Sheets("Sheet1").Copy Before:=Workbooks("Example.xlsm").Sheets(1)
	
'Hide Sheet'
Sheets("Sheet1").visible = False
or 
Sheets("Sheet1").visible = xlSheetHidden

'Unhide Sheet'
Sheets("Sheet1").Visible = True
or
Sheets("Sheet1").Visible = xlSheetVisible

'Very Hide Sheet'
Sheets("Sheet1").Visible = xlSheetVeryHidden

'Delete Sheet'
Sheets("Sheet1").Delete

'Delete Sheet (Error Handling)'
On Error Resume Next
Sheets("Sheet1").Delete
On Error GoTo 0

'Delete Sheet (No Prompt)'
Application.DisplayAlerts = False
Sheets("Sheet1").Delete
Application.DisplayAlerts = True

'Clear Sheet'
Sheets("Sheet1").Cells.Clear

'Clear Sheet Contents Only'
Sheets("Sheet1").Cells.ClearContents

'Clear Sheet UsedRange'
Sheets("Sheet1").UsedRange.Clear

'Unprotect (No Password)'
Sheets("Sheet1").Unprotect

'Unprotect (Password)'
Sheets("Sheet1").Unprotect "Password"

'Protect (No Password)'
Sheets("Sheet1").Protect

'Protect (Password)'
Sheets("Sheet1").Protect "Password"

'Protect but Allow VBA Access'
Sheets("Sheet1").Protect UserInterfaceOnly:=True

'Unprotect All Sheets'
Dim ws As Worksheet
For Each ws In Worksheets
ws.Unprotect "password"
Next ws

https://www.automateexcel.com/vba/sheets-worksheets

Save snippets that work from anywhere online with our extensions

Available in the Chrome Web Store

Get Firefox Add-on

Get VS Code extension

Comments

More like this

ping and send Whatsapp message

Function Ping(strip)
Dim objshell, boolcode
Set objshell = CreateObject("Wscript.Shell")
boolcode = objshell.Run("ping -n 1 -w 1000 " & strip, 0, True)
If boolcode = 0 Then
    Ping = True
Else
    Ping = False
End If
End Function
Sub PingSystem()
Dim strip As String
Dim strPhoneNumber As String
Dim strMessage As String
Dim strPostData As String
Dim IE As Object

strPhoneNumber = Sheets("DATA").Cells(2, 1).Value

For introw = 2 To ActiveSheet.Cells(65536, 2).End(xlUp).Row
    strip = ActiveSheet.Cells(introw, 2).Value
    If Ping(strip) = True Then
        ActiveSheet.Cells(introw, 3).Interior.ColorIndex = 0
        ActiveSheet.Cells(introw, 3).Font.Color = RGB(0, 0, 0)
        ActiveSheet.Cells(introw, 3).Value = "Online"
        Application.Wait (Now + TimeValue("0:00:01"))
        ActiveSheet.Cells(introw, 3).Font.Color = RGB(0, 200, 0)
        
'Send Whatsapp Message
        strMessage = "Ping " & ActiveSheet.Cells(introw, 1).Value & " " & ActiveSheet.Cells(introw, 2).Value & " is Online"
        
'IE.navigate "whatsapp://send?phone=phone_number&text=your_message"
        strPostData = "whatsapp://send?phone=" & strPhoneNumber & "&text=" & strMessage
        Set IE = CreateObject("InternetExplorer.Application")
        IE.navigate strPostData
        Application.Wait Now() + TimeSerial(0, 0, 3)
        SendKeys "~"

        Set IE = Nothing
        
    Else
        ActiveSheet.Cells(introw, 3).Interior.ColorIndex = 0
        ActiveSheet.Cells(introw, 3).Font.Color = RGB(200, 0, 0)
        ActiveSheet.Cells(introw, 3).Value = "Offline"
        Application.Wait (Now + TimeValue("0:00:01"))
        ActiveSheet.Cells(introw, 3).Interior.ColorIndex = 6
        
'Send Whatsapp Message
        strMessage = "Ping " & ActiveSheet.Cells(introw, 1).Value & " " & ActiveSheet.Cells(introw, 2).Value & " is Offline"
        
'IE.navigate "whatsapp://send?phone=phone_number&text=your_message"
        strPostData = "whatsapp://send?phone=" & strPhoneNumber & "&text=" & strMessage
        Set IE = CreateObject("InternetExplorer.Application")
        IE.navigate strPostData
        Application.Wait Now() + TimeSerial(0, 0, 3)
        SendKeys "~"
        Set IE = Nothing
    End If
Next
End Sub

VBA to clear data from sheets

Sub ClearData()

Worksheets("Clients").Rows("2:" & Rows.Count).ClearContents
Worksheets("Cases").Rows("2:" & Rows.Count).ClearContents
Worksheets("Sessions").Rows("2:" & Rows.Count).ClearContents

End Sub

Sub PAUSE(Period As Single)
Dim TimeNow As Single
TimeNow = Timer
Do
    DoEvents
Loop While TimeNow + Period > Timer
End Sub

PPT manipulation VBA

Sub display_all_chart_shapes()

    Dim sld As Slide
    Dim shp As Shape
    Dim sr As Series
    Dim chrt As Chart
    Dim counter As Integer
    counter = 1
    For Each sld In ActivePresentation.Slides
        For Each shp In sld.Shapes
            Debug.Print counter & "##" & sld.Name & " " & shp.Name
        Next shp
        counter = counter + 1
    Next sld

End Sub

Function pieknosc()
    
    Dim sld As Slide
    Dim shp As Shape
    Dim sr As Series
    Dim chrt As Chart
    Dim counter As Integer
    counter = 1
    For Each sld In ActivePresentation.Slides
        For Each shp In sld.Shapes
            'Debug.Print counter & "##" & sld.Name & " " & shp.Name
            '
            '
            ' KOMENTARZE
            '
            '
            If shp.Name = "TextBox 11" Then
                Debug.Print counter & "##" & sld.Name & " " & shp.Name & "left: " & shp.Left & "top: " & shp.Top & "width: " & shp.Width
                sngDefaultSlideWidth = ActivePresentation.PageSetup.SlideWidth
                sngDefaultSlideHeight = ActivePresentation.PageSetup.SlideHeight
                'shp.Left = (sngDefaultSlideWidth / 2 - shp.Width) / 2 + sngDefaultSlideWidth / 2
                'shp.Top = (sngDefaultSlideHeight / 2 - shp.Height) / 2 + 8 + sngDefaultSlideHeight / 2
                shp.Left = 10
                shp.Top = 460
                shp.Width = 720
                shp.TextEffect.FontName = "Arial"
                shp.TextEffect.FontSize = 9
            End If
            '
            '
            ' PODTYTUŁY
            '
            '
            If shp.Name = "Podtytuł 2" Then
                Debug.Print counter & "##" & sld.Name & " " & shp.Name & "left: " & shp.Left & "top: " & shp.Top & "width: " & shp.Width
                sngDefaultSlideWidth = ActivePresentation.PageSetup.SlideWidth
                sngDefaultSlideHeight = ActivePresentation.PageSetup.SlideHeight
                'shp.Left = (sngDefaultSlideWidth / 2 - shp.Width) / 2 + sngDefaultSlideWidth / 2
                'shp.Top = (sngDefaultSlideHeight / 2 - shp.Height) / 2 + 8 + sngDefaultSlideHeight / 2
                shp.Left = 10
                shp.Top = 10
                shp.Width = 900
                shp.TextEffect.FontName = "Arial"
                shp.TextEffect.FontSize = 24
            End If
            
            
            
        Next shp
        counter = counter + 1
    Next sld
End Function

Zip All Email Attachments In A Outlook Folder

Sub ZipAllEmailsInAFolder()
    Dim objFolder As Outlook.Folder
    Dim objItem As Object
    Dim objMail As Outlook.MailItem
    Dim strSubject As String
    Dim varTempFolder As Variant
    Dim varZipFile As Variant
    Dim objShell As Object
    Dim objFileSystem As Object
   
    'Select an Outlook Folder
    Set objFolder = Outlook.Application.Session.PickFolder
 
    If Not (objFolder Is Nothing) Then
       'Create a temp folder
       varTempFolder = "C:\Temp\" & objFolder.Name & Format(Now, "YYMMDDHHMMSS")
       MkDir (varTempFolder)
       varTempFolder = varTempFolder & "\"
   
       'Save each email as msg file
       For Each objItem In objFolder.Items
 
           If TypeOf objItem Is MailItem Then
              Set objMail = objItem
              strSubject = objMail.subject
              strSubject = Replace(strSubject, "/", " ")
              strSubject = Replace(strSubject, "\", " ")
              strSubject = Replace(strSubject, ":", "")
              strSubject = Replace(strSubject, "?", " ")
              strSubject = Replace(strSubject, Chr(34), " ")
 
              objMail.SaveAs varTempFolder & strSubject & ".msg", olMSG
           End If
       Next
 
       'Create a new ZIP file
       varZipFile = "C:\Temp\" & objFolder.Name & " Emails.zip"
       Open varZipFile For Output As #1
       Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
       Close #1
 
       'Add the exported msg files to the ZIP file
       Set objShell = CreateObject("Shell.Application")
       objShell.NameSpace(varZipFile).CopyHere objShell.NameSpace(varTempFolder).Items

       On Error Resume Next
       Do Until objShell.NameSpace(varZipFile).Items.Count = objShell.NameSpace(varTempFolder).Items.Count
          Application.Wait (Now + TimeValue("0:00:01"))
       Loop
       On Error GoTo 0
 
       'Delete the temp folder
       Set objFileSystem = CreateObject("Scripting.FileSystemObject")
       objFileSystem.DeleteFolder Left(varTempFolder, Len(varTempFolder) - 1)
    End If
End Sub






Sub ZipAttachments()
    Dim objMail As Outlook.MailItem
    Dim objAttachments As Outlook.Attachments
    Dim objAttachment As Outlook.Attachment
    Dim objFileSystem As Object
    Dim objShell As Object
    Dim varTempFolder As Variant
    Dim varZipFile As Variant
 
    'Save the attachments to Temporary folder
    Set objFileSystem = CreateObject("Scripting.FileSystemObject")
    varTempFolder = objFileSystem.GetSpecialFolder(2).Path & "\Temp " & Format(Now, "dd-mm-yyyy- hh-mm-ss-")
    MkDir (varTempFolder)
    varTempFolder = varTempFolder & "\"
 
    Set objMail = Outlook.Application.ActiveInspector.CurrentItem
    Set objAttachments = objMail.Attachments
    For Each objAttachment In objAttachments
        objAttachment.SaveAsFile (varTempFolder & objAttachment.FileName)
    Next
 
    'Create a new zip file
    varZipFile = InputBox("Specify a name for the new zip file", "Name Zip File", objMail.subject)
    varZipFile = objFileSystem.GetSpecialFolder(2).Path & "\" & varZipFile & ".zip"
    Open varZipFile For Output As #1
    Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
    Close #1
 
    'Copy all the saved attachments to the new zip file
     Set objShell = CreateObject("Shell.Application")
     objShell.NameSpace(varZipFile).CopyHere objShell.NameSpace(varTempFolder).Items

     'Keep macro running until Compressing is done
     On Error Resume Next
     Do Until objShell.NameSpace(varZipFile).Items.Count = objShell.NameSpace(varTempFolder).Items.Count
        Application.Wait (Now + TimeValue("0:00:01"))
     Loop
     On Error GoTo 0
 
     'Delete all the attachments
     Set objAttachments = objMail.Attachments
     While objAttachments.Count > 0
           objAttachments.Item(1).Delete
     Wend
 
     'Add the new zip file to the current email
     objMail.Attachments.Add varZipFile
 
    'Prompt
    MsgBox ("Complete!")
End Sub

Count Emails By Date (Public)

Dim objDictionary As Object 

 

Sub CountSentMailsByMonth() 'Must enable Microsoft Excel Reference Library 

    Dim objOutlookFile As Outlook.Folder 

    Dim objFolder As Outlook.Folder 

    Dim objExcelApp As Excel.Aapplication 

    Dim objExcelWorkbook As Excel.Workbook 

    Dim objExcelWorksheet As Excel.Worksheet 

    Dim varMonths As Variant 

    Dim varItemCounts As Variant 

    Dim nLastRow As Integer 

  

    Set objDictionary = CreateObject("Scripting.Dictionary") 

    Set objInbox = Outlook.Application.Session.GetDefaultFolder(olFolderInbox) 

  

    'Get the default Outlook data file 

    Set objOutlookFile = Outlook.Application.Session.GetDefaultFolder(olFolderInbox).Parent 

  

    For Each objFolder In objOutlookFile.Folders 

        If objFolder.DefaultItemType = olMailItem Then 

           Call ProcessFolders(objFolder) 

        End If 

    Next 

 

    Set objExcelApp = CreateObject("Excel.Application") 

    objExcelApp.Visible = True 

    Set objExcelWorkbook = objExcelApp.Workbooks.Add 

    Set objExcelWorksheet = objExcelWorkbook.Sheets(1) 

  

    With objExcelWorksheet 

        .Cells(1, 1) = "Month" 

        .Cells(1, 2) = "Count" 

    End With 

  

    varMonths = objDictionary.Keys 

    varItemCounts = objDictionary.Items 

  

    For i = LBound(varMonths) To UBound(varMonths) 

        nLastRow = objExcelWorksheet.Range("A" & objExcelWorksheet.Rows.Count).End(xlUp).Row + 1 

        With objExcelWorksheet 

            .Cells(nLastRow, 1) = varMonths(i) 

            .Cells(nLastRow, 2) = varItemCounts(i) 

        End With 

    Next 

  

    objExcelWorksheet.Columns("A:B").AutoFit 

End Sub 

 

Sub ProcessFolders(ByVal objCurFolder As Outlook.Folder) 

    Dim i As Long 

    Dim objMail As Outlook.MailItem 

    Dim strMonth As String 

  

    For i = objCurFolder.Items.Count To 1 Step -1 

        If objCurFolder.Items(i).Class = olMail Then 

           Set objMail = objCurFolder.Items(i) 

           'Change to your own email address 

           If objMail.SenderEmailAddress = "you@datanumen.com" Then 

              strMonth = Format(Year(objMail.SentOn) & "-" & Month(objMail.SentOn), "YYYY/MM") 

  

              If objDictionary.Exists(strMonth) Then 

                 objDictionary(strMonth) = objDictionary(strMonth) + 1 

              Else 

                 objDictionary.Add strMonth, 1 

              End If 

           End If 

       End If 

    Next 

End Sub

Zip All Email Attachments to Temporary Folder (Public)

Sub ZipAllEmailsInAFolder() 

    Dim objFolder As Outlook.Folder 

    Dim objItem As Object 

    Dim objMail As Outlook.MailItem 

    Dim strSubject As String 

    Dim varTempFolder As Variant 

    Dim varZipFile As Variant 

    Dim objShell As Object 

    Dim objFileSystem As Object 

    

    'Select an Outlook Folder 

    Set objFolder = Outlook.Application.Session.PickFolder 

  

    If Not (objFolder Is Nothing) Then 

       'Create a temp folder 

       varTempFolder = "C:\Temp\" & objFolder.Name & Format(Now, "YYMMDDHHMMSS") 

       MkDir (varTempFolder) 

       varTempFolder = varTempFolder & "\" 

    

       'Save each email as msg file 

       For Each objItem In objFolder.Items 

  

           If TypeOf objItem Is MailItem Then 

              Set objMail = objItem 

              strSubject = objMail.subject 

              strSubject = Replace(strSubject, "/", " ") 

              strSubject = Replace(strSubject, "\", " ") 

              strSubject = Replace(strSubject, ":", "") 

              strSubject = Replace(strSubject, "?", " ") 

              strSubject = Replace(strSubject, Chr(34), " ") 

  

              objMail.SaveAs varTempFolder & strSubject & ".msg", olMSG 

           End If 

       Next 

  

       'Create a new ZIP file 

       varZipFile = "C:\Temp\" & objFolder.Name & " Emails.zip" 

       Open varZipFile For Output As #1 

       Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0) 

       Close #1 

  

       'Add the exported msg files to the ZIP file 

       Set objShell = CreateObject("Shell.Application") 

       objShell.NameSpace(varZipFile).CopyHere objShell.NameSpace(varTempFolder).Items 

 

       On Error Resume Next 

       Do Until objShell.NameSpace(varZipFile).Items.Count = objShell.NameSpace(varTempFolder).Items.Count 

          Application.Wait (Now + TimeValue("0:00:01")) 

       Loop 

       On Error GoTo 0 

  

       'Delete the temp folder 

       Set objFileSystem = CreateObject("Scripting.FileSystemObject") 

       objFileSystem.DeleteFolder Left(varTempFolder, Len(varTempFolder) - 1) 

    End If 

End Sub 

 

 

 

 

 

 

Sub ZipAttachments() 

    Dim objMail As Outlook.MailItem 

    Dim objAttachments As Outlook.Attachments 

    Dim objAttachment As Outlook.Attachment 

    Dim objFileSystem As Object 

    Dim objShell As Object 

    Dim varTempFolder As Variant 

    Dim varZipFile As Variant 

  

    'Save the attachments to Temporary folder 

    Set objFileSystem = CreateObject("Scripting.FileSystemObject") 

    varTempFolder = objFileSystem.GetSpecialFolder(2).Path & "\Temp " & Format(Now, "dd-mm-yyyy- hh-mm-ss-") 

    MkDir (varTempFolder) 

    varTempFolder = varTempFolder & "\" 

  

    Set objMail = Outlook.Application.ActiveInspector.CurrentItem 

    Set objAttachments = objMail.Attachments 

    For Each objAttachment In objAttachments 

        objAttachment.SaveAsFile (varTempFolder & objAttachment.FileName) 

    Next 

  

    'Create a new zip file 

    varZipFile = InputBox("Specify a name for the new zip file", "Name Zip File", objMail.subject) 

    varZipFile = objFileSystem.GetSpecialFolder(2).Path & "\" & varZipFile & ".zip" 

    Open varZipFile For Output As #1 

    Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0) 

    Close #1 

  

    'Copy all the saved attachments to the new zip file 

     Set objShell = CreateObject("Shell.Application") 

     objShell.NameSpace(varZipFile).CopyHere objShell.NameSpace(varTempFolder).Items 

 

     'Keep macro running until Compressing is done 

     On Error Resume Next 

     Do Until objShell.NameSpace(varZipFile).Items.Count = objShell.NameSpace(varTempFolder).Items.Count 

        Application.Wait (Now + TimeValue("0:00:01")) 

     Loop 

     On Error GoTo 0 

  

     'Delete all the attachments 

     Set objAttachments = objMail.Attachments 

     While objAttachments.Count > 0 

           objAttachments.Item(1).Delete 

     Wend 

  

     'Add the new zip file to the current email 

     objMail.Attachments.Add varZipFile 

  

    'Prompt 

    MsgBox ("Complete!") 

End Sub

Create Task With Attachment (Public)

Sub ConvertSelectedMailtoTask() 

    Dim objTask As Outlook.TaskItem 

    Dim objMail As Outlook.MailItem 

     

    Set objTask = Application.CreateItem(olTaskItem) 

    Set objMail = Application.ActiveExplorer.Selection.Item(1) 

 

With objTask 

    .subject = objMail.subject 

    .StartDate = objMail.ReceivedTime 

    .Body = objMail.Body 'Add the message as an attachment 

    .Attachments.Add objMail 

    .Save 

End With 

 

    Set objTask = Nothing 

    Set objMail = Nothing 

End Sub

Copy Outlook Emails and Folder Structure to Folder (Public)

Dim xFSO As Scripting.FileSystemObject 

Sub CopyOutlookFldStructureToWinExplorer() 

    ExportAction "Copy" 

End Sub 

    

Sub ExportAction(xAction As String) 

Dim xFolder As Outlook.Folder 

Dim xFldPath As String 

xFldPath = SelectAFolder() 

If xFldPath = "" Then 

    MsgBox "You did not select a folder. Export cancelled.", vbInformation + vbOKOnly, "Kutools for Outlook" 

Else 

    Set xFSO = New Scripting.FileSystemObject 

    Set xFolder = Outlook.Application.ActiveExplorer.CurrentFolder 

    ExportOutlookFolder xFolder, xFldPath 

End If 

Set xFolder = Nothing 

Set xFSO = Nothing 

End Sub 

  

Sub ExportOutlookFolder(ByVal OutlookFolder As Outlook.Folder, xFldPath As String) 

Dim xSubFld As Outlook.Folder 

Dim xItem As Object 

Dim xPath As String 

Dim xFilePath As String 

Dim xSubject As String 

Dim xCount As Integer 

Dim xFilename As String 

On Error Resume Next 

xPath = xFldPath & "\" & OutlookFolder.Name 

'?????????,?????? 

If Dir(xPath, 16) = Empty Then MkDir xPath 

For Each xItem In OutlookFolder.Items 

    xSubject = ReplaceInvalidCharacters(xItem.subject) 

    xFilename = xSubject & ".msg" 

    xCount = 0 

    xFilePath = xPath & "\" & xFilename 

    If xFSO.FileExists(xFilePath) Then 

        xCount = xCount + 1 

        xFilename = xSubject & " (" & xCount & ").msg" 

        xFilePath = xPath & "\" & xFilename 

    End If 

    xItem.SaveAs xFilePath, olMSG 

Next 

For Each xSubFld In OutlookFolder.Folders 

    ExportOutlookFolder xSubFld, xPath 

Next 

Set OutlookFolder = Nothing 

Set xItem = Nothing 

End Sub 

  

Function SelectAFolder() As String 

Dim xSelFolder As Object 

Dim xShell As Object 

On Error Resume Next 

Set xShell = CreateObject("Shell.Application") 

Set xSelFolder = xShell.BrowseForFolder(0, "Select a folder", 0, 0) 

If Not TypeName(xSelFolder) = "Nothing" Then 

    SelectAFolder = xSelFolder.Self.Path 

End If 

Set xSelFolder = Nothing 

Set xShell = Nothing 

End Function 

    

Function ReplaceInvalidCharacters(Str As String) As String 

Dim xRegEx 

Set xRegEx = CreateObject("vbscript.regexp") 

xRegEx.Global = True 

xRegEx.IgnoreCase = False 

xRegEx.Pattern = "\||\/|\<|\>|""|:|\*|\\|\?" 

ReplaceInvalidCharacters = xRegEx.Replace(Str, "") 

End Function

Extract All Email Attachments with Duplicate Filenames Allowed (Public)

Option Explicit 

'*********************************************************************** 

'* Code based on sample code from Martin Green and adapted to my needs 

'* more on TheTechieGuy.com - Liron@TheTechieGuy.com 

'*********************************************************************** 

'*********************************************************************** 

 

Sub GetAttachments() 

On Error Resume Next 

'create the folder if it doesnt exists: 

    Dim FSO, ttxtfile, txtfile, WheretosaveFolder 

    Dim objFolders As Object 

    Set objFolders = CreateObject("WScript.Shell").SpecialFolders 

  

    'MsgBox objFolders("mydocuments") 

    ttxtfile = objFolders("mydocuments") 

     

    Set FSO = CreateObject("Scripting.FileSystemObject") 

    Set txtfile = FSO.CreateFolder(ttxtfile & "\Email Attachments") 

    ' Changes made by Andrew Davis (adavis@xtheta.com) on October 28th 2015 

    ' ------------------------------------------------------ 

        ' Set fso = Nothing 

    ' ------------------------------------------------------ 

    WheretosaveFolder = ttxtfile & "\Email Attachments" 

     

On Error GoTo GetAttachments_err 

' Declare variables 

    Dim ns As NameSpace 

    Dim Inbox As MAPIFolder 

    Dim Item As Object 

    Dim Atmt As Attachment 

    Dim FileName As String 

    Dim i As Integer 

    Set ns = GetNamespace("MAPI") 

    'Set Inbox = ns.GetDefaultFolder(olFolderInbox) 

    ' added the option to select whic folder to export 

    Set Inbox = ns.PickFolder 

     

    'to handle if the use cancalled folder selection 

    If Inbox Is Nothing Then 

                MsgBox "You need to select a folder in order to save the attachments", vbCritical, _ 

               "Export - Not Found" 

        Exit Sub 

    End If 

 

    '''' 

     

 

    i = 0 

' Check Inbox for messages and exit of none found 

    If Inbox.Items.Count = 0 Then 

        MsgBox "There are no messages in the selected folder.", vbInformation, _ 

               "Export - Not Found" 

        Exit Sub 

    End If 

' Check each message for attachments 

    For Each Item In Inbox.Items 

' Save any attachments found 

        For Each Atmt In Item.Attachments 

        ' This path must exist! Change folder name as necessary. 

         

        ' Changes made by Andrew Davis (adavis@xtheta.com) on October 28th 2015 

        ' ------------------------------------------------------ 

            FileName = WheretosaveFolder & "\" & FSO.GetBaseName(Atmt.FileName) & i & "." & FSO.GetExtensionName(Atmt.FileName) 

        ' ------------------------------------------------------ 

            Atmt.SaveAsFile FileName 

            i = i + 1 

         Next Atmt 

    Next Item 

' Show summary message 

    If i > 0 Then 

        MsgBox "There were " & i & " attached files." _ 

        & vbCrLf & "These have been saved to the Email Attachments folder in My Documents." _ 

        & vbCrLf & vbCrLf & "Thank you for using Liron Segev - TheTechieGuy's utility", vbInformation, "Export Complete" 

    Else 

        MsgBox "There were no attachments found in any mails.", vbInformation, "Export - Not Found" 

    End If 

    ' Changes made by Andrew Davis (adavis@xtheta.com) on October 28th 2015 

    ' ------------------------------------------------------ 

        Set FSO = Nothing 

    ' ------------------------------------------------------ 

' Clear memory 

GetAttachments_exit: 

    Set Atmt = Nothing 

    Set Item = Nothing 

    Set ns = Nothing 

    Exit Sub 

' Handle errors 

GetAttachments_err: 

    MsgBox "An unexpected error has occurred." _ 

        & vbCrLf & "Please note and report the following information." _ 

        & vbCrLf & "Macro Name: GetAttachments" _ 

        & vbCrLf & "Error Number: " & Err.Number _ 

        & vbCrLf & "Error Description: " & Err.Description _ 

        , vbCritical, "Error!" 

    Resume GetAttachments_exit 

End Sub

Extract All Emails from Outlook Folder (Does not handle Duplicates) (Public)

Dim strAttachmentFolder As String 

 

Sub ExtractAttachmentsFromEmailsStoredinWindowsFolder() 'Does not handle duplicates this one 

    Dim objShell, objWindowsFolder As Object 

  

    'Select a Windows folder 

    Set objShell = CreateObject("Shell.Application") 

    Set objWindowsFolder = objShell.BrowseForFolder(0, "Select a Windows Folder:", 0, "") 

  

    If Not objWindowsFolder Is Nothing Then 

       'Create a new folder for saving extracted attachments 

       strAttachmentFolder = "C:\Users\cnewnham\Downloads\attachments-" & Format(Now, "MMDDHHMMSS") & "\" 

       MkDir (strAttachmentFolder) 

       Call ProcessFolders(objWindowsFolder.Self.Path & "\") 

       MsgBox "Completed!", vbInformation + vbOKOnly 

    End If 

End Sub 

 

Sub ProcessFolders(StrFolderPath As String) 

    Dim objFileSystem As Object 

    Dim objFolder As Object 

    Dim objFiles As Object 

    Dim objFile As Object 

    Dim objItem As Object 

    Dim i As Long 

    Dim objSubfolder As Object 

 

    Set objFileSystem = CreateObject("Scripting.FileSystemObject") 

    Set objFolder = objFileSystem.GetFolder(StrFolderPath) 

    Set objFiles = objFolder.Files 

  

    For Each objFile In objFiles 

        If objFileSystem.GetExtensionName(objFile) = "msg" Then 

           'Open the Outlook emails stored in Windows folder 

           Set objItem = Session.OpenSharedItem(objFile.Path) 

 

           If TypeName(objItem) = "MailItem" Then 

              If objItem.Attachments.Count > 0 Then 

                 'Extract attachments 

                 For i = objItem.Attachments.Count To 1 Step -1 

                     objItem.Attachments(i).SaveAsFile strAttachmentFolder & objItem.Attachments(i).FileName 

                 Next 

              End If 

           End If 

        End If 

    Next 

  

    'Process all subfolders recursively 

    If objFolder.SubFolders.Count > 0 Then 

       For Each objSubfolder In objFolder.SubFolders 

           If ((objSubfolder.Attributes And 2) = 0) And ((objSubfolder.Attributes And 4) = 0) Then 

              Call ProcessFolders(objSubfolder.Path) 

           End If 

       Next 

    End If 

End Sub

Extract Attachments From Single Message (Public)

Public Sub SaveMessagesAndAttachments() ' Export for Single Message 

Dim objOL As Outlook.Application 

Dim objMsg As Outlook.MailItem 'Object 

Dim objAttachments As Outlook.Attachments 

Dim i As Long 

Dim lngCount As Long 

Dim StrFile As String 

Dim StrName As String 

Dim StrFolderPath As String 

Dim strDeletedFiles As String 

 Dim sFileType As String 

Dim enviro As String 

enviro = CStr(Environ("USERPROFILE")) 

     

Dim FSO As Object 

Dim oldName 

     

Set FSO = CreateObject("Scripting.FileSystemObject") 

       

    On Error Resume Next 

Set objOL = CreateObject("Outlook.Application") 

Set objMsg = objOL.ActiveExplorer.Selection.Item(1) 

 StrName = StripIllegalChar(objMsg.subject) 

     

StrFolderPath = enviro & "\Documents\" & StrName & "\" 

If Not FSO.FolderExists(StrFolderPath) Then 

    FSO.CreateFolder (StrFolderPath) 

End If 

 

 objMsg.SaveAs StrFolderPath & StrName & ".htm", olHTML 

  

    Set objAttachments = objMsg.Attachments 

    lngCount = objAttachments.Count 

          

    If lngCount > 0 Then 

      

    For i = lngCount To 1 Step -1 

      

    StrFile = objAttachments.Item(i).FileName 

    Debug.Print StrFile 

    StrFile = StrFolderPath & StrFile 

    objAttachments.Item(i).SaveAsFile StrFile 

    

    Next i 

    End If 

           

ExitSub: 

  

Set objAttachments = Nothing 

Set objMsg = Nothing 

Set objSelection = Nothing 

Set objOL = Nothing 

End Sub 

 

Function StripIllegalChar(StrInput) 

    Dim RegX            As Object 

    Set RegX = CreateObject("vbscript.regexp") 

        

    RegX.Pattern = "[\" & Chr(34) & "\!\@\#\$\%\^\&\*\(\)\=\+\|\[\]\{\}\`\'\;\:\<\>\?\/\,]" 

    RegX.IgnoreCase = True 

    RegX.Global = True 

        

    StripIllegalChar = RegX.Replace(StrInput, "") 

        

ExitFunction: 

    Set RegX = Nothing 

        

End Function

Extract Email Attachments from Emails Stored In Windows Folder (Public)

Dim strAttachmentFolder As String 

 

Sub ExtractAttachmentsFromEmailsStoredinWindowsFolder() 

    Dim objShell, objWindowsFolder As Object 

  

    'Select a Windows folder 

    Set objShell = CreateObject("Shell.Application") 

    Set objWindowsFolder = objShell.BrowseForFolder(0, "Select a Windows Folder:", 0, "") 

  

    If Not objWindowsFolder Is Nothing Then 

       'Create a new folder for saving extracted attachments 

       strAttachmentFolder = "C:\Users\cnewnham\Downloads\attachments-" & Format(Now, "MMDDHHMMSS") & "\" 

       MkDir (strAttachmentFolder) 

       Call ProcessFolders(objWindowsFolder.Self.Path & "\") 

       MsgBox "Completed!", vbInformation + vbOKOnly 

    End If 

End Sub 

 

Sub ProcessFolders(StrFolderPath As String) 

    Dim objFileSystem As Object 

    Dim objFolder As Object 

    Dim objFiles As Object 

    Dim objFile As Object 

    Dim objItem As Object 

    Dim i As Long 

    Dim objSubfolder As Object 

 

    Set objFileSystem = CreateObject("Scripting.FileSystemObject") 

    Set objFolder = objFileSystem.GetFolder(StrFolderPath) 

    Set objFiles = objFolder.Files 

  

    For Each objFile In objFiles 

        If objFileSystem.GetExtensionName(objFile) = "msg" Then 

           'Open the Outlook emails stored in Windows folder 

           Set objItem = Session.OpenSharedItem(objFile.Path) 

 

           If TypeName(objItem) = "MailItem" Then 

              If objItem.Attachments.Count > 0 Then 

                 'Extract attachments 

                 For i = objItem.Attachments.Count To 1 Step -1 

                     objItem.Attachments(i).SaveAsFile strAttachmentFolder & objItem.Attachments(i).FileName 

                 Next 

              End If 

           End If 

        End If 

    Next 

  

    'Process all subfolders recursively 

    If objFolder.SubFolders.Count > 0 Then 

       For Each objSubfolder In objFolder.SubFolders 

           If ((objSubfolder.Attributes And 2) = 0) And ((objSubfolder.Attributes And 4) = 0) Then 

              Call ProcessFolders(objSubfolder.Path) 

           End If 

       Next 

    End If 

End Sub

Extract attachments from outlook folder (Accounting for duplicates) (Public)

Option Explicit 

 

Public Sub ExportAttachments() 'Extract attachments from outlook folder accounting for duplicates 

    Dim objOL As Outlook.Application 

    Dim objMsg As Object 

    Dim objAttachments As Outlook.Attachments 

    Dim objSelection As Outlook.Selection 

    Dim i As Long, lngCount As Long 

    Dim filesRemoved As String, fName As String, StrFolder As String, saveFolder As String, savePath As String 

    Dim alterEmails As Boolean, overwrite As Boolean 

    Dim result 

     

    saveFolder = BrowseForFolder("Select the folder to save attachments to.") 

    If saveFolder = vbNullString Then Exit Sub 

     

    result = MsgBox("Do you want to remove attachments from selected file(s)? " & vbNewLine & _ 

    "(Clicking no will export attachments but leave the emails alone)", vbYesNo + vbQuestion) 

    alterEmails = (result = vbYes) 

     

    Set objOL = CreateObject("Outlook.Application") 

    Set objSelection = objOL.ActiveExplorer.Selection 

     

    For Each objMsg In objSelection 

        If objMsg.Class = olMail Then 

            Set objAttachments = objMsg.Attachments 

            lngCount = objAttachments.Count 

            If lngCount > 0 Then 

                filesRemoved = "" 

                For i = lngCount To 1 Step -1 

                    fName = objAttachments.Item(i).FileName 

                    savePath = saveFolder & "\" & fName 

                    overwrite = False 

                    While Dir(savePath) <> vbNullString And Not overwrite 

                        Dim newFName As String 

                        newFName = InputBox("The file '" & fName & _ 

                            "' already exists. Please enter a new file name, or just hit OK overwrite.", _ 

                            "Confirm File Name", fName) 

                        If newFName = vbNullString Then GoTo skipfile 

                        If newFName = fName Then overwrite = True Else fName = newFName 

                        savePath = saveFolder & "\" & fName 

                    Wend 

                     

                    objAttachments.Item(i).SaveAsFile savePath 

                     

                    If alterEmails Then 

                        filesRemoved = filesRemoved & "<br>""" & objAttachments.Item(i).FileName & """ (" & _ 

                                                                formatSize(objAttachments.Item(i).size) & ") " & _ 

                            "<a href=""" & savePath & """>[Location Saved]</a>" 

                        objAttachments.Item(i).Delete 

                    End If 

skipfile: 

                Next i 

                 

                If alterEmails Then 

                    filesRemoved = "<b>Attachments removed</b>: " & filesRemoved & "<br><br>" 

                     

                    Dim objDoc As Object 

                    Dim objInsp As Outlook.Inspector 

                    Set objInsp = objMsg.GetInspector 

                    Set objDoc = objInsp.WordEditor 

 

                    objMsg.HTMLBody = filesRemoved + objMsg.HTMLBody 

                    objMsg.Save 

                End If 

            End If 

        End If 

    Next 

     

ExitSub: 

    Set objAttachments = Nothing 

    Set objMsg = Nothing 

    Set objSelection = Nothing 

    Set objOL = Nothing 

End Sub 

 

Function formatSize(size As Long) As String 

    Dim val As Double, newVal As Double 

    Dim unit As String 

     

    val = size 

    unit = "bytes" 

     

    newVal = Round(val / 1024, 1) 

    If newVal > 0 Then 

        val = newVal 

        unit = "KB" 

    End If 

    newVal = Round(val / 1024, 1) 

    If newVal > 0 Then 

        val = newVal 

        unit = "MB" 

    End If 

    newVal = Round(val / 1024, 1) 

    If newVal > 0 Then 

        val = newVal 

        unit = "GB" 

    End If 

     

    formatSize = val & " " & unit 

End Function 

 

'Function purpose:  To Browser for a user selected folder. 

'If the "OpenAt" path is provided, open the browser at that directory 

'NOTE:  If invalid, it will open at the Desktop level 

Function BrowseForFolder(Optional Prompt As String, Optional OpenAt As Variant) As String 

    Dim ShellApp As Object 

    Set ShellApp = CreateObject("Shell.Application").BrowseForFolder(0, Prompt, 0, OpenAt) 

 

    On Error Resume Next 

    BrowseForFolder = ShellApp.Self.Path 

    On Error GoTo 0 

    Set ShellApp = Nothing 

      

    'Check for invalid or non-entries and send to the Invalid error handler if found 

    'Valid selections can begin L: (where L is a letter) or \\ (as in \\servername\sharename.  All others are invalid 

    Select Case Mid(BrowseForFolder, 2, 1) 

        Case Is = ":": If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid 

        Case Is = "\": If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid 

        Case Else: GoTo Invalid 

    End Select 

      

    Exit Function 

Invalid: 

     'If it was determined that the selection was invalid, set to False 

    BrowseForFolder = vbNullString 

End Function 

 

Function BrowseForFile(Optional Prompt As String, Optional OpenAt As Variant) As String 

    Dim ShellApp As Object 

    Set ShellApp = CreateObject("Shell.Application").BrowseForFolder(0, Prompt, 16 + 16384, OpenAt) 

     

    On Error Resume Next 

    BrowseForFile = ShellApp.Self.Path 

    On Error GoTo 0 

    Set ShellApp = Nothing 

      

    'Check for invalid or non-entries and send to the Invalid error handler if found 

    'Valid selections can begin L: (where L is a letter) or \\ (as in \\servername\sharename.  All others are invalid 

    Select Case Mid(BrowseForFolder, 2, 1) 

        Case Is = ":": If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid 

        Case Is = "\": If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid 

        Case Else: GoTo Invalid 

    End Select 

      

    Exit Function 

Invalid: 

     'If it was determined that the selection was invalid, set to False 

    BrowseForFile = vbNullString 

End Function

Fix Email Subject Line Text Case (Public)

Sub ProperCaseSubject() 

 

    Dim myMessage As Outlook.MailItem 

    Set myMessage = Outlook.ActiveInspector.CurrentItem 

 

    Dim subject As String 

 

    subject = myMessage.subject ' Problematic line 

                                ' You need to input this or capture this 

    s = StrConv(subject, vbProperCase) 

 

    myMessage.subject = s 

 

End Sub

Browse more snippets >>