ppt实用宏Word格式文档下载.docx

ppt实用宏Word格式文档下载.docx

《ppt实用宏Word格式文档下载.docx》由会员分享，可在线阅读，更多相关《ppt实用宏Word格式文档下载.docx（25页珍藏版）》请在冰点文库上搜索。

vbCrLf&

_

"

Pleasebeseated.Weareabouttobegin."

With.Shapes

（1）

Countdowninseconds

TMinus=120

DoWhile（TMinus>

-1）

Suspendprogramexecutionfor1second（1000milliseconds）

Sleep1000

.TextFrame.TextRange.Text=Format（TimeValue（Format（Now,"

hh:

mm:

ss"

））-_

TimeSerial（Hour（Now）,Minute（Now）,Second（Now）+TMinus）,"

）

TMinus=TMinus-1

Verycrucialelsethedisplaywon'

trefreshitself

DoEvents

Loop

EndWith

3-2-1-0Blastoffandmovetothenextslideoranyslideforthatmatter

SlideShowWindows

（1）.View.GotoSlide

（2）

isRunning=False

Clickheretostartcountdown"

EndIf

EndSub

批量删除幻灯片备注之宏代码

SubDeleteNote（）

DimactpptAsPresentation

DimpptcountAsInteger

DimiChoseAsInteger

DimbDeleteAsBoolean

DimsMsgBoxAsString

DimdirpathAsString

DimtxtstringAsString

sMsgBox="

运行该宏之前，请先作好备份！

继续吗？

iChoice=MsgBox（sMsgBox,vbYesNo,"

备份提醒"

IfiChoice=vbNoThen

ExitSub

导出备注后，需要删除PPT备注吗？

导出注释"

bDelete=False

bDelete=True

Setactppt=Application.ActivePresentation

dirpath=actppt.Path&

"

\"

actppt.Name&

的备注.txt"

pptcount=actppt.Slides.Count

打开书写文件

Setfs=CreateObject（"

Scripting.FileSystemObject"

Seta=fs.CreateTextFile（dirpath,True）

遍历ppt

Withactppt

Fori=1Topptcount

txtstring=.Slides（i）.NotesPage.Shapes.Placeholders

（2）.TextFrame.TextRange.Text

If（bDelete）Then

.Slides（i）.NotesPage.Shapes.Placeholders

（2）.TextFrame.TextRange.Text="

a.writeline（.Slides（i）.SlideIndex）

a.writeline（txtstring）

a.writeline（"

Nexti

a.Close

UsingSetTimer/KillTimerAPI

APIDeclarations

DeclareFunctionSetTimerLib"

user32"

（ByValhwndAsLong,_

ByValnIDEventAsLong,_

ByValuElapseAsLong,_

ByVallpTimerFuncAsLong）AsLong

DeclareFunctionKillTimerLib"

ByValnIDEventAsLong）AsLong

PublicVariables

PublicSecondCtrAsInteger

PublicTimerIDAsLong

PublicbTimerStateAsBoolean

SubTimerOnOff（）

IfbTimerState=FalseThen

TimerID=SetTimer（0,0,1000,AddressOfTimerProc）

IfTimerID=0Then

MsgBox"

Unabletocreatethetimer"

vbCritical+vbOKOnly,"

Error"

bTimerState=True

TimerID=KillTimer（0,TimerID）

Unabletostopthetimer"

bTimerState=False

Thedefinedroutinegetscalledeverynnnnmilliseconds.

SubTimerProc（ByValhwndAsLong,_

ByValuMsgAsLong,_

ByValidEventAsLong,_

ByValdwTimeAsLong）

SecondCtr=SecondCtr+1

ActivePresentation.Slides

（1）.Shapes

（2）.TextFrame.TextRange.Text=CStr（SecondCtr）

改变表格边框颜色及线条粗细之宏代码

SubHowToUseIt（）

CallSetTableBorder（ActivePresentation.Slides

（1）.Shapes

（1）.Table）

SubSetTableBorder（oTableAsTable）

DimIAsInteger

WithoTable

ForI=1To.Rows.Count

With.Rows（I）.Cells

（1）.Borders（ppBorderLeft）

.ForeColor.RGB=RGB（255,153,51）

.Weight=10

With.Rows（I）.Cells（.Rows（I）.Cells.Count）.Borders（ppBorderRight）

NextI

ForI=1To.Columns.Count

With.Columns（I）.Cells

（1）.Borders（ppBorderTop）

With.Columns（I）.Cells（.Columns（I）.Cells.Count）.Borders（ppBorderBottom）

删除所有隐藏幻灯片的宏代码

SubDelHiddenSlide（）

DimsldAsSlide,shpAsShape,foundAsBoolean

Do

found=False

ForEachsldInActivePresentation.Slides

Ifsld.SlideShowTransition.Hidden=msoTrueThen

found=True

sld.Delete

Next

LoopWhilefound=True

PPT自动生成大纲宏：

DimstrFileNameAsString

BothI&

Jareusedascounters

DimJAsInteger

Workingontheactivepresentation.

WithActivePresentation

Displaytheinputboxwiththedefault'

Titles.Txt'

strFileName=InputBox（"

Enterafilenametoexportslidetitles"

"

Providefilename..."

Titles.txt"

CheckiftheuserhaspressedCancel（Inputboxreturnsazerolengthstring）

IfstrFileName="

Then

Dosomegoodhousekeepingandcheckfortheexistenceofthefile.

Asktheuserforfurtherdirectionsincaseitdoes.:

）

IfDir（.Path&

strFileName）<

>

IfMsgBox（strFileName&

alreadyexists.Overwriteit?

_

vbQuestion+vbYesNo,"

Warning"

）=vbNoThen

Openthefileforexportingtheslidetitles.Fileiscreatedinthesamefolderastheopenpresentation.

IfthePresentationisanewone（Nopath）thenitwillgetcreatedintheRootFolder

Open.Path&

strFileNameForOutputAs#1

ForI=1To.Slides.Count

ReturnsTRUEifthereisaTitlePlaceholder

If.Slides（I）.Shapes.HasTitleThen

NowloopthruthePlaceHoldersandpickthetextfromtheTitlePlaceHolder

ForJ=1To.Slides（I）.Shapes.Placeholders.Count

With.Slides（I）.Shapes.Placeholders.Item（J）

If.PlaceholderFormat.Type=ppPlaceholderTitleThen

Justinsertedfordebuggingpurposes...

Debug.Print.TextFrame.TextRange

Writethetitletexttotheoutputfile

Print#1,.TextFrame.TextRange

NextJ

Closetheopenfile

Close#1

Locatespecifictextandformattheshapecontainingit

---------------------------------------------------------------------

Copyright?

1999-2007,ShyamPillai,AllRightsReserved.

Youarefreetousethiscodewithinyourownapplications,add-ins,

documentsetcbutyouareexpresslyforbiddenfromsellingor

otherwisedistributingthissourcecodewithoutpriorconsent.

Thisincludesbothpostingfreedemoprojectsmadefromthis

codeaswellasreproducingthecodeintextorhtmlformat.

Searchesforthespecifiedtextinalltypesofshapes

andformatstheboxcontainingit.

Theshapereferenceispassedtopickuptheformating

ofthedesiredshapeforhighlighting

SubFindTextAndHighlightShape（SearchStringAsString,_

oHighlightShapeAsShape）

DimoSldAsSlide

DimoShpAsShape

DimoTxtRngAsTextRange

DimoTmpRngAsTextRange

OnErrorResumeNext

SetoSld=SlideShowWindows

（1）.View.Slide

ForEachoShpInoSld.Shapes

Iamlookingforbeveledautoshapesincethesecontainthe

textandformattingandhenceshouldbeexcludedfromthe

search

IfoShp.Type=msoAutoShapeThen

IfoShp.AutoShapeType=msoShapeBevelThen

GoToNextShape

IfoShp.HasTextFrameThen

IfoShp.TextFrame.HasTextThen

SetoTxtRng=oShp.TextFrame.TextRange

SetoTmpRng=oTxtRng.Find（SearchString,,,True）

IfNotoTmpRngIsNothingThen

oHighlightShape.PickUp

oShp.Apply

WithoShp.Fill

.Visible=False

.Transparency=0#

NextShape:

NextoShp

Assignthismacrototheshapescontainingthesearchtext.

SubClickHere（oShpAsShape）

oShpcontainsreferencetotheshapethatwasclicked

tofirethemacro.

Thetextintheshapeispassedtothesearchroutine.

CallFindTextAndHighlightShape（oShp.TextFrame.TextRange.Text,oShp）

CallRefreshSlide

SubRefreshSlide（）

WithSlideShowWindows

（1）.View

.GotoSlide.CurrentShowPosition

Locateandhighlightinstancesofaspecificword

Locatespecifictextandformattheshapecontainingit.

andhighlightsonlythetext.

TheTextRangeispassedtoapplytheformatting

ofthetextforhighlighting

oHighlightTextRangeAsTextRange）

Oneneedstolocatethetextaswellasiterate

formultipleinstancesofthetext

DoWhileNotoTmpRngIsNothing

Highlightthetextwiththedesiredcolor

oTmpRng.Font.Colo