supergrass71

Option Explicit
Private Type SHITEMID
cb As Long
abID As Byte
End Type
Private Type ITEMIDLIST
mkid As SHITEMID
End Type
Private Const CSIDL_PERSONAL As Long = &H5
Private Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" _

supergrass71

Public referenceDocument As Document
Public lookupDocument As Document
Public activeDictionary As Object
Option Explicit
Sub createAcronymTableFile()
'#####################################################################################################
'#                                                                                                   #
'#      *  Take table of abbreviations from existing document and use it as a separate reference     #
'#      *  Takes ideas from a number of places                                                       #
'#      *                                                                                            #

supergrass71

Function CleanTrim(ByVal S As String, Optional ConvertNonBreakingSpace As Boolean = True) As String
'https://www.mrexcel.com/forum/excel-questions/923725-vba-remove-all-non-printable-special-characters-well-trim.html
  Dim X As Long, CodesToClean As Variant
  CodesToClean = Array(0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, _
                       21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 127, 129, 141, 143, 144, 157)
  If ConvertNonBreakingSpace Then S = Replace(S, Chr(160), " ")
  For X = LBound(CodesToClean) To UBound(CodesToClean)
    If InStr(S, Chr(CodesToClean(X))) Then S = Replace(S, Chr(CodesToClean(X)), "")
  Next
  CleanTrim = S

supergrass71

Function ReplaceInTable(textToFind As String) As String
'http://www.msofficeforums.com/word-vba/28049-vba-table-search-all-tables-find-replace.html
Dim oRng As Range
Set oRng = ActiveDocument.Range
'if used as sub add inputbox for texttofind
    With oRng.Find
        Do While .Execute(FindText:=textToFind)
            If oRng.Information(wdWithInTable) Then
                oRng.Select
                Selection.Cells(1).Next.Select

supergrass71

Sub addScreenTip(doc As Document, rng As Range, bmark As String, tip As String)
'add bookmark
With doc.Bookmarks
    .Add Range:=Selection.Range, Name:=bmark
    .DefaultSorting = wdSortByName
    .ShowHidden = False
End With
 
End Sub

supergrass71

Sub createNote2()
'based on https://wordribbon.tips.net/T013230_ScreenTips_without_Hyperlinks
'uses acronym module instead of user inputbox
Dim timeStamp As String, bookmarkName As String, screentipText As String, key As String
Dim rng As Range
Dim answer As Integer
Dim tbl As Table
Application.ScreenUpdating = False
timeStamp = Format(Now(), "yyyyMMddHHmmss")
'On Error GoTo ErrHandler

supergrass71

Public Sub FindReplaceAnywhere() 'https://wordmvp.com/FAQs/Customization/ReplaceAnywhere.htm Dim rngStory As Word.Range Dim pFindTxt As String Dim pReplaceTxt As String Dim lngJunk As Long Dim oShp As Shape
pFindTxt = InputBox("Enter the text that you want to find.", "FIND")
If pFindTxt = "" Then
MsgBox "Cancelled by User"
Exit Sub
End If
TryAgain: pReplaceTxt = InputBox("Enter the replacement.", "REPLACE")
If pReplaceTxt = "" Then
    If MsgBox("Do you just want to delete the found text?", vbYesNoCancel) = vbNo Then
        GoTo TryAgain

supergrass71

Sub MakeSquareCells()
'// Create graph paper in Excel see http://www.erlandsendata.no/english/index.php?d=envbawssetrowcol
'if you want cm or inches
Dim noOfColumns As Integer, squareSide As Integer, i As Integer
noOfColumns = Application.InputBox(Prompt:="Select number of columns for grid (from column A:)", _
	Title:="Square Grid Maker", Default:=1, Type:=1)
squareSide = Application.InputBox(Prompt:="Select width (mm:", _
	Title:="Square Grid Maker", Default:=1, Type:=1)
Application.ScreenUpdating = False
With Activesheet

supergrass71

Sub AddValidation(cell as range)
'designed to work in tandem with worksheet function (see next)
If cell.rows.count>1 or cell.columns.count>1 then exit sub

With cell.validation
	.delete
    .add Type:=xlValidateList, AlertStyle:=xlValidateAlertStop, Operator: _
    	xlBetween, Formula:="A,list,of,your,values"
    .ignoreblank = True
    .incelldropdown = true

supergrass71

Attribute VB_Name = "Document_Cleanse"
Option Explicit

Sub LoopFolder()

'from https://www.mrexcel.com/forum/excel-questions/866125-vba-loop-through-all-files-all-subfolders.html
    Dim fso As New FileSystemObject
    Dim f As Folder, sf As Folder
    Dim ofile As File
    Dim MyPath As String, RootFolder As String