I want to screen a lot of websites quickly using VBA. I have to have a quick look at them myself, so I basically just need my code to search for a new URL every other second in the same tab.
The existing VBA code I use is:
Sub test
End = Range("A2:C2").End(xlDown).Row
Dim chromepath As String
chromepath = """chrome.exe"""
Dim Weburl As String
Dim I As Integer
For I = 2 To end
Application.Wait (Now + TimeValue("0:00:02"))
Weburl = Cells(I, 1).Value & """"
Shell (chromepath & " -url " & Cells(I, 1))
end sub
The issue I am having is that it opens a lot of tabs, instead of searching in the same tab every other second. Has anyone found a solution for this?
Related
Since I am not able to save the files in internet explorer, I`m trying to copy the links to google chrome because it downloades automatically. Only problem is that the links are not working or I am not using the proper references.
If I turn on the msgbox it will give me the exact url that I need but It doesn't work when I enter it in the shell line. What am I doing wrong here? Discard the code below downloadfiles, this was a first attempt to store all the links and save them all at once (but I can`t even save 1 file)
Dim allHREFs As New Collection
Dim TableName As String
For iRow = 0 To 1
TableName = "docTypeForm:documentTbl:" & iRow & ":j_idt250"
On Error GoTo DownloadFiles
Set allLinks = obJIE.Document.getElementById(TableName).getElementsByTagName("a")
For Each link In allLinks
allHREFs.Add link.href
testing = link.href
'MsgBox testing
Shell ("C:\Program Files (x86)\Google\Chrome\Application\Chrome.exe" & " testing")
Next link
Next iRow
DownloadFiles:
'For j = 1 To allHREFs.Count
'obJIE.Navigate Url + allHREFs(j)
'Application.Wait (Now + TimeValue("0:00:04"))
'Next
I have a userform which I input information into, one of the inputs are called webpage and I want to open the webpage for each item I input into the userform when I click a command button.
Sheets("Data").Range("DataStart").Offset(TargetRow, 10).Value = Webpage
MyForm.Webpage = Sheets("Data").Range("DataStart").Offset(TargetRow, 10).Value
I am trying to use follow.hyperlink
Private Sub Webpage_Click()
Dim webpage As String
Set webpage = MyForm.Webpage = Sheets("Data").Range("DataStart").Offset(TargetRow, 10).Value
ActiveWorkbook.FollowHyperlink Address:="webpage"
End Sub
This doesn´t work.
ActiveWorkbook.FollowHyperlink Address:=webpage
no quotes
You can also use the Shell to open a specific browser, if required:
Sub Open_HyperLinks()
Dim browserPath As String
Dim linkURL As String
browserPath = Environ("PROGRAMFILES(X86)") & "\Mozilla Firefox\firefox.exe"
linkURL = Cells(1, 1).Value
Shell browserPath & " -url " & linkURL
End Sub
I am trying to extract the data from a PDF document into a worksheet. The PDFs show and text can be manually copied and pasted into the Excel document.
I am currently doing this through SendKeys and it is not working. I get an error when I try to paste the data from the PDF document. Why is my paste not working? If I paste after the macro has stopped running it pastes as normal.
Dim myPath As String, myExt As String
Dim ws As Worksheet
Dim openPDF As Object
'Dim pasteData As MSForms.DataObject
Dim fCell As Range
'Set pasteData = New MSForms.DataObject
Set ws = Sheets("DATA")
If ws.Cells(ws.Rows.Count, "A").End(xlUp).Row > 1 Then Range("A3:A" & ws.Cells(ws.Rows.Count, "A").End(xlUp).Row).ClearContents
myExt = "\*.pdf"
'When Scan Receipts Button Pressed Scan the selected folder/s for receipts
For Each fCell In Range(ws.Cells(1, 1), ws.Cells(1, ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column))
myPath = Dir(fCell.Value & myExt)
Do While myPath <> ""
myPath = fCell.Value & "\" & myPath
Set openPDF = CreateObject("Shell.Application")
openPDF.Open (myPath)
Application.Wait Now + TimeValue("00:00:2")
SendKeys "^a"
Application.Wait Now + TimeValue("00:00:2")
SendKeys "^c"
'Application.Wait Now + TimeValue("00:00:2")
ws.Select
ActiveSheet.Paste
'pasteData.GetFromClipboard
'ws.Cells(3, 1) = pasteData.GetText
Exit Sub
myPath = Dir
Loop
Next fCell
You can open the PDF file and extract its contents using the Adobe library (which I believe you can download from Adobe as part of the SDK, but it comes with certain versions of Acrobat as well)
Make sure to add the Library to your references too (On my machine it is the Adobe Acrobat 10.0 Type Library, but not sure if that is the newest version)
Even with the Adobe library it is not trivial (you'll need to add your own error-trapping etc):
Function getTextFromPDF(ByVal strFilename As String) As String
Dim objAVDoc As New AcroAVDoc
Dim objPDDoc As New AcroPDDoc
Dim objPage As AcroPDPage
Dim objSelection As AcroPDTextSelect
Dim objHighlight As AcroHiliteList
Dim pageNum As Long
Dim strText As String
strText = ""
If (objAvDoc.Open(strFilename, "") Then
Set objPDDoc = objAVDoc.GetPDDoc
For pageNum = 0 To objPDDoc.GetNumPages() - 1
Set objPage = objPDDoc.AcquirePage(pageNum)
Set objHighlight = New AcroHiliteList
objHighlight.Add 0, 10000 ' Adjust this up if it's not getting all the text on the page
Set objSelection = objPage.CreatePageHilite(objHighlight)
If Not objSelection Is Nothing Then
For tCount = 0 To objSelection.GetNumText - 1
strText = strText & objSelection.GetText(tCount)
Next tCount
End If
Next pageNum
objAVDoc.Close 1
End If
getTextFromPDF = strText
End Function
What this does is essentially the same thing you are trying to do - only using Adobe's own library. It's going through the PDF one page at a time, highlighting all of the text on the page, then dropping it (one text element at a time) into a string.
Keep in mind what you get from this could be full of all kinds of non-printing characters (line feeds, newlines, etc) that could even end up in the middle of what look like contiguous blocks of text, so you may need additional code to clean it up before you can use it.
Hope that helps!
I know this is an old issue but I just had to do this for a project at work, and I am very surprised that nobody has thought of this solution yet:
Just open the .pdf with Microsoft word.
The code is a lot easier to work with when you are trying to extract data from a .docx because it opens in Microsoft Word. Excel and Word play well together because they are both Microsoft programs. In my case, the file of question had to be a .pdf file. Here's the solution I came up with:
Choose the default program to open .pdf files to be Microsoft Word
The first time you open a .pdf file with word, a dialogue box pops up claiming word will need to convert the .pdf into a .docx file. Click the check box in the bottom left stating "do not show this message again" and then click OK.
Create a macro that extracts data from a .docx file. I used MikeD's Code as a resource for this.
Tinker around with the MoveDown, MoveRight, and Find.Execute methods to fit the need of your task.
Yes you could just convert the .pdf file to a .docx file but this is a much simpler solution in my opinion.
Over time, I have found that extracting text from PDFs in a structured format is tough business. However if you are looking for an easy solution, you might want to consider XPDF tool pdftotext.
Pseudocode to extract the text would include:
Using SHELL VBA statement to extract the text from PDF to a temporary file using XPDF
Using sequential file read statements to read the temporary file contents into a string
Pasting the string into Excel
Simplified example below:
Sub ReadIntoExcel(PDFName As String)
'Convert PDF to text
Shell "C:\Utils\pdftotext.exe -layout " & PDFName & " tempfile.txt"
'Read in the text file and write to Excel
Dim TextLine as String
Dim RowNumber as Integer
Dim F1 as Integer
RowNumber = 1
F1 = Freefile()
Open "tempfile.txt" for Input as #F1
While Not EOF(#F1)
Line Input #F1, TextLine
ThisWorkbook.WorkSheets(1).Cells(RowNumber, 1).Value = TextLine
RowNumber = RowNumber + 1
Wend
Close #F1
End Sub
Since I do not prefer to rely on external libraries and/or other programs, I have extended your solution so that it works.
The actual change here is using the GetFromClipboard function instead of Paste which is mainly used to paste a range of cells.
Of course, the downside is that the user must not change focus or intervene during the whole process.
Dim pathPDF As String, textPDF As String
Dim openPDF As Object
Dim objPDF As MsForms.DataObject
pathPDF = "C:\some\path\data.pdf"
Set openPDF = CreateObject("Shell.Application")
openPDF.Open (pathPDF)
'TIME TO WAIT BEFORE/AFTER COPY AND PASTE SENDKEYS
Application.Wait Now + TimeValue("00:00:2")
SendKeys "^a"
Application.Wait Now + TimeValue("00:00:2")
SendKeys "^c"
Application.Wait Now + TimeValue("00:00:1")
AppActivate ActiveWorkbook.Windows(1).Caption
objPDF.GetFromClipboard
textPDF = objPDF.GetText(1)
MsgBox textPDF
If you're interested see my project in github.
Copying and pasting by user interactions emulation could be not reliable (for example, popup appears and it switches the focus). You may be interested in trying the commercial ByteScout PDF Extractor SDK that is specifically designed to extract data from PDF and it works from VBA. It is also capable of extracting data from invoices and tables as CSV using VB code.
Here is the VBA code for Excel to extract text from given locations and save them into cells in the Sheet1:
Private Sub CommandButton1_Click()
' Create TextExtractor object
' Set extractor = CreateObject("Bytescout.PDFExtractor.TextExtractor")
Dim extractor As New Bytescout_PDFExtractor.TextExtractor
extractor.RegistrationName = "demo"
extractor.RegistrationKey = "demo"
' Load sample PDF document
extractor.LoadDocumentFromFile ("c:\sample1.pdf")
' Get page count
pageCount = extractor.GetPageCount()
Dim wb As Workbook
Dim ws As Worksheet
Dim TxtRng As Range
Set wb = ActiveWorkbook
Set ws = wb.Sheets("Sheet1")
For i = 0 To pageCount - 1
RectLeft = 10
RectTop = 10
RectWidth = 100
RectHeight = 100
' check the same text is extracted from returned coordinates
extractor.SetExtractionArea RectLeft, RectTop, RectWidth, RectHeight
' extract text from given area
extractedText = extractor.GetTextFromPage(i)
' insert rows
' Rows(1).Insert shift:=xlShiftDown
' write cell value
Set TxtRng = ws.Range("A" & CStr(i + 2))
TxtRng.Value = extractedText
Next
Set extractor = Nothing
End Sub
Disclosure: I am related to ByteScout
Using Bytescout PDF Extractor SDK is a good option. It is cheap and gives plenty of PDF related functionality. One of the answers above points to the dead page Bytescout on GitHub. I am providing a relevant working sample to extract table from PDF. You may use it to export in any format.
Set extractor = CreateObject("Bytescout.PDFExtractor.StructuredExtractor")
extractor.RegistrationName = "demo"
extractor.RegistrationKey = "demo"
' Load sample PDF document
extractor.LoadDocumentFromFile "../../sample3.pdf"
For ipage = 0 To extractor.GetPageCount() - 1
' starting extraction from page #"
extractor.PrepareStructure ipage
rowCount = extractor.GetRowCount(ipage)
For row = 0 To rowCount - 1
columnCount = extractor.GetColumnCount(ipage, row)
For col = 0 To columnCount-1
WScript.Echo "Cell at page #" +CStr(ipage) + ", row=" & CStr(row) & ", column=" & _
CStr(col) & vbCRLF & extractor.GetCellValue(ipage, row, col)
Next
Next
Next
Many more samples available here: https://github.com/bytescout/pdf-extractor-sdk-samples
To improve the solution of Slinky Sloth I had to add this beforere get from clipboard :
Set objPDF = New MSForms.DataObject
Sadly it didn't worked for a pdf of 10 pages.
This doesn't seem to work with the Adobe Type library. As soon as it gets to Open, I get a 429 error. Acrobat works fine though...
I have created a simple spreadsheet in Excel 2010 containing a form that loads as the spreadsheet opens. The employee fills out the required form data and presses a "Save" button macro utilizing the SaveAs method.
My question is if it possible to disable the form in the saved copy? The reason is that I would like to avoid the form to load when our bookkeeping department opens the copy to review the data.
To clarify this is how my vba code is
Sub SaveAsButton()
Dim applicationUserName As String
Dim saveLocation As String
Dim fileName As String
Dim weekNo As String
Dim year As String
weekNo = ThisWorkbook.Sheets("Service").Range("M4").Value
Debug.Print (weekNo)
year = ThisWorkbook.Sheets("Service").Range("R4").Value
Debug.Print (year)
applicationUserName = Application.UserName
Debug.Print (applicationUserName)
saveLocation = "w:\Service Users\" & applicationUserName & "\Service\"
Debug.Print (saveLocation)
fileName = "Service" & "-" & weekNo & "-" & year & "-" & applicationUserName
Debug.Print (fileName)
fileName = Replace(fileName, " ", "")
Debug.Print (fileName)
ThisWorkbook.SaveAs (saveLocation & fileName)
End Sub
Thank you.
If you don't need any code in the final workbook you could simply save as .xlsx and thereby remove all the vb components
You may want to use CustomProperties for that.
First, create a CustomProperty:
ActiveWorkbook.CustomDocumentProperties.Add "Saved", False, msoPropertyTypeNumber, 0
Change the value of the CustomProperty to 1 when user saves the form (add the following code to SaveAsButton()):
ActiveWorkbook.CustomDocumentProperties("Saved").Value = 1
Add a check if ActiveWorkbook.CustomDocumentProperties("Saved").Value = 0 to the method which opens the form.
I wrote a Macro, which should take two Dates (dd.mm.yyyy) as a String from a table in an OpenOffice Document (Writer, not Calc). These two Dates should be merged to this:
ddmmyyyy-ddmmyyyy. This should be used as the filename then.
The Table has only one row and 6 columns, the first Date being in table2:D1:D1 and the second one in table2:F1:F1.
I "translated" this to table2(1, 4) and table2(1, 6)
This German site is doing what I want to do, but with spreadsheets in a OOCalc Document and not OOWriter.
Enough talk, here is my code:
sub save
oDoc=thisComponent
sStartDate = oDoc.Table2(1, 4)
sEndDate = oDoc.Table2(1, 6))
sFilename = sStartDate.String & sEndDate.String
sURL = ConvertToURL("file:///home/cp/Documents/" & sFilename & ".odt")
msgbox sURL
' oDoc.StoreAsURL(sURL, Array())
end sub
Yes, I run linux, so the path should be correct.
When I try to run this script it says:
Property or Method not found table2
I of course tried google but somehow I could not find a solution. A hint in the right direction could be enough, I also guessed I have to write "more":
sStartDate = oDoc.getString(table2(1, 4))
or something similar. Didnt work either. Another thing I tried was using (0, 3) instead of (1, 4).
Well I would appreciate it, if someone could help me a bit! :)
And I hope I have done everything right how I posted here.
Vaelor
EDIT:
I have now modified the script to this, according to the PDF found HERE in chapter 14.9.
It now looks like this,
sub save
oDoc=thisComponent
Dim oTable
Dim sTableName As String
sTableName = "Table2"
oTable = oDoc.getTextTables().getByName(sTableName)
' oTable = oTables.getByName(sTableName)
sStartDate = oTable.getCellByPosition(0, 3)
sEndDate = oTable.getCellByPosition(0, 5)
sFilename = sStartDate.String & sEndDate.String
sURL = ConvertToURL("file:///home/cp/Documents/" & sFilename & ".odt")
msgbox sURL
' oDoc.StoreAsURL(sURL, Array())
end sub
But, still not working. Now I get this exception IndexOutOfBoundsException.
(I wanted to link it, but it says, I cant post more than 2 links :-( )
My first thought was I had to change the cels to 0, 3 and 0, 5. After changing that, the error still occurs. :-(
Edit2:
Since I got no response, I think I will try this in Python, maybe it yields better results.
This code demonstrates how to locate a text table with the given name and how to access individual cells.
function get_table_by_name(name as string) as object
dim oenum as object
dim oelem as object
oenum = thisComponent.text.createEnumeration
while oenum.hasMoreelements
oelem = oenum.nextElement
if oelem.supportsService("com.sun.star.text.TextTable") then
if oelem.Name = name then
get_table_by_name = oelem
exit function
end if
end if
wend
end function
Sub Main
dim table as object
table = get_table_by_name("Table1")
if not isNull(table) then
msgbox "Got " & table.Name & " " & table.getRows().getCount() & "x" & table.getColumns().getCount()
msgbox "Cell[0,0] is " & table.getCellByPosition(0, 0).getString()
end if
End Sub