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
I have the code below in a button in my forms in MS Access. The problem is that sometimes not all "strCTRL"s exist. In some forms they do, in some they don't. The whole code is 900+ lines long so I won't post all of it. It's a SQL query which references controls and extracts their value.
The problem comes when not all controls are present, then I get the error: Compile error: Method or data Member not found.
Is there a way to bypass the compile error or tell VBA to compile it only if it exists? I tried If...Nothing and On Error Resume Next, but they don't seem to work. There's also other objects that will not exist on each page, not just the ones below. So...any ideas? =/
Dim strCTRL1 As String
Dim strCTRL2 As String
Dim strCTRL3 As String
Dim strCTRL4 As String
Dim strCTRL5 As String
Dim strCTRL6 As String
Dim strCTRL7 As String
Dim strCTRL8 As String
Dim strCTRL9 As String
Dim strCTRL10 As String
DoCmd.SetWarnings False
On Error Resume Next
strCTRL1 = "[Control Number] = " & Me.Text684.DefaultValue & " "
strCTRL2 = "[Control Number] = " & Me.Label2210.DefaultValue & " "
strCTRL3 = "[Control Number] = " & Me.Label2295.DefaultValue & " "
strCTRL4 = "[Control Number] = " & Me.Label73.DefaultValue & " "
strCTRL5 = "[Control Number] = " & Me.Label160.DefaultValue & " "
strCTRL6 = "[Control Number] = " & Me.Label246.DefaultValue & " "
strCTRL7 = "[Control Number] = " & Me.Label332.DefaultValue & " "
strCTRL8 = "[Control Number] = " & Me.Label417.DefaultValue & " "
strCTRL9 = "[Control Number] = " & Me.Label506.DefaultValue & " "
strCTRL10 = "[Control Number] = " & Me.Text2285.DefaultValue & " "
You can create an array or list of the label names, then:
Dim LabelName As String
Dim LabelNames As Variant
LabelNames = Array("Text684", "Label2210", ...etc.)
' ...
LabelName = LabelNames(1)
strCTRL1 = "[Control Number] = " & Me(LabelName).DefaultValue & " "
That will compile, though - of course - fail at runtime for non-existing labels.
OK, thanks to #Gustav, you got your code to compile, and his suggestions, combined with On Error Resume Next will get your code to run without errors under any circumstance.
But there is no way to tell if your code is correct, because now, the compiler won't tell you which controls are misnamed or missing.
So instead, I would suggest an array-based approach like this:
Dim Ctl As Access.Control
Dim CtlValues() As String
Dim i as Long
i = 0
ReDim CtlValues 1 To Me.Controls.Count
For Each Ctl In Me.Controls
If Ctl.ControlType = acTextBox Then
i = i + 1
CtlValues(i) = "[Control Number] = " & CStr(Nz(Ctl.DefaultValue, "Null"))
End If
Next
ReDim Preserve CtlValues 1 To i
These 12 lines of code perform the same task that the 900 lines do (going by your example). This code will work in any form, regardless of how many controls there are, and what they are named. This code is way easier to understand and work with.
See if maybe an approach like this will work here.
The "Find and Replace" dialog keeps coming up after my button event runs. Why and what can I do to stop it?
Private Sub btn_Find_Click()
Dim query_string As String
'MsgBox (Me.InventoryDetailsID)
query_string = "SELECT " & _
"tbl_Inventory_Header.InventoryHeaderID, " & _
"tbl_Inventory_Header.InventoryTitle, " & _
"tbl_Inventory_Header.Author, " & _
"tbl_Lookup_MediaTypes.MediaTypeDescription, " & _
"tbl_Inventory_Details.ShelfNumber, " & _
"tbl_Lookup_Vendors.VendorName, " & _
"tbl_Inventory_Header.Year_Publish_Produced, " & _
"tbl_Inventory_Header.InventoryDescription " & _
"FROM (((tbl_Inventory_Header " & _
"INNER JOIN tbl_Inventory_Details ON tbl_Inventory_Details.InventoryHeaderID = tbl_Inventory_Header.InventoryHeaderID) " & _
"INNER JOIN tbl_Lookup_Vendors ON tbl_Lookup_Vendors.VendorID = tbl_Inventory_Header.VendorID) " & _
"INNER JOIN tbl_Lookup_MediaTypes ON tbl_Lookup_MediaTypes.MediaTypeID = tbl_Inventory_Header.MediaTypeID) " & _
"WHERE tbl_Inventory_Details.InventoryDetailsID LIKE '" & Me.InventoryDetailsID & "';"
Me.Controls!test.Value = query_string
'MsgBox ("Querying for record data")
CurrentDb.QueryDefs("qry_Inventory_Header_ISBN").SQL = query_string
Dim recordSet As DAO.recordSet
Set recordSet = CurrentDb.OpenRecordset("qry_Inventory_Header_ISBN")
If Not recordSet.RecordCount > 0 Then
MsgBox ("No record found for barcode " & Me.Controls!InventoryDetailsID)
GoTo Exit_btn_SearchByHeaderId_Click
Else
'MsgBox ("record found")
End If
'MsgBox (recordSet!InventoryTitle)
'MsgBox ("filling controls")
Me.Controls!InventoryTitle.Value = recordSet!InventoryTitle
Me.Controls!Author = recordSet!Author
Me.Controls!MediaTypeDescription = recordSet!MediaTypeDescription
Me.Controls!VendorName = recordSet!VendorName
Me.Controls!Year_Publish_Produced = recordSet!Year_Publish_Produced
Me.Controls!InventoryDescription = recordSet!InventoryDescription
Me.Controls!ShelfNumber = recordSet!ShelfNumber
Me.Controls!ISBN.SetFocus
On Error GoTo Err_btn_SearchByHeaderId_Click
'MsgBox ("got error")
Screen.PreviousControl.SetFocus
DoCmd.RunCommand acCmdFind
Exit_btn_SearchByHeaderId_Click:
'MsgBox ("exit")
Exit Sub
Err_btn_SearchByHeaderId_Click:
MsgBox Err.Description
Resume Exit_btn_SearchByHeaderId_Click
End Sub
The Find dialog derives at this command DoCmd.RunCommand acCmdFind towards the bottom just before the error handlers.
And according to the code, this Find command will always run since no If Then, Do While Loop, For Next, or Goto is wrapped around it.
Consider removing it, re-positioning it, or placing an Exit Sub before it if this Find command should be part of an error handle.
I am struggling with the above error when trying to write the Visual Basic code for a 2010 Access Form. I am trying to get ensure that the associate and the Team Lead get the same email. When I first wrote the code, it worked initially. I have since added an "issue date" to the form, but not to the email. I attempted to add the issue date to the Script, but that did not work. I have since removed both the issue date from the form and the script. Any help would appreciated:
Private Sub cmdEmail_Click()
Dim objOutlook As Object
Dim objMailItem As Object
Const olMailItem As Integer = 0
Dim objMailItem1 As Object
Const olMailItem1 As Integer = 0
Set objOutlook = CreateObject("Outlook.Application")
Set objMailItem = objOutlook.CreateItem(olMailItem)
Set objMailItem1 = objOutlook.CreateItem(olMailItem1)
Dim strPathAttach As String
On Error GoTo err_Error_handler
'set receipient, you can use a DLookup() to retrieve your associate Email address
objMailItem.To = DLookup("Email_ID", "dbo_Noble_Associates", "[Fullname]='" & Me.cboAssociate & "'")
objMailItem1.To = DLookup("Email_ID", "dbo_TeamLeads$", "[Fullname]='" & Me.txtTeamLead & "'")
'set subject with text and Form values
objMailItem.Subject = "Attendance Violation " & Me.cboAssociate
objMailItem1.Subject = "Attendance Violation " & Me.cboAssociate
'set body content with text and Form values etc.
objMailItem.htmlBody = "Date of Occurrence: " & Format(Me.Occurrence_Date, "mm/dd/yyyy") & "<br>" & "Attendance Points: " & Me.CboType & "<br>" & "Total Points: " & Me.txtTotalpoints & "<br>" & "Notes: " & Me.txtNotes
objMailItem1.htmlBody = "Date of Occurrence: " & Format(Me.Occurrence_Date, "mm/dd/yyyy") & "<br>" & "Attendance Points: " & Me.CboType & "<br>" & "Total Points: " & Me.txtTotalpoints & "<br>" & "Notes: " & Me.txtNotes
' display email
' objMailItem.Display
' sending mail automaticly
objMailItem.Send
objMailItem1.Send
Set objOutlook = Nothing
Set objMailItem = Nothing
Set objMailItem1 = Nothing
exit_Error_handler:
On Error Resume Next
Set objOutlook = Nothing
Set objMailItem = Nothing
Set objMailItem1 = Nothing
Exit Sub
err_Error_handler:
Select Case Err.Number
'trap error 287
Case 287
MsgBox "Canceled by user.", vbInformation
Case Else
MsgBox "Error " & Err.Number & " " & Err.Description
End Select
Resume exit_Error_handler
End Sub
Private Sub CheckEmail_Click()
End Sub
Private Sub cmdSaveandNew_Click()
If Me.txtOccurrence_Date & "" = "" Then
MsgBox "Please enter the date."
Me.txtOccurrence_Date.SetFocus
Exit Sub
ElseIf Me.cboAssociate & "" = "" Then
MsgBox "Please select the associate's name."
Me.cboAssociate.SetFocus
Exit Sub
ElseIf Me.txtPoints & "" = "" Then
MsgBox "Please enter the number of Points."
Me.txtPoints.SetFocus
Exit Sub
End If
If Me.CheckEmail = True Then
cmdEmail_Click
End If
DoCmd.Close acForm, Me.Name
End Sub
Private Sub cmd_Cancel_Click()
Me.Undo
DoCmd.Close acForm, Me.Name
End Sub
Private Sub cboassociate_AfterUpdate()
Me.txtTeamLead.Value = Me.cboAssociate.Column(1)
End Sub
Private Sub cboFullname_AfterUpdate()
Me.txtCurrentpoints.Value = Me.cbofullname.Column(1)
End Sub
Private Sub CboType_AfterUpdate()
Me.txtPoints.Value = Me.CboType.Column(1)
End Sub
I am open to any suggestions.
I'm hoping someone has already developed a script to do this.
I'm need to query all objects in AD (users, computers, containers (OU's), everything exceot for the forest root) and show which objects in AD do not have the "Include inheritable permissions from this object's parent" attribute checked.
Thanks much
If you show some initiative, I can help in VBS. I wrote a VBS a while ago to query everything in AD for below attributes via LDAP, and putting results in Excel and plain text file.
"objectCategory"
"objectClass"
"objectGUID"
"objectSid"
"sIDHistory"
"sAMAccountName"
"description"
"sAMAccountType"
"userAccountControl"
"whenCreated"
"whenChanged"
"givenName"
"sn"
"displayName"
"title"
"mail"
"physicalDeliveryOfficeName"
"memberOf"
"telephoneNumber"
"mobile"
"pager"
"company"
"lastLogon"
"badPwdCount"
"badPasswordTime"
"streetAddress"
"l"
"postalCode"
"st"
"co"
I will show you my first 50/360 lines of code:
Const ADS_SCOPE_SUBTREE = 2
Const PageSize = 2000
Const GAP = "——————————————————————————————————————————————————"
'=== Public Variables ===
Dim aADProp, sRootLDAP, oRecordSet, oFSO, oLogFile, oExcel, oWB, oWS
Dim lObjects, lComputersEnabled, lUsersEnabled, lComputersDisabled, lUsersDisabled, lOtherDisabled, lExcelRow
Dim aUAC ' AD's UserAccountControl flags array
Dim aSAT ' AD's sAMAccountType flags array
'==================================================
Main
'==================================================
Sub Main
Init
ConnectAD
If Err.Number = 0 Then ProcessRecords
CleanUp
End Sub
'--------------------------------------------------
Sub Init
Dim dNow
dNow = Now
Wscript.echo dNow & vbTab & "Init"
DefineADProp
DefineUACArray
DefineSATArray
Set oFSO = CreateObject("scripting.filesystemobject")
Set oLogFile = oFSO.CreateTextFile(WScript.ScriptFullName & "_" & Join(Array(Year(dNow),Month(dNow),Day(dNow)),".") & ".log")
sRootLDAP = "'LDAP://" & GetObject("LDAP://RootDSE").Get("defaultNamingContext") & "'"
LogT vbCrlf & Q(WScript.ScriptFullName) & " started."
Logg "RootLDAP: " & sRootLDAP
Logg "Listing AD Attributes: " & Join(aADProp,", ")
Logg GAP
lObjects = 0
lUsersEnabled = 0
lUsersDisabled = 0
lComputersEnabled = 0
lComputersDisabled = 0
lOtherDisabled = 0
If Err.Number = 0 Then
lExcelRow = 1
Set oExcel = CreateObject("Excel.Application")
oExcel.visible = True
Set oWB = oExcel.Workbooks.Add
Set oWS = oWB.Worksheets(1)
oWS.Cells(lExcelRow,1) = "distinguishedName"
oWS.Range(oWS.Cells(lExcelRow,2),oWS.Cells(lExcelRow,UBound(aADProp)+2)) = aADProp
End If
End Sub
Yes I made a mistake and didn't post the question initially. When I posted originally, I wasn't able to enumerate all AD objects and had a question about that, but it is since been resolved and the code below works (in case anyone else needs it - sharing is OK). No need to try and reinvent the wheel if the code already existed. And many thanks to Rems # Petri
'
'//----------------------------- Code below -----------------------------//
'
Const SE_DACL_PROTECTED = &H1000
Dim objRootDSE
With WScript.CreateObject("WScript.Network")
Set objRootDSE = GetObject ("LDAP://" & .UserDomain & "/RootDSE")
End With
strDomainDN = objRootDSE.Get("DefaultNamingContext")
Set objCommand = CreateObject("ADODB.Command")
Set objConnection = CreateObject("ADODB.Connection")
objConnection.Provider = "ADsDSOObject"
objConnection.Open "Active Directory Provider"
objCommand.ActiveConnection = objConnection
objCommand.Properties("Searchscope") = 2 ' SUBTREE
objCommand.Properties("Page Size") = 250
objCommand.Properties("Timeout") = 30
objCommand.Properties("Cache Results") = False
objCommand.CommandText = "SELECT ADsPath FROM 'LDAP://" & strDomainDN & "'"
Set objRecordSet = objCommand.Execute
On Error Resume Next
If Not objRecordSet.eof Then
objRecordSet.MoveFirst
Do Until objRecordSet.EOF
ModUser objRecordSet.Fields("ADsPath").Value
objRecordSet.MoveNext
Loop
End If
objRecordset.Close : objConnection.Close
wscript.echo vbCrLf & "-- All done --" : wscript.quit 0
Sub ModUser(strADsPath)
Dim objUser, objNtSecurityDescriptor, intNtSecurityDescriptorControl
Set objuser = GetObject(strADsPath)
Set objNtSecurityDescriptor = objUser.Get("ntSecurityDescriptor")
intNtSecurityDescriptorControl = objNtSecurityDescriptor.Control
If (intNtSecurityDescriptorControl And SE_DACL_PROTECTED) Then
Wscript.Echo objUser.sAMAccountName & " (" & objUser.distinguishedName & ") is NOT checked"
End If
End Sub