《2022年常用宏代码 .pdf》由会员分享，可在线阅读，更多相关《2022年常用宏代码 .pdf（6页珍藏版）》请在taowenge.com淘文阁网|工程机械CAD图纸|机械工程制图|CAD装配图下载|SolidWorks_CaTia_CAD_UG_PROE_设计图分享下载上搜索。
1、PPT 中常用宏代码倒计时宏代码Option Explicit Public Declare Sub Sleep Lib kernel32 (ByVal dwMilliseconds As Long) Sub Tmr() Just in the eventuality that you click the start button twice isRunning stores the current state of the macro TRUE = Running; FALSE = Idle Static isRunning As Boolean If isRunning = True Th
2、en End Else isRunning = True Dim TMinus As Integer Dim xtime As Date xtime = Now On Slide 1, Shape 1 is the textbox With ActivePresentation.Slides(1) .Shapes(2).TextFrame.TextRange.Text = Ladies & Gentlemen. & vbCrLf & _ Please be seated. We are about to begin. With .Shapes(1) Countdown in seconds T
3、Minus = 120 Do While (TMinus -1) Suspend program execution for 1 second (1000 milliseconds) Sleep 1000 xtime = Now .TextFrame.TextRange.Text = Format(TimeValue(Format(Now, hh:mm:ss) - _ TimeSerial(Hour(Now), Minute(Now), Second(Now) + TMinus), hh:mm:ss) TMinus = TMinus - 1 Very crucial else the disp
4、lay wont refresh itself DoEvents Loop End With 3-2-1-0 Blast off and move to the next slide or any slide for that matter SlideShowWindows(1).View.GotoSlide (2) isRunning = False .Shapes(2).TextFrame.TextRange.Text = Click here to start countdown End End With 名师资料总结 - - -精品资料欢迎下载 - - - - - - - - - -
5、- - - - - - - - 名师精心整理 - - - - - - - 第 1 页，共 6 页 - - - - - - - - - End If End Sub 批量删除幻灯片备注之宏代码Sub DeleteNote() Dim actppt As Presentation Dim pptcount As Integer Dim iChose As Integer Dim bDelete As Boolean Dim sMsgBox As String Dim dirpath As String Dim txtstring As String sMsgBox = 运行该宏之前，请先作好备份！
6、继续吗？ iChoice = MsgBox(sMsgBox, vbYesNo, 备份提醒 ) If iChoice = vbNo Then Exit Sub End If sMsgBox = 导出备注后，需要删除PPT备注吗？ iChoice = MsgBox(sMsgBox, vbYesNo, 导出注释 ) If iChoice = vbNo Then bDelete = False Else bDelete = True End If Set actppt = Application.ActivePresentation dirpath = actppt.Path & & actppt.N
7、ame & 的备注 .txt pptcount = actppt.Slides.Count 打开书写文件Set fs = CreateObject(Scripting.FileSystemObject) Set a = fs.CreateTextFile(dirpath, True) 遍历 ppt With actppt For i = 1 To pptcount txtstring = .Slides(i).NotesPage.Shapes.Placeholders(2).TextFrame.TextRange.Text If (bDelete) Then .Slides(i).NotesP
8、age.Shapes.Placeholders(2).TextFrame.TextRange.Text = End If 名师资料总结 - - -精品资料欢迎下载 - - - - - - - - - - - - - - - - - - 名师精心整理 - - - - - - - 第 2 页，共 6 页 - - - - - - - - - a.writeline (.Slides(i).SlideIndex) a.writeline (txtstring) a.writeline () Next i End With a.Close End Sub Using SetTimer/KillTimer
9、 API Option Explicit API Declarations Declare Function SetTimer Lib user32 _ (ByVal hwnd As Long, _ ByVal nIDEvent As Long, _ ByVal uElapse As Long, _ ByVal lpTimerFunc As Long) As Long Declare Function KillTimer Lib user32 _ (ByVal hwnd As Long, _ ByVal nIDEvent As Long) As Long Public Variables Pu
10、blic SecondCtr As Integer Public TimerID As Long Public bTimerState As Boolean Sub TimerOnOff() If bTimerState = False Then TimerID = SetTimer(0, 0, 1000, AddressOf TimerProc) If TimerID = 0 Then MsgBox Unable to create the timer, vbCritical + vbOKOnly, Error Exit Sub End If bTimerState = True Else
11、TimerID = KillTimer(0, TimerID) If TimerID = 0 Then MsgBox Unable to stop the timer, vbCritical + vbOKOnly, Error End If bTimerState = False End If End Sub 名师资料总结 - - -精品资料欢迎下载 - - - - - - - - - - - - - - - - - - 名师精心整理 - - - - - - - 第 3 页，共 6 页 - - - - - - - - - The defined routine gets called ever
12、y nnnn milliseconds. Sub TimerProc(ByVal hwnd As Long, _ ByVal uMsg As Long, _ ByVal idEvent As Long, _ ByVal dwTime As Long) SecondCtr = SecondCtr + 1 ActivePresentation.Slides(1).Shapes(2).TextFrame.TextRange.Text = CStr(SecondCtr) End Sub 改变表格边框颜色及线条粗细之宏代码Option Explicit Sub HowToUseIt() Call Set
13、TableBorder(ActivePresentation.Slides(1).Shapes(1).Table) End Sub Sub SetTableBorder(oTable As Table) Dim I As Integer With oTable For I = 1 To .Rows.Count With .Rows(I).Cells(1).Borders(ppBorderLeft) .ForeColor.RGB = RGB(255, 153, 51) .Weight = 10 End With With .Rows(I).Cells(.Rows(I).Cells.Count).
14、Borders(ppBorderRight) .ForeColor.RGB = RGB(255, 153, 51) .Weight = 10 End With Next I For I = 1 To .Columns.Count With .Columns(I).Cells(1).Borders(ppBorderTop) .ForeColor.RGB = RGB(255, 153, 51) .Weight = 10 End With With .Columns(I).Cells(.Columns(I).Cells.Count).Borders(ppBorderBottom) .ForeColo
15、r.RGB = RGB(255, 153, 51) .Weight = 10 End With Next I End With End Sub 删除所有隐藏幻灯片的宏代码Sub DelHiddenSlide() Dim sld As Slide, shp As Shape, found As Boolean Do found = False 名师资料总结 - - -精品资料欢迎下载 - - - - - - - - - - - - - - - - - - 名师精心整理 - - - - - - - 第 4 页，共 6 页 - - - - - - - - - For Each sld In Acti
16、vePresentation.Slides If sld.SlideShowTransition.Hidden = msoTrue Then found = True sld.Delete End If Next Loop While found = True End Sub PPT自动生成大纲宏：Dim strFileName As String Both I & J are used as counters Dim I As Integer Dim J As Integer Working on the active presentation. With ActivePresentatio
17、n Display the input box with the default Titles.Txt strFileName = InputBox(Enter a filename to export slide titles, Provide filename., Titles.txt) Check if the user has pressed Cancel (Inputbox returns a zero length string) If strFileName = Then Exit Sub End If Do some good housekeeping and check fo
18、r the existence of the file. Ask the user for further directions in case it does. : ) If Dir(.Path & & strFileName) Then If MsgBox(strFileName & already exists. Overwrite it?, _ vbQuestion + vbYesNo, Warning) = vbNo Then Exit Sub End If End If Open the file for exporting the slide titles. File is cr
19、eated in the same folder as the open presentation. If the Presentation is a new one (No path) then it will get created in the Root Folder Open .Path & & strFileName For Output As #1 For I = 1 To .Slides.Count Returns TRUE if there is a TitlePlaceholder If .Slides(I).Shapes.HasTitle Then Now loop thr
20、u the PlaceHolders and pick the text from the TitlePlaceHolder For J = 1 To .Slides(I).Shapes.Placeholders.Count With .Slides(I).Shapes.Placeholders.Item(J) 名师资料总结 - - -精品资料欢迎下载 - - - - - - - - - - - - - - - - - - 名师精心整理 - - - - - - - 第 5 页，共 6 页 - - - - - - - - - If .PlaceholderFormat.Type = ppPlac
21、eholderTitle Then Just inserted for debugging purposes. Debug.Print .TextFrame.TextRange Write the title text to the output file Print #1, .TextFrame.TextRange End If End With Next J End If Next I Close the open file Close #1 End With End Sub 名师资料总结 - - -精品资料欢迎下载 - - - - - - - - - - - - - - - - - - 名师精心整理 - - - - - - - 第 6 页，共 6 页 - - - - - - - - -