ppt实用宏Word文件下载.docx
《ppt实用宏Word文件下载.docx》由会员分享,可在线阅读,更多相关《ppt实用宏Word文件下载.docx(21页珍藏版)》请在冰豆网上搜索。
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.Color=