Quaisquer soluções e/ou desenvolvimento de aplicações pessoais, ou da empresa, que não constem neste Blog podem ser tratados como consultoria freelance.





Widgets Mundo Blogger

VBA Excel - Removendo todas as referências a Links externos da planilha

Sub RemoveLinks()
Dim Link As Variant If ActiveWorkbook.LinkSources Then If MsgBox("Tem certeza que deseja retirar todos os links? ", vbYesNo + vbQuestion, "RemoveLinks") _
         = 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
End Sub

Tags: VBA, Excel, link, remove

Inline image 1

VBA Powerpoint - Atualizando gráfico com dados do MS Excel

Blog Office VBA | Blog Excel | Blog Access |

Atualize o gráfico no MS Powerpoint através de dados em planilha MS Excel.
'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 + vbInformation
End Sub

Tags: VBA, Powerpoint, Excel, export, chart, exportar, gráfico, graph

VBA Powerpoint - Acrescentando comentários aos Slides com codificação

Adicione comentários nos slides do MS POWERPOINT através de VBA.

'Open Microsoft powerpoint application and add a Slide
'Open VBA editor(Alt+F11),Insert a Module and Paste the following code in to the code window
'Close VBA Editor and run this Macro from Powerpoint window(Alt+F8)

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 first    
Sl.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 Sh
End If
End Sub

Tags: VBA, Powerpoint, Notes, anotações

Inline image 1

VBA Powerpoint - Equivalente ao comando Application.ScreenUpdating

' UserDefined Error codes

' API declarations for FindWindow() & LockWindowUpdate()
' Use FindWindow API to locate the PowerPoint handle.
Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
      (ByVal lpClassName As String, _
       ByVal lpWindowName As Long) As Long

' Use LockWindowUpdate to prevent/enable window refresh
Declare Function LockWindowUpdate Lib "user32" _
      (ByVal hwndLock As Long) As Long

' Use UpdateWindow to force a refresh of the PowerPoint window 
Declare Function UpdateWindow Lib "user32" (ByVal hwnd As Long) As Long
Property Let ScreenUpdating(State As Boolean)

Static hwnd As Long
Dim VersionNo As String

' Get Version Number
      If State = False Then

        VersionNo = Left(Application.Version, _
                    InStr(1, Application.Version, ".") - 1)

' Get handle to the main application window using ClassName
        Select Case VersionNo
Case "8"  ' For PPT97:

            hwnd = FindWindow("PP97FrameClass", 0&)
Case "9"  ' For PPT2K:

            hwnd = FindWindow("PP9FrameClass", 0&)
Case "10" ' For XP:
hwnd = FindWindow("PP10FrameClass", 0&)
Case "11" ' For 2003:
hwnd = FindWindow("PP11FrameClass", 0&)
Case "12" ' For 2007:
hwnd = FindWindow("PP12FrameClass", 0&)
        Case Else
            Err.Raise Number:=vbObjectError + ERR_VERSION_NOT_SUPPORTED, _
            Description:="Supported for PowerPoint 97/2000/2002/2003 only."
Exit Property
End Select

If hwnd = 0 Then
            Err.Raise Number:=vbObjectError + ERR_NO_WINDOW_HANDLE, _
            Description:="Unable to get the PowerPoint Window handle"
Exit Property
End If

If LockWindowUpdate(hwnd) = 0 Then
            Err.Raise Number:=vbObjectError + ERR_WINDOW_LOCK_FAIL, _
            Description:="Unable to set a PowerPoint window lock"
            Exit Property
End If


        ' Unlock the Window to refresh
        LockWindowUpdate (0&)
        UpdateWindow (hwnd)
        hwnd = 0

      End If

End Property
'Sample Usage:
Sub LongProcessingSub()
' Lock screen redraw
' --- Long time consuming code
' Redraw screen again
' Also see below article for another example of usage of the code
End Sub

Tags: VBA, Powerpoint, refresh

Inline image 1

VBA Powerpoint - Abrindo uma apresentação .PPS

Termo de Responsabilidade

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

Tags: VBA, Powerpoint, open, PPS

Inline image 1

VBA Powerpoint - Misturando a apresentação dos Slides

Termo de Responsabilidade

Através de código VBA você pode misturar a apresentação dos seus slides.

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!", vbCritical
End Sub

Tags: VBA, Powerpoint, shake, misturando

Inline image 1

VBA Powerpoint - Mudando a cor do Slide

Termo de Responsabilidade

Ótimo exercício para a introdução ao VBA do MS Powerpoint.

Mude a cor de fundo do Slide. 

O padrão das cores prá quem desconhece é RED, GREEN e BLUE.

Sub Mudacor(oshp As Shape)
Let oshp.Fill.ForeColor.RGB = RGB (255, 0, 0) 
Exit Suberrhandler:
End Sub

Tags: VBA, Excel, matriz, vetor, array, DAO, ADO, Northwind, CopyFromRecordset

Inline image 1

VBA Powerpoint - Detectando o último Slide

Termo de Responsabilidade

Prá quem deseja começar a brincar com o VBA no Powerpoint e não sabia como, segue código....

Bom início!

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

Tags: VBA, Powerpoint

Inline image 1

VBA Word - Exportando o conteúdo de um .DOC para um Slide .PPT

Termo de Responsabilidade

Isso é que chamo uma excelente oportunidade de economizar tempo. Exporte o conteúdo do seu documento MS Word para slides do MS Powerpoint.

A ação abaixo ocorrerá basicamente num único passo:
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
 Set nPresentation = Nothing
 End Sub

Tags: VBA, Word, Powerpoint, export, slide

Inline image 1

VBA Word - Retire todos hyperlinks mantendo o texto no .DOC

Termo de Responsabilidade

Não raro recebemos e/ou baixamos documentos do MS Word repleto de links que somente nos irritam tamanho número de links no seu interior.

Abaixo segue a solução para retirá-los, preservando o texto.

Sub EjectLinks()Dim nRange As Range

For Each nRange In ActiveDocument.StoryRanges
Do While nRange.Hyperlinks.Count & nRange.Hyperlinks(1).Delete
Next nRange
End Sub

Tags: VBA, Word, hyperlinks

Inline image 1

Excel VBA – Solução eficiente para deletar milhares de linhas

Termo de Responsabilidade

Caso necessite deletar aquelas planilhas com milhares de linhas em branco poderá usar a funcionalidade abaixo.
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
Let nRow = nRow + 1
End If
 End Function

Tags: VBA, Excel, row, line, delete

Inline image 1

Related Posts Plugin for WordPress, Blogger...
diHITT - Notícias