How to make a style as a bookmark in word 2010?
You won't be able to use most of the text in the document as the bookmark name. It is just illegal to use certain characters in a bookmark name in Word/VBA. It may be possible to add such characters in bookmark names in an XML format of the document, so if it is required, you can ask a separate question.
This feels like way too much code to post on SO. You really need to explain what framework you have in place and tell us where your hurdles are. We can't do this again. "Works for me". If you have any questions though don't hesitate to ask.
Run the "RunMe" macro at the bottom.
Private Function IsParagraphStyledWithHeading(para As Paragraph) As Boolean
Dim flag As Boolean: flag = False
If InStr(1, para.Style, "heading", vbTextCompare) > 0 Then
flag = True
End If
IsParagraphStyledWithHeading = flag
End Function
Private Function GetTextRangeOfStyledParagraph(para As Paragraph) As String
Dim textOfRange As String: textOfRange = para.Range.Text
GetTextRangeOfStyledParagraph = textOfRange
End Function
Private Function BookmarkNameAlreadyExist(bookmarkName As String) As Boolean
Dim bookmark As bookmark
Dim flag As Boolean: flag = False
For Each bookmark In ActiveDocument.Bookmarks
If bookmarkName = bookmark.name Then
flag = True
End If
Next
BookmarkNameAlreadyExist = flag
End Function
Private Function CreateUniqueBookmarkName(bookmarkName As String)
Dim uniqueBookmarkName As String
Dim guid As String: guid = Mid$(CreateObject("Scriptlet.TypeLib").guid, 2, 36)
guid = Replace(guid, "-", "", , , vbTextCompare)
uniqueBookmarkName = bookmarkName & guid
CreateUniqueBookmarkName = uniqueBookmarkName
End Function
Private Function BookmarkIt(rng As Range, bookmarkName As String)
Dim cleanName As String: cleanName = MakeValidBMName(bookmarkName)
If BookmarkNameAlreadyExist(cleanName) Then
cleanName = CreateUniqueBookmarkName(cleanName)
End If
ActiveDocument.Bookmarks.Add name:=cleanName, Range:=rng
End Function
''shamelessly stolen from gmaxey at http://www.vbaexpress.com/forum/showthread.php?t=37674
Private Function MakeValidBMName(strIn As String)
Dim pFirstChr As String
Dim i As Long
Dim tempStr As String
strIn = Trim(strIn)
pFirstChr = Left(strIn, 1)
If Not pFirstChr Like "[A-Za-z]" Then
strIn = "A_" & strIn
End If
For i = 1 To Len(strIn)
Select Case Asc(Mid$(strIn, i, 1))
Case 49 To 58, 65 To 90, 97 To 122
tempStr = tempStr & Mid$(strIn, i, 1)
Case Else
tempStr = tempStr & "_"
End Select
Next i
tempStr = Replace(tempStr, " ", " ")
MakeValidBMName = tempStr
End Function
Sub RunMe()
Dim para As Paragraph
Dim textOfPara As String
For Each para In ActiveDocument.Paragraphs
If IsParagraphStyledWithHeading(para) Then
textOfPara = GetTextRangeOfStyledParagraph(para)
If para.Range.Bookmarks.Count < 1 Then
BookmarkIt para.Range, textOfPara
End If
End If
Next
End Sub
Related
I am trying to create an excel function which will fill column with data gathered from OGame's reports. I have encountered strage behavior (at least from my point of view).
I have a form where the user can copy their reports to a form's textbox. After clicking the button, the following functions should start:
Option Explicit
Private Sub CommandButton1_Click()
Dim arr() As String
Dim test As Boolean
Dim str As String
str = testFunction()
arr = readData(Raporty.Value)
' Dim element As Variant
' For Each element In arr
' Debug.Print element
' Debug.Print "-------------------------------"
' Next element
test = writeData(arr)
Debug.Print (test)
Debug.Print ("str: " + str)
Unload ufWczytajRaporty
End Sub
Private Function testFunction() As String
Debug.Print ("testFunction")
testFunction = "testFunctionText"
End Function
Private Function writeData(arr1() As String) As Boolean
Debug.Print ("writeData")
For Each element In arr1
writeDataRow (element)
Next element
writeData = True
End Function
Private Function readData(text As String) As String()
Debug.Print ("readData")
Dim list As Object
Dim substr As Integer
Dim temp As String
Dim arr(0 To 10) As String
Dim result() As String
Dim counter As Integer
Set list = CreateObject("System.Collections.ArrayList")
counter = 0
If text = "" Then
MsgBox "Dane nie mogą być puste! Proszę uzupełnić poprawnymi raportami!", vbCritical
Else
If InStr(1, text, "Przybył statek handlowy") = 1 Then
While (InStr(1, text, "Towar został już odebrany."))
substr = InStr(1, text, "Towar został już odebrany.") + 26
arr(counter) = Left(text, substr)
temp = Mid(text, substr, Len(text))
text = temp
counter = counter + 1
Wend
Unload ufWczytajRaporty
Else
MsgBox "Niepoprawne raporty! Proszę wkleć dobre raporty!", vbCritical
End If
End If
ReDim result(0 To counter)
Dim i As Integer
For i = 0 To counter
result(i) = arr(i)
Next i
readData = arr
End Function
This functions provide the following result in Immediate:
testFunction
readData
False
str: testFunctionText
As you can see the above false is a call of writeData fuction, however it never entered the function. writeData function contains Debug.Print ("writeData") but it was never displayed.
Furthermore if I change places the following function:
str = testFunction()
arr = readData(Raporty.Value)
to
arr = readData(Raporty.Value)
str = testFunction()
testFunction is not called aswell.
Can someone explain me what is happening? Why those functions are not called?
I have a button and I pass String as parameter. If string parameter increase more that 255 characters, it doesn't get any value. If string parameter is less than 255 characters, it is working fine.
Here is my code:
Dim parameterText As String
parameterText = "First Parameter Value | Third Parameter Value | Third Parameter Value"
Dim AdviceItem As CommandBarButton
Set AdviceItem = CategoryItem.Controls.Add(msoControlButton, , , , True)
With AdviceItem
.Caption = adviceText
.Visible = True
.Parameter = strParameter
.OnAction = "myFunction"
End With
Sub myFunction()
Dim parameters() As String
ReDim parameters(3)
Dim parameterText As String
parameterText = Application.CommandBars.ActionControl.Parameter
'parameterText is blank if there are more than 255 characters passed from above function
MsgBox ("parameterText" & parameterText)
parameters() = Split(parameterText, "|")
End Sub
Can anybody suggest me how to achieve it?
Assuming that there is a limitation on the .parameter, you can bypass this by using an array to store the string you want to display.
Option Explicit
Public AllParameters(100) As String
Public AllAdviceTexts(100) as String
Sub defineParameters()
AllParameters(0) = "First Parameter Value"
AllParameters(1) = "Third Parameter Value "
AllParameters(2) = "Third Parameter Value "
'etc
'set advice texts here too
End Sub
Private Sub Workbook_Open()
Dim AdviceItem As CommandBarButton
Dim i As Integer
Call defineParameters
For i = 0 To 100
Set AdviceItem = CategoryItem.Controls.Add(msoControlButton, , , , True)
With AdviceItem
.Caption = AllAdviceTexts(i)
.Visible = True
.Parameter = i
.OnAction = "myFunction"
End With
Next i
End Sub
Sub myFunction()
Dim parameterText As String
Dim index As Integer
index = Application.CommandBars.ActionControl.Parameter
parameterText = AllParameters(index)
MsgBox ("parameterText" & parameterText)
End Sub
No its not. VB string type can hold data more than 255 character.
A variable-length string can contain up to approximately 2 billion (2^31) characters
A fixed-length string can contain 1 to approximately 64K (2^16) characters.
and for SPLIT you can try like below
Dim LString As String
Dim LArray() As String
LString = "foobar.com"
LArray = Split(LString, ".")
MsgBox LArray(0)
MsgBox LArray(1)
Note: https://msdn.microsoft.com/en-us/library/6x627e5f(v=vs.90).aspx
Try to use below code if you get some idea.
Function Over255()
Dim myArray(3) As String '<<<<< not variant
myArray(0) = String(300, "a")
myArray(1) = String(300, "b")
myArray(2) = String(300, "c")
myArray(3) = String(300, "d")
'Over255 = Application.Transpose(myArray())
Over255 = TR(myArray)
End Function
'like Application.Transpose...
Function TR(arrIn) As String()
Dim arrOut() As String, r As Long, ln As Long, i As Long
ln = (UBound(arrIn) - LBound(arrIn)) + 1
ReDim arrOut(1 To ln, 1 To 1)
i = 1
For r = LBound(arrIn) To UBound(arrIn)
arrOut(i, 1) = arrIn(r)
i = i + 1
Next r
TR = arrOut
End Function
I have this function which returns as string the value in comma separated string which is in order of given integer value.
Private Sub TestGetNthNumber()
Debug.Print GetNthNumber("NUMBERS 5088, 5089, 5090, 5091", 2)
End Sub
Public Function GetNthNumber(sMark As String, iOrder As Integer) As String
Dim sTemp As String
Dim sNumber As String
Dim iLoop As Integer
If sMark = "" Then
Exit Function
End If
sTemp = sMark & ","
For iLoop = 1 To iOrder
sTemp = Mid(sTemp, InStr(sTemp, " "))
sNumber = Trim(Left(sTemp, InStr(sTemp, ",") - 1))
sTemp = Mid(sTemp, InStr(sTemp, ",") + 1)
Next
GetNthNumber = sNumber
End Function
The test Sub will return "5089" as its given number 2 in the list of values.
My question;
Is there better method to do this instead of the messy string manipulation with Mid, Left and InStr? Like a way to turn the comma separated string values into an array?
Another problem;
It is possible the string is in format "NUMBERS 5088, 5089, 5090 and 5091". But for this I assume simply replacing " and" with "," before handling it does the trick.
The other alternative is to use RegEx/RegExp. Your function will looks like that:
Public Function GetNthNumberAlternative(sMark As String, iOrder As Integer) As String
'regexp declaration
Dim objRegExp As Object
Set objRegExp = CreateObject("vbscript.regexp")
With objRegExp
.Global = True
.Pattern = "\d+"
GetNthNumberAlternative = .Execute(sMark)(iOrder - 1).Value
End With
End Function
And you could call it in this way:
Private Sub TestGetNthNumber()
Debug.Print GetNthNumberAlternative("NUMBERS 5088 AND 5089 OR 5090, 5091", 1)
End Sub
You want to use the Split function. If you have the same values each time then you can remove the NUMBERS and the final AND. Something like this:
Private Sub TestGetNthNumber()
Debug.Print GetNthNumber("NUMBERS 5088, 5089, 5090, 5091", 2)
End Sub
Public Function GetNthNumber(sMark As String, iOrder As Integer) As String
Dim vArray As Variant
sMark = Replace(sMark, "NUMBERS", "")
sMark = Replace(sMark, "AND", "")
vArray = Split(sMark, ",")
GetNthNumber = vArray(iOrder)
End Function
I have string "ololo123".
I need get position of first digit - 1.
How to set mask of search ?
Here is a lightweight and fast method that avoids regex/reference additions, thus helping with overhead and transportability should that be an advantage.
Public Function GetNumLoc(xValue As String) As Integer
For GetNumLoc = 1 To Len(xValue)
If Mid(xValue, GetNumLoc, 1) Like "#" Then Exit Function
Next
GetNumLoc = 0
End Function
Something like this should do the trick for you:
Public Function GetPositionOfFirstNumericCharacter(ByVal s As String) As Integer
For i = 1 To Len(s)
Dim currentCharacter As String
currentCharacter = Mid(s, i, 1)
If IsNumeric(currentCharacter) = True Then
GetPositionOfFirstNumericCharacter = i
Exit Function
End If
Next i
End Function
You can then call it like this:
Dim iPosition as Integer
iPosition = GetPositionOfFirstNumericCharacter("ololo123")
Not sure on your environment, but this worked in Excel 2010
'Added reference for Microsoft VBScript Regular Expressions 5.5
Const myString As String = "ololo123"
Dim regex As New RegExp
Dim regmatch As MatchCollection
regex.Pattern = "\d"
Set regmatch = regex.Execute(myString)
MsgBox (regmatch.Item(0).FirstIndex) ' Outputs 5
I actually have that function:
Public Function GetNumericPosition(ByVal s As String) As Integer
Dim result As Integer
Dim i As Integer
Dim ii As Integer
result = -1
ii = Len(s)
For i = 1 To ii
If IsNumeric(Mid$(s, i, 1)) Then
result = i
Exit For
End If
Next
GetNumericPosition = result
End Function
You could try regex, and then you'd have two problems. My VBAfu is not up to snuff, but I'll give it a go:
Function FirstDigit(strData As String) As Integer
Dim RE As Object REMatches As Object
Set RE = CreateObject("vbscript.regexp")
With RE
.Pattern = "[0-9]"
End With
Set REMatches = RE.Execute(strData)
FirstDigit = REMatches(0).FirstIndex
End Function
Then you just call it with FirstDigit("ololo123").
If speed is an issue, this will run a bit faster than Robs (noi Rob):
Public Sub Example()
Const myString As String = "ololo123"
Dim position As Long
position = GetFirstNumeric(myString)
If position > 0 Then
MsgBox "Found numeric at postion " & position & "."
Else
MsgBox "Numeric not found."
End If
End Sub
Public Function GetFirstNumeric(ByVal value As String) As Long
Dim i As Long
Dim bytValue() As Byte
Dim lngRtnVal As Long
bytValue = value
For i = 0 To UBound(bytValue) Step 2
Select Case bytValue(i)
Case vbKey0 To vbKey9
If bytValue(i + 1) = 0 Then
lngRtnVal = (i \ 2) + 1
Exit For
End If
End Select
Next
GetFirstNumeric = lngRtnVal
End Function
An improved version of spere's answer (can't edit his answer), which works for any pattern
Private Function GetNumLoc(textValue As String, pattern As String) As Integer
For GetNumLoc = 1 To (Len(textValue) - Len(pattern) + 1)
If Mid(textValue, GetNumLoc, Len(pattern)) Like pattern Then Exit Function
Next
GetNumLoc = 0
End Function
To get the pattern value you can use this:
Private Function GetTextByPattern(textValue As String, pattern As String) As String
Dim NumLoc As Integer
For NumLoc = 1 To (Len(textValue) - Len(pattern) + 1)
If Mid(textValue, NumLoc, Len(pattern)) Like pattern Then
GetTextByPattern = Mid(textValue, NumLoc, Len(pattern))
Exit Function
End If
Next
GetTextByPattern = ""
End Function
Example use:
dim bill as String
bill = "BILLNUMBER 2202/1132/1 PT2200136"
Debug.Print GetNumLoc(bill , "PT#######")
'Printed result:
'24
Debug.Print GetTextByPattern(bill , "PT#######")
'Printed result:
'PT2200136
Is there any way, in either VBA or C# code, to get a list of the existing macros defined in a workbook?
Ideally, this list would have a method definition signatures, but just getting a list of the available macros would be great.
Is this possible?
I haven't done vba for Excel in a long time, but if I remember well, the object model for the code was inaccessible through scripting.
When you try to access it, you receive the following error.
Run-time error '1004':
Programmatic access to Visual Basic Project is not trusted
Try:
Tools | Macro | Security |Trusted Publisher Tab
[x] Trust access to Visual Basic Project
Now that you have access to the VB IDE, you could probably export the modules and make a text search in them, using vba / c#, using regular expressions to find sub and function declarations, then delete the exported modules.
I'm not sure if there is an other way to do this, but this should work.
You can take a look the following link, to get started with exporting the modules.
http://www.developersdex.com/vb/message.asp?p=2677&ID=%3C4FCD0AE9-5DCB-4A96-8B3C-F19C63CD3635%40microsoft.com%3E
This is where I got the information about giving thrusted access to the VB IDE.
Building on Martin's answer, after you trust access to the VBP, you can use this set of code to get an array of all the public subroutines in an Excel workbook's VB Project. You can modify it to only include subs, or just funcs, or just private or just public...
Private Sub TryGetArrayOfDecs()
Dim Decs() As String
DumpProcedureDecsToArray Decs
End Sub
Public Function DumpProcedureDecsToArray(ByRef Result() As String, Optional InDoc As Excel.Workbook) As Boolean
Dim VBProj As Object
Dim VBComp As Object
Dim VBMod As Object
If InDoc Is Nothing Then Set InDoc = ThisWorkbook
ReDim Result(1 To 1500, 1 To 4)
DumpProcedureDecsToArray = True
On Error GoTo PROC_ERR
Set VBProj = InDoc.VBProject
Dim FuncNum As Long
Dim FuncDec As String
For Each VBComp In VBProj.vbcomponents
Set VBMod = VBComp.CodeModule
For i = 1 To VBMod.countoflines
If IsSubroutineDeclaration(VBMod.Lines(i, 1)) Then
FuncDec = RemoveBlanksAndDecsFromSubDec(RemoveAsVariant(VBMod.Lines(i, 1)))
If LCase(Left(VBMod.Lines(i, 1), Len("private"))) <> "private" Then
FuncNum = FuncNum + 1
Result(FuncNum, 1) = FindToLeftOfString(InDoc.Name, ".") '
Result(FuncNum, 2) = VBMod.Name
Result(FuncNum, 3) = GetSubName(FuncDec)
Result(FuncNum, 4) = VBProj.Name
End If
End If
Next i
Next VBComp
PROC_END:
Exit Function
PROC_ERR:
GoTo PROC_END
End Function
Private Function RemoveCharFromLeftOfString(TheString As String, RemoveChar As String) As String
Dim Result As String
Result = TheString
While LCase(Left(Result, Len(RemoveChar))) = LCase(RemoveChar)
Result = Right(Result, Len(Result) - Len(RemoveChar))
Wend
RemoveCharFromLeftOfString = Result
End Function
Private Function RemoveBlanksAndDecsFromSubDec(TheLine As String) As String
Dim Result As String
Result = TheLine
Result = RemoveCharFromLeftOfString(Result, " ")
Result = RemoveCharFromLeftOfString(Result, " ")
Result = RemoveCharFromLeftOfString(Result, "Public ")
Result = RemoveCharFromLeftOfString(Result, "Private ")
Result = RemoveCharFromLeftOfString(Result, " ")
RemoveBlanksAndDecsFromSubDec = Result
End Function
Private Function RemoveAsVariant(TheLine As String) As String
Dim Result As String
Result = TheLine
Result = Replace(Result, "As Variant", "")
Result = Replace(Result, "As String", "")
Result = Replace(Result, "Function", "")
If InStr(1, Result, "( ") = 0 Then
Result = Replace(Result, "(", "( ")
End If
RemoveAsVariant = Result
End Function
Private Function IsSubroutineDeclaration(TheLine As String) As Boolean
If LCase(Left(RemoveBlanksAndDecsFromSubDec(TheLine), Len("Function "))) = "function " Or LCase(Left(RemoveBlanksAndDecsFromSubDec(TheLine), Len("sub "))) = "sub " Then
IsSubroutineDeclaration = True
End If
End Function
Private Function GetSubName(DecLine As String) As String
GetSubName = FindToRightOfString(FindToLeftOfString(DecLine, "("), " ")
End Function
Function FindToLeftOfString(FullString As String, ToFind As String) As String
If FullString = "" Then Exit Function
Dim Result As String, ToFindPos As Integer
ToFindPos = InStr(1, FullString, ToFind, vbTextCompare)
If ToFindPos > 0 Then
Result = Left(FullString, ToFindPos - 1)
Else
Result = FullString
End If
FindToLeftOfString = Result
End Function
Function FindToRightOfString(FullString As String, ToFind As String) As String
If FullString = "" Then Exit Function
Dim Result As String, ToFindPos As Integer
ToFindPos = InStr(1, FullString, ToFind, vbTextCompare)
Result = Right(FullString, Len(FullString) - ToFindPos + 1 - Len(ToFind))
If ToFindPos > 0 Then
FindToRightOfString = Result
Else
FindToRightOfString = FullString
End If
End Function