Batch: Stop Cortana Memory Hog

Googling for "Microsoft Windows 10 Cortana®" reveal MANY complaints about memory loss. My experience is 28-33% reported by Task Manager even when Cortana (voice listening and response services) are DISABLED / "inactive"! The best advice found to-date has been "remove" or "rename it"!

Usually a BAD workaround! Especially since it was IMPOSSIBLE to do it manually.
Therefore this BATCH file is offered with the warning "EXAMPLE only! Do *NOT* attempt this on any computer. This batch file is ONLY OFFERED as an example of the "IF" statement and batch logic flow."

@echo off

rem set statusstring="end of %0"

SET /P ISADMIN=Are you RUNNING THIS AS ADMIN (usually from a shortcut 'RUN AS ADMIN') Y/N: =
if /I NOT "%ISADMIN%"=="Y" goto OOPS
rem KLUDGE to SOLVE MEMORY HOG PROBLEM
rem CORTANA is MICROSOFT's AUDIO LISTENER
rem it can take 20-30% or more of RAM
rem can't MANUALLY RENAME or MOVE it because Task Manager RELOADS it
rem SOLUTION: replace MANUAL steps with BATCH commands

setlocal
rem @echo on

echo step 1 kill SearchUI and rename
IF %ERRORLEVEL% GTR 1 SET ERRSTRING=errlevel%ERRORLEVEL%

for %%x in (ActionUriServer.exe PlacesServer.exe RemindersServer.exe RemindersShareTargetApp.exe SearchUI.exe backgroundTaskHost.exe) do IF EXIST %%x taskkill /T /F /PID %%x

rem taskkill /T /F /PID SearchUI.exe
rem taskkill /T /F /PID backgroundTaskHost.exe

echo step 2 rename folder and/or SearchUI.exe to stop RESTART of Cortana
IF EXIST C:\Windows\SystemApps\Microsoft.Windows.Cortana_cw5n1h2txyewy pushd C:\Windows\SystemApps\Microsoft.Windows.Cortana_cw5n1h2txyewy
IF EXIST SearchUI.exe rename SearchUI.exe zSearchUI.exe
pushd C:\Windows\SystemApps
IF EXIST Microsoft.Windows.Cortana_cw5n1h2txyewy move /Y Microsoft.Windows.Cortana_cw5n1h2txyewy Microsoft.Windows.½Cortana_cw5n1h2txyewy

dir /ad Microsoft.Windows.?C*

GOTO END
:OOPS
set statusstring=RUN AS ADMIN (right click on "%0" and Run As Admin)
echo %statusstring%
:END

echo ....
IF NOT "%ERRSTRING%"=="" echo %ERRSTRING%
ECHO FINISHED BATCH FILE %0
pause
endlocal

 

vB Regex Error Detection

This is a sample of "stub" code using REGEX (regular expressions) to find predefined Error words 

    1. detect and skip  Windows Certificate Errors or similar Error page that IE may surprise the user with
    2. Fill in a Login Form
  • To WORK: it needs you to identify the (login or other) form elements
    1. identify a unique STRING in the unexpected  Error (Certificate) page
'________________________

FunctioncheckForError(strErr,strTag)' returns 1 of 3 strings FULL LARGE INNERTEXT STRING IF ERR FOUND, ELSE "PASS"
Dimnames,ele,innerText,outerText,temp,bFlag' used as string to debug
temp="":bFlag=False' flag True if ERR FOUND, false if ERR NOT FOUND
Setnames=objIE.Document.getElementsByTagName(strTag)

' sample: needs IE page object to be defined and navigated to as current page, having login form elements

' CHECKING for and bypassing MICROSOFT CERTIFICATE WARNING



isUnsafe=findClickOkIfUnsafe("not recommended",testLinks)'bad string is first param signalling certificate error

ifisUnsafe>=0then

testLinks(isUnsafe-1).Click'(1) works if HARD CODED FROM OBSERVATION - code returns (2) ??
' testLinks(isUnsafe).Click ' using index as boolean???? xyz
callwaitForReady(objIE)' do this after each click on menu
endif

' self documenting comments by doing "find" of H4 tag or any desired flag/tag

' LEAVING MICROSOFT CERTIFICATE WARNING INTO LOG IN PAGE



'_________ functions / subroutines _________

FunctionfindClickOkIfUnsafe(strInnerText,someArray)' returns index if any member of someArray has "bad string"
dimk,foundAt,strtmp
foundAt=-1
strtmp=""
'msgbox "array length: " & someArray.length,,"from Function findClickOkIfUnsafe" ' for debugging, tells you where you are
for k = 0 to someArray.length-1'LBound(someArray) to UBound(someArray)
If (boolRegExMatch ( someArray( k ).innerText, trim(strInnerText)) > 0)then
'booltemp = True '( True OR booltemp)
foundAt= k
exit for
end if
next 'k

findClickOkIfUnsafe=foundAt ' if for/next never entered then returns -1 from second line
End Function

'________________________

FunctionboolRegExMatch(regx,strng) ' returns COUNT no it's NOT boolean!!!!
Dim regEx,Match,Matches,n,tmp ' Create variable.
SetregEx=NewRegExp ' Create a regular expression.
regEx.Pattern=regx ' Set pattern.
regEx.IgnoreCase=True ' Set case insensitivity.
regEx.Global=True ' Set global applicability.
SetMatches=regEx.Execute(strng)' Execute search.
boolRegExMatch=Matches.count
setMatches=Nothing
setRegEx=Nothing
End Function

'________________________

FunctioncheckForError(strErr,strTag)' returns 1 of 3 strings FULL LARGE INNERTEXT STRING IF ERR FOUND, ELSE "PASS"
Dimnames,ele,innerText,outerText,temp,bFlag' used as string to debug
temp="":bFlag=False' flag True if ERR FOUND, false if ERR NOT FOUND
Setnames=objIE.Document.getElementsByTagName(strTag)

Foreacheleinnames
innerText=ele.innerText
If(boolRegExMatch(strErr,innerText)>0)Then
'If Instr(1, innerText, strErr) Then
temp="Fail: "&innerText' innerText

exitFor' only reports first error found!?
Else
temp="PASS"
EndIf
Next
checkForError=temp
EndFunction
'________________________
FunctionfnLogin(uid,pwd)
Diminputs,strPageStatus
Setinputs=objIE.Document.getElementsByTagName("INPUT")

' inputs(1).Value = uid
' on Error Resume Next
inputs(2).Value=uid
inputs(3).Value=pwd
inputs(4).Click

' on Error GoTo 0
' If Err.Number then strPageStatus = "FAILERROR: CLOSE DUPLICATE BROWSER SESSION" & vbCrlf & Err.Description else
waitForReady(objIE)
strPageStatus=checkForError(".*password.*incorrect.*|Prohibite.*","DIV")'prefixes "Failed:" to InnerText
' End If
fnLogin=strPageStatus
EndFunction

'________________________

FunctioncheckForError(strErr,strTag)' returns 1 of 3 strings FULL LARGE INNERTEXT STRING IF ERR FOUND, ELSE "PASS"
Dimnames,ele,innerText,outerText,temp,bFlag' used as string to debug
temp="":bFlag=False' flag True if ERR FOUND, false if ERR NOT FOUND
Setnames=objIE.Document.getElementsByTagName(strTag)

Foreacheleinnames
innerText=ele.innerText
If(boolRegExMatch(strErr,innerText)>0)Then
'If Instr(1, innerText, strErr) Then
temp="Fail: "&innerText' innerText

exitFor' only reports first error found!?
Else
temp="PASS"
EndIf
Next
checkForError=temp
EndFunction
'________________________

How to TRIM() cr/lf?

What about TRIM() for removing white space from strings!
Although it is a really handy BUG-ELIMINATOR for whenever a user pastes into your (MS-Access) application, STILL this attachment demonstrates that TRIM only works on outer spaces, not other white space characters like ASCII characters 9, 10, 12, 13. (vbTab, vbLf, Formfeed, vbCr)

' Save  this in a VBS file on your desktop for a VISUAL DEMO comparing three string cleaning functions below
Dim someOtherString, someOtherString1, someOtherString2, someOtherString3
someOtherString1 = vbCrLf & vbTab & "Hi Mom!" & int(rnd(100)*5) & vbTab & vbCrLf
someOtherString2 = vbCrLf & vbTab & "Hi Mom!" & int(rnd(100)*5) & vbTab & vbCrLf
someOtherString3 = vbCrLf & vbTab & "Hi Mom!" & int(rnd(100)*5) & vbTab & vbCrLf
msgbox chr(34) & trim(someOtherString1) & chr(34),,"Trim"
msgbox chr(34) & nibble(someOtherString2) & chr(34),,"Nibble"
msgbox chr(34) & chomp(someOtherString3) & chr(34),,"Chomp"
' --------------------
Function chomp(somestring)
if len(somestring) >= 1 then 
while (asc(right(somestring,1)) <= 13 ) 
   somestring = left(somestring, len(somestring)-1) 
   wend 
end if 
chomp = somestring  
End Function 
' -------------------- 
Function nibble(somestring) 
 if len(somestring) >= 1 then 
   while (asc(left(somestring,1)) <= 13 ) 
somestring = right(somestring, len(somestring)-1) 
wend 
end if 
nibble = somestring  
End Function

See http://excel-on-demand.com/2017/01/25/vbcommon-chomp-nibble/

Word Security Risk? Find Hidden Fields!

When you Share or modify Word files - you can get OTHER PEOPLE's  names, IDs and personal information!  WORSE yet, you can GIVE others your own personal or proprietary info! How to Find these fields?  How to replace or purge them?

The macro at bottom of this page performs a checkup of common fields.

The top of the page shows you screenshots of how to find these fields in WinWord (Word for Windows®) via (a) shortcut "Alt-I-F" (b) Menu Tab "Insert" and (c) Macro Message box

(a) shortcut Alt-I-F
(a) shortcut Alt-I-F
(b) Menu Tab ''Insert''
(b) Menu Tab ''Insert''
c) Macro WordDocProperties Message box
c) Macro WordDocProperties Message box

Sub WordDocProperties()
Dim strTemp, strProp, strNameList As String
Dim thisRange   'strNameList used to bypass error thrown by at least one of the named properties
strNameList = "title,subject,author,last author,company,manager,Last Save time,Creation Date,Comments,Total Editing Time" 
'short list for demo. See menu [screenshot (b) above] in Word® for full list
xyz = Split(strNameList, ",")
Set thisRange = ActiveDocument.Content
 thisRange.Collapse Direction:=wdCollapseEnd ' wdCollapseStart is default per https://msdn.microsoft.com/en-us/library/office/ff840825(v=office.15).aspx
For Each Prop In ActiveDocument.BuiltInDocumentProperties '.CustomDocumentProperties BuiltInDocumentProperties
  With thisRange
    On Error Resume Next
    strProp = Prop.Name 'here, at least one property throws an error not trapped by 'on error'
    If Err.Number Then strProp = " n/a " ' this never happens: see above
' strTemp = strTemp & vbCrLf & Prop.Name 'for deriving full namelist
    If IsNumeric(findElementinArray(Prop.Name, xyz)) Then strTemp = strTemp & vbCrLf & Prop.Name & " = " & Prop.Value
    On Error GoTo 0
 End With
Next
 MsgBox strTemp, , "Sub WordDocProperties"
End Sub
'--------
Function findElementinArray(someString, someArray) 'returns index of found item, else "" if not found
Dim kounter, i, j, k As Integer
findElementinArray = ""
    For k = LBound(someArray) To UBound(someArray)
        If UCase(someString) = UCase(someArray(k)) Then
            findElementinArray = k
            Exit For
        End If
    Next k
End Function

A macro to Purge or SetWordDocProperties will be available 2017-April-02 in the "Office Macro Package"

Print Unique Footer Header with Tabs

Problem:  You've been given  20 minutes to update 3 tabs of a 25 Tab *MONSTER* Spreadsheet, and REPORT your updates ....  Some are Landscape and some are Portrait.  Most are 5+ pages long.

How to make page number, sheet name and file name show in header and footer for your meeting in 20 minutes?

Sub Write_Header_Footer_from_Many_Tabbed_Workbook()
 Dim qystring, howmany, menudefault, sht
 'THIS IS FOR A XLS OF MANY TABS - sets the header, footer, and margins of each tab
 If Not ActiveWorkbook.Saved Then
 qystring = "nonemptystring"
 howmany = Sheets.Count
 Do
 menudefault = "OK to wait " & howmany * 10 & " seconds " ' Set default.
 qystring = InputBox("Wait 10 seconds each while header/footers written for " & howmany & " tabs?" _
 & vbCrLf & vbCrLf & "Enter Yes / No (or press 'Escape Key' to Skip)", "Enter Yes / No (or press 'Escape Key' to Skip)", menudefault)
 If qystring > "" Then qystring = UCase(Left(qystring, 1))
 'qystring = MsgBox(menudefault & " for " & howmany & " tabs?", vbYesNoCancel, "Write Tab Names to Header and Footer")
 Loop Until ((qystring = "N") Or (qystring = "Y") Or (qystring = "O") Or (qystring = ""))
 End If 'if not saved
 If UCase(Left(qystring, 1)) = "N" Then
 Exit Sub
' If qystring <> vbYes Then Exit Sub 'this line is if using msgbox alternative to inputbox above
 Else
 For Each sht In Sheets
 With sht.PageSetup
 .CenterHeader = "&A"
 .RightFooter = "Page &P of &N"
 .CenterFooter = "&08" & "&F" 'to show full (network) path use ' Me.Path & "/" & vbCrLf & "&F"
 .LeftFooter = "&D &T"
 .FitToPagesWide = 1
 .FitToPagesTall = 999
 .PrintTitleRows = "$1:$1"
 If (.Orientation = xlLandscape) Then
 .LeftMargin = Application.InchesToPoints(0.25)
 .RightMargin = Application.InchesToPoints(0.25)
 .TopMargin = Application.InchesToPoints(0.65)
 .BottomMargin = Application.InchesToPoints(0.65)
 .HeaderMargin = Application.InchesToPoints(0.2)
 .FooterMargin = Application.InchesToPoints(0.2)
 Else
 .LeftMargin = Application.InchesToPoints(0.5)
 .RightMargin = Application.InchesToPoints(0.5)
 .TopMargin = Application.InchesToPoints(0.5)
 .BottomMargin = Application.InchesToPoints(0.5)
 .HeaderMargin = Application.InchesToPoints(0.2)
 .FooterMargin = Application.InchesToPoints(0.2)
 End If
 End With
 Next sht
 End If ' vbyes
 
 End Sub
'--------------

VBS – time stamp: options demo

VBS will run in Windows as a stand alone script just like JS (JavaScript) and BATCH files.

'save as ANSI TXT file with extenstion ".vbs" 
'saving as UTF and Unicode will show "Error in Line 1"
nowis = Now
msgbox minuteStamp, vbOKOnly,"MinuteStamp"
msgbox timeStamp, vbOKOnly, "TimeStamp"
msgbox timestamphhmmss(nowis), vbOKOnly, "Time Stamp hh mm ss"

' ==== 'right' forces two digit values ===
Function minuteStamp() 
 minuteStamp = Year(Now) & "_" & _
 Right("0" & Month(Now),2) & "_" & _
 Right("0" & Day(Now),2) & "_" & _ 
 Right("0" & Hour(Now),2) & _
 Right("0" & Minute(Now),2) 
 '& _ Right("0" & Second(Now),2) 
End Function

' ============
Function timeStamp()
 timeStamp = Year(Now) & "_" & _
 Right("0" & Month(Now),2) & "_" & _
 Right("0" & Day(Now),2) & "_" & _ 
 Right("0" & Hour(Now),2) & _
 Right("0" & Minute(Now),2) & _
 Right("0" & Second(Now),2) 
End Function
' ======


Function timestamphhmmss(someTime)
 timestamphhmmss = FormatDateTime(someTime,vbshorttime) & ":" & right("0" & Second(someTime), 2)
End Function
 
'Constant Value Description from Microsoft® HELP
'vbGeneralDate 0 Display a date and/or time. If there is a date part, display it as a short date. If there is a time part, display it as a long time. If present, both parts are displayed.
' vbLongDate 1 Display a date using the long date format specified in your computer's regional settings.
' vbShortDate 2 Display a date using the short date format specified in your computer's regional settings.
' vbLongTime 3 Display a time using the time format specified in your computer's regional settings.
' vbShortTime 4 Display a time using the 24-hour format (hh:mm).
'_______________________________

 

Macro: datetimestamp()

Appends date/time stamp to current cell.

Sub datestamp()
Dim strWhatTime
 
 strWhatTime = Format(Now(), "mm-dd-yy hh:mm:ss ddd")
 If ActiveCell.Value = "" Then
 ActiveCell.Value = strWhatTime
 '& (tempp - Int(temp))
 'ActiveCell.Value = Format(Now(), "c") '& (tempp - Int(temp))
 Else
 ActiveCell.Value = ActiveCell.Value & " " & strWhatTime
 End If
 
End Sub
'ActiveCell.FormulaR1C1 = "11/1/2011"

AHK Macro: Show NumLock, Insert

Is your LAPTOP  keyboard MISSING the STATUS INDICATOR for Insert , CapsLock or NumLock keys?

*IF* your computer once had but LOST this feature, it will be EASIER for you to reinstall from your OEM's website or the installation disk that *may* have come with your computer.

Otherwise this will help!  Requires installing AHK.

; AHK script - a great PLAN B if your laptop is missing this feature AND not available from the OEM download page

~CapsLock:: ; Show CapsLock state on screen
 if GetKeyState("CapsLock", "T")
 Progress, B1 W200 H28 ZH0 FS11 WS900 Y700 CTFF0000, CAPS LOCK ON
 else
 Progress, B1 W200 H28 ZH0 FS11 WS900 Y700 CT0000FF, CAPS LOCK OFF
 SetTimer, OSD_OFF, -2000
 return

~NumLock:: ; Show NumLock state on screen
 if GetKeyState("NumLock", "T")
 Progress, B1 W200 H28 ZH0 FS11 WS900 Y700 CT00FF00, NUM LOCK ON
 else
 Progress, B1 W200 H28 ZH0 FS11 WS900 Y700 CTFF0000, NUM LOCK OFF
 SetTimer, OSD_OFF, -2000
 return

~Insert:: ; Show Insert state on screen
 if GetKeyState("Insert", "T")

 Progress, B1 W200 H28 ZH0 FS11 WS900 Y700 CTE60316, OVERWRITE MODE
else
 Progress, B1 W200 H28 ZH0 FS11 WS900 Y700 CT007800, INSERT MODE
 SetTimer, OSD_OFF, -2000
 return

OSD_OFF:
 Progress, off
 return

;https://autohotkey.com/board/topic/67080-display-capslock-state-helpful-for-vim/?hl=numlock+state#entry457616
 ; https://autohotkey.com/docs/KeyList.htm

Other AHK resources:

Install AutoHotKey for Windows
AHK Tutorial
Setup Notepad++ for AutoHotkey

 

 

Merge with Zero Data Loss

This macro is best called by assigning it to a short-cut key-sequence, e.g. "Ctrl-Shift-M"(erge).  Do this in the Macro Edit dialog by the Excel short-cut sequence Alt-T-M-M (See SWF video - will run in most browsers: IE, Chrome, Firefox). It calls "nibble" which has it's own Post, but is also included below.

Sub mergeselection()
 Dim strTemp As String
 Dim youAreHere As Object
 Dim cc, k As Integer
 
 Set youAreHere = ActiveCell
' MsgBox ActiveCell.Address
' MsgBox Selection.Rows.Count
 
 
 For Each cc In Selection.Cells
 strTemp = strTemp & vbCrLf & cc.Value
 'strTemp = strTemp & vbCrLf & k + 1 & " " & cc.Value
 'k = k + 1
 Next cc
 With Selection  'With Selection is left over from macro recording
 .HorizontalAlignment = xlCenter
 .VerticalAlignment = xlBottom
 .WrapText = False
 .Orientation = 0
 .AddIndent = False
 .IndentLevel = 0
 .ShrinkToFit = False
 .ReadingOrder = xlContext
 ' .MergeCells = False
 End With
 Application.DisplayAlerts = False
 Selection.Merge
 Application.DisplayAlerts = True
 strTemp = nibble(strTemp) '& vbCrLf
 
 With youAreHere
 youAreHere.Value = strTemp
 youAreHere.HorizontalAlignment = xlLeft
 youAreHere.VerticalAlignment = xlTop
 youAreHere.Activate
 End With
 
End Sub

' ===========================
Private Function nibble(somestring)
 'Dim islf
 If Len(somestring) >= 1 Then
 While (Asc(Left(somestring, 1)) <= 13) 'this will eat vbTab chr(9) !!!
 ' islf = asc(right(somestring,1))
 somestring = Right(somestring, Len(somestring) - 1)
 Wend
 End If
 nibble = somestring
End Function

 

Batch: Clean Windows Desktop

Runs from any location - moves designated files into a (new) folder on the Windows desktop  named with  today's date.

@echo offrem DESKCLEAN.BAT MAKES DAILY FOLDER FOR WORKING FILES - UNcomment DEBUGFLAG to troubleshoot / pause:set debugflag=ANYTHING:set PAUSEFLAG=ANYTHINGIF NOT "%DEBUGFLAG%"=="" ECHO ON
setlocal
pushd %userprofile%\Desktop<
set filestring = *.pdf;*.txt;*.log;*.xls*;*.sql;*.bak;*.java;*.class;*.jp*;*.gif;*.png;*.bku;*.bkk;*.bmp;*.htm*;*.php;*.css;*.pl;*.py;*.rb;*.doc*;*.ppt*
 REM set newdir=_hold_%timestamp% - RATHER THAN HUNT FOR THIS LINE 
rem DEEPER, ASSIGN PREFIX / FOLDER NAME NEXT LINE
  SET DIRPREFIX=
 rem has Day of Week from below "rem set xdate=%xdate:~4%"
rem makedir with timestamp - the source for the odd string manipulators below is cmd's "help for" and "help if"
: below - remove in sequence, colon, period, space, slash (replace
 rem with underscore) then last two remove trailing 1/100ths of second and leading day of week
:xtime not used unless appended to timestamp
   set xtime=%time::=%
   set xtime=%xtime:.=_%
   set xtime=%xtime: =0%
   set xtime=%xtime:~0,-3%
set xdate=%date: =_%
set xdate=%xdate:/=_%rem set xdate=%xdate:~4%
set timestamp=%xdate%
rem set newdir=_%timestamp%
set newdir=%DIRPREFIX%%timestamp%
 rem set newdir=_%timestamp%
 rem remark out above line if you want day of week included at front
rem set timestamp=%xdate%_%xtime% rem this includes timestamp seconds, making unique folder - OMIT to have only one folder per day
for %%x in (%filestring%) do if exist "%%x" if not exist "%newdir%" md "%newdir%"
for %%x in (%filestring%) do if exist "%%x" move "%%x" %newdir%
rem for %%x in (*.tif;*.jpg;*.jpg;*.gif;*.pdf;*.txt;*.log;*.xls*;*.sql;*.bak;*.bku)
 if exist "%%x" if not exist %newdir% md %newdir%
rem for %%x in (*.tif;*.jpg;*.jpg;*.gif;*.pdf;*.txt;*.log;*.xls*;*.sql;*.bak;*.bku)
if exist "%%x" move "%%x" %newdir%
IF "%DEBUGFLAG%"=="" GOTO END
pause<
:END
popd: UNcomment any below to pause and see variables at work
:set n
:SET D
echo END OF BATCH FILE %0
IF NOT "%PAUSEFLAG%"=="" PAUSE

endlocal

Optionally Uncomment line(s) 5 and/or 6 to watch it work

 
set debugflag=dbf
: (or anything except blank)

set PAUSEFLAG= pflag   ~

Excel to the Horse Races

Excel to the Horse Races
A working demonstration of unit conversion between old and new methods.

In this case COMPARE same Horse in different TRACKS and CONDITIONS:
furlongs, meters, feet, yards!  (Screenshots and download links below).

Conversion Demonstration - furlongs, meters, yards, miles

BEST PRACTICE ALERT: TEST your default security
and SCAN BEFORE downloading ANY product with MACROs.
This can be handled by most modern anti-virus software (I use
Webroot) *AND* by setting your Excel, or Word Options | Trust settings to highest security.

Consumer bears full responsibility to scan for unexpected code errors, malware or viruses.

http://excel-on-demand/wp-content/uploads/2017/01/equus044b1.xlsm (optional Active-X button and macro in first sheet to simplify default setting.)

http://excel-on-demand/wp-content/uploads/2017/01/equus044b2.xlsx (no local macro: ActiveX buttons only work in local tab: use a "form button" element to if you want to call a button handler from the local macro template in folder "XLStart")

Powerpoint Update all Fonts

Update all Slides' single Font - to improve readability via video projector

REVERTs multiple fonts to the SINGLE font (Arial) chosen on line 3

Sub FarEastFontsToArial()
 Dim oSh As Shape, oSl As Slide, strFont as String
strFont = "Arial" 'or Calibri or your choice

For Each oSl In ActivePresentation.Slides
 For Each oSh In oSl.Shapes
 If oSh.HasTextFrame Then
 oSh.TextFrame.TextRange.Font.NameFarEast = strFont
 End If
 Next
 Next

For Each oSh In ActivePresentation.SlideMaster.Shapes
 If oSh.HasTextFrame Then
 oSh.TextFrame.TextRange.Font.NameFarEast = strFont
 End If
 Next

If ActivePresentation.HasTitleMaster Then
 For Each oSh In ActivePresentation.TitleMaster.Shapes
 If oSh.HasTextFrame Then
 oSh.TextFrame.TextRange.Font.NameFarEast = strFont 
End If 
Next Osh
End If 
End Sub

'Must turn on macros in File | Options