Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" _
(ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, _
ByVal lpsz2 As String) As Long
Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" _
(ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function GetWindowTextLength Lib "user32" Alias _
"GetWindowTextLengthA" (ByVal hwnd As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Dim Ret As Long, ChildRet As Long, OpenRet As Long
Dim strBuff As String, ButCap As String
Dim MyPassword As String
Const WM_SETTEXT = &HC
Const BM_CLICK = &HF5
Sub Unlock_Upload()
'Exit Admin mode and upload to sharepoint':
‘The file will do the below
'1) Duplicate the file to location c:\
'2) Open in separate instance and unlock
'3) Remove tabs from the workbook
'4) Remove Modules from the project
'5) Close all tabs except the following:
'- Looking
'6) Save to sharepoint and close duplicate file.
' On Error GoTo Errorhandler
Dim strTempFolderPath As String
Dim wbDuplicate As Workbook
Dim shSheet As Worksheet
Dim strSharePointPath As String
Application.ScreenUpdating = False
Application.Calculation = xlAutomatic
Application.DisplayAlerts = False 'Disables file overwrite warnings.
Application.DisplayStatusBar = True
Application.EnableEvents = False
'1) ----------> Duplicate the file to a temp folder in C:\
'Pick the folder path from C100 in 'Admin' sheet.
'If C100 does not contain the path, then set it to C:\Temp.
strTempFolderPath = Range("C100").Value
If strTempFolderPath = "" Then strTempFolderPath = "C:\Temp\o22"
If Dir(strTempFolderPath, vbDirectory) = "" Then
MkDir strTempFolderPath
End If
strTempFolderPath = strTempFolderPath & "\"
'Create duplicate in temp folder.
ThisWorkbook.SaveCopyAs strTempFolderPath & "o22.xlsb"
'2) ----------> Open in separate instance and unlock
Dim xlAp As Object, oWb As Object
Set xlAp = CreateObject("Excel.Application")
xlAp.Visible = True
'~~> Open the workbook in a separate instance
Set oWb = xlAp.Workbooks.Open("C:\Temp\o22\o22.xlsb")
'~~> Launch the VBA Project Password window
'~~> I am assuming that it is protected. If not then
'~~> put a check here.
xlAp.VBE.CommandBars(1).FindControl(ID:=2578, recursive:=True).Execute
'~~> Your passwword to open then VBA Project
MyPassword = "my password goes here"
'~~> Get the handle of the "VBAProject Password" Window
Ret = FindWindow(vbNullString, "VBAProject Password")
If Ret <> 0 Then
'MsgBox "VBAProject Password Window Found"
'~~> Get the handle of the TextBox Window where we need to type the password
ChildRet = FindWindowEx(Ret, ByVal 0&, "Edit", vbNullString)
If ChildRet <> 0 Then
'MsgBox "TextBox's Window Found"
'~~> This is where we send the password to the Text Window
SendMess MyPassword, ChildRet
DoEvents
'~~> Get the handle of the Button's "Window"
ChildRet = FindWindowEx(Ret, ByVal 0&, "Button", vbNullString)
'~~> Check if we found it or not
If ChildRet <> 0 Then
'MsgBox "Button's Window Found"
'~~> Get the caption of the child window
strBuff = String(GetWindowTextLength(ChildRet) + 1, Chr$(0))
GetWindowText ChildRet, strBuff, Len(strBuff)
ButCap = strBuff
'~~> Loop through all child windows
Do While ChildRet <> 0
'~~> Check if the caption has the word "OK"
If InStr(1, ButCap, "OK") Then
'~~> If this is the button we are looking for then exit
OpenRet = ChildRet
Exit Do
End If
'~~> Get the handle of the next child window
ChildRet = FindWindowEx(Ret, ChildRet, "Button", vbNullString)
'~~> Get the caption of the child window
strBuff = String(GetWindowTextLength(ChildRet) + 1, Chr$(0))
GetWindowText ChildRet, strBuff, Len(strBuff)
ButCap = strBuff
Loop
'~~> Check if we found it or not
If OpenRet <> 0 Then
'~~> Click the OK Button
SendMessage ChildRet, BM_CLICK, 0, vbNullString
SendKeys "{ENTER}"
'3) ----------> Remove tabs from the workbook
oWb.Sheets("Sheet1").Delete
oWb.Sheets("Sheet2").Delete
oWb.Sheets("Sheet3").Delete
oWb.Sheets("Index").Delete
oWb.Sheets("Sheet12").Delete
'4) ----------> Remove Modules from the project
Dim modulesToRemove As Variant
Dim i As Long
oWb.Application.DisplayAlerts = False
modulesToRemove = Array("Module1", "module2", "Module3”)
'On Error Resume Next
For i = LBound(modulesToRemove) To UBound(modulesToRemove)
With oWb.VBProject.VBComponents
.Remove .Item(modulesToRemove(i))
End With
Next i
On Error GoTo 0
'5) ----------> Close all tabs except the following:
'- Looking
Worksheets("Looking").Unprotect
Worksheets("Admin").Visible = False
Sheets("Admin").Visible = False
For Each shSheet In oWb.Sheets
If shSheet.Name <> "Looking" And shSheet.Name <> "Admin" Then
shSheet.Visible = xlVeryHidden
End If
Next shSheet
'6) ----------> Save to sharepoint and close duplicate file.
oWb.Sheets("Admin").Visible = False
oWb.Save 'As "Onboarding Tracker"
oWb.SaveAs "https://myown.sharepoint.com/folder " & "/" & "o22.xlsb", xlExcel12
oWb.Close True
Application.DisplayAlerts = False
MsgBox "File uploaded to SharePoint successfully.", , "Exit Admin Mode"
Else
MsgBox "The Handle of OK Button was not found"
End If
Else
MsgBox "Button's Window Not Found"
End If
Else
MsgBox "The Edit Box was not found"
End If
Else
MsgBox "VBAProject Password Window was not Found"
End If
Sheets("Admin").Visible = True
End Sub
Sub SendMess(Message As String, hwnd As Long)
Call SendMessage(hwnd, WM_SETTEXT, False, ByVal Message)
End Sub
