In LibreOffice is it possible to get bookmark that is inserted in the text?
With the code below I can get the list of all the bookmarks I have available, but I just wanted the ones that are actually inserted in the text.
XBookmarksSupplier xBookmarksSupplier =
UnoRuntime.queryInterface(XBookmarksSupplier.class,
xCurrentComponent); XNameAccess xNamedBookmarks =
xBookmarksSupplier.getBookmarks();
Hope this helps:
Sub MyBookmarks
Dim oBookmarks As Variant
Dim oElementNames As Variant
Dim oBookmark As Variant
Dim oTextFields As Variant
Dim oEnum As Variant
Dim oTextField As Variant
Dim sSourceName As String
Dim i As Long, j As Long
Dim sResult As String
Rem First step - collect Bookmarks
oBookmarks = ThisComponent.getBookmarks()
oElementNames = oBookmarks.getElementNames()
Rem Create list of Bookmarks to count Text Fields with it
ReDim oBookmark(LBound(oElementNames) To UBound(oElementNames))
For i = LBound(oElementNames) To UBound(oElementNames)
oBookmark(i) = Array(oElementNames(i),0)
Next i
Rem Enumerate Text Fields
oTextFields = ThisComponent.getTextFields()
oEnum = oTextFields.createEnumeration()
Do While oEnum.hasMoreElements()
oTextField = oEnum.nextElement()
sSourceName = oTextField.SourceName
For i = LBound(oBookmark) To UBound(oBookmark)
If oBookmark(i)(0) = sSourceName Then
oBookmark(i)(1) = oBookmark(i)(1) + 1
Exit For
EndIf
Next i
Loop
Rem Show results
sResult = ""
For i = LBound(oBookmark) To UBound(oBookmark)
If oBookmark(i)(1) > 0 Then
sResult = sResult + oBookmark(i)(0) + " (" + oBookmark(i)(1) + ")" + Chr(10)
EndIf
Next i
If Len(sResult) > 0 Then
sResult = Left(sResult, Len(sResult)-1)
MsgBox("The text of the document uses Bookmarks:" + Chr(10) + sResult, MB_ICONINFORMATION, "Used Bookmarks")
Else
MsgBox("No Bookmarks are used in the text of the document", MB_ICONEXCLAMATION, "No Bookmarks")
EndIf
sResult = ""
For i = LBound(oBookmark) To UBound(oBookmark)
If oBookmark(i)(1) = 0 Then
sResult = sResult + oBookmark(i)(0) + ", "
EndIf
Next i
If Len(sResult) > 0 Then
MsgBox("Bookmarks that are not used in the text of the document:" + Chr(10) + Left(sResult, Len(sResult)-2), MB_ICONINFORMATION, "Not Used Bookmarks")
EndIf
End Sub
Related
I learning how to use Microsoft Word wildcards and codes to help me in my position as a medical editor. A big part of my job is submitting manuscripts to medical journals for review, and each journal has very specific requirements.
Most of the journals we submit manuscripts to require that medical terms/phrases be abbreviated only if they are used three or more times. For example, the term “Overall Survival” can be abbreviated to OS if the term is referenced at least three times in the text. If the text only mentions “Overall Survival” once or twice, it is preferred that the term remain expanded, and it should not be abbreviated to OS.
We have been using the PerfectIt system, by Intelligent Editing. This Word widget scans for abbreviations that are only used once and will flag them for our review, but does not pick up if an abbreviation is only used twice in the selected text. We are hoping to find some solution (my thought would be some sort of wildcard search or macro) that will be able to detect if an abbreviation is used only one or two times.
I saw this similar post on stackoverflow, but it seemed to do with code. I will need this to be on a company computer that I do not have administrative access to, and furthermore, I know nothing about code. I appreciate any help, guidance, or directions for further research!
Thank you!
Edit: I could use a wildcard search to make all of the two+ capitalized letters highlighted by using <[A-Z]{2,}>, then formatting them as highlighted, if this would help with any macros.
For any given abbreviation, you could use a macro like:
Sub Demo()
Application.ScreenUpdating = False
Dim i As Long
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = InputBox("What is the Text to Find")
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = True
.MatchWholeWord = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute
End With
Do While .Find.Found
i = i + 1
.Collapse wdCollapseEnd
.Find.Execute
Loop
End With
Application.ScreenUpdating = True
MsgBox i & " instances found."
End Sub
For PC macro installation & usage instructions, see: http://www.gmayor.com/installing_macro.htm
For Mac macro installation & usage instructions, see: https://wordmvp.com/Mac/InstallMacro.html
Provided there's at least one occurrence of the abbreviation in parens you could use a macro like the following. The macro checks the contents of a document for upper-case/numeric parenthetic abbreviations it then looks backwards to try to determine what term they abbreviate. For example:
World Wide Web (WWW)
Naturally, given the range of acronyms in use, it’s not foolproof and, if a match isn’t made, the preceding sentence (in VBA terms) is captured so the user can edit the output. A table is then built at the end of the document, which is then searched for all references to the acronym (other than for the definition) and the counts and page numbers added to the table.
Note that the macro won't tell you how many times 'World Wide Web' appears in the document, though. After all, given your criteria, it's impossible to know what terms should have been reduced to an acronym but weren't.
Sub AcronymLister()
Application.ScreenUpdating = False
Dim StrTmp As String, StrAcronyms As String, i As Long, j As Long, k As Long, Rng As Range, Tbl As Table
StrAcronyms = "Acronym" & vbTab & "Term" & vbTab & "Page" & vbTab & "Cross-Reference Count" & vbTab & "Cross-Reference Pages" & vbCr
With ActiveDocument
With .Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.MatchWildcards = True
.Wrap = wdFindStop
.Text = "\([A-Z0-9]{2,}\)"
.Replacement.Text = ""
.Execute
End With
Do While .Find.Found = True
StrTmp = Replace(Replace(.Text, "(", ""), ")", "")
If (InStr(1, StrAcronyms, .Text, vbBinaryCompare) = 0) And (Not IsNumeric(StrTmp)) Then
If .Words.First.Previous.Previous.Words(1).Characters.First = Right(StrTmp, 1) Then
For i = Len(StrTmp) To 1 Step -1
.MoveStartUntil Mid(StrTmp, i, 1), wdBackward
.Start = .Start - 1
If InStr(.Text, vbCr) > 0 Then
.MoveStartUntil vbCr, wdForward
.Start = .Start + 1
End If
If .Sentences.Count > 1 Then .Start = .Sentences.Last.Start
If .Characters.Last.Information(wdWithInTable) = False Then
If .Characters.First.Information(wdWithInTable) = True Then
.Start = .Cells(.Cells.Count).Range.End + 1
End If
ElseIf .Cells.Count > 1 Then
.Start = .Cells(.Cells.Count).Range.Start
End If
Next
End If
StrTmp = Replace(Replace(Replace(.Text, " (", "("), "(", "|"), ")", "")
StrAcronyms = StrAcronyms & Split(StrTmp, "|")(1) & vbTab & Split(StrTmp, "|")(0) & vbTab & .Information(wdActiveEndAdjustedPageNumber) & vbTab & vbTab & vbCr
End If
.Collapse wdCollapseEnd
.Find.Execute
Loop
StrAcronyms = Replace(Replace(Replace(StrAcronyms, " (", "("), "(", vbTab), ")", "")
Set Rng = .Characters.Last
With Rng
If .Characters.First.Previous <> vbCr Then .InsertAfter vbCr
.InsertAfter Chr(12)
.Collapse wdCollapseEnd
.Style = "Normal"
.Text = StrAcronyms
Set Tbl = .ConvertToTable(Separator:=vbTab, NumRows:=.Paragraphs.Count, NumColumns:=5)
With Tbl
.Columns.AutoFit
.Rows(1).HeadingFormat = True
.Rows(1).Range.Style = "Strong"
.Rows.Alignment = wdAlignRowCenter
End With
.Collapse wdCollapseStart
End With
End With
Rng.Start = ActiveDocument.Range.Start
For i = 2 To Tbl.Rows.Count
StrTmp = "": j = 0: k = 0
With .Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Format = False
.Forward = True
.Text = "[!\(]" & Split(Tbl.Cell(i, 1).Range.Text, vbCr)(0) & "[!\)]"
.MatchWildcards = True
.Execute
End With
Do While .Find.Found
If Not .InRange(Rng) Then Exit Do
j = j + 1
If k <> .Duplicate.Information(wdActiveEndAdjustedPageNumber) Then
k = .Duplicate.Information(wdActiveEndAdjustedPageNumber)
StrTmp = StrTmp & k & " "
End If
.Collapse wdCollapseEnd
.Find.Execute
Loop
End With
Tbl.Cell(i, 4).Range.Text = j
StrTmp = Replace(Trim(StrTmp), " ", ",")
If StrTmp <> "" Then
'Add the current record to the output list (StrOut)
StrTmp = Replace(Replace(ParseNumSeq(StrTmp, "&"), ",", ", "), " ", " ")
End If
Tbl.Cell(i, 5).Range.Text = StrTmp
Next
End With
Set Rng = Nothing: Set Tbl = Nothing
Application.ScreenUpdating = True
End Sub
Function ParseNumSeq(StrNums As String, Optional StrEnd As String)
'This function converts multiple sequences of 3 or more consecutive numbers in a
' list to a string consisting of the first & last numbers separated by a hyphen.
' The separator for the last sequence can be set via the StrEnd variable.
Dim ArrTmp(), i As Long, j As Long, k As Long
ReDim ArrTmp(UBound(Split(StrNums, ",")))
For i = 0 To UBound(Split(StrNums, ","))
ArrTmp(i) = Split(StrNums, ",")(i)
Next
For i = 0 To UBound(ArrTmp) - 1
If IsNumeric(ArrTmp(i)) Then
k = 2
For j = i + 2 To UBound(ArrTmp)
If CInt(ArrTmp(i) + k) <> CInt(ArrTmp(j)) Then Exit For
ArrTmp(j - 1) = ""
k = k + 1
Next
i = j - 2
End If
Next
StrNums = Join(ArrTmp, ",")
StrNums = Replace(Replace(Replace(StrNums, ",,", " "), ", ", " "), " ,", " ")
While InStr(StrNums, " ")
StrNums = Replace(StrNums, " ", " ")
Wend
StrNums = Replace(Replace(StrNums, " ", "-"), ",", ", ")
If StrEnd <> "" Then
i = InStrRev(StrNums, ",")
If i > 0 Then
StrNums = Left(StrNums, i - 1) & Replace(StrNums, ",", " " & Trim(StrEnd), i)
End If
End If
ParseNumSeq = StrNums
End Function
From time to time, typically when coding, I would like to dictate a phrase so that it is camelCased a phrase. For example, when I dictate sentence generator I would like Dragon NaturallySpeaking to write sentenceGenerator.
How can I camelCase a phrase with Dragon NaturallySpeaking's advanced scripting?
Same question for Dragon Dictate: How can I convert a series of words into camel case in AppleScript?
You can use this function:
' CamelCases the previous <1to10> words:
' Voice command name: CamelCase <1to10>
' Author: Edgar
' URL: https://www.knowbrainer.com/forums/forum/messageview.cfm?FTVAR_FORUMVIEWTMP=Linear&catid=12&threadid=14634&discTab=true
' URL mirror: https://web.archive.org/web/20170606015010/https://www.knowbrainer.com/forums/forum/messageview.cfm?FTVAR_FORUMVIEWTMP=Linear&catid=12&threadid=14634&discTab=true
' Tested with Dragon NaturallySpeaking 12.5 with Windows 7 SP1 x64 Ultimate
Sub Main
Dim camelVariable, dictate, firstCharacter As String
Dim wasSpace, isLower, trailingSpace As Boolean
Dim dictationLength As Integer
For increment = 1 To Val (ListVar1)
SendKeys "+^{Left}", 1
Next increment
Wait 0.2
SendKeys "^c", 1
Wait 0.3
dictate = Clipboard
Wait 0.3
dictationLength = Len (dictate)
If Mid (dictate, dictationLength, 1) = " " Then trailingSpace = True
'Dim testing As String
'testing = "#" + Mid (dictate, 1, dictationLength) + "#"
'MsgBox testing
dictate = Trim (dictate)
firstCharacter = Mid (dictate, 1, 1)
firstCharacter = LCase (firstCharacter)
camelVariable = firstCharacter
dictationLength = Len (dictate)
If dictationLength > 1 Then
For increment = 2 To dictationLength
firstCharacter = Mid (dictate, increment, 1)
If firstCharacter = " " Then
wasSpace = True
Else
If wasSpace = True Then firstCharacter = UCase (firstCharacter)
camelVariable = camelVariable + firstCharacter
wasSpace = False
End If
Next increment
End If
If leadingSpace = True Then camelVariable = " " + camelVariable
If trailingSpace = True Then camelVariable = camelVariable + " "
SendKeys camelVariable
End Sub
or
' CamelCases the previous dictated words:
' Voice command name: CamelCase that
' Author: Heather
' URL: https://www.knowbrainer.com/forums/forum/messageview.cfm?FTVAR_FORUMVIEWTMP=Linear&catid=12&threadid=14634&discTab=true
' URL mirror: https://web.archive.org/web/20170606015010/https://www.knowbrainer.com/forums/forum/messageview.cfm?FTVAR_FORUMVIEWTMP=Linear&catid=12&threadid=14634&discTab=true
' Tested with Dragon NaturallySpeaking 12.5 with Windows 7 SP1 x64 Ultimate
Option Explicit
Sub Main
Dim engCtrl As New DgnEngineControl
Dim Text As String
Dim VarText As String
HeardWord "cut","that"
Text = Clipboard
SendDragonKeys "" & CamelCase(Text)
End Sub
Public Function CamelCase(strInput As String) As String
Dim i As Integer
Dim sMid As String
Dim foundSpace As Boolean
For i = 1 To Len(strInput)
sMid = Mid(strInput, i, 1)
Select Case Asc(sMid)
Case 32:
foundSpace = True
Case 65 To 90:
If i = 1 Then
CamelCase = CamelCase + LCase(sMid)
Else
CamelCase = CamelCase + sMid
End If
foundSpace = False
Case 97 To 122:
If foundSpace Then
CamelCase = CamelCase + UCase(sMid)
Else
CamelCase = CamelCase + sMid
End If
foundSpace = False
Case Else:
CamelCase = CamelCase + sMid
foundSpace = False
End Select
Next i
End Function
or
' CamelCases the next dictated words:
' Voice command name: CamelCase <dictation>
' Author: Edgar
' URL: https://www.knowbrainer.com/forums/forum/messageview.cfm?FTVAR_FORUMVIEWTMP=Linear&catid=12&threadid=14634&discTab=true
' URL mirror: https://web.archive.org/web/20170606015010/https://www.knowbrainer.com/forums/forum/messageview.cfm?FTVAR_FORUMVIEWTMP=Linear&catid=12&threadid=14634&discTab=true
' Requires Dragon NaturallySpeaking 13 Professional or higher, because the variable <dictation> was introduced in Dragon NaturallySpeaking 13 Professional.
Sub Main
Dim camelVariable, dictate, firstCharacter As String
Dim wasSpace, isLower As Boolean
Dim dictationLength As Integer
dictate = ListVar1
dictate = Trim (dictate)' probably unnecessary
firstCharacter = Mid (dictate, 1, 1)
firstCharacter = LCase (firstCharacter)
camelVariable = firstCharacter
dictationLength = Len (dictate)
If dictationLength > 1 Then
For increment = 2 To dictationLength
firstCharacter = Mid (dictate, increment, 1)
If firstCharacter = " " Then
wasSpace = True
Else
If wasSpace = True Then firstCharacter = UCase (firstCharacter)
camelVariable = camelVariable + firstCharacter
wasSpace = False
End If
Next increment
End If
SendKeys " " + camelVariable + " "
End Sub
(source) (mirror)
The answer from 2017 has syntax issues. I just coded and tested this for Dragon 15:
'#Language "WWB-COM"
' Command name: case camel <dictation>
'
' Description:
' Applies camel case to provided phrase.
'
' Usage:
' "case camel looks good to me" -> "looksGoodToMe"
Option Explicit
Sub Main
Dim phrase As String
Dim result As String
Dim wasSpace As Boolean
Dim i As Integer
phrase = ListVar1
phrase = Trim(phrase)
wasSpace = False
For i = 0 To Len(phrase) - 1
If i = 0 Then
result = LCase(Mid(phrase,i + 1,1))
ElseIf Mid(phrase,i + 1,1) = " " Then
wasSpace = True
ElseIf wasSpace Then
result += UCase(Mid(phrase,i + 1,1))
wasSpace = False
Else
result += LCase(Mid(phrase,i + 1,1))
End If
Next
SendKeys result
End Sub
I'm trying to export one of my queries to email using VBA in a table format. Similar to when you go to external data and click and E-Mail and it adds an attachment to outlook. Except I want it in the body. I put the following code in a button.
I found and made some changes to some code. This is what I have.
Private Sub Command5_Click()
Dim olApp As Object
Dim olItem As Variant
Dim db As DAO.Database
Dim rec As DAO.Recordset
Dim strQry As String
Dim aHead(1 To 4) As String
Dim aRow(1 To 4) As String
Dim aBody() As String
Dim lCnt As Long
'Create the header row
aHead(1) = "Part"
aHead(2) = "Description"
aHead(3) = "Qty"
aHead(4) = "Price"
lCnt = 1
ReDim aBody(1 To lCnt)
aBody(lCnt) = "<HTML><body><table border='2'><tr><th>" & Join(aHead, "</th> <th>") & "</th></tr>"
'Create each body row
strQry = "SELECT * From qry_email"
Set db = CurrentDb
Set rec = CurrentDb.OpenRecordset(strQry)
If Not (rec.BOF And rec.EOF) Then
Do While Not rec.EOF
lCnt = lCnt + 1
ReDim Preserve aBody(1 To lCnt)
aRow(1) = rec("Part")
aRow(2) = rec("Description")
aRow(3) = rec("Qty")
aRow(4) = rec("Price")
aBody(lCnt) = "<tr><td>" & Join(aRow, "</td><td>") & "</td></tr>"
rec.MoveNext
Loop
End If
aBody(lCnt) = aBody(lCnt) & "</table></body></html>"
'create the email
Set olApp = CreateObject("Outlook.application")
Set olItem = olApp.CreateItem(0)
olItem.Display
olItem.To = "email#email.com"
olItem.Subject = "Test E-mail"
olItem.HTMLBody = Join(aBody, vbNewLine)
olItem.Display
End Sub
When I run the code, I get a "Run-time error '3061' too few parameters. Expected 1."
If i click debug i get this highlighted in yellow. Anybody help would be greatly appreciated!
Edit
I tried a different approach which actually gave me the list in the body of the email. But it does it for the whole table instead of just the one record I want. This is what the SQL looks like of the query.
SELECT tblePMParts.[Part#], tblePMParts.PartDescription, tblePMParts.Qty, tblePMParts.Price
FROM tblePMParts
WHERE (((tblePMParts.WOID)=[Forms]![fmremail]![Text1]));
How would I go about adding the WHERE to the code below.
Private Sub Command4_Click()
'On Error GoTo Errorhandler
Dim olApp As Object
Dim olItem As Variant
Dim olatt As String
Dim olMailTem As Variant
Dim strSendTo As String
Dim strMsg As String
Dim strTo As String
Dim strcc As String
Dim rst As DAO.Recordset
Dim rs As DAO.Recordset
Dim db As DAO.Database
Dim qry As DAO.QueryDef
Dim fld As Field
Dim varItem As Variant
Dim strtable As String
Dim rec As DAO.Recordset
Dim strQry As String
strQry = "SELECT tblePMParts.[Part#], tblePMParts.PartDescription, tblePMParts.Qty, tblePMParts.Price " & _
"FROM tblePMParts; "
strSendTo = "test#email.com"
strTo = ""
strcc = ""
Set olApp = CreateObject("Outlook.application")
Set olItem = olApp.CreateItem(olMailTem)
olItem.Display
olItem.To = strTo
olItem.CC = strcc
olItem.Body = ""
olItem.Subject = "Please Quote the Following!"
Set db = CurrentDb
Set rec = CurrentDb.OpenRecordset(strQry)
If Not (rec.BOF And rec.EOF) Then
rec.MoveLast
rec.MoveFirst
intCount = rec.RecordCount
For intLoop = 1 To intCount
olItem.Body = olItem.Body & rec("[Part#]") & " - " & rec("PartDescription") & " - " & rec("Qty") & " - " & rec("Price")
rec.MoveNext
Next intLoop
End If
MsgBox "Completed Export"
Set olApp = Nothing
Set olItem = Nothing
Exit_Command21_Click:
Exit Sub
ErrorHandler:
MsgBox Err.Description, , Err.Number
Resume Exit_Command21_Click
End Sub
I got it working. Here is the code in case anybody needs it.
Private Sub Command5_Click()
Dim olApp As Object
Dim olItem As Variant
Dim db As DAO.Database
Dim rec As DAO.Recordset
Dim strQry As String
Dim aHead(1 To 3) As String
Dim aRow(1 To 3) As String
Dim aBody() As String
Dim lCnt As Long
'Create the header row
aHead(1) = "Part#"
aHead(2) = "Description"
aHead(3) = "Qty"
lCnt = 1
ReDim aBody(1 To lCnt)
aBody(lCnt) = "<HTML><body><table border='2'><tr><th>" & Join(aHead, "</th><th>") & "</th></tr>"
'Create each body row
strQry = "SELECT tblePMParts.[Part#], tblePMParts.PartDescription, tblePMParts.Qty, tblePMParts.Price " & _
"FROM tblePMParts " & _
"WHERE (((tblePMParts.WOID)=" & [Forms]![fmremail]![Text1] & "));"
Set db = CurrentDb
Set rec = CurrentDb.OpenRecordset(strQry)
If Not (rec.BOF And rec.EOF) Then
Do While Not rec.EOF
lCnt = lCnt + 1
ReDim Preserve aBody(1 To lCnt)
aRow(1) = rec("[Part#]")
aRow(2) = rec("PartDescription")
aRow(3) = rec("Qty")
aBody(lCnt) = "<tr><td>" & Join(aRow, "</td><td>") & "</td></tr>"
rec.MoveNext
Loop
End If
aBody(lCnt) = aBody(lCnt) & "</table></body></html>"
'create the email
Set olApp = CreateObject("Outlook.application")
Set olItem = olApp.CreateItem(0)
olItem.Display
olItem.To = "Email"
olItem.Subject = "Test E-mail"
olItem.HTMLBody = Join(aBody, vbNewLine)
olItem.Display
End Sub
Somewhere in your code, put a line that says
X = [Forms]![fmremail]![Text1]
Put a breakpoint in your code (hopefully you know how to do that?) on that line. When the code breaks, press F8 to step to the next line, and then type ?X in the Immediate Window. Or you can just hover your mouse over the line with the break point. The point is, you need to see what your code thinks [Forms]![fmremail]![Text1] is equal to. If it's null, you have a problem with your reference. In that case, you may need to add ".Value" or ".Text" to the end of it.
Another thing to check is your datatype for WOID. if it's text, you need to surround it with single quotes.
strQry = "SELECT tblePMParts.[Part#], tblePMParts.PartDescription, tblePMParts.Qty, tblePMParts.Price " & _
"FROM tblePMParts " & _
"WHERE (((tblePMParts.WOID)='" & [Forms]![fmremail]![Text1] & "'));"
I encounter a real difficulty in tracking changes and updates in the company models.
I research the tool abilities a lot, but still didn't find the golden way that match my requirements of:
Provide indication where was a change
What was the change
Keep the original model state, aside to the up-to-date state
EA offers the following ways:
Baselines
Version Control
Clone
Change Elements
None of them provides indication on what exactly was the change and where.
What is the easiest way to manage the changes effectively?
You forgot the last resort: audit. Turn on auditing and you can get a lot more information. Of course this also has its drawbacks
it uses a lot of space
there are still changes that are not tracked in the detail you might need it.
Turn it on at Project/Auditing. More information here.
Additionally you could think of writing triggers, but I would not recommend that since it makes your repository almost unmaintainable.
Auditing is of course also no silver bullet. Tracking changes is tedious. And personally I would not spend too much effort in this "accusation mode". Better spend your energy in driving the model towards the company goals. Nobody needs yesterday's model.
I wrote some scripts to handle change management in EA.
The idea is that the user links the changed items to a change request element that represents a workitem, project, change request, bug,...
Each link contains the date, user and a comment for the change to that item.
The scripts are part of the open source EA VBScript library:
The main script is the following
'[path=\Projects\Project A\A Scripts]
'[group=Atrias Scripts]
!INC Local Scripts.EAConstants-VBScript
!INC Atrias Scripts.Util
' Script Name: LinkToCRMain
' Author: Geert Bellekens
' Purpose: Link Elemnents to a change
' Date: 2015-10-30
'
'
function linkItemToCR(selectedItem, selectedItems)
dim groupProcessing
groupProcessing = false
'if the collection is given then we initialize the first item.
if selectedItem is nothing then
if not selectedItems is nothing then
if selectedItems.Count > 0 then
set selectedItem = selectedItems(0)
if selectedItems.Count > 1 then
groupProcessing = true
end if
end if
end if
end if
if selectedItem is nothing then
set selectedItem = Repository.GetContextObject()
end if
'get the select context item type
dim selectedItemType
selectedItemType = selectedItem.ObjectType
select case selectedItemType
case otElement, otPackage, otAttribute, otMethod, otConnector :
'if the selectedItem is a package then we use the Element part of the package
if selectedItemType = otPackage then
set selectedItem = selectedItem.Element
end if
'get the logged in user
Dim userLogin
userLogin = getUserLogin
dim lastCR as EA.Element
set lastCR = nothing
dim CRtoUse as EA.Element
set CRtoUse = nothing
set lastCR = getLastUsedCR(userLogin)
'get most recent used CR by this user
if not selectedItem is nothing then
dim lastComments
lastComments = vbNullString
'if there is a last CR then we ask the user if we need to use that one
if not lastCR is nothing then
dim response
if groupProcessing then
response = Msgbox("Link all " & selectedItems.Count & " elements to change: """ & lastCR.Name & """?", vbYesNoCancel+vbQuestion, "Link to CR")
elseif not isCRLinked(selectedItem,lastCR) then
response = Msgbox("Link element """ & selectedItem.Name & """ to change: """ & lastCR.Name & """?", vbYesNoCancel+vbQuestion, "Link to CR")
end if
'check the response
select case response
case vbYes
set CRToUse = lastCR
case vbCancel
'user cancelled, stop altogether
Exit function
end select
end if
'If there was no last CR, or the user didn't want to link that one we let the user choose one
if CRToUse is nothing then
dim CR_id
CR_ID = Repository.InvokeConstructPicker("IncludedTypes=Change")
if CR_ID > 0 then
set CRToUse = Repository.GetElementByID(CR_ID)
end if
else
'user selected same change as last time. So he might want to reuse his comments as well
lastComments = getLastUsedComment(userLogin)
end if
'if the CRtoUse is now selected then we link it to the selected element
if not CRToUse is nothing then
dim linkCounter
linkCounter = 0
'first check if this CR is not already linked
if isCRLinked(selectedItem,CRToUse) and not groupProcessing then
MsgBox "The CR was already linked to this item", vbOKOnly + vbExclamation ,"Already Linked"
else
'get the comments to use
dim comments
comments = InputBox("Please enter comments for this change", "Change Comments",lastComments)
if len(comments) > 2 then
if groupProcessing then
for each selectedItem in selectedItems
'check the object type
selectedItemType = selectedItem.ObjectType
select case selectedItemType
case otElement, otPackage, otAttribute, otMethod, otConnector :
if not isCRLinked(selectedItem,CRToUse) then
linkToCR selectedItem, selectedItemType, CRToUse, userLogin, comments
linkCounter = linkCounter + 1
end if
end select
next
if linkCounter > 0 then
MsgBox "Successfully linked " & selectedItems.Count & " elements to change """ & CRToUse.Name& """" , vbOKOnly + vbInformation ,"Elements linked"
else
MsgBox "No links created to change " & CRToUse.Name & "." & vbNewLine & "They are probably already linked" , vbOKOnly + vbExclamation ,"Already Linked"
end if
else
linkToCR selectedItem, selectedItemType, CRToUse, userLogin, comments
end if
else
MsgBox "The CR has not been linked because no comment was provided", vbOKOnly + vbExclamation ,"No CR link"
end if
end if
end if
end if
case else
MsgBox "Cannot link this type of element to a CR" & vbNewline & "Supported element types are: Element, Package, Attribute, Operation and Relation"
end select
end function
function isCRLinked(item, CR)
dim taggedValue as EA.TaggedValue
isCRLinked = false
for each taggedValue in item.TaggedValues
if taggedValue.Value = CR.ElementGUID then
isCRLinked = true
exit for
end if
next
end function
function linkToCR(selectedItem, selectedItemType, CRToUse, userLogin, comments)
Session.Output "CRToUse: " & CRToUse.Name & " userLogin: " & userLogin & " comments: " & comments
dim crTag
set crTag = nothing
set crTag = selectedItem.TaggedValues.AddNew("CR","")
if not crTag is nothing then
crTag.Value = CRToUse.ElementGUID
crTag.Notes = "user=" & userLogin & ";" & _
"date=" & Year(Date) & "-" & Right("0" & Month(Date),2) & "-" & Right("0" & Day(Date),2) & ";" & _
"comments=" & comments
crTag.Update
end if
end function
function getLastUsedCR(userLogin)
dim wildcard
dim sqlDateString
if Repository.RepositoryType = "JET" then
wildcard = "*"
sqlDateString = " mid(tv.Notes, instr(tv.[Notes],'date=') + len('date='),10) "
Else
wildcard = "%"
sqlDateString = " substring(tv.Notes, charindex('date=',tv.[Notes]) + len('date='),10) "
end if
dim sqlGetString
sqlGetString = "select top 1 o.Object_id " & _
" from (t_objectproperties tv " & _
" inner join t_object o on o.ea_guid = tv.VALUE) " & _
" where tv.[Notes] like 'user=" & userLogin & ";" & wildcard & "' " & _
" order by " & sqlDateString & " desc, tv.PropertyID desc "
dim CRs
dim CR as EA.Element
set CR = nothing
'get the last CR
set CRs = getElementsFromQuery(sqlGetString)
if CRs.Count > 0 then
set CR = CRs(0)
end if
set getLastUsedCR = CR
end function
function getLastUsedComment(userLogin)
dim wildcard
dim sqlDateString
dim sqlCommentsString
if Repository.RepositoryType = "JET" then
wildcard = "*"
sqlDateString = " mid(tv.Notes, instr(tv.[Notes],'date=') + len('date='),10) "
sqlCommentsString = " mid(tv.Notes, instr(tv.[Notes],'comments=') + len('comments=')) "
Else
wildcard = "%"
sqlDateString = " substring(tv.Notes, charindex('date=',tv.[Notes]) + len('date='),10) "
sqlCommentsString = " substring(tv.Notes, charindex('comments=',tv.[Notes]) + len('comments='), datalength(tv.Notes)) "
end if
dim sqlGetString
sqlGetString = "select top 1 " & sqlCommentsString & " as comments " & _
" from (t_objectproperties tv " & _
" inner join t_object o on o.ea_guid = tv.VALUE) " & _
" where tv.[Notes] like 'user=" & userLogin & ";" & wildcard & "' " & _
" order by " & sqlDateString & " desc, tv.PropertyID desc "
dim queryResult
queryResult = Repository.SQLQuery(sqlGetString)
Session.Output queryResult
dim results
results = convertQueryResultToArray(queryResult)
if Ubound(results) > 0 then
getLastUsedComment = results(0,0)
else
getLastUsedComment = vbNullString
end if
end function
I have a select distinct query that works find on selected fields from a listbox. However I would like it to be a count distinct and I can't seem to get the code right. Below is my working code for select distinct. Thanks in advance for any assistance I've searched for count distinct questions but I don't see any specific to listbox selections.
Private Sub CmdDistinctVal_Click()
Dim cn1 As ADODB.Connection
Dim rs1 As New ADODB.Recordset
Dim cmd1 As New ADODB.Command
Dim varItem As Variant
Dim aFields() As aArray
Dim NumRows As Integer
Dim NumFields As Integer
Dim colcount As Integer
Dim colwidths As String
Dim strRow As String
Dim cnt1 As Integer
Dim cnt2 As Integer
'On Error GoTo Err_ CmdDistinctVal_Click
'cmd1.ActiveConnection = CurrentProject.Connection
Me.DistinctResultsFldVal.RowSource = ""
ReDim aFields(50)
For cnt1 = 1 To 50
ReDim aFields(cnt1).fValue(6000)
Next
NumRows = 0
colcount = 0
For Each varItem In Me!ResultsFieldList.ItemsSelected
colcount = colcount + 1
aFields(colcount).fName = Me!ResultsFieldList.ItemData(varItem)
NumFields = 0
rs1.Open "SELECT DISTINCT " & Me!ResultsFieldList.ItemData(varItem) & "
FROM [Results Report]", CurrentProject.Connection, adOpenKeyset, adLockOptimistic
If rs1.RecordCount > NumRows Then NumRows = rs1.RecordCount
strRow = strRow & Me!ResultsFieldList.ItemData(varItem) & ";"
While Not rs1.EOF
NumFields = NumFields + 1
If NumFields > NumRows Then
NumRows = NumFields
End If
aFields(colcount).fValue(NumFields) = rs1(0) & ""
rs1.MoveNext
Wend
rs1.Close
Next varItem
strRow = Left(strRow, Len(strRow) - 1)
Me.DistinctResultsFldVal.ColumnCount = colcount
Me.DistinctResultsFldVal.ColumnWidths = Mid(colwidths, 2)
Me.DistinctResultsFldVal.AddItem (strRow)
For cnt1 = 1 To NumRows
strRow = ""
For cnt2 = 1 To colcount
If aFields(cnt2).fValue(cnt1) = "" Then
strRow = strRow & ";"
Else
strRow = strRow & aFields(cnt2).fValue(cnt1) & ";"
End If
Next
strRow = Left(strRow, Len(strRow) - 1)
Me.DistinctResultsFldVal.AddItem (strRow)
Next
'Err_ CmdDistinctVal_Click:
'MsgBox "All null values were found in one or more of your selected fields"
End Sub