I would like to retrieve the number of the page a picture is on.
I know how to retrieve the picture using
ActiveDocument.Range.ShapeRange.LinkFormat.SourceFullName
but what variable holds the pagenumber of a picture?
https://word.tips.net/T000728_Determining_the_Current_Page_Number.html
CurPage = Selection.Information(wdActiveEndAdjustedPageNumber)
CurPage = Selection.Information(wdActiveEndPageNumber)
How about this?
Maybe you could change it to:
ActiveDocument.Range.ShapeRange.Information(wdActiveEndAdjustedPageNumber)
ActiveDocument.Range.ShapeRange.Information(wdActiveEndPageNumber)
Not tested as on a Linux machine right now!!
The following code will create a list of pictures including the page it is located on.
...
Sub LoopPages()
With ActiveDocument
Dim numPages As Integer: numPages = .Content.ComputeStatistics(wdStatisticPages)
Dim actPage As Integer
Dim rng As Range
Dim num As Integer
Dim FileOut As String: FileOut = "c:\Temp\Images\Pages.txt"
Open FileOut For Output As #1
For actPage = 1 To numPages
' Create a range of Page actPage
Set rng = .GoTo(What:=wdGoToPage, Name:=actPage)
Set rng = rng.GoTo(What:=wdGoToBookmark, Name:="\page")
For Each Shp In rng.ShapeRange
With Shp
If (.Type = msoLinkedPicture) Then
num = num + 1
Print #1, Format(num, "000") & " --> Page= " & actPage & " --> " & .LinkFormat.SourceFullName
End If
End With
Next Shp
For Each Shp In rng.InlineShapes
With Shp
If (.Type = wdInlineShapeLinkedPicture) Then
num = num + 1
Print #1, Format(num, "000") & " --> Page= " & actPage & " --> " & .LinkFormat.SourceFullName
End If
End With
Next Shp
Next actPage
MsgBox num
Close #1
End With
End Sub
...
Related
I'm writing a routine that builds a TOC in a presentation based on the existence of 'Section Divider Slides' (Custom Layout Slide). When I try to build the TOC per se in a table that I add on a 'Table of Contents' custom slide, trying to set the .cell values I get an 'Object does not support this property or method'. I think it may have to do with the way I add the table and reference it but I can't figure it out.
The problematic code is just before the pseudo code for the rest of the routine starts. Bare in mind it's a first run so it may not be polished.
Thanks in advance.
Option Explicit
Sub BuildTOC()
Dim oSlide As slide
Dim i As Single
Dim myCol As Collection
Dim myColDividers As Collection
Dim UserInput As Variant
Dim InputQuestion As String
Dim SectionCount As Single
Dim DeleteTOCs As Long
Dim TOCSlide As Single
Dim SlideNum As Single
Dim TitleText As String
Dim oTable As Shape
Dim tRows As Long
Dim tCols As Long
Dim tLeft As Single
Dim tTop As Single
Dim tWidth As Single
Dim tHeight As Single
Dim tCol1Width As Single
Dim tCol2Width As Single
Dim tCol3Width As Single
Set myCol = New Collection
Set myColDividers = New Collection
If ActivePresentation.Slides.Count = 0 Then Exit Sub
'' Get number of dividers
SectionCount = 0
For i = 1 To ActivePresentation.Slides.Count
Debug.Print i & ": " & ActivePresentation.Slides(i).CustomLayout.Name
If ActivePresentation.Slides(i).CustomLayout.Name = "Section Divider" Then
SectionCount = SectionCount + 1
End If
Next i
Debug.Print "==================================="
'' loop through slides and add TOC layouts to collection
For i = 1 To ActivePresentation.Slides.Count
Debug.Print i & ": " & ActivePresentation.Slides(i).CustomLayout.Name
If ActivePresentation.Slides(i).CustomLayout.Name = "Table of Contents" Then
myCol.Add CStr(i), CStr(i)
End If
Next i
'' if no TOCs found, exit
If myCol.Count > 0 Then
'' Delete TOCs found
DeleteTOCs = MsgBox("This will delete all existing Tables of Contents." & vbNewLine & "Continue?", vbYesNo)
If vbYes Then
i = 0
For i = myCol.Count To 1 Step -1
ActivePresentation.Slides(val(myCol.item(i))).Delete
Debug.Print "Delete TOC on slide " & myCol.item(i)
Next
End If
End If
' Select position for TOC
' Keeping looping until we get a valid answer
InputQuestion = "Insert TOC before which slide number?" & vbNewLine & _
"Please input a number between 1 and " & ActivePresentation.Slides.Count & "."
Do
'Retrieve answer from the user
UserInput = InputBox(InputQuestion, "Table of Contents Position")
'Check if user selected cancel button
If StrPtr(UserInput) = 0 Then Exit Sub
'Check if user clicked OK without entering a value
If UserInput = vbNullString Then
MsgBox ("You must enter a value or click on Cancel")
End If
Loop While UserInput < 1 Or UserInput > ActivePresentation.Slides.Count
' Insert it
Set oSlide = ActivePresentation.Slides.AddSlide(UserInput, GetLayout("Table of Contents"))
TOCSlide = oSlide.SlideIndex
Debug.Print "==================================="
'' loop through slides and add TOC layouts to collection
For i = 1 To ActivePresentation.Slides.Count
Debug.Print i & ": " & ActivePresentation.Slides(i).CustomLayout.Name
If ActivePresentation.Slides(i).CustomLayout.Name = "Table of Contents" Then
myColDividers.Add CStr(i), CStr(i)
End If
Next i
Debug.Print "==================================="
'' Loop through slides and collect dividers
For i = 1 To ActivePresentation.Slides.Count
Debug.Print i & ": " & ActivePresentation.Slides(i).CustomLayout.Name
If ActivePresentation.Slides(i).CustomLayout.Name = "Section Divider" Then
myColDividers.Add CStr(i), CStr(i)
End If
Next i
' set Rows and Columns
tRows = SectionCount
tCols = 3
' Table dimensions
tLeft = CentimetersToPoints(9.09)
tTop = CentimetersToPoints(6.13)
tWidth = CentimetersToPoints(22.74)
tHeight = 24 ''CentimetersToPoints(11.72)
tCol1Width = CentimetersToPoints(2.7)
tCol2Width = CentimetersToPoints(17.4)
tCol3Width = CentimetersToPoints(2.7)
'' Create table
Set oSlide = Nothing
Set oSlide = ActivePresentation.Slides(TOCSlide)
Call DeleteTablesFromSlide(oSlide)
Set oTable = oSlide.Shapes.AddTable(tRows, tCols, tLeft, tTop, tWidth, tHeight)
With oTable.Table
.Columns(1).Width = tCol1Width
.Columns(2).Width = tCol2Width
.Columns(3).Width = tCol3Width
Debug.Print "======================================"
i = 0
For i = 1 To myColDividers.Count
SlideNum = val(myColDividers.item(i))
TitleText = ActivePresentation.Slides(SlideNum).Shapes.Title.textFrame.textRange.text
If ActivePresentation.Slides(SlideNum).Shapes.HasTitle Then
If Len(TitleText) > 0 Then
Debug.Print SlideNum & ": " & TitleText
.cell(i, 1) = i
.cell(i, 2) = TitleText
.cell(i, 3) = SlideNum
End If
Else
Debug.Print "No title"
.cell(i, 1) = i
.cell(i, 2) = " No title"
.cell(i, 3) = SlideNum
End If
Next i
End With
' For RowNum = 1 To SectionCount
' .cell(RowNum, 1) = RowNum
' .
' With shp.Table.cell(RowNum, 1).Shape.textFrame.textRange.ActionSettings(ppMouseClick).Hyperlink
' .SubAddress = .cell(RowNum, 1).Shape.textFrame.textRange.text
' .TextToDisplay = .cell(RowNum, 1).Shape.textFrame.textRange.text
' End With
'' 'slide number col
'' With shp.Table.cell(i - 1, 2).Shape.textFrame.textRange.ActionSettings(ppMouseClick).Hyperlink
'' .SubAddress = shp.Table.cell(i - 1, 2).Shape.textFrame.textRange.text
'' .TextToDisplay = shp.Table.cell(i - 1, 2).Shape.textFrame.textRange.text
'' End With
''Next i
'' Format TOC
''
''
''Next
''paste Table
''
''
''i = 0
''x = 0
''Set mycoll = Nothing
''
''For Each oSlide In ActivePresentation.Slides
''
'' If oSlide.layout = divider
'' Add to collection
''
''Find the table
''
''For Each oShape In oSlide.Shapes
''
''''
''End If
''
'' Oslide table delete
'' End If
''Next
''
''
''For i = 1 to slide count
'' If slide(i) layout = divider
'' Add to mycoll
''Next
''i = 0
''
''For i = 1 To mycoll.Count
''slide (i)
''Paste Table
''Format row i to highlight row position
''Next
End Sub
Public Function GetLayout( _
LayoutName As String, _
Optional ParentPresentation As Presentation = Nothing) As CustomLayout
Dim oLayout As CustomLayout
If ParentPresentation Is Nothing Then
Set ParentPresentation = ActivePresentation
End If
For Each oLayout In ParentPresentation.SlideMaster.CustomLayouts
If oLayout.Name = LayoutName Then
Set GetLayout = oLayout
Exit For
End If
Next
End Function
Public Function DeleteTablesFromSlide(mySlide As PowerPoint.slide) As Long
Dim lCntr As Long
Dim lTables As Long
' Count backwards when deleting items from a collection
For lCntr = mySlide.Shapes.Count To 1 Step -1
With mySlide.Shapes(lCntr)
Select Case .Type
Case msoTable: .Delete: lTables = lTables + 1 ' msoTable = 19
Case msoPlaceholder ' msoPlaceholder = 19
If .PlaceholderFormat.ContainedType = msoTable Then .Delete: lTables = lTables + 1
End Select
End With
Next
DeleteTablesFromSlide = lTables
End Function
As #timothyrylatt pointed out, my mistake was in how I was trying to manipulate the cells.
Instead of:
.cell(row,col) = Text
it should be:
.Cell(row, col).Shape.TextFrame.TextRange.Text = Text
Currently I have code which combines pdfs together.
It takes all pages from each file I specify in Column A3:A5 and appends to A2.
Lets say all my pdfs have 5 pages each. However what If I want to only take the first 3 A3, and full 5 pages of A4, and 1 page A5?
Also I don't need to specify in between pages, ie 2 , 4 and 5 of A3.
It will always be in order, ie 1-3 or 1-5 or 1-2.
I have a counter that gets the number of pages already
Dim i As Long, pgnumber As Range
For Each pgnumber In Range("A2:A100")
If Not IsEmpty(pgnumber) Then
i = i + 1
AcroDoc.Open pgnumber
PageNum = AcroDoc.GetNumPages
Cells(pgnumber.Row, 4) = PageNum
End If
AcroDoc.Close
Next pgnumber
full code:
Sub main3()
Set app = CreateObject("Acroexch.app")
Dim FilePaths As Collection
Set FilePaths = New Collection
Dim AcroDoc As Object
Set AcroDoc = New AcroPDDoc
'Counts # of pages in each pdf, loads to column D.
Dim i As Long, pgnumber As Range
For Each pgnumber In Range("A2:A100")
If Not IsEmpty(pgnumber) Then
i = i + 1
AcroDoc.Open pgnumber
PageNum = AcroDoc.GetNumPages
Cells(pgnumber.Row, 4) = PageNum
End If
AcroDoc.Close
Next pgnumber
'Append to this file, ideally will be a front page to append to, commented out for now.
'FilePaths.Add "\path\name\here"
'Active or not feature in Column B, Specify Yes to include in combination, no to exclude
Dim cell As Range
For Each cell In Range("A2:A100")
If cell.Offset(0, 1).Value2 <> "No" Then FilePaths.Add cell.Value2
Next cell
'Combine files which are listed in Column A.
Set primaryDoc = CreateObject("AcroExch.PDDoc")
OK = primaryDoc.Open(FilePaths(1))
Debug.Print "PRIMARY DOC OPENED & PDDOC SET: " & OK
For colIndex = 2 To FilePaths.Count
numPages = primaryDoc.GetNumPages() - 1
Set sourceDoc = CreateObject("AcroExch.PDDoc")
OK = sourceDoc.Open(FilePaths(colIndex))
Debug.Print "(" & colIndex & ") SOURCE DOC OPENED & PDDOC SET: " & OK
numberOfPagesToInsert = sourceDoc.GetNumPages
OK = primaryDoc.InsertPages(numPages, sourceDoc, 0, numberOfPagesToInsert, False)
Debug.Print "(" & colIndex & ") PAGES INSERTED SUCCESSFULLY: " & OK
Set sourceDoc = Nothing
Next colIndex
OK = primaryDoc.Save(PDSaveFull, FilePaths(1))
Debug.Print "PRIMARYDOC SAVED PROPERLY: " & OK
Set primaryDoc = Nothing
app.Exit
Set app = Nothing
MsgBox "DONE"
End Sub
Any help on how to achieve this would be appreciated.
Tried the below code, but it doesn't have any effect:
'attempt to do start and end page in col E and F.
startPage = Range("E" & colIndex)
endPage = Range("F" & colIndex)
OK = sourceDoc.DeletePages(1, startPage - 1)
OK = sourceDoc.DeletePages(endPage - startPage + 2, sourceDoc.GetNumPages)
There is a More Nearly Complete Answer Below
See my comment on your question. If that is accurate, this may fix the problem:
Add:
Dim FileRows As Collection
Set FileRows = New Collection
Change
If cell.Offset(0, 1).Value2 <> "No" Then FilePaths.Add cell.Value2
To:
If cell.Offset(0, 1).Value2 <> "No" Then
FilePaths.Add cell.Value2
FileRows.Add cell.Row
Endif
Change:
startPage = Range("E" & colIndex)
endPage = Range("F" & colIndex)
To:
startPage = Range("E" & FileRows(colIndex))
endPage = Range("F" & FileRows(colIndex))
More Nearly Complete Answer
Okay, I know I shouldn't do this, but here we go. I have revised your code to work the way I think it should work. It is not a complete revision, because the whole thing could be doing in one pass and the Collection objects could be eliminated. There may be bugs in the following code, because I don't have the Adobe Acrobat SDK. But, I think it gets you closer than you were and it puts everything in place. You should be able to do any debugging from here:
Sub CompileDocuments()
Dim acroExchangeApp as Object ' Needed because?
Dim filePaths As Collection ' Paths for PDFs to append
Dim fileRows As Collection ' Row numbers PDFs to append
Dim fileIndex as Long ' For walking through the collections
Dim acroDoc As AcroPDDoc ' Manages imported PDFs
Dim sourceDoc as Object ' Manages imported PDFs (Same as above?)
Dim primaryDoc As Object ' Everything gets appended to this
Dim importPath As Range ' Cell containing a PDF to append
Dim pageCount As Long ' Total pages in an appendable PDF
Dim insertPoint as Long ' PDFs will be appended after this page in the primary Doc
Dim startPage as Long ' First desired page of appended PDF
Dim endPage as Long ' Last desired page of appended PDF
' Initialize
Set filePaths = New Collection
Set fileRows = New Collection
Set acroDoc = New AcroPDDoc
Set acroExchangeApp = CreateObject("Acroexch.app")
Set primaryDoc = CreateObject("AcroExch.PDDoc")
' Pass through rows setting page numbers and capturing paths
For Each importPath In Range("A2:A100")
' Put the page count of each PDF document in column D
If Not IsEmpty(importPath) Then
acroDoc.Open importPath
pageCount = acroDoc.GetNumPages
importPath.OffSet(0,3) = pageCount
acroDoc.Close
End If
Set acroDoc = Nothing
' Remember which documents to append and the row on which they appear
' Skipping any rows with "No" in column B
If importPath.Offset(0, 1).Value2 <> "No" Then
filePaths.Add importPath.Value2
fileRows.Add importPath.Row
End If
Next importPath
' Combine all file listed in Column A.
' Start by opening the file in A2.
OK = primaryDoc.Open(filePaths(1))
Debug.Print "PRIMARY DOC OPENED & PDDOC SET: " & OK
' Loop through the remaining files, appending pages to A2
' Note that columns E and F define the desired pages to extract from
' the appended document.
For fileIndex = 2 To filePaths.Count
' Pages will be added after this insert point
insertPoint = primaryDoc.GetNumPages() - 1
' Open the source document
Set sourceDoc = CreateObject("AcroExch.PDDoc")
OK = sourceDoc.Open(filePaths(fileIndex))
Debug.Print "(" & fileIndex & ") SOURCE DOC OPENED & PDDOC SET: " & OK
' Get start and end pages
startPage = Range("E" & CStr(fileRows(fileIndex))).Value
endPage = Range("F" & CStr(fileRows(fileIndex))).Value
OK = primaryDoc.InsertPages(insertPoint, sourceDoc, startPage, endPage-startPage+1, False)
Debug.Print "(" & fileIndex & ") " & endPage-startPage+1 & " PAGES INSERTED SUCCESSFULLY: " & OK
Set sourceDoc = Nothing
Next fileIndex
OK = primaryDoc.Save(PDSaveFull, filePaths(1))
Debug.Print "primaryDoc SAVED PROPERLY: " & OK
Set primaryDoc = Nothing
acroExchangeApp.Exit
Set acroExchangeApp = Nothing
MsgBox "DONE"
End Sub
You can try deleting the unwanted parts of each pdf prior to appending them all together with sourceDoc.DeletePages(startPage, endPage) for example:
OK = sourceDoc.Open(FilePaths(colIndex))
startPage = Range("C" & colIndex)
endPage = Range("D" & colIndex)
OK = sourceDoc.DeletePages(1, startPage - 1)
OK = sourceDoc.DeletePages(endPage - startPage + 2, sourceDoc.GetNumPages) ' just some arithmetic
Debug.Print "(" & colIndex & ") SOURCE DOC OPENED & PDDOC SET: " & OK
You would just need to specify startPage and endPage for each in columns C & D... or you can change this snippet and specificy them however you prefer
EXPLANATION:
For First Code I removed everything but the barebones: filepath to the doc being appended to and filepaths to the file that we are getting the pages that are to be appended into primary doc.
I set up a constant for us and set it to 2. We can set it to 3 or 5 etc. This constant will be passed in the PAGE TO END part of the insertpage function. I have a feeling that you are going to say that there is some relationship between total num of pages in a pdf and the num to append, but this is not clear from OP
BREAKING DOWN INSERTPAGES():
INSERTPAGES(the page number where insertion starts (inside primaryDoc), a path to the PDF that is the source of the insertion pages (sourcedoc pathway), page to start from (sourceDoc), page to end (sourceDoc), true or false whether books are inserted too
CODE BAREBONES:
Option Explicit
Sub AppendPDF()
Dim app As Object
Dim acroDoc As Object
Dim filePaths As Collection
Dim pathwayIterator As Range
Dim primaryDoc As Object
Dim OK As String
Dim numPages As Long
Dim colIndex As Long
Dim sourceDoc As Object
Const finalPage = 2
Set app = CreateObject("Acroexch.app")
Set acroDoc = New AcroPDDoc
Set filePaths = New Collection
For Each pathwayIterator In Range("A2:A100")
If pathwayIterator.Value <> "" Then
filePaths.Add pathwayIterator.Value2
End If
Next pathwayIterator
Set primaryDoc = CreateObject("AcroExch.PDDoc")
OK = primaryDoc.Open(filePaths(1))
Debug.Print "PRIMARY DOC OPENED & PDDOC SET: " & OK
For colIndex = 2 To filePaths.Count
numPages = primaryDoc.GetNumPages() - 1
Set sourceDoc = CreateObject("AcroExch.PDDoc")
OK = sourceDoc.Open(filePaths(colIndex))
Debug.Print "(" & colIndex & ") SOURCE DOC OPENED & PDDOC SET: " & OK
OK = primaryDoc.InsertPages(numPages, sourceDoc, 0, finalPage, False)
Debug.Print "(" & colIndex & ") PAGES INSERTED SUCCESSFULLY: " & OK
sourceDoc.Close
Set sourceDoc = Nothing
Next colIndex
OK = primaryDoc.Save(PDSaveFull, filePaths(1))
Debug.Print "PRIMARYDOC SAVED PROPERLY: " & OK
Set primaryDoc = Nothing
app.Exit
Set app = Nothing
MsgBox "DONE"
End Sub
CODE EXTRA:
Here we added a bit more. I am not sure what you are doing with the file lengths, I have a feeling that you are going to link them with the number of pages to append. Here we make two collections, one with pathways to the files we are working with a second holds the number of pages of each of these files
Option Explicit
Sub AppendPDF()
Dim app As Object
Dim acroDoc As Object
Dim filePaths As Collection
Dim pgnumber As Range
Dim pageNum As Long
Dim FileNumPages As Collection
Dim pathwayIterator As Range
Dim primaryDoc As Object
Dim OK As String
Dim numPages As Long
Dim colIndex As Long
Dim sourceDoc As Object
Const finalPage = 2
Set app = CreateObject("Acroexch.app")
Set acroDoc = New AcroPDDoc
Set filePaths = New Collection
'Counts # of pages in each pdf, loads to column D.
For Each pgnumber In Range("A2:A100")
If Not IsEmpty(pgnumber) Then
acroDoc.Open pgnumber
pageNum = acroDoc.GetNumPages
Cells(pgnumber.Row, 4) = pageNum
End If
acroDoc.Close
Next pgnumber
'Append to this file, ideally will be a front page to append to, commented out for now.
'FilePaths.Add "\path\name\here"
'Active or not feature in Column B, Specify Yes to include in combination, no to exclude
Set filePaths = New Collection
Set FileNumPages = New Collection
For Each pathwayIterator In Range("A2:A100")
If pathwayIterator.Value <> "" Then
filePaths.Add pathwayIterator.Value2
FileNumPages.Add Cells(pathwayIterator.Row, 4)
End If
Next pathwayIterator
'Combine files which are listed in Column A.
Set primaryDoc = CreateObject("AcroExch.PDDoc")
OK = primaryDoc.Open(filePaths(1))
Debug.Print "PRIMARY DOC OPENED & PDDOC SET: " & OK
For colIndex = 2 To filePaths.Count
numPages = primaryDoc.GetNumPages() - 1
Set sourceDoc = CreateObject("AcroExch.PDDoc")
OK = sourceDoc.Open(filePaths(colIndex))
Debug.Print "(" & colIndex & ") SOURCE DOC OPENED & PDDOC SET: " & OK
OK = primaryDoc.InsertPages(numPages, sourceDoc, 0, finalPage, False)
Debug.Print "(" & colIndex & ") PAGES INSERTED SUCCESSFULLY: " & OK
sourceDoc.Close
Set sourceDoc = Nothing
Next colIndex
OK = primaryDoc.Save(PDSaveFull, filePaths(1))
Debug.Print "PRIMARYDOC SAVED PROPERLY: " & OK
Set primaryDoc = Nothing
app.Exit
Set app = Nothing
MsgBox "DONE"
End Sub
I don't really know how to program but I have compiled a few scripts to achieve nearly what I want, but I have failed at the last step.
The script opens a .txt file from a file directory in, cell B2, sheet 2, and copies its contents into excel (as well as a notepad which I don't care about).
However, I have 120 file directories I want to do this for. At the moment my script just takes the directory from cell B2, I have the rest of the 119 directories below it in the B column, I run the script and delete the row and repeat, which is a bit painstaking.
I would just like the script to run through all 120 files in the B column automatically. Any help appreciated!
Option Explicit
Sub ReadTxtFile()
Dim start As Date
start = Now
Dim oFSO As Object
Set oFSO = CreateObject("Scripting.FileSystemObject")
Dim oFS As Object
Dim filePath As String
'''''Assign the Workbook File Name along with its Path
filePath = Worksheets("Sheet2").Range("B2").Value
MsgBox Worksheets("Sheet2").Range("B2").Value
Dim arr(100000) As String
Dim i As Long
i = 0
If oFSO.FileExists(filePath) Then
On Error GoTo Err
Set oFS = oFSO.OpenTextFile(filePath)
Do While Not oFS.AtEndOfStream
arr(i) = oFS.ReadLine
i = i + 1
Loop
oFS.Close
Else
MsgBox "The file path is invalid.", vbCritical, vbNullString
Exit Sub
End If
For i = LBound(arr) To UBound(arr)
If InStr(1, arr(i), "Transmission", vbTextCompare) Then
'Declare variables for the new output file
Dim sOutputFileNameAndPath As String
Dim FN As Integer
sOutputFileNameAndPath = "C:\Users\nfraser\Documents\test\second.txt"
FN = FreeFile
'Open new output file
Open sOutputFileNameAndPath For Output As #FN
'While 'end of report' has not been found,
'keep looping to print out contents starting from 'report'
Do While InStr(1, arr(i), "Ancillary", vbTextCompare) = 0
Debug.Print i + 1, arr(i)
Range("A" & Range("A" & Rows.Count).End(xlUp).Row + 1) = i + 1
Range("B" & Range("B" & Rows.Count).End(xlUp).Row + 1) = arr(i)
'Print into new output file
Print #FN, i + 1 & " " & arr(i)
'increment count
i = i + 1
Loop
'Print out the 'end of report' line as well
Debug.Print i + 1, arr(i)
Range("A" & Range("A" & Rows.Count).End(xlUp).Row + 1) = i + 1
Range("B" & Range("B" & Rows.Count).End(xlUp).Row + 1) = arr(i)
'Print 'end of report' line into new output file as well
Print #FN, i + 1 & " " & arr(i)
'close the new output file
Close #FN
'exit the 'For..Next' structure since 'end of report' has been found
Exit For
End If
Next
Debug.Print DateDiff("s", start, Now)
Exit Sub
Err:
MsgBox "Error while reading the file.", vbCritical, vbNullString
oFS.Close
Exit Sub
End Sub
You can add a for... each loop, looping through all cells in your current selection. Here's the pattern:
Dim cCell as Range
For Each cCell in Selection
'do stuff
Next cCell
Now, since you change selections throughout your code, you have to store the selection at the onset into another variable, e.g. originalSelection and then loop through the cells in originalSelection. Otherwise, your selection will change during execution.
Adapting it to your code, we end up with the following... Please note: I broke your code into two methods---ReadTxtFiles and copyTo; the ReadTxtFile() sub was getting way too long.
Option Explicit
Sub ReadTxtFiles()
Dim start As Date
start = Now
Dim oFS As Object
Dim inputFilePath As String
Dim outputFilePath As String
Dim outputDirectory As String
outputDirectory = "C:\Users\nfraser\Documents\test\"
'''''Assign the Workbook File Name along with its Path
Dim originalSelection As Range
Dim cCell As Range
Dim i As Integer
Set originalSelection = Selection
For Each cCell In originalSelection
inputFilePath = cCell.Value
outputFilePath = outputDirectory & i & ".txt"
copyTo inputFilePath, outputFilePath
Next cCell
Debug.Print DateDiff("s", start, Now)
End Sub
Sub copyTo(inputPath As String, outputPath As String)
Dim arr(100000) As String
Dim i As Long
Dim oFSO As Object
Set oFSO = CreateObject("Scripting.FileSystemObject") 'late binding
Dim oFS As Object
i = 0
If oFSO.FileExists(inputPath) Then
On Error GoTo Err 'ensure oFS gets closed
Set oFS = oFSO.OpenTextFile(inputPath)
'read file contents into array
Do While Not oFS.AtEndOfStream
arr(i) = oFS.ReadLine
i = i + 1
Loop
'close
oFS.Close
Else 'file didn't exist
MsgBox "The file path is invalid.", vbCritical, vbNullString
Exit Sub
End If
For i = LBound(arr) To UBound(arr)
If InStr(1, arr(i), "Transmission", vbTextCompare) Then
'Declare variables for the new output file
Dim FN As Integer
FN = FreeFile
'Open new output file
Open outputPath For Output As #FN
'While 'end of report' has not been found,
'keep looping to print out contents starting from 'report'
Do While InStr(1, arr(i), "Ancillary", vbTextCompare) = 0
Debug.Print i + 1, arr(i)
Range("A" & Range("A" & Rows.Count).End(xlUp).Row + 1) = i + 1
Range("B" & Range("B" & Rows.Count).End(xlUp).Row + 1) = arr(i)
'Print into new output file
Print #FN, i + 1 & " " & arr(i)
'increment count
i = i + 1
Loop
'Print out the 'end of report' line as well
Debug.Print i + 1, arr(i)
Range("A" & Range("A" & Rows.Count).End(xlUp).Row + 1) = i + 1
Range("B" & Range("B" & Rows.Count).End(xlUp).Row + 1) = arr(i)
'Print 'end of report' line into new output file as well
Print #FN, i + 1 & " " & arr(i)
'close the new output file
Close #FN
'exit the 'For..Next' structure since 'end of report' has been found
Exit For
End If
Next
Exit Sub
Err:
MsgBox "Error while reading the file.", vbCritical, vbNullString
oFS.Close
Exit Sub
End Sub
For a quick action, Try this:
Change this line:
filePath = Worksheets("Sheet2").Range("B2").Value
Into a loop
Dim v As Variant, filepath As String
For Each v In Worksheets("Sheet2").Columns("B").SpecialCells(xlCellTypeConstants)
filepath = v.Value
debug.Print filePath
.... ' remainder of your code
.. then go to the Next line and write another Next line after it.
Need help to modify this VBA code to read multiple tables from a Word document. It only reads one table, but I would like to import more than one into the same Excel sheet.
Sub ImportWordTables()
'Imports a table from Word document
Dim wdDoc As Object
Dim wdFileName As Variant
Dim TableNo As Integer 'number of tables in Word doc
Dim iTable As Integer 'table number index
Dim iRow As Long 'row index in Excel
Dim iCol As Integer 'column index in Excel
wdFileName = Application.GetOpenFilename("Word files (*.doc*),*.doc*", , _
"Browse for file containing table to be imported")
If wdFileName = False Then Exit Sub '(user cancelled import file browser)
Set wdDoc = GetObject(wdFileName) 'open Word file
With wdDoc
TableNo = wdDoc.tables.Count
If TableNo = 0 Then
MsgBox "This document contains no tables", _
vbExclamation, "Import Word Table"
ElseIf TableNo > 1 Then
TableNo = InputBox("This Word document contains " & TableNo & " tables." & vbCrLf & _
"Enter table number of table to import", "Import Word Table", "1")
End If
With .tables(TableNo)
'copy cell contents from Word table cells to Excel cells
For iRow = 1 To .Rows.Count
For iCol = 1 To .Columns.Count
Cells(iRow, iCol) = WorksheetFunction.Clean(.cell(iRow, iCol).Range.Text)
Next iCol
Next iRow
End With
End With
Set wdDoc = Nothing
End Sub
So this is the code, but it doesn't entirely answer my questions.
I just need the tables from the pdf.
Sub Imp_Into_XL(PDF_File As String, Each_Sheet As Boolean)
'This procedure get the PDF data into excel by following way
'1.Open PDF file
'2.Looping through pages
'3.get the each PDF page data into individual _
sheets or single sheet as defined in Each_Sheet Parameter
Dim AC_PD As Acrobat.AcroPDDoc 'access pdf file
Dim AC_Hi As Acrobat.AcroHiliteList 'set selection word count
Dim AC_PG As Acrobat.AcroPDPage 'get the particular page
Dim AC_PGTxt As Acrobat.AcroPDTextSelect 'get the text of selection area
Dim WS_PDF As Worksheet
Dim RW_Ct As Long 'row count
Dim Col_Num As Integer 'column count
Dim Li_Row As Long 'Maximum rows limit for one column
Dim Yes_Fir As Boolean 'to identify beginning of page
Li_Row = Rows.Count
Dim Ct_Page As Long 'count pages in pdf file
Dim i As Long, j As Long, k As Long 'looping variables
Dim T_Str As String
Dim Hld_Txt As Variant 'get PDF total text into array
RW_Ct = 0 'set the intial value
Col_Num = 1 'set the intial value
Application.ScreenUpdating = False
Set AC_PD = New Acrobat.AcroPDDoc
Set AC_Hi = New Acrobat.AcroHiliteList
'set maximum selection area of PDF page
AC_Hi.Add 0, 32767
With AC_PD
'open PDF file
.Open PDF_File
'get the number of pages of PDF file
Ct_Page = .GetNumPages
'if get pages is failed exit sub
If Ct_Page = -1 Then
MsgBox "Pages Cannot determine in PDF file '" & PDF_File & "'"
.Close
GoTo h_end
End If
'add sheet only one time if Data retrive in one sheet
If Each_Sheet = False Then
Set WS_PDF = Worksheets.Add(, Worksheets(Sheets.Count))
WS_PDF.Name = "PDF3Text"
End If
'looping through sheets
For i = 1 To Ct_Page
T_Str = ""
'get the page
Set AC_PG = .AcquirePage(i - 1)
'get the full page selection
Set AC_PGTxt = AC_PG.CreateWordHilite(AC_Hi)
'if text selected successfully get the all the text into T_Str string
If Not AC_PGTxt Is Nothing Then
With AC_PGTxt
For j = 0 To .GetNumText - 1
T_Str = T_Str & .GetText(j)
Next j
End With
End If
If Each_Sheet = True Then
'add each sheet for each page
Set WS_PDF = Worksheets.Add(, Worksheets(Sheets.Count))
End If
'transfer PDF data into sheet
With WS_PDF
If Each_Sheet = True Then
.Name = "Page-" & i
'get the PDF data into each sheet for each PDF page
'if text accessed successfully then split T_Str by VbCrLf
'and get into array Hld_Txt and looping through array and fill sheet with PDF data
If T_Str <> "" Then
Hld_Txt = Split(T_Str, vbCrLf)
For k = 0 To UBound(Hld_Txt)
T_Str = CStr(Hld_Txt(k))
If Left(T_Str, 1) = "=" Then T_Str = "'" & T_Str
.Cells(k + 1, 1).Value = T_Str
Next k
Else
'information if text not retrive from PDF page
.Cells(1, 1).Value = "No text found in page " & i
End If
Else
'get the pdf data into single sheet
If T_Str <> "" Then
Hld_Txt = Split(T_Str, vbCrLf)
Yes_Fir = True
For k = 0 To UBound(Hld_Txt)
RW_Ct = RW_Ct + 1
'check begining of page if yes enter PDF page number for any idenfication
If Yes_Fir Then
RW_Ct = RW_Ct + 1
.Cells(RW_Ct, Col_Num).Value = "Text In Page - " & i
RW_Ct = RW_Ct + 2
Yes_Fir = False
End If
'check for maximum rows if exceeds start from next column
If RW_Ct > Li_Row Then
RW_Ct = 1
Col_Num = Col_Num + 1
End If
T_Str = CStr(Hld_Txt(k))
If Left(T_Str, 1) = "=" Then T_Str = "'" & T_Str
.Cells(RW_Ct, Col_Num).Value = T_Str
Next k
Else
RW_Ct = RW_Ct + 1
.Cells(RW_Ct, Col_Num).Value = "No text found in page " & i
RW_Ct = RW_Ct + 1
End If
End If
End With
Next i
.Close
End With
Application.ScreenUpdating = True
MsgBox "Imported"
h_end:
Set WS_PDF = Nothing
Set AC_PGTxt = Nothing
Set AC_PG = Nothing
Set AC_Hi = Nothing
Set AC_PD = Nothing
End Sub
You can use this to do something with each table in the document:
Dim oTbl As Table
For Each oTbl In ActiveDocument.Tables
' Do something
Debug.Print oTbl.Columns.Count & " " & oTbl.Rows.Count
Next
You'll need to figure out how you want the user to specify which table/tables to work with.
Something like this, perhaps:
Sub UserChosenTables()
Dim oTbl As Table
Dim sTemp As String
Dim aTables() As String
Dim x As Long
sTemp = InputBox("Which tables", "Select tables")
If Len(sTemp) = 0 Then ' user entered nothing
Exit Sub
End If
aTables = Split(sTemp, ",")
' of course you'll want to add more code to CYA in case the user
' asks for a table that's not there or otherwise enters something silly.
' You might also want to let them enter e.g. ALL if they want you to do all of them
' (but don't know how many there are)
For x = LBound(aTables) To UBound(aTables)
Set oTbl = ActiveDocument.Tables(CLng(aTables(x)))
' do [whatever] with table here
Debug.Print oTbl.Columns.Count & " " & oTbl.Rows.Count
Next
End Sub
I want to update Powerpoint Graph 2010 from Excel 2010.
Code looks for the Objects and finds the range with name similar in powerpoint, it applies changes to the graph. Graph format should be same only data must be updated.
Code is as follow, it is not able to find charts, either able to update it.
Option Explicit
Private Const NAMED_RANGE_PREFIX = "Export_"
Private Const NAMED_RANGE_PREFIX_TEXT = "ExportText"
Private m_sLog As String
Private Sub CommandButton1_Click()
On Error GoTo Catch
Dim pptApp As PowerPoint.Application
Dim pptPresentation As PowerPoint.Presentation
Dim pptSlide As PowerPoint.Slide
Dim pptShape As PowerPoint.Shape
Dim mgrChart As Chart
Dim mgrDatasheet As Graph.DataSheet
Dim rngData As Excel.Range
Dim iRow As Long, iCol As Long
Dim sTag As String
Dim nFound As Long, nUpdated As Long
Dim nFoundText As Long, nUpdatedText As Long
Dim i As Integer
Dim fLog As frmLog
Dim Box1Status As VbMsgBoxResult
m_sLog = ""
'Prompt to Export
Box1Status = MsgBox("Export and Save to Powerpoint Template?" & Chr(13) & "Reminder: Please use a clean template for export and be sure to back up the template beforehand. " & Chr(13) & Chr(13) & "PLEASE SAVE ANY OTHER OPEN POWERPOINT DOCUMENTS AS ALL UNSAVED WORK WILL BE LOST!", vbQuestion + vbYesNo, "Confirm Export")
If Box1Status = vbNo Then Exit Sub
i = 1
UpdateStatus "Opening Powerpoint presentation '" & Range("fileloc")
Set pptApp = New PowerPoint.Application
pptApp.Activate
Set pptPresentation = pptApp.Presentations.Open(Range("fileloc"))
pptApp.WindowState = ppWindowMinimized
'Looks for (tagged) charts to update
UpdateStatus "Searching presentation for charts..."
For Each pptSlide In pptPresentation.Slides
For Each pptShape In pptSlide.Shapes
If pptShape.Type = msoEmbeddedOLEObject Then
If TypeOf pptShape.OLEFormat.Object Is Graph.Chart Then
nFound = nFound + 1
Set mgrChart = pptShape.OLEFormat.Object
Set mgrChart = pptShape.Chart
Set mgrDatasheet = mgrChart.Application.DataSheet
With mgrDatasheet
sTag = .Cells(1, 1)
If Left(sTag, 6) = "Export" Then UpdateStatus "Found chart on slide '" & pptSlide.SlideNumber & "' with tag '" & sTag & "'. Searching Excel workbook for same tag..."
Set rngData = RangeForChart(sTag)
If rngData Is Nothing Then
' This chart has no data in this Excel workbook
If Left(sTag, 6) <> "Export" Then
UpdateStatus "Found chart on slide '" & pptSlide.SlideNumber & "' with no tag, skipping"
Else
UpdateStatus "'" & sTag & "' does not exist in workbook, skipping."
End If
Else
' Update the PowerPoint chart with the Excel data
UpdateStatus "Found '" & sTag & "' at named range '" & rngData.Name & "'. Updating presentation..."
.Cells.ClearContents
For iRow = 0 To rngData.Rows.Count - 1
For iCol = 0 To rngData.Columns.Count - 1
.Cells(iRow + 1, iCol + 1) = rngData.Cells(iRow + 1, iCol + 1)
Next iCol
Next iRow
.Application.Update
UpdateStatus "Chart with tag '" & sTag & "' updated."
nUpdated = nUpdated + 1
End If
End With
Set mgrDatasheet = Nothing
mgrChart.Application.Quit
Set mgrChart = Nothing
End If
'End If
Next pptShape
i = i + 1
Next pptSlide
UpdateStatus "Finished searching presentation. Closing PowerPoint."
pptPresentation.Save
pptPresentation.Close
Set pptPresentation = Nothing
pptApp.Quit
Set pptApp = Nothing
UpdateStatus "Done. " & nFound & " charts found and " & nUpdated & " charts updated. " & nFoundText & " text boxes found and " & nUpdatedText & " text boxes updated."
Set fLog = New frmLog
fLog.Caption = "Update of Powerpoint Template Complete"
fLog.txtLog.Text = m_sLog
fLog.Show
Unload fLog
Set fLog = Nothing
Exit Sub
Catch:
MsgBox "An unexpected error occurred while updating: " & Err.Number & " " & Err.Description, vbCritical
ForceCleanup mgrChart, mgrDatasheet, pptPresentation, pptApp
End Sub
Private Property Get RangeForChart(sTag As String) As Range
Dim sChartTag As String
Dim iUpdate As Long
Dim NameList As Range
'Dim nRow As Range
Set NameList = Range("Name_List")
If Left(sTag, 6) <> "Export" Then Exit Property
'For Each nRow In NameList.Rows
Do While sChartTag <> sTag
iUpdate = iUpdate + 1
' This will error if there is no named range for "Export_", which means that sTag does not
' exist in the workbook so return nothing
On Error Resume Next
sChartTag = ActiveWorkbook.Names(NAMED_RANGE_PREFIX & NameList(iUpdate, 1).Value).RefersToRange.Cells(1, 1)
If Err.Number <> 0 Then
' Return nothing
Exit Property
End If
On Error GoTo 0
Loop
'Next nRow
Set RangeForChart = ActiveWorkbook.Names(NAMED_RANGE_PREFIX & NameList(iUpdate, 1).Value).RefersToRange
End Property
Private Property Get RangeForText(sTag As String) As Range
Dim sTextTag As String
Dim iUpdate As Long
If Left(sTag, 10) <> "ExportText" Then Exit Property
Do While sTextTag <> sTag
iUpdate = iUpdate + 1
' This will error if there is no named range for "ExportText" & iUpdate, which means that sTag does not
' exist in the workbook so return nothing
On Error Resume Next
sTextTag = NAMED_RANGE_PREFIX_TEXT & iUpdate
If Err.Number <> 0 Then
' Return nothing
Exit Property
End If
On Error GoTo 0
Loop
Set RangeForText = ActiveWorkbook.Names(NAMED_RANGE_PREFIX_TEXT & iUpdate).RefersToRange
End Property
Private Sub UpdateStatus(sMessage As String)
m_sLog = m_sLog & Now() & ": " & sMessage & vbNewLine
Application.StatusBar = Now() & ": " & sMessage
DoEvents
End Sub
Private Sub ForceCleanup(mgrChart As Graph.Chart, mgrDatasheet As Graph.DataSheet, pptPresentation As PowerPoint.Presentation, pptApp As PowerPoint.Application)
On Error Resume Next
mgrChart.Application.Quit
Set mgrChart = Nothing
mgrDatasheet.Application.Quit
Set mgrDatasheet = Nothing
pptPresentation.Close
Set pptPresentation = Nothing
pptApp.Quit
Set pptApp = Nothing
End Sub
I don't think you need a bunch of code for this.
Build the charts in Excel, copy them, go to PowerPoint, use Paste Special - Link. Change the data in Excel, and the Excel charts update. Then open the PowerPoint presentation, and if necessary, update links.
In the data sheet for your powerpoint graph, you can "link" the cells to your excel data file by typing in one of the cells (path and file name are made up here)
=c:\PPTXfiles\excelfiles[excelfiles.xlsx]sheetname'!a1
This will create a link that doesn't show up in the links section of powerpoint, but can be updated just by opening both files and double clicking on the chart to activate it.
Sometime the paste by link feature isn't feasible to use since the end user of the file wants to "break it up" and send out parts. That is not possible without the source excel file, since the end users want to be able to edit the chart or the data.
If you can do this and then copy and paste the data sheet by values in VBA, before sending to the enduser that would be fantastic.
Bam!
Sub UpdateLinks()
Dim ExcelFile
Dim exl As Object
Set exl = CreateObject("Excel.Application")
'Open a dialog box to promt for the new source file.
ExcelFile = exl.Application.GetOpenFilename(, , "Select Excel File")
Dim i As Integer
Dim k As Integer
'Go through every slide
For i = 1 To ActivePresentation.Slides.Count
With ActivePresentation.Slides(i)
'Go through every shape on every slide
For k = 1 To .Shapes.Count
'Turn of error checking s that it doesn 't crash if the current shape doesn't already have a link
On Error Resume Next
'Set the source to be the same as teh file chosen in the opening dialog box
.Shapes(k).LinkFormat.SourceFullName = ExcelFile
If .Shapes(k).LinkFormat.SourceFullName = ExcelFile Then
'If the change was successful then also set it to update automatically
.Shapes(k).LinkFormat.Update
End If
On Error GoTo 0
Next k
End With
Next i
End Sub