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

[Jude24Joy]

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.

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:

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:

Sub MacroImage1()


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


End Sub