Results 1 to 3 of 3
  1. #1
    New Lounger
    Join Date
    Sep 2015
    Posts
    10
    Thanks
    1
    Thanked 0 Times in 0 Posts

    Collating the first line of every document in a directory

    Our team regularly needs to create lists of the titles in documents in specific directories. The title is always the first line and always only one line of each document. At the moment, we turn on the preview in Windows Explorer, highlight the first line, copy, paste into a document, repeat. As you can image if there's 60 or 70 documents in the directory, this gets a little tedious.
    I have a macro (pasted below), created by someone on this forum, which opens each document in a directory and checks for revisions and comments. I thought I could just adapt that, as it already does the open "each document the directory bit" bit that I need. But I'm not adept enough with VBA to work out how to change the core bit. Any help would be appreciated.

    Code:
     Function GetFolder() As StringDim 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
    Sub GetResourceTitle()
    Application.ScreenUpdating = False
    Dim strFolder As String, strFile As String, strDocNm As String, wdDoc As Document, StrOut As String
    strDocNm = ActiveDocument.FullName
    strFolder = GetFolder
    If strFolder = "" Then Exit Sub
    strFile = Dir(strFolder & "\*.doc*", vbNormal)
    While strFile <> ""
      If strFolder & "\" & strFile <> strDocNm Then
        Set wdDoc = Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
        With wdDoc
            
          If .Revisions.Count > 0 Then StrOut = StrOut & strFile & vbCr
          If .Comments.Count > 0 Then StrOut = StrOut & strFile & vbCr
          .Close SaveChanges:=True
        End With
      End If
      strFile = Dir()
    Wend
    ActiveDocument.range.Text = StrOut
    Set wdDoc = Nothing
    Application.ScreenUpdating = True
    
    
    If StrOut = "" Then MsgBox "No revisions or comments in files."
    End Sub

  2. #2
    Super Moderator
    Join Date
    Jan 2001
    Location
    Melbourne, Victoria, Australia
    Posts
    3,853
    Thanks
    4
    Thanked 259 Times in 239 Posts
    This might be what you want
    Code:
    Sub GetResourceTitle()
      'Application.ScreenUpdating = False
      Dim strFolder As String, strFile As String, strDocNm As String, wdDoc As Document
      Dim aDoc As Document, aRng As Range
      Set aDoc = ActiveDocument
      strDocNm = aDoc.FullName
      strFolder = GetFolder
      If strFolder = "" Then Exit Sub
      strFile = Dir(strFolder & "\*.doc*", vbNormal)
      While strFile <> ""
        If strFolder & "\" & strFile <> strDocNm Then
          Set wdDoc = Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
          Set aRng = aDoc.Range
          aRng.Collapse wdDirectionEnd
          aRng.Text = wdDoc.Paragraphs(1).Range.Text
          wdDoc.Close SaveChanges:=True
        End If
        strFile = Dir()
      Wend
      Set wdDoc = Nothing
      'Application.ScreenUpdating = True
    End Sub
    Andrew Lockton, Chrysalis Design, Melbourne Australia

  3. #3
    New Lounger
    Join Date
    Sep 2015
    Posts
    10
    Thanks
    1
    Thanked 0 Times in 0 Posts
    You are a superstar! Thank you so much for this piece of magic.

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •