Specifying a particular path and a timer? Edit: Also adding some cropping code

Jude24Joy · #1 07-03-2018, 09:53 AM

Hello,

I have been using some wonderful vba code, mostly, if not all, written by macropod. (Many many thanks!) Now I'd like to alter it a bit. I attempted to figure it out myself, but am having no luck.

Currently, it opens up a dialog box for me to choose which directory I want the code run on. Since that directory very rarely changes, I'd like to specify a particular path, so it doesn't ask me when I run it. Then I want it to continue to run on all of the subfolders, as it does now. That's the first change--to remove the dialog box and type in the top level folder directly into the code.

The second thing, is I'd like the code to automatically run at a particular time every day, or every 12 hours--something like that. I'd also like to keep the ability to run it myself.

Code:

Dim FSO As Object, oFolder As Object, StrFolds As String
 
Sub Main()
Dim TopLevelFolder As String, TheFolders As Variant, aFolder As Variant, i As Long
TopLevelFolder = GetFolder
StrFolds = vbCr & TopLevelFolder
If FSO Is Nothing Then
  Set FSO = CreateObject("Scripting.FileSystemObject")
End If
'Get the sub-folder structure
Set TheFolders = FSO.GetFolder(TopLevelFolder).SubFolders
For Each aFolder In TheFolders
  RecurseWriteFolderName (aFolder)
Next
'Process the documents in each folder
For i = 1 To UBound(Split(StrFolds, vbCr))
  Call UpdateDocuments(CStr(Split(StrFolds, vbCr)(i)))
Next
End Sub
 
 
Sub RecurseWriteFolderName(aFolder)
Dim SubFolders As Variant, SubFolder As Variant
Set SubFolders = FSO.GetFolder(aFolder).SubFolders
StrFolds = StrFolds & vbCr & CStr(aFolder)
On Error Resume Next
For Each SubFolder In SubFolders
  RecurseWriteFolderName (SubFolder)
Next
End Sub

Sub UpdateDocuments(oFolder As String)
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String, strDocNm As String, wdDoc As Document
strDocNm = ActiveDocument.FullName
strFolder = oFolder
If strFolder = "" Then Exit Sub
strFile = Dir(strFolder & "\*.doc")
While strFile <> ""
  If strFolder & "\" & strFile <> strDocNm Then
    Set wdDoc = Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
    With wdDoc
      .Fields.Unlink
      .RemoveDocumentInformation (wdRDIAll)
      .Close SaveChanges:=True
    End With
  End If
  strFile = Dir()
Wend
Set wdDoc = Nothing
Application.ScreenUpdating = True
End Sub

Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function

Thanks for any help you can offer.

One other thing... I'd like to add the following code somewhere so that it runs on every document as well. I've tried inserting it into a couple of places, but I'm getting an error. Here's the code:

Code:

Sub MacroImage1()
Dim myInlineShape As InlineShape
Dim myCrop As Crop

Set myInlineShape = ActiveDocument.InlineShapes(1)
Set myCrop = myInlineShape.PictureFormat.Crop

InlineShapes.Item(1).PictureFormat.CropBottom = 110
InlineShapes.Item(1).PictureFormat.CropTop = 165


End Sub

I added the above to the end, and then added MacroImage1 to the UpdateDocuments sub here:

.Close SaveChanges:=True
MacroImage1

Which, I'm sure, is embarrassingly far off the mark.

This is the error:

Run-time error '5941':

The requested member of the collection does not exist.

Edit again--I figured out the cropping thing. I decided it was better to make a macro and a keyboard shortcut to crop each picture one at a time. That way I can be sure it works correctly.

This is what I ended up with:

Code:

Sub MacroImage1()


Selection.InlineShapes(1).PictureFormat.CropBottom = 110
Selection.InlineShapes(1).PictureFormat.CropTop = 165


End Sub

macropod · #2 07-03-2018, 07:45 PM

For the first question, change:
TopLevelFolder = GetFolder
to something like:
TopLevelFolder = "C:\Users" & Environ("Username") & "\Documents"
That will cause the macro to start the search from your 'Documents' folder - you can drill down to a lower folder for the starting point, if you prefer.

Regarding the second question, you can use the Application.OnTime method to run a macro at a specified time or interval. For example:

Code:

Private Sub Document_Open()
Call Main
End Sub

would run the 'main' macro immediately the document is opened. If you were to add:

Code:

Application.OnTime When:=Now + TimeValue("01:00:00"), Name:="Main", Tolerance:=0

to the end of the 'Main' macro, the process would repeat every hour - provided the document remains open.

As for your third question, you could insert:

Code:

      If .InlineShapes.Count > 0 Then
        With .InlineShapes(1).PictureFormat
          .CropBottom = 110
          .CropTop = 165
        End With
      End If

between:
.RemoveDocumentInformation (wdRDIAll)
and:
.Close SaveChanges:=True

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Timer for outlook	DuncanH	Outlook	0	02-28-2017 08:45 PM
Can you add a count down timer?	breakout	PowerPoint	0	01-09-2015 10:41 PM
Countdown Timer	mcdanita	PowerPoint	0	03-08-2012 12:51 PM
Timer in ppt 2007	Dave4500	PowerPoint	0	01-22-2011 06:56 PM
first timer	papamadre	Forum Support	1	10-24-2009 06:26 AM