need to find every table in ms word and need to html table code through VBA
example
to
The following code will generate a variable Html with a simple table structure for each table found in your document.
Option Explicit
Sub Tables2HTML()
Dim Tbl As Table
Dim R As Row
Dim C As Cell
Dim T As String
Dim Html As String
Html = ""
For Each Tbl In ActiveDocument.Tables
Html = Html & "<table>"
For Each R In Tbl.Rows
Html = Html & "<tr>"
For Each C In R.Cells
T = Replace(C.Range.Text, Chr(7), "")
Html = Html & "<td>" & T & "</td>"
Next
Html = Html & "</tr>"
Next
Html = Html & "</table>"
Next
' Now do what you need with the 'Html' variable. Export it to a file, print it, whatever :)
End Sub
I have not added any file saving code, or other outputs. You can simply use Debug.Print Html to test the result.
Related
I have a seemingly trivial VBA task. However, I do not normally use VBA and almost never in the context of Microsoft Word. I have a Word form that utilizes Content Control fields (as well as a few ActiveX radio buttons) and need to test it by printing a time stamp and completed form entries to a comma delimited file. When I run the following code:
Sub WriteToText()
Dim DataFile As String
Dim StrData As String
Dim CCtrl As ContentControl
Dim bControl_Exists As Boolean
DataFile = "C:\Users\Annabanana\Documents\Data.txt"
StrData = "": Open DataFile For Append As #1
StrData = Format(Now, "DD-MMM-YYYY hh:mm:ss")
With Application.ActiveDocument
bControl_Exists = .Saved
For Each CCtrl In ThisDocument.ContentControls
With CCtrl
Select Case .Type
Case Is = wdContentControlCheckBox
StrData = StrData & "," & .Checked
Case wdContentControlDate, wdContentControlDropdownList, wdContentControlComboBox, wdContentControlText
StrData = StrData & "," & .Range.Text
Case Else
End Select
End With
Next
End With
Print #1, StrData: Close #1
End Sub
I get the datestamp but nothing else. Ideally I would like to eventually print field tags and their corresponding values as such:
Tag1 Value1
Tag2 Value2
Tag3 Value3
.............
Eventually all of those would print to a database, but at this point I just want to be able to see how the data comes out of the form and how I need to transform it prior to loading. Any advice is greatly appreciated. Thank you.
At its heart, you problem comes down to the misuse of ThisDocument. Try:
Sub GetCCtrlData()
Dim CCtrl As ContentControl, StrData As String, DataFile As String
StrData = Format(Now, "DD-MMM-YYYY hh:mm:ss")
DataFile = "C:\Users\" & Environ("UserName") & "\Documents\Data.txt"
For Each CCtrl In ActiveDocument.ContentControls
With CCtrl
StrData = StrData & vbTab & .Title & "|" & .Tag & ": "
Select Case .Type
Case Is = wdContentControlCheckBox
StrData = StrData & .Checked
Case wdContentControlDate, wdContentControlDropdownList, wdContentControlRichText, wdContentControlText
StrData = StrData & .Range.Text
Case Else
End Select
End With
Next
Open DataFile For Append As #1: Print #1, StrData: Close #1
End Sub
The above code also exports the content control titles and tags, using tab-delimiters instead of commas. Using tab-delimiters allows for the possibility there might be commas in the data.
At some stage, I imagine, you'll want to process multiple documents. For that, see: http://www.vbaexpress.com/forum/showthread.php?40406-Extracting-Word-form-Data-and-exporting-to-Excel-spreadsheet&p=257696&viewfull=1#post257696. Although the code there extracts the data to an Excel workbook, the underlying principles are the same.
I am trying to create a vba program in excel that exports the user entered data to XML format, so far I have the following:
Below image shows 4 columns
Student Id
Student Name
Student Age
Student Mark
The Export button opens a popup that let the user choose the location of the output xml file with a Convert button
Once the user clicked on the Convert button, the below xml data is generated into the default.xml file
<?xml version="1.0"?>
<data>
<student><id>1</id>
<name>Jad</name>
<age>25</age>
<mark>17</mark>
</student>
</data>
The output seems fine to me so far, but I am looking to add more functionalities, I am trying to add a "Mark" column dynamically on user button click as shown below
Once the user clicks on Add Mark, a new column will appear in order to let the user enter a new grade, or it is better if we can place the new column in a separate form, for example we may add an additional field named Material Name, so on each button click 2 fields will appear Material Name and Material Mark), the expected excel sheet may be something like the below
the expected output of the xml file may be something like the below
<?xml version="1.0"?>
<data>
<student><id>1</id>
<name>Jad</name>
<age>25</age>
<materials>
<material>
<name>Maths</name>
<mark>17</marks>
</material>
<material>
<name>Physics</name>
<mark>18</marks>
</material>
</materials>
</student>
</data>
The function I am used to generate XML file is shown below
Function fGenerateXML(rngData As Range, rootNodeName As String) As String
'===============================================================
' XML Tags
' Table
Const HEADER As String = "<?xml version=""1.0""?>"
Dim TAG_BEGIN As String
Dim TAG_END As String
Const NODE_DELIMITER As String = "/"
'===============================================================
Dim intColCount As Integer
Dim intRowCount As Integer
Dim intColCounter As Integer
Dim intRowCounter As Integer
Dim rngCell As Range
Dim strXML As String
' Initial table tag...
TAG_BEGIN = vbCrLf & "<" & rootNodeName & ">"
TAG_END = vbCrLf & "</" & rootNodeName & ">"
strXML = HEADER
strXML = strXML & TAG_BEGIN
With rngData
' Discover dimensions of the data we
' will be dealing with...
intColCount = .Columns.Count
intRowCount = .Rows.Count
Dim strColNames() As String
ReDim strColNames(intColCount)
' First Row is the Field/Tag names
If intRowCount >= 1 Then
' Loop accross columns...
For intColCounter = 1 To intColCount
' Mark the cell under current scrutiny by setting
' an object variable...
Set rngCell = .Cells(1, intColCounter)
' Is the cell merged?..
If Not rngCell.MergeArea.Address = _
rngCell.Address Then
MsgBox ("!! Cell Merged ... Invalid format")
Exit Function
End If
strColNames(intColCounter) = rngCell.Text
Next
End If
Dim Nodes() As String
Dim NodeStack() As String
' Loop down the table's rows
For intRowCounter = 2 To intRowCount
strXML = strXML & vbCrLf & TABLE_ROW
ReDim NodeStack(0)
' Loop accross columns...
For intColCounter = 1 To intColCount
' Mark the cell under current scrutiny by setting
' an object variable...
Set rngCell = .Cells(intRowCounter, intColCounter)
' Is the cell merged?..
If Not rngCell.MergeArea.Address = _
rngCell.Address Then
MsgBox ("!! Cell Merged ... Invalid format")
Exit Function
End If
If Left(strColNames(intColCounter), 1) = NODE_DELIMITER Then
Nodes = Split(strColNames(intColCounter), NODE_DELIMITER)
' check whether we are starting a new node or not
Dim i As Integer
Dim MatchAll As Boolean
MatchAll = True
For i = 1 To UBound(Nodes)
If i <= UBound(NodeStack) Then
If Trim(Nodes(i)) <> Trim(NodeStack(i)) Then
'not match
'MsgBox (Nodes(i) & "," & NodeStack(i))
MatchAll = False
Exit For
End If
Else
MatchAll = False
Exit For
End If
Next
' add close tags to those not used afterwards
' don't count it when no content
If Trim(rngCell.Text) <> "" Then
If MatchAll Then
strXML = strXML & "</" & NodeStack(UBound(NodeStack)) & ">" & vbCrLf
Else
For t = UBound(NodeStack) To i Step -1
strXML = strXML & "</" & NodeStack(t) & ">" & vbCrLf
Next
End If
If i < UBound(Nodes) Then
For t = i To UBound(Nodes)
' add to the xml
strXML = strXML & "<" & Nodes(t) & ">"
If t = UBound(Nodes) Then
strXML = strXML & Trim(rngCell.Text)
End If
Next
Else
t = UBound(Nodes)
' add to the xml
strXML = strXML & "<" & Nodes(t) & ">"
strXML = strXML & Trim(rngCell.Text)
End If
NodeStack = Nodes
Else
' since its a blank field, so no need to handle if field name repeated
If Not MatchAll Then
For t = UBound(NodeStack) To i Step -1
strXML = strXML & "</" & Trim(NodeStack(t)) & ">" & vbCrLf
Next
End If
ReDim Preserve NodeStack(i - 1)
End If
' the last column
If intColCounter = intColCount Then
' add close tags to those not used afterwards
If UBound(NodeStack) <> 0 Then
For t = UBound(NodeStack) To 1 Step -1
strXML = strXML & "</" & Trim(NodeStack(t)) & ">" & vbCrLf
Next
End If
End If
Else
' add close tags to those not used afterwards
If UBound(NodeStack) <> 0 Then
For t = UBound(NodeStack) To 1 Step -1
strXML = strXML & "</" & Trim(NodeStack(t)) & ">" & vbCrLf
Next
End If
ReDim NodeStack(0)
' skip if no content
If Trim(rngCell.Text) <> "" Then
strXML = strXML & "<" & Trim(strColNames(intColCounter)) & ">" & Trim(rngCell.Text) & "</" & Trim(strColNames(intColCounter)) & ">" & vbCrLf
End If
End If
Next
Next
End With
strXML = strXML & TAG_END
' Return the HTML string...
fGenerateXML = strXML
End Function
For more info you can refer to this link https://www.codeproject.com/Articles/6950/Export-Excel-to-XML-in-VBA
Please let me know if you have any suggestions.
It appears the XML Generator you are using already has a function to dynamically search for values until it reaches the last column.
Assuming we only have to modify the first row, it would be as simple as adding a new header to the last empty column
Here are two macros as an example:
Sub ButtonClick()
Call Add_XML_Header("/student/mark")
End Sub
Sub Add_XML_Header(Header As String)
Dim LastColumn As Integer
LastColumn = ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column
ActiveSheet.Cells(1, LastColumn + 1).Value = Header
End Sub
Assign the first one titled ButtonClick to the button being used in your form.
This will result in an output like this:
Example1
If you wish to go with second option of 2 headers, simply modify the ButtonClick sub like so:
Sub ButtonClick()
Call Add_XML_Header("/student/material/name")
Call Add_XML_Header("/student/material/mark")
End Sub
However, this will slightly differ from your posted example. It will add both columns to the first row horizontally like the other headers rather than vertically as you had shown.
Here's what it would look like:
Example2
Is it possible to turn an SRT file, which is used for subtitles in videos into a dataset?
When imported into Excel, the SRT file format looks like this:
1
00:00:03,000 --> 00:00:04,000
OVERLAPS PURE COINCIDENCE THAT
...
This pattern continues as time in the "video"/transcript goes on. I'd like to format the SRT file this way:
number ; start ; end ; text
1 ; 00:00:03,000 ; 00:00:04,000 ; OVERLAPS PURE COINCIDENCE THAT
The VBA procedure below loads a standard .srt (SubRip Movie Subtitle File) from a local file and splits it into rows/columns on the active Excel worksheet.
Import SRT subtitles from Local File:
Sub importSRTfromFile(fName As String)
'Loads SRT from local file and converts to columns in Active Worksheet
Dim sIn As String, sOut As String, sArr() As String, x As Long
'load file
Open fName For Input As #1
While Not EOF(1)
Line Input #1, sIn
sOut = sOut & sIn & vbLf
Wend
Close #1
'convert LFs to delimiters & split into array
sOut = Replace(sOut, vbLf & vbLf, vbCr)
sOut = Replace(Replace(sOut, vbLf, "|"), " --> ", "|")
sArr = Split(sOut, vbCr)
'check if activesheet is blank
If ActiveSheet.UsedRange.Cells.Count > 1 Then
If MsgBox(UBound(sArr) & " rows found." & vbLf & vbLf & _
"Okay to clear worksheet '" & ActiveSheet.Name & "'?", _
vbOKCancel, "Delete Existing Data?") <> vbOK Then Exit Sub
ActiveSheet.Cells.ClearContents
End If
'breakout into rows
For x = 1 To UBound(sArr)
Range("A" & x) = sArr(x)
Next x
'split into columns
Columns("A:A").TextToColumns Destination:=Range("A1"), _
DataType:=xlDelimited, Other:=True, OtherChar:="|"
MsgBox "Imported " & UBound(sArr) & " rows from:" & vbLf & fName
End Sub
Example Usage:
Sub test_FileImport()
importSRTfromFile "c:\yourPath\yourFilename.srt"
End Sub
Import SRT subtitles from Website URL:
Alternatively, you can import an .srt (or other similar text files) from a Website URL such as https://subtitle-index.org/ with this:
Sub importSRTfromWeb(url As String)
'Loads SRT from URL and converts to columns in Active Worksheet
Dim sIn As String, sOut As String, sArr() As String, rw As Long
Dim httpData() As Byte, XMLHTTP As Object
'load file from URL
Set XMLHTTP = CreateObject("MSXML2.XMLHTTP")
XMLHTTP.Open "GET", url, False
XMLHTTP.send
httpData = XMLHTTP.responseBody
Set XMLHTTP = Nothing
sOut = StrConv(httpData, vbUnicode)
'convert LFs to delimiters & split into array
sOut = Replace(sOut, vbLf & vbLf, vbCr)
sOut = Replace(Replace(sOut, vbLf, "|"), " --> ", "|")
sArr = Split(sOut, vbCr)
'check if activesheet is blank
If ActiveSheet.UsedRange.Cells.Count > 1 Then
If MsgBox(UBound(sArr) & " rows found." & vbLf & vbLf & _
"Okay to clear worksheet '" & ActiveSheet.Name & "'?", _
vbOKCancel, "Delete Existing Data?") <> vbOK Then Exit Sub
ActiveSheet.Cells.ClearContents
End If
'breakout into rows
For rw = 1 To UBound(sArr)
Range("A" & rw) = sArr(rw)
Next rw
'split into columns
Columns("A:A").TextToColumns Destination:=Range("A1"), _
DataType:=xlDelimited, Other:=True, OtherChar:="|"
MsgBox "Imported " & UBound(sArr) & " rows from:" & vbLf & url
End Sub
Example Usage:
Sub testImport()
importSRTfromWeb _
"https://subtitle-index.org/download/4670541854528212663953859964/SRT/Pulp+Fiction"
End Sub
Many sites host free .srt's; you may have to right-click the download button to copy the link (which may have an .srt extension or might be a pointer, like the example above). The procedure won't work on .zip'd files.
More Information:
Wikipedia : SubRip & SRT
MSDN : Split Function (VBA)
Wikipedia : Newline characters
MSDN : UBound Function
MSDN : Range.TextToColumns Method (Excel)
SubRip Official Website
in the above code :
'breakout into rows
For rw = 1 To UBound(sArr)
Range("A" & rw) = sArr(rw)
Next rw
should be replaced with:
'breakout into rows
For rw = 0 To UBound(sArr)
Range("A" & rw+1) = sArr(rw)
Next rw
else the output will start from line 2
I used Vim and wrote a quick regex to convert a .srt into a .csv file for a translator friend who needed a similar conversion. The csv file can then be opened in Excel / LibreOffice and saved as .xls, .ods or whatever.
My friend didn't need the subtitle numbers to appear in the first column so the regex code looks like this :
set fileencoding=utf-8
%s/"/""/g
g/^\d\+$/d
%s#^\(.*\) --> \(.*\)\n#"\1","\2","#g
%s/\n^$/"/g
Variant to keep the sub numbering :
set fileencoding=utf-8
%s/"/""/g
%s#\(^\d\+\)$\n^\(.*\) --> \(.*\)\n#"\1","\2","\3","#g
%s/\n^$/"/g
Save this code into a text file with the .vim extension, then source this file when editing your .srt in Vim / Gvim. Save the result as a .csv. Enjoy the magic of Regexes !
NB : my code uses commas as field separators. Change the commas into semi-colons in the above code to use semi-colons. I've also added double-quotes as string delimitors in case double-quotes and commas occur in the subtitle text. Much more error proof !
I'm making a word-macro that saves a word document as PDF, with an array variable in the name, the code as of now looks like this:
Private Sub CommandButton2_Click()
'SavePDF
Dim i As Integer
i = ActiveDocument.MailMerge.DataSource.ActiveRecord
Debug.Print i
ActiveDocument.SaveAs2 FileName:="C:\temp\PDFSaves\" & finalArray(0, i) & ".pdf"
End Sub
But it does not work, any suggestions?
Also, if I set it to save to a filepath that doesn't exist, it will create it right? And I want a copy to be saved as a PDF, not the actual word document since it is a template.
You need to use the ExportAsFixedFormat.
ActiveDocument.ExportAsFixedFormat OutputFileName:="C:\temp\PDFSaves\" & finalArray(0, i) & ".pdf", ExportFormat:=wdExportFormatPDF
I have displayed my hyperlink in the column E as shown
\\maroon\cgm images\mech.pdf
But I want to display only mech.pdf in the cell how to modify my code.
my code used for displaying above hyperlink is shown below:
str = "\\maroon\CGM Images\" & pn & ".pdf"
ActiveSheet.Hyperlinks.Add Range("e" & i), str
In this I want to show only pn & str.
You need to specify TextToDisplay
ActiveSheet.Hyperlinks.Add Anchor:=Range("e" & i), Address:=Str, TextToDisplay:=pn & ".pdf"
Sometimes the Excel VBA reference is indeed helpful to find out on your own how functions and methods work: Hyperlinks.Add Method (Excel)
If you have
\maroon\cgm images\mech.pdf
in a cell and you wanna get only the name of the pdf with ".pdf" you can do the next code:
Dim spliter() as String
Dim str_pdf as String
str = \maroon\cgm images\mech.pdf ' Cells(a,b).value
spliter = Split(str, " ") 'To do the first split (You can delete ', " "' )
spliter = Split(spliter(1), "\")
'Now spliter(1) == mech.pdf so...
str_pdf = spliter(1) ' spliter(0) == images , spliter(1) == mech.pdf