Fairly new to VBA here. I'm attempting to write a piece of VBA that will essentially copy some data from an already open excel file and paste it into a forwarded email in HTML formatting. Creating the email is working fine, the problem is it seems to get stuck in an endless loop when retrieving the data from excel. It gets stuck on the line str = str & "" & c.Value & ""
It will clear through the first for r loop, but then gets stuck repeating on the second.
Here's the code:
Function GetExcelData() As String
Dim OrderColumn As Range, OrderRow As Range, r As Range, c As Range
Dim str As String
Dim xl As Excel.Application
Dim wb As Excel.Workbook
Dim ws As Excel.Worksheet
'Dim rn As Excel.Range
Set xl = GetObject(, "Excel.Application")
Set wb = xl.Workbooks("Book1")
Set ws = wb.Sheets(1)
ws.Activate
Set OrderColumn = ws.Range("A1", ws.Range("A1").End(xlDown))
str = "<table>"
For Each r In OrderColumn
str = str & "<tr>"
Set OrderRow = ws.Range(r, r.End(xlToRight))
For Each c In OrderRow
str = str & "<td>" & c.Value & "</td>"
Next c
str = str & "</tr>"
Next r
str = str & "</table>"
GetExcelData = str
End Function
Any help would be appreciated.
Thanks
Instead of composing an HTML markup for the Excel range you may consider using the Word object model for getting the job done. The WordEditor property of the Inspector class returns an instance of the Document class from the Word object model. See Chapter 17: Working with Item Bodies for more information.
Related
I have a macro allows me send emails of monthly performance to each manager. Codes are as follow:
Sub OutlookEmailsSend()
Dim objOutlook As Outlook.Application
Dim objMail As Outlook.MailItem
Dim lCounter As Long
Dim endColumnNo As Long
Dim a As Long
Dim sFile As String
endColumnNo = ThisWorkbook.Sheets("Sheet1").UsedRange.Columns.Count
Set objOutlook = Outlook.Application
For lCounter = 2 To 3
'
Set objMail = objOutlook.CreateItem(olMailItem)
objMail.To = Sheet1.Range("B" & lCounter).Value
objMail.Subject = "Sales Summary"
sFile = "Dear,<br><br>Please refer to below table for your performance<br><br><table border=1>"
For a = 1 To endColumnNo
sFile = sFile & "<tr><td>" & Cells(1, a) & "</td><td>" & Cells(lCounter, a) & "</td></tr>"
Next
objMail.HTMLBody = sFile
objMail.Display
Set objMail = Nothing
Next
End Sub
The macro produce table like this
Dear,
Please refer to below table for your performance
Name Tom
Email sgcjack#163.com
Item Phone
Sales 123
Bonus 3213
However, I would like the table presents as follow
Name Email Item Sales Bonus
Jack jacksun#citics.com.hk Computer 342 23123
Is there any way can do this?
For the sake of better readibility it might be helpful to organize the html creation in a function and to assign the function result to objMail.HTMLBody omitting the loops.
Btw you forgot the closing table tag </table> which wouldn't result in a valid html structure. - Of course, the most direct approach following the original code would be to follow the recommendation in comment to add the <tr>..</tr> tags outside the loop not forgetting the closing </table> tag.
With Sheet1
objMail.HTMLBody = getBody(.Range("A1",.Cells(1,EndColumnNo)),"Dear xx")`
End With
The help function getBody() joins (a) headers and (b) table data based on a (c) clearly defined table structure.
Note: You can play around and change that definition to a more sophisticated html code with separate header tags, too..
Function getBody(rng As Range, _
Optional greetings As String = "", _
Optional HeaderList As String = "Name,Email,Item,Sales,Bonus")
Const Blanks As String = " "
'a) get headers
Dim headers As String
headers = " <td>" & Replace(HeaderList, ",", "</td><td>") & "</td>"
'b) join table data "<td>..</td>"
Dim data As String
data = Blanks & _
Join(rng.Parent.Evaluate("""<td>""&" & rng.Address(0, 0) & " & ""</td>""") _
, vbNewLine & Blanks)
'c) define table structure
Dim tags()
tags = Array(greetings, _
"<table border='1'>", _
" <tr>", headers, " </tr>", _
" <tr>", data, " </tr>", _
"</table>")
'd) return joined function result
getBody = Join(tags, vbNewLine)
End Function
I've found this code that should find two matching pdf-filenames and merges them into 1 pdf-file always in the same order. File 1 then File 2.
The code matches filenames based on the first part of the filename, before the AnotherWord 2014.pdf or before SomeWord.pdf.
Example document name1: John Doe SomeWord.pdf
Example document name2: John Doe AnotherWord 2014.pdf
I use PDF reDirect Pro v2.5.2 (freeware) and a reference to the program.
The problem I have is that the line
Dim oPDF As New PDF_reDirect_v25002.Batch_RC_AXD
That gives me the error:
User-defined type not defined
How can I fix this?
This is the whole code:
Private Sub Knop0_Click()
'Only works with PDF reDirect Pro v2.5.2
'And needs to have a reference to PDF_reDirect_v2500 and PDF reDirect Pro Remote Control
Dim fs As Object
Dim fld As Object
Dim fld2 As Object
Dim objFile As Object
Dim objFile2 As Object
Set fs = CreateObject("Scripting.FileSystemObject")
Dim oPDF As New PDF_reDirect_v25002.Batch_RC_AXD
Dim TempBool As Boolean
Dim Files_to_Merge(1) As String
Dim ObjFileName() As String
Dim CellNameValue() As String
Dim ofn As String
Dim cnv As String
Dim i As Integer
Set fld = fs.GetFolder("C:\pdf")
Set fld2 = fs.GetFolder("C:\pdf\merged")
i = 1
For Each objFile In fld.files
For Each objFile2 In fld.files
CellNameValue() = Split(objFile.Name, " SomeWord.pdf")
cnv = CellNameValue(0)
ObjFileName() = Split(objFile2.Name, " AnotherWord 2014.pdf")
ofn = ObjFileName(0)
Files_to_Merge(1) = fld & "\" & ofn & " AnotherWord 2014.pdf"
Files_to_Merge(0) = fld & "\" & cnv & " SomeWord.pdf"
If StrComp(ofn, cnv) = 0 Then
With oPDF
TempBool = .Utility_Merge_PDF_Files(fld2 & "\" & ofn & " AnotherWord 2014.pdf", Files_to_Merge) 'The file merges here unless it generates an error and goes to If Not TempBool Then...
If Not TempBool Then
MsgBox "An Error Occured: etc."
Else
'Optional
End If
End With
End If
i = i + 1
Next objFile2
i = i + 1
Next objFile
Set oPDF = Nothing
End Sub
As I said in my comments this should work assuming your trial Pro version will still allow this feature.
You just have to make sure you're using the correct version of the object that has been registered on your system.
Can you delete the line Dim oPDF As New PDF_reDirect_v25002.Batch_RC_AXD and start retyping it from scratch - not copy/pasting? Does the Object for the tool show up in Intellisense as you start typing PDF_Re
Put in the object that it finds PDF_reDirect_v2500 if that's what it is - then type the . and start typing Batch to fill in the last part. You have to use the current version of the object reference.
Compile your code and see if gets past that line
I want to go through a document and find all center aligned text and delete it, I can setup formatted text on the find and replace tool, but when I record, it doesn't save formatting... does anyone know how to edit the basic code to do this?
also is the open office documentation compatible with libre office.
Recording in OpenOffice generates dispatcher code, which usually isn't very good. It's better to use the UNO API when writing macros. Here is some code that does what you want:
Sub DeleteCenteredLines
oDoc = ThisComponent
Dim vDescriptor, vFound
' Create a descriptor from a searchable document.
vDescriptor = oDoc.createSearchDescriptor()
' Set the text for which to search and other
With vDescriptor
.searchString = ""
.searchAll=True
End With
Dim srchAttributes(0) As New com.sun.star.beans.PropertyValue
srchAttributes(0).Name = "ParaAdjust"
srchAttributes(0).Value = com.sun.star.style.ParagraphAdjust.CENTER
vDescriptor.SetSearchAttributes(srchAttributes())
' Find the first one
vFound = oDoc.findFirst(vDescriptor)
Do While Not IsNull(vFound)
vFound.setPropertyValue("ParaAdjust", com.sun.star.style.ParagraphAdjust.LEFT)
oTC = oDoc.Text.createTextCursorByRange(vFound)
oTC.gotoStartOfParagraph(false)
oTC.gotoEndOfParagraph(true)
oTC.String = ""
oTC.goRight(1,true)
oTC.String = ""
vFound = oDoc.findNext( vFound.End, vDescriptor)
Loop
End Sub
Check out http://www.pitonyak.org/AndrewMacro.odt for examples of many common tasks. In my experience, looking for examples in this document is usually easier than trying to record macros and make sense of what was recorded.
This works for OpenOffice as well as LibreOffice. Generally the API is the same for both.
My solution which replaces strings in italic and superscript to tags.
(it is extremly slow. Maybe someone can improve it)
Sub replace_italico_sobrescrito_por_tag()
MsgBox "It takes long to run."
Dim vartemp As String
theDoc = thisComponent
iSheetsCount = theDoc.Sheets.Count
Dim theCell As Object, rText As String, textSlice As String, textItalic As Long, textSup As Integer
Dim theParEnum As Object, theParElement As Object
Dim theSubEnum As Object, theSubElement As Object
For k=0 to iSheetsCount-1
Sheet = theDoc.getSheets().getByIndex(k)
dim pX as integer, pY as integer, maxcol as integer, maxrow as integer
maxcol = 100
maxrow = 500
For pX=0 to maxrow
For pY=0 to maxcol
theCell = Sheet.GetCellByPosition(pX, pY)
theParEnum = theCell.GetText().CreateEnumeration
rText = ""
Do While theParEnum.HasMoreElements
theParElement = theParEnum.NextElement
theSubEnum = theParElement.CreateEnumeration
Do While theSubEnum.HasMoreElements
textSlice = ""
theSubElement = theSubEnum.NextElement
If theCell.Type = 2 Then
textSlice = theSubElement.String
textItalic = theSubElement.CharPosture
textSup = theSubElement.CharEscapement
Else
textSlice = theCell.String
End If
If theSubElement.CharPosture >= 1 Then
textSlice = "<i>" & textSlice & "</i>"
End If
If theSubElement.CharEscapement > 0 Then
textSlice = "<sup>" & textSlice & "</sup>"
End If
rText = rText & textSlice
Loop
Loop
theCell.String=rText
Next pY
Next pX
Next k
MsgBox "End"
End Sub
Is there a way of taking html code for a table and printing out the same table in a word document using VBA (VBA should be able to parse the html code block for a table)?
It is possible to take the contents of the table and copy them into a new table created in Word, however is it possible to recreate a table using the html code and vba?
For any of this, where can one begin to research?
EDIT:
Thanks to R3uK: here is the first portion of the VBA script which reads a line of html code from a file and uses R3uK's code to print it to the excel worksheet:
Private Sub button1_Click()
Dim the_string As String
the_string = Trim(ImportTextFile("path\to\file.txt"))
' still working on removing new line characters
Call PrintHTML_Table(the_string)
End Sub
Public Function ImportTextFile(strFile As String) As String
' http://mrspreadsheets.com/1/post/2013/09/vba-code-snippet-22-read-entire-text-file-into-string-variable.html
Open strFile For Input As #1
ImportTextFile = Input$(LOF(1), 1)
Close #1
End Function
' Insert R3uK's portion of the code here
This could be a good place to start, you will only need to check content after to see if there is any problem and then copy it to word.
Sub PrintHTML_Table(ByVal StrTable as String)
Dim TA()
Dim Table_String as String
Table_String = " " & StrTable & " "
TA = SplitTo2DArray(Table_String, "</tr>", "</td>")
For i = LBound(TA, 1) To UBound(TA, 1)
For j = LBound(TA, 2) To UBound(TA, 2)
ActiveSheet.Cells(i + 1, j + 1) = Trim(Replace(Replace(TA(i, j), "<td>", ""), "<tr>", ""))
Next j
Next i
End Sub
Public Function SplitTo2DArray(ByRef StringToSplit As String, ByRef RowSep As String, ByRef ColSep As String) As String()
Dim Rows As Variant
Dim rowNb As Long
Dim Columns() As Variant
Dim i As Long
Dim maxlineNb As Long
Dim lineNb As Long
Dim asCells() As String
Dim j As Long
' Split up the table value by rows, get the number of rows, and dim a new array of Variants.
Rows = Split(StringToSplit, RowSep)
rowNb = UBound(Rows)
ReDim Columns(0 To rowNb)
' Iterate through each row, and split it into columns. Find the maximum number of columns.
maxlineNb = 0
For i = 0 To rowNb
Columns(i) = Split(Rows(i), ColSep)
lineNb = UBound(Columns(i))
If lineNb > maxlineNb Then
maxlineNb = lineNb
End If
Next i
' Create a 2D string array to contain the data in <Columns>.
ReDim asCells(0 To maxlineNb, 0 To rowNb)
' Copy all the data from Columns() to asCells().
For i = 0 To rowNb
For j = 0 To UBound(Columns(i))
asCells(j, i) = Columns(i)(j)
Next j
Next i
SplitTo2DArray = asCells()
End Function
Question from a amatuer scripter with informal coding background:
I've researched this on stack, msdn, random scripting websites but can't seem to glean a concrete solution. So please be advised this request for help is a last resort even if the solution is simple.
To put it simply, I'm trying to call a function that parses the last modified date of a file into an array of date formats. The filepath is the function parameter. These files are .vbs files in a client-side testing environment. This will be apparent if you look at the script.
My best guess is the "name redefined" error has something to do global variables being Dim'd in some way that's throwing the error.
Anyway, here's the calling sub:
Option Explicit
'=============================
'===Unprocessed Report========
'=============================
'*****Inputs: File Path*********************
dim strFolderPath, strFilename, strReportName, strFileExt, FullFilePath
strFolderPath = "C:\Users\C37745\Desktop\"
strFilename = "UNPROCESSED_REPORT"
strReportName = "Unprocessed"
strFileExt = ".xlsx"
'************************************
FullFilePath = strFolderPath & strFilename & strFilename & strFileExt
'************************************
Sub Include(MyFile)
Dim objFSO, oFileBeingReadIn ' define Objects
Dim sFileContents ' define Strings
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set oFileBeingReadIn = objFSO.OpenTextFile(MyFile, 1)
sFileContents = oFileBeingReadIn.ReadAll
oFileBeingReadIn.Close
ExecuteGlobal sFileContents
End Sub
Include "C:\Users\C37745\Desktop\VBStest\OtherTest\TEST_DLM.vbs"
''''''''''FOR TESTING''''''''''''''
Dim FilePath, varTEST
strFilePath = FullFilePath
varTEST = ParseDLMToArray(strFilePath)
msgbox varTESTtemp(0)
'''''''''''''''''''''''''''''''''
Here's the function I'm trying to call (or read, I guess):
Function ParseDLMtoArray(strFilePath)
Dim strFilePath, dlmDayD, dlmMonthM, dlmYearYY, dlmYearYYYY, DateFormatArray, dateDLM
Dim objFSO, File_Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set File_Object = objFSO.GetFile(strFilePath)
dateDLM = File_object.DateLastModified
dlmDayD = Day(dateDLM)
dlmMonthM = Month(dateDLM)
dlmYearYY = Right(Year(dateDLM),2)
dlmYearYYYY = Year(dateDLM)
'Adds a leading zero if a 1-digit month is detected
If(Len(Month(dlmDayD))=1) Then
dlmmonthMM ="0"& dlmMonthM
Else
dlmMonthMM = dlmMonthM
End If
'Adds a leading zero if a 1-digit day is detected
If(Len(Day(dlmDayD))=1) Then
dlmDayDD = "0" & dlmDayD
Else
dlmDayDD = dlmDayD
End If
varDLM_mmyyyy = dlmMonthMM & dlmYearYYYY
varDLM_mmddyy = dlmMonthMM & dlmDayDD & dlmYearYY
varDLM_mmddyyyy = dlmMonthMM & dlmDayDD & dlmYearYYYY
DateFormatArray = Array( _
varDLM_mmyyyy, _
varDLM_mmddyy, _
varDLM_mmddyyyy _
)
ParseDLMtoArray = DateFormatArray
End Function
Any advice is appreciated, including general feedback on best practices if you see an issue there. Thanks!
Your
Function ParseDLMtoArray(strFilePath)
Dim strFilePath
...
tries to declare/define strFilePath again. That obviously can't be allowed, because it would be impossible to decide whether that variable should contain Empty (because of the Dim) or the argument you passed.
At a first glance at your code, you can just delete the Dim strFilePath.