We have migrated a server and transferred the files over using the same share path. My customer has got a word document with hyperlinks in it which point to the older server name.
i.e.
\\serverOld\accounts\1234.pdf and \\serverNew\accounts\1234.pdf
I have found this VB Script below that has done what i need but it is for Excel not Word.
Sub HyperLinkChange()
Dim oldtext As String
Dim newtext As String
Dim h As Hyperlink
' These can be any text portion of a hyperlink, such as ".com" or ".org".
oldtext = "\\topscan-server"
newtext = "\\ts-sbs"
' Check all hyperlinks on active sheet.
For Each h In ActiveSheet.Hyperlinks
x = InStr(1, h.Address, oldtext)
If x > 0 Then
If h.TextToDisplay = h.Address Then
h.TextToDisplay = newtext
End If
h.Address = Application.WorksheetFunction. _
Substitute(h.Address, oldtext, newtext)
End If
Next
End Sub
Please can someone help me edit this text to work with Microsoft Word 2010?
Try this
Sub HyperLinkChange()
Dim oldtext As String, newtext As String
Dim h As Hyperlink
oldtext = "\\topscan-server"
newtext = "\\ts-sbs"
For Each h In ActiveDocument.Hyperlinks
If InStr(1, h.Address, oldtext) Then
If h.TextToDisplay = h.Address Then
h.TextToDisplay = newtext
End If
h.Address = Replace(h.Address, oldtext, newtext)
End If
Next
End Sub
Related
Here is a macro, which allows to replace hyperlinks across images.
(How to use it: copy some images to document, then add hyperlinks to each of them, for example, www.google.com, and then, using this macro, you can replace these hyperlinks to something different, for example www.stackoverflow.com. Test file uploaded here: https://ufile.io/qbdcp).
At first, I tried to use
If .Type = msoHyperlinkInlineShape
but for some reason, it doesn't work for inline images, which were copied from file manager (Ctrl-C in file manager, Ctrl-V in Word).
Then, I replaced it to
If .Type = msoHyperlinkShape
and now it works.
But I still wondering why I was forced to change msoHyperlinkInlineShape to msoHyperlinkShape, whereas I use inline pictures. Why msoHyperlinkInlineShape doesn't work?
Sub ReplaceHyperlinks()
Dim HL As Hyperlink
Dim sFind As String
Dim sRepl As String
Dim iCnt As Integer
sFind = InputBox("Find what", "Find Hyperlink")
If Len(sFind) = 0 Then Exit Sub
sRepl = InputBox("Replace with", "Replace Hyperlink")
If Len(sRepl) = 0 Then Exit Sub
iCnt = 0
For Each HL In ActiveDocument.Hyperlinks
With HL
If .Type = msoHyperlinkShape Then ' msoHyperlinkInlineShape will not work for some reason
If InStr(LCase(.Address), LCase(sFind)) Then
.Address = Replace(.Address, sFind, sRepl, , , vbTextCompare)
.ScreenTip = Replace(.ScreenTip, sFind, sRepl, , , vbTextCompare)
On Error Resume Next
.Range.Fields.Update
iCnt = iCnt + 1
End If
If InStr(LCase(.TextToDisplay), LCase(sFind)) Then
.TextToDisplay = Replace(.TextToDisplay, sFind, sRepl, , , vbTextCompare)
.Range.Fields.Update
End If
End If
End With
Next
MsgBox ("Links replaced: " & iCnt)
End Sub
I am working on an automated peer review macro that would check for certain words and highlight them in a Microsoft Word document. However, I am looking to substitute the WordList = Split(" is , are ,", ",") with a list I created in excel. This would be easier for me to add new words instead of manually typing the words I want highlighted in the code.
For example: A1 has the word " is ", so I am hoping it would be something like Wordlist = Split("A1, A2")
or something like Exlist = Range("A1:A2").value so WordList = Split(ExList)
Is something like that possible? Thank you for your help.
Sub PeerReview()
Dim r As Range
Dim WordList() As String
Dim a As Long
Dim Doc As Document
Dim Response As Integer
'This code will search through all of the open word documents and ask you which ones you would like to peer review.
For Each Doc In Documents
'MsgBox Doc
Response = MsgBox(prompt:="Do you want to peer review " & Doc & "?", Buttons:=vbYesNo)
If Response = vbNo Then GoTo ShortCut
'This code will highlight words that do not belong in the paragraph
WordList = Split(" is , are ,", ",") 'List of words to check for when it is peer-reviewing
Options.DefaultHighlightColorIndex = wdPink *'Highlight when found*
For a = 0 To UBound(WordList())
Set r = ActiveDocument.Range
With r.Find
.Text = WordList(a)
.Replacement.Highlight = wdYellow
.Execute Replace:=wdReplaceAll
End With
Next 'next word
ShortCut:
Next
End Sub
Here are three ways to retrieve an array of words from an external file (Word, Excel, and Text Files) in MS Word. Reading from the text file is by far the fastest.
Results
Word: 0.328125 Seconds
Excel: 1.359130859375 Seconds
Text: 0.008056640625 Seconds
---------- ----------
Get Word List from Word Document
Start Time:12/1/2007 11:03:56 PM
End Time:9/1/2016 12:53:16 AM
Duration:0.328125 Seconds
------------------------------
---------- ----------
Get Word List from Excel
Start Time:12/1/2007 3:05:49 PM
End Time:9/1/2016 12:53:17 AM
Duration:1.359130859375 Seconds
------------------------------
---------- ----------
Get Word List from Text Document
Start Time:11/30/2007 6:16:01 AM
End Time:9/1/2016 12:53:17 AM
Duration:0.008056640625 Seconds
------------------------------
Unit Test
Sub TestWordList()
Dim arData
EventsTimer "Get Word List from Word Document"
arData = GetWordsListDoc
'Debug.Print Join(arData, ",")
EventsTimer "Get Word List from Word Document"
EventsTimer "Get Word List from Excel"
arData = GetWordsListXL
'Debug.Print Join(arData, ",")
EventsTimer "Get Word List from Excel"
EventsTimer "Get Word List from Text Document"
arData = GetWordsListTxt
'Debug.Print Join(arData, ",")
EventsTimer "Get Word List from Text Document"
End Sub
Event Timer
Sub EventsTimer(Optional EventName As String)
Static dict As Object
If dict Is Nothing Then Set dict = CreateObject("Scripting.Dictionary")
If dict.Exists(EventName) Then
Debug.Print
Debug.Print String(10, "-"), String(10, "-")
Debug.Print EventName
Debug.Print ; "Start Time:"; ; Now - dict(EventName)
Debug.Print ; "End Time:"; ; Now
Debug.Print ; "Duration:"; ; Timer - dict(EventName) & " Seconds"
Debug.Print String(10, "-"); String(10, "-"); String(10, "-")
dict.Remove EventName
Else
dict.Add EventName, CDbl(Timer)
End If
If dict.Count = 0 Then Set dict = Nothing
End Sub
Functions to retrieve a word list from MS Word, Ms Excel and a Text File.
Function GetWordsListDoc()
Const FilePath As String = "C:\Users\best buy\Downloads\stackoverfow\Wordlist\WordList.docx"
Dim doc As Word.Document, oWords As Word.Words
Dim x As Long
Dim arData
Set doc = Application.Documents.Open(FileName:=FilePath, ReadOnly:=True)
Set oWords = doc.Words
ReDim arData(oWords.Count - 1)
For x = 1 To oWords.Count
arData(x - 1) = Trim(oWords.Item(x))
Next
doc.Close False
GetWordsListDoc = arData
End Function
Function GetWordsListXL()
Const FilePath As String = "C:\Users\best buy\Downloads\stackoverfow\Wordlist\WordsList.xlsb"
Const xlUp = -4162
Dim arData
Dim x As Long
Dim oExcel As Object, oWorkbook As Object
Set oExcel = CreateObject("Excel.Application")
With oExcel
.Visible = False
Set oWorkbook = .Workbooks.Open(FileName:=FilePath, ReadOnly:=True)
End With
With oWorkbook.Worksheets(1)
arData = .Range("A1", .Range("A" & .Rows.Count).End(xlUp)).Value
arData = oExcel.WorksheetFunction.Transpose(arData)
End With
oWorkbook.Close False
oExcel.Quit
GetWordsListXL = arData
End Function
Function GetWordsListTxt()
Const FilePath As String = "C:\Users\best buy\Downloads\stackoverfow\Wordlist\WordList.txt"
Dim arData, f, fso
Set fso = CreateObject("Scripting.Filesystemobject")
Set f = fso.OpenTextFile(FilePath)
arData = Split(f.ReadAll, vbNewLine)
GetWordsListTxt = arData
End Function
This is an extract form an excel 2010 macro I’m working on in VBA, the function I’m having issues with is DelStrikethroughs
Whenever the value in a cell is "TRUE", "FALSE", or "#N/A" (when its "#N/A" the macro crashes) the function returns a null string. Upon further investigation it looks like the variable x.text is always blank and has the error "Unable to get the text property of the characters class" when i try to debug it.
Any ideas on how to fix this? (I'm happy for the function to return the original text if it cant remove the strike through text, but a proper solution is preferred)
Below is the code sample:
Sub testx()
Dim testRange As Range
Set testRange = selection
Call DelStrikethroughs(testRange.Cells(1, 1))
End Sub
Function DelStrikethroughs(Cell As Range) As String
'Returns the text value of a cell with strikethrough characters removed
Dim NewText As String
Dim iCh As Integer
For iCh = 1 To Len(Cell)
Dim x As Characters
Set x = Cell.Characters(iCh, 1)
On Error Resume Next '"On Error" is here to deal with blank characters
If x.Font.Strikethrough = False Then
NewText = NewText & x.text
End If
If Err.Number = 0 Then
NewText = NewText
Else
NewText = NewText & x.text
End If
Next iCh
DelStrikethroughs = NewText
End Function
Try this:
Sub testx()
Dim testRange As Range, c As Range
Set testRange = Selection
For Each c In testRange
c.Offset(0, 1).Value = DelStrikethroughs(c)
Next c
End Sub
Function DelStrikethroughs(Cell As Range) As String
'Returns the text value of a cell with strikethrough characters removed
Dim NewText As String
Dim iCh As Long, l As Long, ch As Characters
On Error Resume Next
l = Cell.Characters.Count
On Error GoTo 0
If l = 0 Then
NewText = Cell.Text
Else
For iCh = 1 To l
Set ch = Cell.Characters(iCh, 1)
NewText = NewText & IIf(ch.Font.Strikethrough, "", ch.Text)
Next iCh
End If
DelStrikethroughs = NewText
End Function
If all you want to do is return the text in the cell without any strikethrough, then try:
Function DelStrikethroughs(Cell As Range) As String
DelStrikethroughs = Cell.Text
End Function
I am facin strange problem looks like = is not working as it should be. I got code below:
Dim lineText As String
For Each p In WordDoc.Paragraphs
lineText = p.Range.Text
If lineText = "" Then GoTo Dalej
.....
even if i do:
lineText = ""
If lineText = "" Then GoTo Dalej
its not going to Dalej but going next. Looks like its not problem with code but with operators i got similar problem with <>. I tried to workaround tht with InStr or StrComp but its doing completly not as it should be like something inside excel has been changed with application itself. Do you have any idea what this could be?
This is full code:
Sub Sprawdz_Pola_Korespondencji_Click()
Application.ScreenUpdating = True
Dim RowNr As Integer
Dim EWS As Worksheet
RowNr = 30
Set EWS = Sheets("Arkusz do wypełnienia")
Dim FileName As Variant, wb As Workbook
FileName = Application.GetOpenFilename(FileFilter:="Word File (*.docx),*.docx", Title:="Select File To Be Opened")
If FileName = False Then Exit Sub
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = False
Set WordDoc = WordApp.Documents.Open(FileName)
Dim p As Paragraph
If lineText = "" Then GoTo Dalej
If InStr(lineText, PoleExcel) Then
EWS.Cells(5, X).Interior.ColorIndex = 18
Else
EWS.Cells(5, X).Interior.ColorIndex = 3
End If
Dalej:
Next p
Nastepna:
Loop Until EWS.Cells(RowNr, X) = "KONIEC"
'EWS.Activate 'WordDoc.Activate '<============================================================
WordDoc.Close savechanges:=False 'or false
WordApp.Quit
Set WordDoc = Nothing
Set WordApp = Nothing
End Sub
Public Function ReplaceSpaces(strInput As String) As String
' Replaces spaces in a string of text with underscores
Dim Result As String
Result = strInput
If InStr(strInput, " ") > 0 Then
Result = Replace(strInput, " ", "_")
End If
ReplaceSpaces = Result
End Function
You need to write:
Next p
Dalej:
instead. (i.e. switch round the Next p and Dalej:). Currently the label is inside the for loop.
But, it would be far better to use Exit For instead of the GoTo. Doing this means you don't need to maintain a label.
GoTo statements are notoriously brittle.
To strip out the CR do this:
lineText = replace(lineText, chr(13), "")
I'd like to create a VBA macro which would allow me to edit all selected hyperlinks in a column and change "text to display" to the same word for all. For example, if this was the column:
www.google.com/search=cars
www.google.com/search=houses
www.google.com/search=cities
I would want to highlight those three elements of the column and change the text to display to "Google Search" so that the outcome would be this:
Google Search
Google Search
Google Search
Edit: So I found a macro similar to what I want to do on the microsoft support site, but my issue is that this macro targets all the hyperlinks in the sheet while I'd want to select a specific column to edit the hyperlinks.
Sub HyperLinkChange()
Dim oldtext As String
Dim newtext As String
Dim h As Hyperlink
oldtext = "http://www.microsoft.com/"
newtext = "http://www.msn.com/"
For Each h In ActiveSheet.Hyperlinks
x = InStr(1, h.Address, oldtext)
If x > 0 Then
If h.TextToDisplay = h.Address Then
h.TextToDisplay = newtext
End If
h.Address = Application.WorksheetFunction. _
Substitute(h.Address, oldtext, newtext)
End If
Next End Sub
This works on the current selection:
Sub SetLinkText()
Dim LinkText As String
Dim h As Hyperlink
LinkText = InputBox("Enter link text")
If LinkText = "" Then Exit Sub
For Each h In Selection.Hyperlinks
h.TextToDisplay = LinkText
Next
End Sub