What I want to do
I have an Access database ( C:\Users\289894\Desktop\Database1.accdb )
One of the fields of [Table1] is [Memo].
That field is of the Memo data type, with the text format set to rich text.
It makes it possible to save some records as Bold and some records saved as Italics, for example.
I want to open a connexion to this Access database from an excel file in order to read/write into this rich text field.
The code I used is the following:
Dim datab As Database
Dim rs As Recordset
Dim path As String
path = "C:\Users\289894\Desktop\Database1.accdb"
Set datab = OpenDatabase(path)
Set rs = datab.OpenRecordset("SELECT * FROM [Table1]")
Debug.Print rs!Memo
Range("A1") = rs!Memo
My question
This code works well to open a connexion and read ordinary text fields, but rich text acts in a surprising way (for me). The original text in access was "aaa". That's "aaa" in bold font.
After running the code, both the debug.print and Range("A1") have <div><strong>aaa</strong></div> written into them.
How can I change my code to send the format to excel as well? I'd like to have "aaa" written in bold in cell A1, just like it is in Access.
EDIT: Workaround
This solves the immediate problem asked by the question without really answering the question itself. It uses internet explorer to paste the text back as Rich Text, without the tags.
Sub Sample()
Dim Ie As Object
Dim rng As Range
Set rng = Feuil1.Range("A1")
Set Ie = CreateObject("InternetExplorer.Application")
With Ie
.Visible = False
.Navigate "about:blank"
.Document.body.InnerHTML = rng.Value
.ExecWB 17, 0
'Select all contents in browser
.ExecWB 12, 2
'Copy them
ActiveSheet.Paste Destination:=rng
.Quit
End With
End Sub
Give this a shot. Loop range is generic. Also, function assumes very limited HTML as shown in your example.
Sub Test()
Dim cel As Range
For Each cel In Range("A1:A100")
cel.Font.Bold = InStr(1, cel.Value, "<strong>")
cel.Font.Italic = InStr(1, cel.Value, "<i>")
cel.Value = RemoveHTML(cel.Value)
Next
End Sub
Function RemoveHTML(sHTML As String) As String
Dim sTemp As String
sTemp = sHTML
Dim bLeft As Byte, bRight As Byte
bRight = InStr(1, sTemp, "</")
bLeft = InStrRev(sTemp, ">", bRight)
RemoveHTML = Mid(sTemp, bLeft + 1, bRight - bLeft - 1)
End Function
Related
I'm trying to pull data from tables in a Word document to Excel. I'm able to pull it as text but I don't know how to pull the numbers as numbers.
Sub extractData()
Dim wd As New Word.Application
Dim doc As Word.Document
Dim sh As Worksheet
wd.Visible = True
Set doc = wd.Documents.Open(ActiveWorkbook.Path & "C:\Users\itays\Desktop\TTd.docx")
Set tbl = doc.Tables
Set sh = ActiveSheet
For i = 1 To 17
sh.Cells(i, 1).Value = tbl(5).Rows(i).Cells(1).Range.Text
Next
For i = 1 To 17
sh.Cells(i, 2).Value = tbl(5).Rows(i).Cells(2).Range.Text
Next
Range("a:e").Columns.AutoFit
doc.Close
End Sub
Basically, I need the second For command to pull the data as a number and not as a text.
Word handles text, not numbers. You have to make sure that the text in the second column comes out as a number by converting it to the correct data type. First you have to strip out the text you cannot convert, like linebreaks and table formatting. There are several ways to do this, the following is my example. Trim removes whitespace, Val keeps just the digits, CLng converts it to a Long.
sh.Cells(i, 2).Value = CLng(Val(Trim(tbl(1).Rows(i).Cells(2).Range.Text)))
By the way, the path when you open the Word document looks really weird?
EDIT
You need to clean the data before converting. Adding a Replace-command to change the commas to periods, then convert to a Double instead of a Long to handle the decimal value with CDbl:
sh.Cells(i, 2).Value = CDbl(Val(Trim(Replace(tbl(1).Rows(i).Cells(2).Range.Text, ",", "."))))
Try:
Sub ExtractData()
Application.ScreenUpdating = False
Dim wdApp As New Word.Application, wdDoc As Word.Document, r As Long
Set wdDoc = wdApp.Documents.Open(ActiveWorkbook.Path & "\TTd.docx")
With wdDoc.Tables(5)
For r = 1 To 17
ActiveSheet.Cells(r, 1).Value = Split(.Cell(r, 1).Range.Text, vbCr)(0)
ActiveSheet.Cells(r, 2).Value = Split(.Cell(r, 2).Range.Text, vbCr)(0)
Next
End With
wdDoc.Close False: wdApp.Quit
Range("a:e").Columns.AutoFit
Application.ScreenUpdating = True
End Sub
I'm trying to write a VBA macro that will read through a text document and place specific words into columns. UPDATE: Here's a sample of the file, apparently it's XML, so at least I learned something new today. So i guess what I need is a program to shed the XML parts, and place just the text into columns.
<Alarm>
<ID>1002</ID>
<Type>Fault</Type>
<Message>Bad Brake</Message>
<Tagname>error.e2</Tagname>
</Alarm>
<Alarm>
<ID>1004</ID>
<Type>Fault</Type>
<Message>No Motion</Message>
<Tagname>error.e4</Tagname>
</Alarm>
<Alarm>
<ID>1005</ID>
<Type>Fault</Type>
<Message>Upper safety door open</Message>
<Tagname>error.e5</Tagname>
</Alarm>
Ultimately, I'm trying to put the 4 digit error codes in column A (i.e. 1002, 1004...), and the error message in column B (i.e. Bad Brake, No motion....). I'll paste what I have so far, I tried coding it for just one pair of data to start. I'm stuck trying to get the error message into column B. The error messages all start in the same position on each line, but I can't figure out how to stop copying the text, since each error message is a different length of characters. Any ideas?
(P.S. - I apologize if the code is terrible, I've been interning as an electrical engineer, so my programming has gotten rather rusty.)
Private Sub CommandButton1_Click()
Dim myFile As String, textLine As String, ID As Integer, error_msg As Integer
myFile = "C:\Users\scholtmn\Documents\Projects\Borg_Warner_txt_file\BW_fault_codes.txt"
Open myFile For Input As #1
Do Until EOF(1)
Line Input #1, textLine
Text = Text & textLine
Loop
Close #1
ID = InStr(Text, "<ID>")
error_msg = InStr(Text, "<Message>")
Range("A1").Value = Mid(Text, ID + 4, 4)
Range("B1").Value = Mid(Text, error_msg + 9, (InStr(Text, " <") - 31))
End Sub
Please, try the next code:
Sub ExtractErrorsDefinition()
'it needs a reference to 'Microsoft XML, v6.0'
Dim XMLFileName As String, oXMLFile As New MSXML2.DOMDocument60, sh As Worksheet
Dim N As MSXML2.IXMLDOMNode, i As Long, arr
Set sh = ActiveSheet 'use here the necessary sheet
XMLFileName = "the full text file path" '"C:\Utile\Teste Corel\XMLtext.txt"
oXMLFile.Load (XMLFileName)
ReDim arr(1 To oXMLFile.SelectNodes("AlarmDictionary/Alarm").length, 1 To 2): i = 1
For Each N In oXMLFile.SelectNodes("AlarmDictionary/Alarm")
arr(i, 1) = N.SelectSingleNode("ID").Text: arr(i, 1) = N.SelectSingleNode("Message").Text: i = i + 1
Next
sh.Range("A2").Resize(UBound(arr), 2).value = arr
End Sub
It may work using late binding, but it is better to have the intellisense suggestion, especially when not very well skilled in working with XML.
If looks complicated to add such a reference, I can add a piece of code to automatically add it.
Please, run the next code to automatically add the necessary reference. Save your workbook and run the first code after:
Sub addXMLRef()
'Add a reference to 'Microsoft Scripting Runtime':
'In case of error ('Programmatic access to Visual Basic Project not trusted'):
'Options->Trust Center->Trust Center Settings->Macro Settings->Developer Macro Settings->
' check "Trust access to the VBA project object model"
Application.VBE.ActiveVBProject.References.AddFromFile "C:\Windows\System32\msxml6.dll"
End Sub
It looks like the txt file you are using is actually an xml file. If you changed the format, this piece of code I slightly adjusted from here should work fine.
Sub From_XML_To_XL()
Dim xmlWb As Workbook, xSWb As Workbook, xStrPath$, xfdial As FileDialog, _
xFile$, lr%, first As Boolean, r As Range
first = True
Set xfdial = Application.FileDialog(msoFileDialogFilePicker)
xfdial.AllowMultiSelect = False
xfdial.Title = "Select an XML File"
If xfdial.Show = -1 Then xStrPath = xfdial.SelectedItems(1) & ""
If xStrPath = "" Then Exit Sub
Set xSWb = ThisWorkbook
lr = xSWb.ActiveSheet.Range("a" & Rows.Count).End(xlUp).Row ' last used row, column A
xFile = xStrPath
Set xmlWb = Workbooks.OpenXML(xFile)
If first Then
Set r = xmlWb.Sheets(1).UsedRange ' with header
Else
xmlWb.Sheets(1).Activate
Set r = ActiveSheet.UsedRange
Set r = Range(Cells(3, 1), Cells(r.Rows.Count, r.Columns.Count))
End If
r.Copy xSWb.ActiveSheet.Cells(lr + 1, 1)
lr = xSWb.ActiveSheet.Range("a" & Rows.Count).End(xlUp).Row
xmlWb.Close False
first = False
End Sub
I think you'll find this task a lot easier if you take advantage of the fact it is in XML format. You can find more information about working with XML in VBA here.
As Ben Mega already stated: you have an XML-File - why not use XML-functionality.
Add "Microsoft XML, v6.0" to your project references - then you can use this code
Public Sub insertTextFromXML()
Dim objXML As MSXML2.DOMDocument60
Set objXML = New MSXML2.DOMDocument60
If Not objXML.Load("T:\Stackoverflow\Test.xml") Then
Err.Raise objXML.parseError.ErrorCode, , objXML.parseError.reason
End If
Dim nAlarm As MSXML2.IXMLDOMNode
'loop through all alarms and output ID plus message
For Each nAlarm In objXML.SelectNodes("AlarmDictionary/Alarm")
With nAlarm
Debug.Print .SelectSingleNode("ID").Text, .SelectSingleNode("Message").Text
End With
Next
'Filter for ID 1004
Set nAlarm = objXML.SelectSingleNode("AlarmDictionary/Alarm[ID=1004]")
Debug.Print nAlarm.XML
End Sub
You can google for VBA XPath to find out how to access the various values.
I have copied a code which runs a string in html format into the I.E. web browser, which converts it to rich text, then copies it back into the cell that the code was run on. I've included the code below.
However, I want the ability to run this sub as a function for other users so they will never have to access the developer tab. I'm stuck on how to convert this sub into a function so it would be great if someone could help me out.
Sub Sample()
Dim Ie As Object
Set Ie = CreateObject("InternetExplorer.Application")
With Ie
.Visible = False
.Navigate "about:blank"
.document.body.InnerHTML = Sheets("Sheet1").Range("A1").Value
.ExecWB 17, 0: .ExecWB 12, 2
ActiveSheet.Paste Destination:=Sheets("Sheet1").Range("A1")
.Quit
End With
End Sub
Thanks for all the responses.
for example, in cell A1 I have '< html > this is < b > a custom text < / b>'. I want to be able to write in cell A2 '=sample(A1)', and for the text in A1 to be converted into formatted text, ie. 'this is a custom text' by the code I've included. The cell A2 would have the converted text in.
This UDF addresses the use case given in the question. The function uses a regular expression to parse out the text to be bolded and then leverages Mark.R's code from a few years ago to translate the character values to the equivalent unicode bold character values. This code only handles the <b> tag but it could easily be extended to handle the <i> tag.
Option Explicit
Function EmboldenText(ByVal source As Range) As String
Dim re As VBScript_RegExp_55.RegExp
Dim m As VBScript_RegExp_55.Match
Dim strIn As String
Dim strout As String
Dim start As Integer
Set re = New VBScript_RegExp_55.RegExp
re.Pattern = "<b>(.+?)</b>"
re.Global = True
strIn = source.Value
strout = ""
start = 1
For Each m In re.Execute(strIn)
strout = strout & Mid(strIn, start, m.FirstIndex - start + 1) & _
Bold(m.SubMatches(0))
start = m.FirstIndex + m.Length + 1
Next m
EmboldenText = strout & Mid(strIn, start)
End Function
You will need to add this library to your references if you want to try this solution.
I've got a working code but I'd like to replace my Drop-Down with Content Control, because I need to be able to also manually type in a value.
The value inside is a list from a https, this string works completely fine, so please ignore.
Here's my code:
Dim MyRequest As Object
Dim Data() As String
Dim i As Integer
Dim j As Integer
Dim maxi As Integer
Set MyRequest = CreateObject("WinHttp.WinHttpRequest.5.1")
MyRequest.Open "GET", _
"https... (This is hidden for security resons, /csv/)"
' Send Request.
MyRequest.Send
'And we get this response
'MsgBox MyRequest.ResponseText
Data = Split(MyRequest.ResponseText, "|")
If UBound(Data()) > 25 Then
maxi = 25
Else
maxi = UBound(Data())
End If
For j = 1 To 6
ActiveDocument.FormFields("Dropdown" & j).DropDown.ListEntries.Clear
For i = 0 To maxi - 1
ActiveDocument.FormFields("Dropdown" & j).DropDown.ListEntries.Add Name:=Data(i)
Next i
Next j
End Sub
You should not use content controls and formfields in the same document. They were not designed to be used that way and doing so is a known source of problems.
As you observed, dropdown formfields don’t support text entry. To provide that facility, you could provide an option in the dropdown for 'free text' and use an on-exit macro with an Inputbox to insert the user’s 'free text' into the dropdown. For example, suppose you have a dropdown with 5 items, the last of which offers free text entry (e.g. an 'Other' option). Adding the following on-exit macro to the formfield will provide that:
Sub FreeText()
Dim StrNew As String, i As Long
With Selection.FormFields(1).DropDown
i = .ListEntries.Count
If .Value = i Then
StrNew = Trim(InputBox("Input your text", "Data Entry", .ListEntries(i).Name))
If StrNew = vbNullString Then Exit Sub
.ListEntries(i).Delete
.ListEntries.Add StrNew
.Value = i
End If
End With
End Sub
I tried since more days to create a Word Document with Excel-VBA
Step by Step:
first: create Word-Document and add a Table (Mailing-Label)
second: fill sometext into some cells. Works great!
Now my Problem:
at last, i want to append an Picture in the cell.
My Problem is, the Image RANGE clear the old text.
And i don't know, how to set the Image and the text at the end of the Loop.
My code
oDoc.Tables(1).Cell(zeile, spalte).Range.Text = "some string"
oDoc.Tables(1).Cell(zeile, spalte).Range.InlineShapes.AddPicture path_to_image
The way to understand what's happening is to think about how this would work if you were doing this manually, working with a selection. When you assign text to a Range that's like typing it in, as you'd expect. The second line of code, inserting the image, is like selecting the entire cell (in this case) then inserting the image: it replaces what's in the Range. When working manually, if you had selected the entire cell, you'd press Right Arrow or click at the end to put the focus after what had been typed.
The same principle applies when using a Range object: it needs to collapse in order to add something to it.
The following code example demonstrates this. It also highlights how the code can be made more efficient by assigning the table and the target range to objects.
Dim tbl As Word.Table 'or As Object if using late-binding
Dim rng As Word.Range 'or As Object if using late-binding
Dim chrCount As Long
Set tbl = oDoc.Tables(1)
Set rng = tbl.Cell(zeile, spalte).Range
rng.Text = "test"
chrCount = rng.Characters.Count
'Get the end of the cell content
Set rng = rng.Characters(chrCount - 1)
rng.Collapse wdCollapseEnd
rng.InlineShapes.AddPicture path_to_image
May be something like
Sub Test()
Dim Wrd As Word.Application
Dim oDoc As Word.Document
Set Wrd = CreateObject("Word.Application")
Wrd.Visible = True
Set oDoc = Wrd.Documents.Add
oDoc.Tables.Add oDoc.Range, 3, 3
zeile = 2
spalte = 2
path_to_image = "C:\Users\user\Desktop\Pull2.jpg"
oDoc.Tables(1).Cell(zeile, spalte).Range.Select
With Wrd.Selection
.TypeText Text:="some string"
.InlineShapes.AddPicture path_to_image
End With
End Sub