I tried to approach my goal using in-build Outlook rules however without success so I decide to use VBA script but it is not also working properly.
Scenario:
Every 1h I am reciving email with report in xls format, which need to be saved on share folder. Every 1h report can be overridden by new one. I don't need any date and time in file name just save file which was received.
I have dedicated sub folder in inbox, where all emails which contains in topic string "Sales Report" have to be moved. I tried to create rule - when email is recive then move it to subfolder, and afterward run VBA scrip which allows to save attachment. However it is not working as sometimes instead of saving xls file, script is saving file "ATP Scan In Progress". Looks like script is saving xls file before file was scanned by in-built Outlook scanner.
Is there any way to delay saving xls until scan will be completed, or there is any other way to aproach my goal.
Thank you for support.
Public Sub SaveAttachmentsToDisk(MItem As Outlook.MailItem)
Dim oAttachment As Outlook.Attachment
Dim sSaveFolder As String
sSaveFolder = "\\reports\jon\"
For Each oAttachment In MItem.Attachments
oAttachment.SaveAsFile sSaveFolder & oAttachment.DisplayName
Next
End Sub
Something like this should work...
In ThisOutlookSession
Private WithEvents ReportItems As Outlook.Items
Private Sub Application_Startup()
On Error Resume Next
With Outlook.Application
Set ReportItems = .GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Folders("Sales Reports").Items
End With
End Sub
Private Sub ReportItems_ItemAdd(ByVal Item As Object)
On Error Resume Next
If TypeName(Item) = "MailItem" Then Call SaveXLSAttachments(Item, "\\reports\jon\")
End Sub
In a module
Sub SaveXLSAttachments(ByVal Item As Object, FilePath As String)
Dim i As Long, FileName As String, Extension As String
If Right(FilePath, 1) <> "\" Then FilePath = FilePath & "\"
Delay(5) 'If required
Extension = ".xls"
With Item.Attachments
If .Count > 0 Then
For i = 1 To .Count
FileName = FilePath & .Item(i).FileName
If LCase(Right(FileName, Len(Extension))) = Extension Then .Item(i).SaveAsFile FileName
Next i
End If
End With
End Sub
Function Delay(Seconds As Single)
Dim StopTime As Double: StopTime = Timer + Seconds
Do While Timer < StopTime
DoEvents
Loop
End Function
Related
Through a sub i download an excel file from a website. when the download button is clicked, it both opens the excel file and also let the file get downloaded. i dont need it to get opened so as soon as it gets opened and before srart of next subs, i need to close it. By some codes i tried to do it but I failed.
The problem is that the Do Loop i wrote, can not catch the file and hangs.
It just works well when i debug it through F8. Then i thought maybe by application.wait method I can let the sub to wait till the workbook appears, like what happens in debug mode but it didnt help as well.
Also i need to add that since everytime the file gets downloaded its name changes by the webiste then i used Like operator.
Sub Test()
Dim wb As Workbook
Dim wbName As String
Dim Cnt As Integer
wbName = "transactions_history_"
'Application.Wait Now + TimeValue("00:00:10") ' it didnt help so i commented it
Do
Application.Wait Now + TimeValue("00:00:01")
For Each wb In Application.Workbooks
If wb.Name Like wbName & "*" Then
Cnt = 1
Exit Do
End If
Next wb
Loop Until Cnt = 1
wb.Close
End Sub
Anybody has any idea? thanks.
FaneDuru,
I copy here the code which downloads the workbook from the website. it worked very well until the website changed something and when the file gets downloaded it gets opened too. I need to close it to let the rest of the programms work without problem but i coudlnt manage it so far.
Sub TBC()
' declerations
Dim myBrowser As Selenium.ChromeDriver
Dim FindBy As New Selenium.by
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim A, I As Integer
Dim FileName, BankFolderAddress As String
Dim N As Byte
' initializations
BankFolderAddress = "D:\Projects\Excel\Main Program\Bank Statements\"
Set FindBy = New Selenium.by
Set myBrowser = New WebDriver
I = 0
A = 0
Sheet2.Cells.ClearContents
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(BankFolderAddress)
For Each objFile In objFolder.Files
Sheet2.Cells(I + 1, 1) = objFile.Name
Sheet2.Cells(I + 1, 2) = objFile.Path
I = I + 1
Next objFile
If Sheet2.Cells(1, 1) <> "" Then
For N = 1 To I
Kill Sheet2.Cells(N, 2).value
Next N
End If
Start:
myBrowser.SetProfile Environ("LOCALAPPDATA") & "\GOOGLE\CHROME\USER DATA"
myBrowser.AddArgument "profile-directory=Default"
myBrowser.Start "chrome"
Application.DisplayAlerts = False
'Address e website
myBrowser.Get "https://tbconline.ge/tbcrd/login?t=false"
myBrowser.Window.Maximize
A = 0
Do
Application.Wait Now + TimeValue("00:00:01")
A = A + 1
If A = 10 Then GoTo Finish
Loop Until myBrowser.IsElementPresent(FindBy.XPath("//button"))
If myBrowser.IsElementPresent(FindBy.Css("input[formcontrolname='username']")) Then
myBrowser.FindElementByXPath("//button").Click
Else
GoTo JMP
End If
JMP:
'For removing PopUps
If myBrowser.IsElementPresent(FindBy.XPath("//div[#id='mainLoadingLayer']/ui-view/ui-view/div/div[2]/div/div/div/div/div[3]/button")) Then
myBrowser.FindElementByXPath("//div[#id='mainLoadingLayer']/ui-view/ui-view/div/div[2]/div/div/div/div/div[3]/button").Click
End If
' Choosing Transaction Menu
A = 0
Do
Application.Wait Now + TimeValue("00:00:01")
A = A + 1
If A = 10 Then GoTo Finish
Loop Until myBrowser.IsElementPresent(FindBy.XPath("//a[contains(text(),'Transactions')]"))
If myBrowser.IsElementPresent(FindBy.XPath("//a[contains(text(),'Transactions')]")) Then
myBrowser.FindElementByXPath("//a[contains(text(),'Transactions')]").Click
End If
'choosing Transaction submenu
A = 0
Do
Application.Wait Now + TimeValue("00:00:01")
A = A + 1
If A = 10 Then GoTo Finish
Loop Until myBrowser.IsElementPresent(FindBy.XPath("//span[contains(.,'Transactions')]"))
If myBrowser.IsElementPresent(FindBy.XPath("//span[contains(.,'Transactions')]")) Then
myBrowser.FindElementByXPath("//span[contains(.,'Transactions')]").Click
End If
'Clicking on Download icon
Do
Application.Wait Now + TimeValue("00:00:01")
Loop Until myBrowser.IsElementPresent(FindBy.XPath("//ib-controls/div/div[2]/div[2]"))
If myBrowser.IsElementPresent(FindBy.XPath("//ib-controls/div/div[2]/div[2]")) Then
myBrowser.FindElementByXPath("//ib-controls/div/div[2]/div[2]").Click
End If
' clicking on excel option to download it
Do
Application.Wait Now + TimeValue("00:00:01")
Loop Until myBrowser.IsElementPresent(FindBy.XPath("//a[contains(.,'Excel')]"))
If myBrowser.IsElementPresent(FindBy.XPath("//a[contains(.,'Excel')]")) Then
myBrowser.FindElementByXPath("//a[contains(.,'Excel')]").Click
End If
'checking if the file is downloaded
Do
Application.Wait Now + TimeValue("00:00:02")
Loop Until Dir(BankFolderAddress & "transactions_history_*.xlsx") <> ""
' get the file name
FileName = Dir(BankFolderAddress & "transactions_history_*.xlsx", vbDirectory)
' check if the downloaded file size
Do
Application.Wait Now + TimeValue("00:00:05") '03 bood
Loop Until FileLen(BankFolderAddress & FileName) > 10000
Finish:
' close the Browser
myBrowser.close
' ## I added this code to close the workbook but failed
' call Test()
Dim wb As Workbook
Dim wbName As String
Dim Cnt As Integer
wbName = FileName
Do
Application.Wait Now + TimeValue("00:00:01")
For Each wb In Application.Workbooks
If wb.Name=FileName Then
Cnt = 1
wb.Close
Exit Do
End If
Next wb
Loop Until Cnt = 1
call BankDataExtraction()
End Sub
the problem is that if i do not stop the sub before the loop in debug mode, the downloaded workbook neither appears on the screen nor in task manager, and the loop can not catch it and close it, it hangs then. wait methode doesnt help too. I tried you code but it gave me automation error invalid syntax, while executing Set sessEx = GetObject(wbFullName).Application
I passed the complete file address to it, If Not sameExSession(FileName).
If you are sure that the wbName is the name of the workbook searching for, your code must do what you need, but only if the workbook in discussion is open IN THE SAME EXCEL SESSION. I asked about the code opening it, but no clarification received. Please, use the next function to check if the workbook is open in the same session (with the workbook keeping the checking code). If its second parameter is True, it closes the workbook, even in a different session and quit that session. Many codes searches for an existing Excel session and use it, but open a new session if no such a session has been found. Others, uses a new session:
Function sameExSession(wbFullName As String, Optional boolClose As Boolean) As Boolean
Dim sessEx As Excel.Application, wb As Workbook
Set sessEx = GetObject(wbFullName).Application
If sessEx.hwnd = Application.hwnd Then
sameExSession = True
Else
sameExSession = False
If boolClose Then
sessEx.Workbooks(Right(wbFullName, Len(wbFullName) - InStrRev(wbFullName, "\"))).Close False
sessEx.Quit: Set sessEx = Nothing
End If
End If
End Function
It can be called from your existing code in this way:
Sub Test()
Dim wb As Workbook, wbName As String, Cnt As Integer
wbName = "transactions_history_"
If Not sameExSession Then Exit Sub 'take care to use the workbook FULL NAME!
Do
Application.Wait Now + TimeValue("00:00:01")
For Each wb In Application.Workbooks
If wb.Name Like wbName & "*" Then
Cnt = 1
Exit Do
End If
Next wb
Loop Until Cnt = 1
wb.Close
End Sub
If you do not know the workbook extension (since you do not use it in your above code), you can obtain the workbook name using:
Dim strFullName As String, foldName As String
foldName = "path to the folder where the workbook is downloaded"
strFullName = dir(foldName & "\" & vbname & "*.*")
If strFullName <> "" Then
If Not sameExSession Then Exit Sub
Else
MsgBox "Strange...": Stop 'Just in case. It must be found, if foldName and vbName are correct...
End If
It may fail if in the same folder there are more then one such a workbook having a name containing the used string. It will return the first of them, in alphabetical order. But, if such a case, you are the one who is needed to bring some clarifications... Of course, if opening in the other session is the correct assumption. In such a case a piece of code can iterate between all those workbooks having the same string in their name, to determine the last saved one.
You can be sure about this aspect (other session), manually searching for the workbook, copying its Full name and create a testing Sub which only calls the function I supplied, using the determined its full name.
I wanted to develop VBA code that:
Loops through all email items in mailbox
If there are any type of other items say "Calendar Invitation" skips that item.
Finds out the emails with attachments
If attached file has ".xml" extension and a specific title in it, saves it to a directory, if not it keeps searching
Puts all email includes .xml attachments to "Deleted Items" folder after doing step 4 and deletes all emails in that folder by looping.
Code works perfect EXCEPT;
For example
There are 8 email received with ".xml" file attached to each one of them in your mailbox.
run the code
you will see only 4 of the 8 items are processed successfully, other 4 remain in their positions.
If you run the code again, now there would be 2 items processed successfully and other 2 remain in your mailbox.
Problem: After running the code, it is supposed to process all files and deletes them all not the half of them in each run. I want it to process all items at a single run.
BTW, this code runs every time I open the Outlook.
Private Sub Application_Startup()
'Initializing Application_Startup forces the macros to be accessible from other offic apps
'Process XML emails
Dim InboxMsg As Object
Dim DeletedItems As Outlook.Folder
Dim MsgAttachment As Outlook.Attachment
Dim ns As Outlook.NameSpace
Dim Inbox As Outlook.Folder
Dim fPathTemp As String
Dim fPathXML_SEM As String
Dim fPathEmail_SEM As String
Dim i As Long
Dim xmlDoc As New MSXML2.DOMDocument60
Dim xmlTitle As MSXML2.IXMLDOMNode
Dim xmlSupNum As MSXML2.IXMLDOMNode
'Specify the folder where the attachments will be saved
fPathTemp = "some directory, doesn't matter"
fPathXML_SEM = "some directory, doesn't matter"
fPathEmail_SEM = "some directory, doesn't matter"
'Setup Outlook
Set ns = GetNamespace("MAPI")
Set Inbox = ns.Folders.Item("mailbox-name").Folders("Inbox")
Set DeletedItems = ns.Folders.Item("mailbox-name").Folders("Deleted Items")
'Loop through all Items in Inbox, find the xml attachements and process if they are the matching reponses
'On Error Resume Next
For Each InboxMsg In Inbox.Items
If InboxMsg.Class = olMail Then 'if it is a mail item
'Check for xml attachement
For Each MsgAttachment In InboxMsg.Attachments
If Right(MsgAttachment.DisplayName, 3) = "xml" Then
'Load XML and test for the title of the file
MsgAttachment.SaveAsFile fPathTemp & MsgAttachment.FileName
xmlDoc.Load fPathTemp & MsgAttachment.FileName
Set xmlTitle = xmlDoc.SelectSingleNode("//title")
Select Case xmlTitle.Text
Case "specific title"
'Get supplier number
Set xmlSupNum = xmlDoc.SelectSingleNode("//supplierNum")
'Save the XML to the correct folder
MsgAttachment.SaveAsFile fPathXML_SEM & xmlSupNum.Text & "_" & Format(Date, "yyyy-mm-dd") & ".xml"
'Save the email to the correct folder
InboxMsg.SaveAs fPathEmail_SEM & xmlSupNum.Text & "_" & Format(Date, "yyyy-mm-dd") & ".msg"
'Delete the message
InboxMsg.Move DeletedItems
Case Else
End Select
'Delete the temp file
On Error Resume Next
Kill fPathTemp & MsgAttachment.FileName
On Error GoTo 0
'Unload xmldoc
Set xmlDoc = Nothing
Set xmlTitle = Nothing
Set xmlSupNum = Nothing
End If
Next
End If
Next
'Loop through deleted items and delete
For Each InboxMsg In DeletedItems.Items
InboxMsg.Delete
Next
'Clean-up
Set InboxMsg = Nothing
Set DeletedItems = Nothing
Set MsgAttachment = Nothing
Set ns = Nothing
Set Inbox = Nothing
i = 0
End Sub
Likely cause: When you do this InboxMsg.Move, all of the messages in your inbox after the one that was moved are bumped up by one position in the list. So you end up skipping some of them. This is a major annoyance with VBA's For Each construct (and it doesn't seem to be consistent either).
Likely solution: Replace
For Each InboxMsg In Inbox.Items
with
For i = Inbox.Items.Count To 1 Step -1 'Iterates from the end backwards
Set InboxMsg = Inbox.Items(i)
This way you iterate backward from the end of the list. When you move a message to deleted items, then it doesn't matter when the following items in the list are bumped up by one, because you've already processed them anyway.
It's often not a good idea to modify the contents of a (sub)set of items while looping over them. You could modify your code so that it first identifies all of the items that need to be processed, and adds them to a Collection. Then process all the items in that collection.
Basically you shouldn't be removing items from the Inbox while you're looping through its contents. First collect all the items you want to process (in your Inbox loop), then when you're done looping, process that collection of items.
Here's some pseudo-code which demonstrates this:
Private Sub Application_Startup()
Dim collItems As New Collection
'Start by identifying messages of interest and add them to a collection
For Each InboxMsg In Inbox.Items
If InboxMsg.Class = olMail Then 'if it is a mail item
For Each MsgAttachment In InboxMsg.Attachments
If Right(MsgAttachment.DisplayName, 3) = "xml" Then
collItems.Add InboxMsg
Exit For
End If
Next
End If
Next
'now deal with the identified messages
For Each InboxMsg In collItems
ProcessMessage InboxMsg
Next InboxMsg
'Loop through deleted items and delete
For Each InboxMsg In DeletedItems.Items
InboxMsg.Delete
Next
End Sub
Sub ProcessMessage(InboxMsg As Object)
'deal with attachment(s) and delete message
End Sub
I'm trying to write data into an Excel workbook that is hosted in our SharePoint document library.
I instantiate Excel from Microsoft Project.
I tried the following:
Check if file can be checked out
If it can be checked out, then open it
Here's the code snippet:
If ExcelApp.Workbooks.CanCheckOut (FileURL) = True Then
Set NewBook = ExcelApp.Workbooks.Open(FileName:=FileURL, ReadOnly:=False)
ExcelApp.Workbooks.CheckOut (FileURL)
Else
MsgBox "File is checked out in another session."
End If
The CanCheckOut function always returns FALSE. I'm not able to tell when a file can be checked out by the Excel instance.
Is it not working because I'm calling the VBA code from MS Project?
My app should be able to check if a file is not checked out, then check it out, update it, and save + check it back in.
I've found through trial and error that Workbooks.CanCheckOut (Filename:= FullName) where FullName is the URL for the SharePoint file only works for files that are not open in the current instance of Excel.
The method will always return False if you have the file open in the current instance of Excel which is obviously the case here.
Workbooks.CheckOut (ActiveWorkbook.FullName) opens the file, checks it out and then inexplicably, closes the file. So opening and checking out a SharePoint file becomes a 3 step process.
Sub CheckOutAndOpen()
Dim TestFile As String
TestFile = "http://spserver/document/Test.xlsb"
If Workbooks.CanCheckOut(TestFile) = True Then
Workbooks.CheckOut(TestFile)
Workbooks.Open (TestFile)
Else
MsgBox TestFile & " can't be checked out at this time.", vbInformation
End If
End Sub
This is all a bit counter intuitive because when working manually with SharePoint files you have to open them to see if they can be checked out and then perform the check-out operation.
Neither MSDN or Excel VBA help mention that the Workbooks.CanCheckOut (Filename:= FullName) method always returns False if you have the file open in the current instance of Excel.
The other methods never worked for me. This will CheckOut the file and either open it hidden and terminate (Visible = False), or you can just have it open (Visible = True) and remove the Quit, BUT while the doc is Checked out, I can't seem to target or check in that mXLApp doc further. The solution is to not leave the mXLApp doc open, but then once closed to open that same doc as normal, and then it will Check in with the Check in code line.
Sub TestCheckOut()
Dim FileName as String
FileName = "http://spserver/document/Test.xlsx"
SP_CheckOut FileName
End Sub
Sub SP_CheckOut(docCheckOut As String)
Set mXlApp = CreateObject("Excel.Application")
' Determine if workbook can be checked out.
' CanCheckOut does not actually mean the doc is not currently checked out, but that the doc can be checked in/out.
If mXlApp.Workbooks.CanCheckOut(docCheckOut) = True Then
mXlApp.Workbooks.Open fileName:=docCheckOut
mXlApp.Workbooks.CheckOut docCheckOut
' False is hidden
mXlApp.Visible = False
mXlApp.Quit
Set mXlApp = Nothing
Workbooks.Open fileName:=docCheckOut
Else
MsgBox "Unable to check out this document at this time."
End If
End Sub
As for Checkin, can't get any methods to work except:
Workbooks(CheckName).checkin SaveChanges:=True, Comments:=""
Sub CheckIn(CheckName As String, CheckPath As String)
' Must be open to save and then checkin
Dim wb As Workbook
On Error Resume Next
Set wb = Workbooks(CheckName)
If Err = 0 Then
WorkbookIsOpen = True
Else
WorkbookIsOpen = False
Set wb = Workbooks.Open(CheckPath)
End If
wb.CheckIn SaveChanges:=True, Comments:=""
End Sub
I did try using a Query on the SharePoint browser link to determine who has the doc checked out (if anyone). This worked sometimes. If it did work, half the time it would take too long to be useful, and the other half of the time it would throw a timeout error. Not to mention the query would disrupt other processes, like saving or certain other macros. So I put together a WebScrape which quickly returns who might have the doc checked out.
Sub TestWho()
Dim SPFilePath As String
SPFilePath = "http://teams.MyCompany.com/sites/PATH/PATH/Fulfillment/Forms/AllItems.aspx"
Debug.Print CheckedByWho(SPFilePath , "YOURdocName.xlsx")
End Sub
Function CheckedByWho(ShareFilePath As String, ShareFileName As String)
Dim ie As Object
Dim CheckedWho As String
Dim ImgTag As String
Dim CheckStart, CheckEnd As Integer
Dim SplitArray() As String
Set ie = GetObject("new:{D5E8041D-920F-45e9-B8FB-B1DEB82C6E5E}")
With ie
.Visible = False
.Navigate ShareFilePath
Do Until .readyState = 4: DoEvents: Loop
Do While .Busy: DoEvents: Loop
End With
CheckedWho = "Not Check Out"
For Each objLink In ie.document.getElementsByTagName("img")
ImgTag = objLink.outerHTML
CheckedOutPos = InStr(objLink.outerHTML, ShareFileName & "
Checked Out To:")
If CheckedOutPos > 0 Then
CheckStart = InStr(objLink.outerHTML, "Checked Out To: ")
CheckedWho = Mid(objLink.outerHTML, CheckedOutPos + 41)
SplitArray = Split(CheckedWho, """")
CheckedWho = SplitArray(0)
End If
Next objLink
CheckedByWho = CheckedWho
ie.Quit
End Function
I am designing a VBA Form in Excel. The Workbook has a table called "images", and inside there I am dropping some images from my local hard drive.
These Workbook & UserForm are to be shared with my colleagues. They might not have these images in their harddrive, but they will have them inside of the Excel table.
I am looking for a way to load an image that's inside of a table inside of an "Image" VBA form control.
In Google all I find is how to load an image from my hard drive (i.e. using an absolute path like "C:/my_images/car.png"). What I can't find is how to load an image that's within a table, i.e. already bundled within the Workbook.
Any ideas?
If you are still interested in this question, I came up with a solution.
First you need to export the picture from the shape into a file. I found that only .jpg files can be used. My code generates a temporary filename (you need to be able to read/write that path but I think it is usually not a problem), and saves the picture by inserting it into a ChartObject, which can export its contents as a picture. I suppose this process may modify (e.g. compress) the original data but I saw no visible difference on the screen.
When this is done, it loads the picture from this file into the Image control on the UserForm.
Finally, it deletes the temporary file to clean up this side-effect.
Option Explicit
' Include: Tools > References > Microsoft Scripting Runtime
Private Sub cmdLoad_Click()
' Assumption: The UserForm on which you want to load the picture has a CommandButton, cmdLoad, and this function is its event handler
Dim imgImageOnForm As Image: Set imgImageOnForm = imgTarget ' TODO: Set which Control you want the Picture loaded into. You can find the Name in the VBA Form Editor's Properties Bar
Dim strSheetName As String: strSheetName = "TargetSheet" ' TODO: Specify the Name of the Worksheet where your Shape (picture) is
Dim strShapeName As String: strShapeName = "TargetPicture" ' TODO: Specify the Name of your Shape (picture) on the Worksheet
Dim strTemporaryFile As String: strTemporaryFile = GetTemporaryJpgFileName ' TODO: Give a path for the temporary file, the file extension is important, e.g. .jpg can be loaded into Form Controls, while .png cannot
LoadShapePictureToFormControl _
strSheetName, _
strShapeName, _
imgImageOnForm, _
strTemporaryFile
End Sub
Private Sub LoadShapePictureToFormControl(strSheetName As String, strShapeName As String, imgDst As MSForms.Image, strTemporaryFile As String)
' Note: This Sub overwrites the contents of the Clipboard
' Note: This Sub creates and deletes a temporary File, therefore it needs access rights to do so
Dim shpSrc As Shape: Set shpSrc = ThisWorkbook.Worksheets(strSheetName).Shapes(strShapeName)
Dim strTmp As String: strTmp = strTemporaryFile
ExportShapeToPictureFile shpSrc, strTmp
ImportPictureFileToImage strTmp, imgDst
FileSystem.Kill strTmp
End Sub
Private Sub ExportShapeToPictureFile(shpSrc As Shape, strDst As String)
shpSrc.CopyPicture xlScreen, xlBitmap
Dim chtTemp As ChartObject: Set chtTemp = shpSrc.Parent.ChartObjects.Add(0, 0, shpSrc.Width, shpSrc.Height)
With chtTemp
.Activate
.Parent.Shapes(.Name).Fill.Visible = msoFalse
.Parent.Shapes(.Name).Line.Visible = msoFalse
.Chart.Paste
.Chart.Export strDst
.Delete
End With
End Sub
Private Sub ImportPictureFileToImage(strSrc As String, imgDst As MSForms.Image)
Dim ipdLoaded As IPictureDisp: Set ipdLoaded = StdFunctions.LoadPicture(strSrc)
Set imgDst.Picture = ipdLoaded
End Sub
Private Function GetTemporaryJpgFileName() As String
Dim strTemporary As String: strTemporary = GetTemporaryFileName
Dim lngDot As Long: lngDot = InStrRev(strTemporary, ".")
If 0 < lngDot Then
strTemporary = Left(strTemporary, lngDot - 1)
End If
strTemporary = strTemporary & ".jpg"
GetTemporaryJpgFileName = strTemporary
End Function
Private Function GetTemporaryFileName() As String
Dim fsoTemporary As FileSystemObject: Set fsoTemporary = New FileSystemObject
Dim strResult As String: strResult = fsoTemporary.GetSpecialFolder(TemporaryFolder)
strResult = strResult & "\" & fsoTemporary.GetTempName
GetTemporaryFileName = strResult
End Function
I have about 60 workbooks with several modules and I need to remove one sub routine in one module then add code to a specific worksheet.
I currently have code running every time you open the workbook asking to run and archive data to another worksheet, it works. Problem is we are in the workbooks several times, so every time we open them, we have to answer the question.
I found a more elegant way to ask to archive when I go to the first worksheet where we go to change data at the end of the month. Only when we open this are we needing to archive the old data. Some times we go here to look at the data, but it's not the usual. I have new code now for the specific worksheet using on select, that works.
I'm trying to update the code across all my workbooks without having to open them up 1 by 1 and make the changes, copy, paste, delete, save, open next file, repeat.
'code to remove from module named ArchiveHistoricalData
Sub Auto_Open()
AskArchive
End Sub
'Code to add to worksheet named Data Dump
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
AskArchive
End Sub
I'd like to remove the first sub, then add the second sub to a specific worksheet (Named the same across all workbooks). Then if I have changes in the future, I can easily update all my workbooks with other changes.
Posting another answer structured as generalized tools to delete and/or add or replace any number of procedures from any number of files. As mentioned earlier it is assumed that Trust Access to Visual Basics Project must be enabled.
In a new excel file with added reference to Microsoft Visual Basic for Application extensibility, add a module named “Copy_Module”. Specifically in your case, copy Worksheet_SelectionChange code in a module named “Copy_Module”.
Its AddReplaceProc function would copy any procedure from a module named “Copy_Module” in the source workbook while DeleteProc function would delete a procedure.
Sub test4()
Dim Wb As Workbook, ws As Worksheet
Dim Path As String, Fname As String
Dim Fno As Long
Path = "C:\Users\User\Documents\TestFolder\"
Fname = Dir(Path & "*.xlsm")
Fno = 1
Do While Fname <> ""
Set Wb = Application.Workbooks.Open(Path & Fname)
If Wb.VBProject.Protection = vbext_pp_none Then
Set ws = ThisWorkbook.ActiveSheet
Fno = Fno + 1
ws.Cells(Fno, 1).Value = Fname
'ws.Cells(Fno, 2).Value = AddReplaceProc(Wb, "ArchiveHistoricalData", "DoStuff2")
ws.Cells(Fno, 2).Value = DeleteProc(Wb, "ArchiveHistoricalData", "Auto_Open")
ws.Cells(Fno, 3).Value = AddReplaceProc(Wb, Wb.Worksheets("Data Dump").CodeName, "Worksheet_SelectionChange")
Wb.Close True
Else
Wb.Close False
End If
Fname = Dir
Loop
End Sub
Private Function DeleteProc(Wb As Workbook, CompName As String, ProcName As String) As Boolean
Dim Vbc As CodeModule, Vbcomp As VBComponent
DeleteProc = False
For Each Vbcomp In Wb.VBProject.VBComponents
If Vbcomp.Name = CompName Then
Set Vbc = Vbcomp.CodeModule
On Error GoTo XExit
If Vbc.ProcStartLine(ProcName, 0) > 0 Then
Vbc.DeleteLines Vbc.ProcStartLine(ProcName, 0), Vbc.ProcCountLines(ProcName, 0)
DeleteProc = True
Exit For
End If
End If
Next Vbcomp
XExit: On Error GoTo 0
End Function
Private Function AddReplaceProc(Wb As Workbook, CompName As String, ProcName As String) As Boolean
Dim Vbc As CodeModule, Vbcomp As VBComponent
Dim VbcSrc As CodeModule, StLine As Long, EndLine As Long
Dim i As Long, X As Long
'Check for older version of the procedure and delete the same before coping new version
AddReplaceProc = DeleteProc(Wb, CompName, ProcName)
Debug.Print "Old Proc " & ProcName & " Found and Deleted : " & AddReplaceProc
AddReplaceProc = False
For Each Vbcomp In Wb.VBProject.VBComponents
If Vbcomp.Name = CompName Then
Set Vbc = Vbcomp.CodeModule
Set VbcSrc = ThisWorkbook.VBProject.VBComponents("Copy_Module").CodeModule
StLine = VbcSrc.ProcStartLine(ProcName, 0)
EndLine = StLine + VbcSrc.ProcCountLines(ProcName, 0) - 1
X = 0
For i = StLine To EndLine
X = X + 1
Vbc.InsertLines X, VbcSrc.Lines(i, 1)
Next i
AddReplaceProc = True
Exit For
End If
Next Vbcomp
End Function
Proper caution is a must for this type of remote changes. It is always wise to try the code first only to copies of target files and confirm proper working etc.
It only works with files with unprotected VBA projects. For files with protected VBA files refer SO post Unprotect VBProject from VB code.
Try the code from any workbook (not in the same target folder) module. Add reference to Microsoft visual basic for applications extensibility. and/or make vbext_pk_Proc as 0.
Sub test3()
Dim ws As Workbook
Dim Vbc As CodeModule
Dim Path As String, Fname As String
Dim Wx As Worksheet
Dim HaveAll As Boolean
Dim VbComp As VBComponent
Path = "C:\Users\User\Documents\TestFolder\"
Fname = Dir(Path & "*.xlsm")
Do While Fname <> ""
' Debug.Print Fname
Set ws = Application.Workbooks.Open(Path & Fname)
HaveAll = False
For Each VbComp In ws.VBProject.VBComponents
If VbComp.Name = "ArchiveHistoricalData" Then
'used erron handler instead of iterating through all the lines for keeping code short
On Error GoTo failex
If VbComp.CodeModule.ProcStartLine("Auto_Open", 0) > 0 Then
HaveAll = True
failex: Resume failex2
failex2: On Error GoTo 0
Exit For
End If
End If
Next VbComp
If HaveAll Then
HaveAll = False
For Each Wx In ws.Worksheets
If Wx.Name = "Data Dump" Then
HaveAll = True
Exit For
End If
Next Wx
End If
If HaveAll Then
Set Vbc = ws.VBProject.VBComponents("ArchiveHistoricalData").CodeModule
Vbc.DeleteLines Vbc.ProcStartLine("Auto_Open", vbext_pk_Proc), Vbc.ProcCountLines("Auto_Open", vbext_pk_Proc)
Set Vbc = ws.VBProject.VBComponents(ws.Worksheets("Data Dump").CodeName).CodeModule
Vbc.InsertLines 1, "Private Sub Worksheet_SelectionChange(ByVal Target As Range)"
Vbc.InsertLines 2, "AskArchive"
Vbc.InsertLines 3, "End Sub"
ws.Close True
Else
ws.Close False
End If
Debug.Print Fname, HaveAll
Fname = Dir
Loop
End Sub
However code will encounter error if the stated Worksheets, code modules and procedures are not available. Please take due care, if not confirmed about availability of the stated Worksheets, code modules and procedures in all the target files. (may use error handler or check for existence for the Sheets, code modules and procedures by iterating through after opening the target file and skip accordingly). Also Trust Access To Visual Basics Project must be enabled.