Youtube.com/VbaA2z (subscribe for new videos every weekend!): October 2016

How to accept or decline all Facebook Friends Request at once

Accept all Facebook Friends Request at once.

Click here for short Video explainer - YouTube

https://www.facebook.com/reqs.php

DEMO CODE 1
javascript:for( i = 1;i<document.getElementsByName("actions[accept]").length;i++){document.getElementsByName("actions[accept]")[i].click();}void(0);

DEMO CODE 2
javascript:for( i = 1;i<10;i++){document.getElementsByName("actions[accept]")[i].click();}void(0);

Click here for short Video explainer - YouTube

javascript:for( i = 0;i<25;i++){document.getElementsByName("actions[accept]")[i].click();}void(0);
javascript:for( i = 0;i<7;i++){document.getElementsByName("actions[reject]")[i].click();}void(0);
javascript:for( i = 0;i<document.getElementsByName("actions[accept]").length;i++){document.getElementsByName("actions[accept]")[i].click();}void(0);
javascript:alert(document.getElementsByName("actions[accept]").length)

VLOOKUP using VBA. VBA and Excel WorkSheet Functions

Like what I do? Donate

Did I help you? Did one of my tutorials save you sometime?

You can say thank you by buying me a cup of coffee, I go through a lot of it.

Help keep Greater Good resources free for everyone. Please donate today.

This page is not monitored so for questions please comment on the youtube video page. For suggestions email vbaa2z.team@gmail.com

Download project or source code from below link(s)

Option Explicit

Sub vlookuptest1()
    Range("B2:B501").FormulaR1C1 = "=VLOOKUP(RC[-1],Data!R1C1:R501C13,2,0)"
End Sub

Sub vlookuptest2()
    Range("B2:B501").Formula = "=VLOOKUP(A2,Data!$A$1:$M$501,2,0)"
End Sub


Sub vlookuptest2()
    
'-----------------------------
'Thanks for downloading the code. 
'Please visit our channel for a quick explainer on this code.
'Feel free to update the code as per your need and also share with your friends.
'Channel: Youtube.com/vbaa2z
'Download free codes from http://vbaa2z.blogspot.com
'Autor: L Pamai (vbaa2z.team@gmail.com)
'-----------------------------

    Dim myuidstr As String
    Dim firstNameStr As String
    
    myuidstr = "1000006"
    
    firstNameStr = Application.WorksheetFunction.VLookup(myuidstr, Sheets("Data").Range("A1:M501"), 2, 0)
    
    MsgBox firstNameStr
    
End Sub

VBA Function to check if User is currently Connected to Certain Cube

You can use below tested VBA function to check if current user is currently connected to a TM1 Cube.

Function IsConnectedTo(xServer) As Boolean

'-----------------------------
'Thanks for downloading the code. 
'Please visit our channel for a quick explainer on this code.
'Feel free to update the code as per your need and also share with your friends.
'Channel: Youtube.com/vbaa2z
'Download free codes from http://vbaa2z.blogspot.com
'Autor: L Pamai (vbaa2z.team@gmail.com)
'-----------------------------

On Err GoTo tm1err_x1
Dim x
IsConnectedTo = False
x = Application.Run("TM1USER", xServer)
If Len(x & vbNullString) > 0 Then IsConnectedTo = True
Exit Function
tm1err_x1:
IsConnectedTo = False
End Function

Usage example:

Sub TestCode()

If IsConnectedTo("ENTER YOUR CUBE OR SERVER NAME HERE") Then
    'is connected proceed with your codes...
    Else
    MsgBox "Please ensure that you are connected to XTM1CUBE and try again"
End If
End Sub

VBA Program Booster

Hello friends, all relevant materials for this topic/tutorial can be downloaded from here. Please support us by subscribing to our channel and sharing them with your friends.

If you have any questions/feedback/tutorial request, please you can email me directly vbaa2z.team@gmail.com or comment on YouTube Video (blog comments are not actively monitored).

Support our channel: youtube.com/vbaa2z

Insert new module and paste below code.

Refer to Usage Example on how to use the code.

Public PriorCalcMode As Variant

Public Function TurnOnSpeed(x As Boolean)

'-----------------------------
'Thanks for downloading the code. 
'Please visit our channel for a quick explainer on how to use this code.
'Feel free to update the code as per your need and also share with your friends.
'Download free codes from http://vbaa2z.blogspot.com
'Support our channel: youtube.com/vbaa2z
'Author: L Pamai (vbaa2z.team@gmail.com)
'-----------------------------

    If x = True Then
    With Application
        PriorCalcMode = Application.Calculation
            .ScreenUpdating = False
            .DisplayAlerts = False
            .EnableEvents = False
            .Cursor = xlWait
            .Calculation = xlCalculationManual
    End With
    
    ElseIf x = False Then
    
    With Application
            .ScreenUpdating = True
            .DisplayAlerts = True
            .EnableEvents = True
            .StatusBar = False
            .Cursor = xlDefault
        .Calculation = PriorCalcMode
        End With
    End If

End Function

In short, this function will turn off ScreenUpdating, DisplayAlerts, EnableEvents, Calculation
before executing the code and when TurnOnSpeed is set to False it will turn back on.

Please remember that if you are using this code too along with some your code that does the cell / Excel calculation you can instruct your code to calculate cell/range/ application using below codes.

Execute calculation for from VBA

'application level (all workbook)
Application.Calculate

'sheet level (only specified sheet
Worksheets("SheetName").Calculate
Activesheet.Calculate

'range
Range("S1:Z900").Calculate
Range.CalculateRowMajorOrder

'ForceFullCalculation All
'If you can ensure that any dependencies within a block of formulas always refer backward to cells to the left or above, the Range.CalculateRowMajorOrder can be the fastest calculation method in Excel on a single processor system.

Workbook.ForceFullCalculation


'Calculate All
'ctrl + alt + f9
Application.CalculateFull

'CalculateFullRebuild
'ctrl + shift + alt + f9
Application.CalculateFullRebuild

Usage Example

Sub YourMacro()
'your declarations

'place this line "TurnOnSpeed True" before your macro execution starts
TurnOnSpeed True


'this is where all your codes / scripts will reside


'place this line "TurnOnSpeed False" where your macro execution ends
TurnOnSpeed False

Exit Sub

ErrHndler:

'place this line "TurnOnSpeed False" where your macro execution ends / exit the code due to error / for error handlers
TurnOnSpeed False

End Sub

Connection Strings

Connection Strings

1. Excel to Access database Connection String


'-----------------------------
'Thanks for downloading the code. 
'Please visit our channel for a quick explainer on this code.
'Feel free to update the code as per your need and also share with your friends.
'Channel: Youtube.com/vbaa2z
'Download free codes from http://vbaa2z.blogspot.com
'Autor: L Pamai (vbaa2z.team@gmail.com)
'-----------------------------

Public Const con1 As String = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=D:\path\FinData2016.accdb;Jet OLEDB:Database Password=yourPassword;"

VBA Errors and Fixes (YouTube)

VBA ADO Access Db + Excel (YouTube)

Short video series will teach you how to integrate Excel and Access Database to create a business solution / automation. In detail and easy to follow tutorial you’ll learn how to use VBA to connect to tb, table, add, sync, update, delete records / data….have fun!

"Not a Valid Password - Runtime Error 3031" Excel ADO VBA Error Message even when password are correctly entered

Are you receiving "Not a Valid Password - Run-time Error 3031" Excel ADO VBA Error Message even when correct password are updated / passed in the argument?

You will encounter this error if you’ve have done MS office/Access upgrade from 2007 to 2010/2013/2016. Existing Code and databases should work.

If you’re creating new database and setting a password or changing the password of existing database using new office (MS ACCESS) you’ll face this issue when connecting via VBA ADO.

Follow below steps to troubleshoot this issue:

1. Fire up Access application (any access file)
2. Click on File and then Options
3. Click on Client Settings
4. Go to Advanced section and check "use legacy encryption (good for reverse compatibility and multi-user database)"
5. Restart Access (by closing all access database currently)
6. Set new password
7. Run your ADO Code to connect to database. It should be working now.

'-----------------------------
'Please visit our channel for a quick explainer on this code.
'Feel free to update the code as per your need and also share with your friends.
'Channel: Youtube.com/vbaa2z
'Download free codes from http://vbaa2z.blogspot.com
'Autor: L Pamai (vbaa2z.team@gmail.com)
'-----------------------------

E02-VBA to link SharePoint in Edit Mode and do Bulk Write back and more

Hello friends, all relevant materials for this topic/tutorial can be downloaded from here. Please support by subscribing to our channel and sharing them with your friends.

https://www.youtube.com/watch?v=nM-gq3N6f2E&list=PLo0aMPtFIFDrcPiWbqJGb3qt3rkOmjDbN&index=2

Like what I do? Donate

Did I help you? Did one of my tutorials save you sometime?

You can say thank you by buying me a cup of coffee, I go through a lot of it.

Help keep Greater Good resources free for everyone. Please donate today.

Option Explicit
Sub link_edit_Mode()

'-----------------------------
'Thanks for downloading the code. 
'Please visit our channel for a quick explainer on this code.
'Feel free to update the code as per your need and also share with your friends.
'Download free codes from http://vbaa2z.blogspot.com
'Subscribe channel: youtube.com/vbaa2z
'Author: L Pamai (vbaa2z.team@gmail.com)
'-----------------------------
    
    Dim mySh As Worksheet
    Dim spSite As String
    
    Set mySh = Sheets(1)
    
    Dim src(0 To 1) As Variant
    
    spSite = "http://lp-pc/" 'site name
    src(0) = spSite & "/_vti_bin"
    
    src(1) = "{ENTER YOUR GUID HERE}" 'GUID
    
    mySh.ListObjects.Add xlSrcExternal, src, True, xlYes, mySh.Range("A1")
    
End Sub

Sub SaveChanges()


'-----------------------------
'Thanks for downloading the code. 
'Please visit our channel for a quick explainer on this code.
'Feel free to update the code as per your need and also share with your friends.
'Download free codes from http://vbaa2z.blogspot.com
'Subscribe channel: youtube.com/vbaa2zot.com
'Author: L Pamai (vbaa2z.team@gmail.com)
'-----------------------------
   Dim mySh As Worksheet
   Dim lstOBJ As ListObject

   On Error GoTo errhdnler
   
   Set mySh = Sheets("DataSP")
   Set lstOBJ = mySh.ListObjects(1)
   
   lstOBJ.UpdateChanges xlListConflictDialog
   
   Set mySh = Nothing
   Set lstOBJ = Nothing
   
Exit Sub
errhdnler:

Debug.Print Err.Description & Err.Number

End Sub


Sub refresh_Con()

'-----------------------------
'Thanks for downloading the code. 
'Please visit our channel for a quick explainer on this code.
'Feel free to update the code as per your need and also share with your friends.
'Download free codes from http://vbaa2z.blogspot.com
'Subscribe channel: youtube.com/vbaa2z
'Author: L Pamai (vbaa2z.team@gmail.com)
'-----------------------------

   Dim mySh As Worksheet
   Dim lstOBJ As ListObject

On Error GoTo errhdnler

   Set mySh = Sheets("DataSP")
   
   Set lstOBJ = mySh.ListObjects(1)
   
   lstOBJ.Refresh
  
   Set mySh = Nothing
   Set lstOBJ = Nothing
   
Exit Sub

errhdnler:

Debug.Print Err.Description & Err.Number

End Sub

Dynamic VBA Function to Return Last Row or Last Column Dynamically.

This post contains two functions to return 1. Last Row and 2. Last Column with data. This will help you in identifying and manipulating range. The function is dynamic and you simple need to link it from your code.

Please refer to the Usage Example provided. Copy and paste the all the code in to new module and test it out. Obviously, you'll have to change the sheet name and workbook name to suit your need. Please let me know if you need help :)

Below codes are tested & ready for copy-paste use.

Get the Last Row Dynamically (Function + Usage Example)

Option Explicit
'------------------------------------------------------GET LAST ROW
Function xlr(keyCol As String, Optional wbName As String, Optional shName As String) As Long

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'| Author: L Pamai (VbaA2z.Team@gmail.com)
'| Visit channel: Youtube.com/VbaA2z
'| More download: VbaA2z.Blogspot.com
'| Free for personal and commercial use. Unsupported product.
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

On Error GoTo errocc

If Len(wbName & vbNullString) > 0 And Len(shName & vbNullString) > 0 Then 'if wb name and sheet name specified
    If WbIsCurrentlyOpen(wbName) And SheetExists(shName, wbName) Then 'check if exist
        xlr = Workbooks(wbName).Sheets(shName).Range(keyCol & Rows.Count).End(xlUp).Row
    End If
    
ElseIf Len(shName & vbNullString) > 0 Then 'if Sheet name only specified
    If SheetExists(shName) Then
        xlr = Sheets(shName).Range(keyCol & Rows.Count).End(xlUp).Row
    End If
    
Else 'if wb name and sheet name NOT specified
    xlr = ActiveSheet.Range(keyCol & Rows.Count).End(xlUp).Row
End If

Exit Function

errocc:
xlr = 0

End Function

Sub usage_example_of_xlr_check()

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'| Author: L Pamai (VbaA2z.Team@gmail.com)
'| Visit channel: Youtube.com/VbaA2z
'| More download: VbaA2z.Blogspot.com
'| Free for personal and commercial use. Unsupported product.
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    Dim lastrow As Long
    
    lastrow = xlr("B") 'get last row by column name specified
    'lastrow = xlr("B", , "Sheet1") 'get last row by column name and sheet name specified
    'lastrow = xlr("B", "bookName.xlsm", "Products") 'get last row by column name and sheet name and workbook name specified

    Sheets("Sheet1").Select
    Range("A1:A" & lastrow).Copy
    Sheet2.Range("A1").PasteSpecial Paste:=xlPasteValues
    Sheet2.Range("A1").PasteSpecial Paste:=xlPasteFormats
    Application.CutCopyMode = False
    
End Sub

Get Last Column Dynamically (Function + Usage Example)

'------------------------------------------------------GET LAST COLUMN
Function xlc(keyRow As String, Optional wbName As String, Optional shName As String) As Long

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'| Author: L Pamai (VbaA2z.Team@gmail.com)
'| Visit channel: Youtube.com/VbaA2z
'| More download: VbaA2z.Blogspot.com
'| Free for personal and commercial use. Unsupported product.
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

On Error GoTo errocc

If Len(wbName & vbNullString) > 0 And Len(shName & vbNullString) > 0 Then 'if wb name and sheet name specified
    If WbIsCurrentlyOpen(wbName) And SheetExists(shName, wbName) Then 'check if exist
        xlc = Workbooks(wbName).Sheets(shName).Cells(keyRow, Columns.Count).End(xlToLeft).Column
    End If
    
ElseIf Len(shName & vbNullString) > 0 Then 'if Sheet name only specified
    If SheetExists(shName) Then
        xlc = Sheets(shName).Cells(keyRow, Columns.Count).End(xlToLeft).Column
    End If
    
Else 'if wb name and sheet name NOT specified
    xlc = ActiveSheet.Cells(keyRow, Columns.Count).End(xlToLeft).Column
End If

Exit Function

errocc:
xlc = 0

End Function

Sub usage_example_of_xlc_check()
    Dim lastcol As Long
    
    'lastcol = xlc(2) 'get last column by row number specified
    'lastcol = xlc(2, , "Sheet1") 'get last column by row number and sheet name specified
    lastcol = xlc(2, "LRLCDynamics.xlsm", "Products") 'get last column by row number and sheet name and workbook name specified

    Sheets("Sheet1").Select
    
    Range(Cells(1, 1), Cells(100, lastcol)).Copy ' range A1 : Dynamic column row no 100;
    
    
    Sheet2.Range("A1").PasteSpecial Paste:=xlPasteValues
    Sheet2.Range("A1").PasteSpecial Paste:=xlPasteFormats
    Application.CutCopyMode = False
    
End Sub

Usage Example both Dynamic Last Row and Dynamic Last Column

Sub usage_example_of_both_xlr_and_xlc_check()

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'| Author: L Pamai (VbaA2z.Team@gmail.com)
'| Visit channel: Youtube.com/VbaA2z
'| More download: VbaA2z.Blogspot.com
'| Free for personal and commercial use. Unsupported product.
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    Dim lastcol As Long
    Dim lastrow As Long
    
    lastrow = xlr("B") 'get last row by column name specified
    'lastrow = xlr("B", , "Sheet1") 'get last row by column name and sheet name specified
    'lastrow = xlr("B", "b
    
    lastcol = xlc(2) 'get last column by row number specified
    'lastcol = xlc(2, , "Sheet1") 'get last column by row number and sheet name specified
    'lastcol = xlc(2, "LRLCDynamics.xlsm", "Products") 'get last column by row number and sheet name and workbook name specified

    Sheets("Sheet1").Select
    
    Range(Cells(1, 2), Cells(lastrow, lastcol)).Copy ' range A1 : Dynamic column row no dynamic lastrow;
    
    
    Sheet2.Range("A1").PasteSpecial Paste:=xlPasteValues
    Sheet2.Range("A1").PasteSpecial Paste:=xlPasteFormats
    Application.CutCopyMode = False
    
End Sub

Additional Functions to check if Workbook or Sheets refer to exist

Public Function SheetExists(shName As String, Optional wbName As String) As Boolean
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'| Author: L Pamai (VbaA2z.Team@gmail.com)
'| Visit channel: Youtube.com/VbaA2z
'| More download: VbaA2z.Blogspot.com
'| Free for personal and commercial use. Unsupported product.
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    Dim ws As Worksheet
    
    SheetExists = False
    
    On Error GoTo errocc
    If Len(wbName & vbNullString) > 0 Then
        Set ws = Workbooks(wbName).Sheets(shName)
        Else
        Set ws = Sheets(shName)
    End If
    
    Set ws = Nothing
    SheetExists = True
    Exit Function
errocc:
    SheetExists = False
End Function

Function WbIsCurrentlyOpen(strBookName As String) As Boolean
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'| Author: L Pamai (VbaA2z.Team@gmail.com)
'| Visit channel: Youtube.com/VbaA2z
'| More download: VbaA2z.Blogspot.com
'| Free for personal and commercial use. Unsupported product.
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    Dim oBk As Workbook
    On Error Resume Next
    Set oBk = Workbooks(strBookName)
    On Error GoTo 0
    If oBk Is Nothing Then
        WbIsCurrentlyOpen = False
    Else
        WbIsCurrentlyOpen = True
    End If
End Function

Get RBG Color Code from Color Number of Sheet, Cell, Shapes and more...

Convert tab color for example from 24704 to RGB Code R=128 ,G= 96 ,B= 0

Option Explicit

Sub tabRGB()

Dim j As Worksheet
Set j = ActiveSheet

Dim f As Variant
f = ConvertCode2RGB(j.Tab.Color)

Debug.Print j.Tab.Color

Debug.Print f(1)
Debug.Print f(2)
Debug.Print f(3)

Set j = Nothing

End Sub

Function ConvertCode2RGB(colorNo) As Variant

'-----------------------------
'Thanks for downloading the code. 
'Please visit our channel for a quick explainer on this code.
'Feel free to update the code as per your need and also share with your friends.
'Channel: Youtube.com/vbaa2z
'Download free codes from http://vbaa2z.blogspot.com
'Autor: L Pamai (vbaa2z.team@gmail.com)
'-----------------------------

    Dim xR As Long, xG As Long, xB As Long
    Dim k(1 To 3) As Variant
    
    xR = colorNo Mod 256
    xG = colorNo \ 256 Mod 256
    xB = colorNo \ 65536 Mod 256
    
    k(1) = xR
    k(2) = xG
    k(3) = xB
    
    ConvertCode2RGB = k()
    
End Function

Extract or Retrieve System or Network IP (Internet Protocol) Addresses using VBA

Subscribe Now!
New videos every Weekend!

Like what I do? Donate

Did I help you? Did one of my tutorials save you sometime?

You can say thank you by buying me a cup of coffee, I go through a lot of it.

Help keep Greater Good resources free for everyone. Please donate today.

This page is not monitored so for questions please comment on the youtube video page. For suggestions email vbaa2z.team@gmail.com

Download project or source code from below link(s)

Use the below code to extract/retrieve System or Network Ip addresses using VBA.
Paste the code in the module.
SysIPAddress function is a master function to connect WMI service and return IP address from Win32_NetworkAdapterConfiguration. Please comment below if you need any assistance.

Subroutine tst_SysIPAddress is used to test the main code. If you run this code it will print all your ip addresses in your immediate window. Have fun!

Option Explicit
Function SysIPAddress() As Variant

'-----------------------------
'Thanks for downloading the code. 
'Please visit our channel for a quick explainer on this code.
'Feel free to update the code as per your need and also share with your friends.
'Channel: Youtube.com/vbaa2z
'Download free codes from http://vbaa2z.blogspot.com
'Autor: L Pamai (vbaa2z.team@gmail.com)
'-----------------------------

Dim WMI_service As Variant
Dim myIP_Adptr As Variant
Dim IPConfiguration As Variant
Dim IPAddress As Variant
Dim XipAdd As String
Dim k() As Variant
Dim f As Byte

'setup WMI service
Set WMI_service = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\" & "." & "\root\cimv2")

'setup TCP/IP-enabled network adapters
Set myIP_Adptr = WMI_service.ExecQuery("SELECT * FROM Win32_NetworkAdapterConfiguration Where IPEnabled=TRUE")

'loop and get all IP addresses associated with myIP_Adptr
For Each IPConfiguration In myIP_Adptr
    IPAddress = IPConfiguration.IPAddress
    If Not IsNull(IPAddress) Then
        f = f + 1
        ReDim Preserve k(1 To f)
        k(f) = IPAddress
    End If
Next

SysIPAddress = k()


'free memory;
Set WMI_service = Nothing
Set myIP_Adptr = Nothing

End Function

Sub tst_SysIPAddress()
Dim ArrMem() As Variant
Dim i As Byte
ArrMem = SysIPAddress()

    For i = 0 To UBound(ArrMem)
        Debug.Print ArrMem(1)(i)
    Next

End Sub

VBA to show System Tray Balloon Notification using VBA

This post will show you/guide you on how to use VBA to show System Tray Balloon Notification using VBA.

Click here for explainer video below with VBA code.

Create an Excel UserForm and name it NotifyFr. and add 2 buttons with names CommandButton1 and CommandButton2. They should have this name by default if not rename them using properties window.

Add any .ico file in the same folder where you have this project saved and name it PerfCenterCpl.ico
This file will be used as an ico when your notification shows up in-tray.

Paste below code in ThisWorkbook module by double-clicking ThisWorkbook from VBE editor.

Option Explicit

Private Sub Workbook_Open()
    
    Application.EnableEvents = True
    ShowMsg "VBA Bytes Add-in loaded successfully..."
    
End Sub

Paste below code in UserForm module.

Private Sub CommandButton1_Click()
Unload Me
ThisWorkbook.Close
End Sub

Private Sub CommandButton2_Click()
Unload Me
ThisWorkbook.Close
End Sub
Private Sub UserForm_Activate()

Me.Hide
RemoveIconFromTray
Unhook

Dim Me_hWnd As Long, Me_Icon As Long, Me_Icon_Handle As Long, IconPath As String
IconPath = IconPathx
Me_hWnd = FindWindowd("ThunderDFrame", Me.Caption)
Me_Icon_Handle = ExtractIcond(0, IconPath, 0)
Hook Me_hWnd
AddIconToTray Me_hWnd, 0, Me_Icon_Handle, "Double Click to re-open userform"
BalloonPopUp_1
Unload Me

End Sub
Private Sub UserForm_Initialize()
Me.Hide
End Sub

Now add / Insert new module and paste the below code to it.

Option Explicit

'-----------------------------
'Thanks for downloading the code. 
'Please visit our channel for a quick explainer on this code.
'Feel free to update the code as per your need and also share with your friends.
'Channel: Youtube.com/vbaa2z
'Download free codes from http://vbaa2z.blogspot.com
'Autor: L Pamai (vbaa2z.team@gmail.com)
'-----------------------------

Declare Function SetForegroundWindow Lib "user32" (ByVal hWnd As Long) As Long
Declare Function Shell_NotifyIcon Lib "shell32.dll" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, lpData As NOTIFYICONDATA) As Long
Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal 

lParam As Long) As Long
Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Declare Function ExtractIcon Lib "shell32.dll" Alias "ExtractIconA" (ByVal hInst As Long, ByVal lpszExeFileName As String, ByVal nIconIndex As Long) As Long

Public Const WM_LBUTTONDOWN = &H201
Public Const WM_LBUTTONUP = &H202
Public Const WM_LBUTTONDBL = &H203
Public Const WM_RBUTTONDOWN = &H204
Public Const WM_RBUTTONUP = &H205
Public Const WM_RBUTTONDBL = &H206
Public Const WM_ACTIVATEAPP = &H1C

Public Const NIS_HIDDEN = &H1
Public Const NIS_SHAREDICON = &H2
Public Const NIF_ICON = &H2
Public Const NIF_MESSAGE = &H1
Public Const NIF_TIP = &H4
Public Const NIF_STATE = &H8
Public Const NIF_INFO = &H10
Public Const NIM_ADD = &H0
Public Const NIM_MODIFY = &H1
Public Const NIM_DELETE = &H2
Public Const WM_MOUSEMOVE = &H200
Public Const MAX_TOOLTIP As Integer = 128
Public Const GWL_WNDPROC = (-4)

'shell version / NOTIFIYICONDATA struct size constants
Public Const NOTIFYICONDATA_V1_SIZE As Long = 88  'pre-5.0 structure size
Public Const NOTIFYICONDATA_V2_SIZE As Long = 488 'pre-6.0 structure size
Public Const NOTIFYICONDATA_V3_SIZE As Long = 504 '6.0+ structure size
Public NOTIFYICONDATA_SIZE As Long

Type NOTIFYICONDATA
   cbSize As Long
   hWnd As Long
   uID As Long
   uFlags As Long
   uCallbackMessage As Long
   hIcon As Long
   szTip As String * MAX_TOOLTIP
   dwState As Long
   dwStateMask As Long
   szInfo As String * 256
   uTimeout As Long
   szInfoTitle As String * 64
   dwInfoFlags As Long
End Type

Public nfIconData As NOTIFYICONDATA

' list the icon types for the balloon message..
Public Const vbNone = 0
Public Const vbInformation = 1
Public Const vbExclamation = 2
Public Const vbCritical = 3
Public MessageX As String


Private FHandle As Long
Private WndProc As Long
Private Hooking As Boolean

Public Sub Hook(Lwnd As Long)
 If Hooking = False Then
  FHandle = Lwnd
  WndProc = SetWindowLong(Lwnd, GWL_WNDPROC, AddressOf WindowProc)
  Hooking = True
 End If
End Sub

Public Sub Unhook()
 If Hooking = True Then
  SetWindowLong FHandle, GWL_WNDPROC, WndProc
  Hooking = False
 End If
End Sub

Public Function WindowProc(ByVal hw As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
 If Hooking Then
  If lParam = WM_LBUTTONDBL Then
   NotifyFr.Show 1
   WindowProc = True
'   Unhook
   Exit Function
  End If
  WindowProc = CallWindowProc(WndProc, hw, uMsg, wParam, lParam)
 End If
End Function
 
Public Sub RemoveIconFromTray()
 Shell_NotifyIcon NIM_DELETE, nfIconData
End Sub

Public Sub AddIconToTray(MeHwnd As Long, MeIcon As Long, MeIconHandle As Long, Tip As String)
 With nfIconData
  .hWnd = MeHwnd
  .uID = MeIcon
  .uFlags = NIF_MESSAGE Or NIF_ICON Or NIF_TIP
  .uCallbackMessage = WM_RBUTTONUP
  .dwState = NIS_SHAREDICON
  .hIcon = MeIconHandle
  .szTip = Tip & Chr$(0)
  .cbSize = NOTIFYICONDATA_V3_SIZE
 End With
 Shell_NotifyIcon NIM_ADD, nfIconData
End Sub

Function FindWindowd(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
 FindWindowd = FindWindow(lpClassName, lpWindowName)
End Function

Function ExtractIcond(ByVal hInst As Long, ByVal lpszExeFileName As String, ByVal nIconIndex As Long) As Long
 ExtractIcond = ExtractIcon(hInst, lpszExeFileName, nIconIndex)
End Function

'this is the part you need to pay attention to :)

Sub test1()
    ShowMsg "VBA Bytes Add-in loaded successfully..."
End Sub

Sub test2()
    ShowMsg "This is second message."
End Sub

Function ShowMsg(xmsg As String) As Boolean
    MessageX = xmsg
    NotifyFr.Show 1
End Function

Public Sub BalloonPopUp_1()
    With nfIconData
        .dwInfoFlags = vbInformation
        .uFlags = NIF_INFO
        .szInfoTitle = "VBA Bytes" & vbNullChar
        .szInfo = MessageX & vbNullChar
    End With
    
    Shell_NotifyIcon NIM_MODIFY, nfIconData
    
End Sub
Public Function IconPathx() As String
    IconPathx = ThisWorkbook.Path & "\PerfCenterCpl.ico"
End Function

Now to test this simple try running sub test1 or test2 or Workbook_Open code. have fun and reach out to me if you have any questions.

VBA to list all file names in any Folder or Directory

You can use the below VBA code to list specified files types from Directory. Below demo sample code will list all .mp3 files in folder/directory "D:\Music\5 Seconds Of Summer\"

If you want to list other files type for example .xlsm files change "*.mp3" to "*.xlsm", or to list all files irrespective change it "*.mp3" to "*.*".

Please share or comment below if you have any questions.

Const vDir As String = "D:\Music\5 Seconds Of Summer\"
Const vPttrn As String = "*.mp3"
Dim vFile As String

Sub test_list_mp3_files()

'-----------------------------
'Thanks for downloading the code. 
'Please visit our channel for a quick explainer on this code.
'Feel free to update the code as per your need and also share with your friends.
'Channel: Youtube.com/vbaa2z
'Download free codes from http://vbaa2z.blogspot.com
'Autor: L Pamai (vbaa2z.team@gmail.com)
'-----------------------------

vFile = Dir(vDir & vPttrn, vbNormal)

Do While Len(vFile) > 0
    Debug.Print vFile
    vFile = Dir
Loop

End Sub

for more please visit http://bit.ly/2dveQPZ

VBA to Remove or Reset Excel Spreadsheet Password

This code below will remove your spreadsheet password for any files from Excel 2003 to Excel 2010.
For more including removing the password from Excel 2016/2013 please visit http://bit.ly/2dlx8iN.
Paste the below code in any module or any VBA Workbook Project and run the code. This only works for Excel 2010 and below versions.

Reference for Office 365 Excel

Watch this video on Youtube

Sub removeShPassword()

'-----------------------------
'Thanks for downloading the code. 
'Please visit our channel for a quick explainer on this code.
'Feel free to update the code as per your need and also share with your friends.
'Channel: Youtube.com/vbaa2z
'Download free codes from http://vbaa2z.blogspot.com
'Autor: L Pamai (vbaa2z.team@gmail.com)
'-----------------------------

Dim i As Integer, j As Integer, k As Integer
Dim l As Integer, m As Integer, n As Integer
Dim i1 As Integer, i2 As Integer, i3 As Integer
Dim i4 As Integer, i5 As Integer, i6 As Integer


If Application.Version > 14 Then
    MsgBox "Only for Excel 2010 and below versions."
    Exit Sub
End If

On Error Resume Next

For i = 65 To 66: For j = 65 To 66: For k = 65 To 66
For l = 65 To 66: For m = 65 To 66: For i1 = 65 To 66
For i2 = 65 To 66: For i3 = 65 To 66: For i4 = 65 To 66
For i5 = 65 To 66: For i6 = 65 To 66: For n = 32 To 126

ActiveSheet.Unprotect Chr(i) & Chr(j) & Chr(k) & _
  Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _
  Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)

  If ActiveSheet.ProtectContents = False Then
            MsgBox "Password removed!"
            Exit Sub
  End If

Next: Next: Next: Next: Next: Next:
Next: Next: Next: Next: Next: Next:
End Sub

Search