Sub RemoveLinks()
Dim Link As Variant If ActiveWorkbook.LinkSources Then If MsgBox("Tem certeza que deseja retirar todos os links? ", vbYesNo + vbQuestion, "RemoveLinks") _End Sub
= vbYes Then For Each Link In ActiveWorkbook.LinkSources ActiveWorkbook.BreakLink Name:=Link, Type:=xlLinkTypeExcelLinks Next MsgBox " Todos os Links externos do Workbook foram removidos! "
Else Exit Sub End If Else MsgBox " Não foi encontrado nenhum Link externo neste workbook."
End If
'Code by Mahipal Padigela
'Open Microsoft Powerpoint,Choose/Insert a Graph type Slide(No.8), then double click to add a graph and click...
'...outside the graph to close the Datasheet, then rename the Graph to "Mychart",Save and Close the Presentation
'Open Microsoft Excel, add some test data to Sheet1(This example assumes that you have some test data...
'...(numbers between 0-100) in Rows 2,3,4 and Columns B,C,D,E).
'Open VBA editor(Alt+F11),Insert a Module and Paste the following code in to the code window
'Reference 'Microsoft Powerpoint Object Library' (VBA IDE-->tools-->references)
'Reference 'Microsoft Graph Object Library' (VBA IDE-->tools-->references)
'Change "strPresPath" with full path of the Powerpoint Presentation created earlier.
'Change "strNewPresPath" to where you want to save the new Presnetation to be created later
'Close VB Editor and run this Macro from Excel window(Alt+F8)
Dim oPPTApp As PowerPoint.Application
Dim oPPTShape As PowerPoint.Shape
Dim oPPTFile As PowerPoint.Presentation
Public oGraph As Graph.Chart
Dim SlideNum As Integer
Sub PPGraphMacro()
Dim strPresPath As String, strExcelFilePath As String, strNewPresPath As String strPresPath = "H:\PowerPoint\Presentation1.ppt" strNewPresPath = "H:\PowerPoint\New1.ppt" Set oPPTApp = CreateObject("PowerPoint.Application") oPPTApp.Visible = msoTrue Set oPPTFile = oPPTApp.Presentations.Open(strPresPath) SlideNum = 1 oPPTFile.Slides(SlideNum).Select Set oPPTShape = oPPTFile.Slides(SlideNum).Shapes("Mychart") Set oGraph = oPPTShape.OLEFormat.Object Sheets("Sheet1").Activate oGraph.Application.DataSheet.Range("A1").Value = Cells(2, 2).Value oGraph.Application.DataSheet.Range("A2").Value = Cells(3, 2).Value oGraph.Application.DataSheet.Range("A3").Value = Cells(4, 2).Value oGraph.Application.DataSheet.Range("B1").Value = Cells(2, 3).Value oGraph.Application.DataSheet.Range("B2").Value = Cells(3, 3).Value oGraph.Application.DataSheet.Range("B3").Value = Cells(4, 3).Value oGraph.Application.DataSheet.Range("C1").Value = Cells(2, 4).Value oGraph.Application.DataSheet.Range("C2").Value = Cells(3, 4).Value oGraph.Application.DataSheet.Range("C3").Value = Cells(4, 4).Value oGraph.Application.DataSheet.Range("D1").Value = Cells(2, 5).Value oGraph.Application.DataSheet.Range("D2").Value = Cells(3, 5).Value oGraph.Application.DataSheet.Range("D3").Value = Cells(4, 5).Value
'Should you need to access the Graph axes to turn them On/Off or to set ranges etc etc...use this'
oGraph.HasAxis(xlValue, xlPrimary) = True ' Shows Y-axis on the graph' Set oAxis = oGraph.Axes(xlValue)' With oAxis' .MinimumScale = 0' .MaximumScale = 1.2' End With' oGraph.HasAxis(xlValue, xlPrimary) = False ' Hides Y-axis on the graph
'Should you need to access the Graph's Markers to change their Color based on Data at...'...runtime etc...use this(Not applicable to the graph in this example but to Graphs with Markers like..'... Bubble, Line etc. Scatter charts)'
Dim i as Integer' For i = 1 To oGraph.SeriesCollection(1).Points.Count' If oGraph.Application.DataSheet.Cells(i, 2).Value >= 50 Then' oGraph.SeriesCollection(1).Points(i).MarkerBackgroundColorIndex = 3' oGraph.SeriesCollection(1).Points(i).MarkerForegroundColorIndex = 3' Else' oGraph.SeriesCollection(1).Points(i).MarkerBackgroundColorIndex = 6' oGraph.SeriesCollection(1).Points(i).MarkerForegroundColorIndex = 6' End If' Next i oGraph.Application.Update oGraph.Application.Quit oPPTFile.SaveAs strNewPresPath oPPTFile.Close oPPTApp.Quit Set oGraph = Nothing Set oPPTShape = Nothing Set oPPTFile = Nothing Set oPPTApp = Nothing MsgBox "Presentation Created", vbOKOnly + vbInformationEnd Sub
Sub AddNotestoPP()
Dim Sl As Slide Dim Sh As Shape Dim strNotesPageText As String Let strNotesPageText = "Adicionando comentários no Slide do Powerpoint" & vbCrLf & " Com código VBA" Set Sl = ActivePresentation.Slides(1) If Sl.NotesPage.Shapes.Count = 0 Then 'If no shapes to take Notes then add a shape firstEnd SubSl.NotesPage.Shapes.AddShape msoShapeRectangle, 0, 0, 0, 0 Let Sh = Sl.NotesPage.Shapes(1) Sh.TextFrame.TextRange.Text = strNotesPageText Else 'has shapes, so see if they take text For Each Sh In Sl.NotesPage.Shapes If Sh.HasTextFrame Then Let Sh.TextFrame.TextRange.Text = strNotesPageText Exit For End If Next ShEnd If
Sub OpenPPSForEdit()
On Error GoTo ErrHandle
Dim pShow As Presentation' Protege a janela para prevenir o "refreshing"
Let ScreenUpdating = False' Abre a apresentação, entretanto usa um flag adicional - WithWindow = FALSE
Set pShow = Presentations.Open("C:\sample.pps", WithWindow:=msoFalse)
' Abra a janela com a edição habilitada.pShow.NewWindow
' Despretege a janela para iniciar o refreshing novamente.Let ScreenUpdating = TrueExit Sub
ErrHandle:If Err.Number <> 0 ThenMsgBox Err.Number & " " & Err.Description, _vbCritical + vbOKOnly, "Erro"End If
End Sub
Sub ShakeSlides()Dim Iupper As IntegerDim Ilower As IntegerDim Ifrom As IntegerDim Ito As IntegerDim i As Integer
Let Iupper = InputBox("Qual é a maior numeração do slide para misturar:")Let Ilower = InputBox("Qual é a menor numeração do slide para misturar:")
If Iupper > ActivePresentation.Slides.Count Or Ilower < 1 Then GoTo errFor i = 1 To 2*I upper RandomizeLet Ifrom = Int((Iupper - Ilower + 1) * Rnd + Ilower)Let Ito = Int((Iupper - Ilower + 1) * Rnd + Ilower)ActivePresentation.Slides(Ifrom).MoveTo (Ito)Next iExit Suberr:MsgBox "O números que entrou não coincidem com a verdade!", vbCriticalEnd Sub
Sub Mudacor(oshp As Shape)Let oshp.Fill.ForeColor.RGB = RGB (255, 0, 0)
Exit Suberrhandler:End Sub
Sub lastplus()
On Error GoTo errorhandlerWith SlideShowWindows(1).View.GotoSlide (.LastSlideViewed.SlideIndex + 1)End WithExit Suberrorhandler:MsgBox ("Desculpe,mas este deve ser o último! ")End Sub
Copie este código num módulo do documento MS Word.
Abra o documento com o conteúdo que deseja exportar e execute o código.
Sub ExportEmbeddedSlidesAsPresentation()
Dim i As Integer
Dim nPresentation As Object
Dim nDocument As Document
Set nDocument = ActiveDocument
For i = 1 To nDocument.InlineShapes.Count
If nDocument.InlineShapes(i).Type = wdInlineShapeEmbeddedOLEObject Then
If nDocument.InlineShapes(i).OLEFormat.ProgID = "PowerPoint.Slide.8" Then
nDocument.InlineShapes(i).OLEFormat.DoVerb 2
Set nPresentation = CreateObject("PowerPoint.Application")
Call nPresentation.presentations(nPresentation.presentations.Count) _ .SaveCopyAs("C:\tmp\InAnyPlaceSlide" & i & ".ppt")
nPresentation.presentations (nPresentation.presentations.Count).Close End If
End If
Next i
nPresentation.Quit
Set nPresentation = Nothing
End Sub
Sub EjectLinks()Dim nRange As Range
For Each nRange In ActiveDocument.StoryRanges
Do While nRange.Hyperlinks.Count & nRange.Hyperlinks(1).Delete
Loop
Next nRange
End Sub
Function EliminateThousandBlankLines (StarLine as Long)
' Author: André Luiz Bernardes.
' Date: 05.02.2009
Let nRow = StartLine
Do While ActiveSheet.Cells(nRow, 1) <> ""
If ActiveSheet.Cells(nRow, 1).Value <> strUserName Then ActiveSheet.Rows(nRow).EntireRow.Delete
Else
Let nRow = nRow + 1
End If
Loop
End Function