Important:

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.

Views

Vitrine

+Views

Widgets Mundo Blogger

VBA Excel - Obtendo informações sobre os pontos no gráfico usando o PointClass - Retrieve Information About Chart Points Using Excel.PointClass

Inline image 1



Este exemplo mostra como obter informações sobre os pontos de um gráfico do MS Excel, como o nome, posições de topo e à esquerda, a largura e a altura.

Vamos aprender a trabalhar com os novos membros da classe Point. Agora podemos obter informações sobre os pontos em um gráfico, incluindo:

  - Nome
  - Início
  - Esquerda
  - Largura
  - Altura

Pontos em um gráfico são numerados a partir da esquerda para a direita na série. Dada a informação sobre o ponto, podemos escrever um código para colocar outras informações sobre o gráfico, ou interagir com estes pontos.

Sub TestPointClass() 
    ' First, create a simple chart that contains points. 
    Range("A1:B1").Value = Array("Region", "Sales") 
    Range("A2:B2").Value = Array("North", 100) 
    Range("A3:B3").Value = Array("South", 200) 
    Range("A4:B4").Value = Array("East", 300) 
    Range("A5:B5").Value = Array("West", 400) 
    
    Dim cht As Chart 
    Set cht = Shapes.AddChart.Chart 
    cht.ChartType = xlLineMarkers 
    cht.SetSourceData Source:=Range("A1:B5") 
    With cht.SeriesCollection(1) 
        .Points(1).MarkerStyle = xlMarkerStyleDiamond 
        .Points(2).MarkerStyle = xlMarkerStyleCircle 
        .Points(3).MarkerStyle = xlMarkerStyleDash 
        .Points(4).MarkerStyle = xlMarkerStyleSquare 
        
        Dim i As Integer 
        For i = 1 To 4 
            DisplayPointProperties .Points(i) 
        Next i 
    End With 
    
End Sub 
Sub DisplayPointProperties(pt As Point) 
    ' Display information about the selected 
    ' point in the Immediate window: 
    Debug.Print "========" 
    Debug.Print "Name:   " & pt.Name 
    Debug.Print "Left:   " & pt.Left 
    Debug.Print "Top :   " & pt.Top 
    Debug.Print "Width:  " & pt.Width 
    Debug.Print "Height: " & pt.Height 
End Sub

Tags: VBA, Excel, Retrieve, Information, Chart, PointClass

VBA Excel - Exibe os primeiros 10% de um Range - Display Top Ten Percent in Ranges Programmatically

Inline image 1



Este exemplo mostra como usar o método AddTop10 para exibir os primeiro 10% de uma série de números numa planilha do MS Excel.

Sub DemoAddTop10() 
  ' Fill a range with random numbers. 
  ' Mark the top 10% of items in green, and the bottom 
  ' 10% of the items in red. 
  
  ' Set up a range, and fill it with random numbers. 
  Dim rng As Range 
  Set rng = Range("A1:E10") 
  SetupRangeData rng 
  
  ' Clear any existing format conditions. 
  rng.FormatConditions.Delete 
  
  ' Set up a condition that formats the top 
  ' 10 percent of items on green. 
  Dim fc As Top10 
  Set fc = rng.FormatConditions.AddTop10 
  fc.Percent = True 
  fc.TopBottom = xlTop10Top 
  fc.Interior.Color = vbGreen 
  
  ' Set up a condition that formats the bottom 
  ' 10 percent of items in red. 
  Set fc = rng.FormatConditions.AddTop10 
  fc.TopBottom = xlTop10Bottom 
  fc.Percent = True 
  fc.Interior.Color = vbRed 
End Sub 
Sub SetupRangeData(rng As Range) 
  rng.Formula = "=RANDBETWEEN(1, 100)" 
End Sub 

Tags: VBA, Excel, Display, Top Ten, Percent, Ranges, Programmatically

VBA Excel - Exporte as planilhas para PDF ou XPS - Export Data to PDF or XPS Using the Excel.ExportAsFixedFormat Method

Inline image 1


Este exemplo mostra como usar o método ExportAsFixedFormat para exportar uma série de dados em uma planilha do Microsoft Excel para o formato PDF ou XPS.

Sub TestExportAsFixedFormat() 
  ' For information on the final parameter, see this page: 
  
  Dim rng As Range 
  Set rng = Range("A1:E10") 
  SetupRangeData rng 
  
  Dim fileName As String 
  ' Change this file name to meet your own needs: 
  Let fileName = "C:\Temp\Export.pdf" 
  
  ' Many of these properties are optional, and are included 
  ' here only to demonstrate how you might use them. The 
  ' Type parameter can be one of xlTypePDF and xlTypeXLS; 
  ' the Quality parameter can be one of xlQualityStandard and 
  ' xlQualityMinimum. Setting the OpenAfterPublish property 
  ' to True will fail if you don't have a default viewer 
  ' installed and configured. 
  
  rng.ExportAsFixedFormat Type:=xlTypePDF, _ 
   fileName:=fileName, Quality:=xlQualityStandard, _ 
   IncludeDocProperties:=True, IgnorePrintAreas:=True, _ 
   From:=1, To:=1, OpenAfterPublish:=True 
End Sub 
Sub SetupRangeData(rng As Range) 
  Let rng.Formula = "=RANDBETWEEN(1, 100)" 
End Sub 



Anexos:



Tags: VBA, Excel, Export, Data, PDF, XPS, ExportAsFixed, Format, Method


VBA Powerpoint - Adicione um Shape ao Slide e o formate - Add and Format Shapes Using PPT.ColorFormat.Brightness

Inline image 1


Microsoft ® Office nos dá ferramentas necessárias para criar aplicativos poderosos. Os exemplos de Microsoft Visual Basic for Applications (VBA) podem nos ajudar a criar seus próprios aplicativos que executam funções específicas ou como um ponto de partida para criar soluções mais complexas.

Este exemplo mostra como selecionar o primeiro slide de uma apresentação do Microsoft PowerPoint, adicionar um Shape a ele, e depois mudar o brilho do Shape na propriedade foreground (primeiro plano).

Cada amostra de código é composto de cerca de 5 a 50 linhas de código que demonstram uma característica diferente ou um conjunto de recursos, tanto em VBA como em VB ou C# (criado no Visual Studio 2010). Os comentários explicarão como configurar o ambiente para que o código seja executado.

Sub TestBrightness() 
    Dim i As Integer 
    Dim shp As Shape 
    Dim sld As Slide 
    
    Set sld = ActivePresentation.Slides(1) 
    
    ' Add a new shape: A 200x100 pixel balloon, and set its color: 
    Set shp = sld.Shapes.AddShape(msoShapeBalloon, 10, 10, 200, 100) 
    shp.Fill.ForeColor.RGB = 3487637 
    
    ' Finally, alter the Brightness of the color. Do not use 
    ' this technique to create animations--PowerPoint handles 
    ' that itself. This is meant only as instructive code that 
    ' demonstrates how modifying the Brightness property 
    ' changes the way a shape looks. 
    For i = 0 To 100 
        SetBrightness shp, i / 100 
        ' Wait 1/10 second or so. 
        Pause 0.1 
    Next i 
End Sub 
Sub SetBrightness(shp As Shape, brightnessValue As Single) 
    ' Set the Brightness property of a ColorFormat object. 
    ' You can retrieve a ColorFormat in a number of ways. 
    ' See this page for more information on ways to retrieve 
    ' a reference to a ColorFormat object: 
    
    Dim cf As ColorFormat 
    Set cf = shp.Fill.ForeColor 
    cf.brightness = brightnessValue 
End Sub 
Function Pause(numberOfSeconds As Variant) 
    Dim startTime, endTime As Variant 
    startTime = Timer 
    endTime = startTime + numberOfSeconds 
    
    Do While Timer < endTime 
        DoEvents 
    Loop 
End Function 



Anexos:




Tags: VBA, Powerpoint, Add, Format, Shapes, Brightness, color


VBA - Retirando os acentos de Planilhas, Textos, Apresentações, bases de dados, etc...




Retirar os acentos de Planilhas, TextosApresentaçõesBases de Dados, etc....eventualmente também é necessário, seguem códigos úteis para serem colados no seu Editor VBA:

Function removeAcentos (ByVal texto As String) As String    
    Dim vPos As Byte
    
    Const vComAcento = "ÀÁÂÃÄÅÇÈÉÊËÌÍÎÏÒÓÔÕÖÙÚÛÜàáâãäåçèéêëìíîïòóôõöùúûü"
    Const vSemAcento = "AAAAAACEEEEIIIIOOOOOUUUUaaaaaaceeeeiiiiooooouuuu"
    
    For i = 1 To Len(texto)
        vPos = InStr(1, vComAcento, Mid(texto, i, 1))
        If vPos > 0 Then
           Mid(texto, i, 1) = Mid(vSemAcento, vPos, 1)
        End If
    Next
    removeAcentos = texto
End Function

Private Sub Command1_Click()
   'exemplo de como chamar
   Text1 = removeAcentos(Text1)
End Sub

Outra opção:
Sub Substituir()
    Cells.Replace What:="é", Replacement:="e", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False

    Cells.Replace What:="É", Replacement:="E", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False

    Cells.Replace What:="á", Replacement:="a", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False

    Cells.Replace What:="Á", Replacement:="A", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
End Sub

Uma ampliação do código em:
Public Function DLTiraAcentos(ByVal strOriginal As String)
'By JPaulo @ 2009
    Dim strToReturn As String
    strToReturn = ""
    
    Dim i As Integer
    For i = 1 To Len(strOriginal)
        strToReturn = strToReturn & DLTiraAcentos_GetCorrectChar(Mid$(strOriginal, i, 1))
    Next i
    
    DLTiraAcentos = strToReturn
End Function

Public Function DLTiraAcentos_GetCorrectChar(ByVal strChar As String) As String
    Dim LetrasComAcentos As String
    Dim LetrasSemAcentos As String

    LetrasComAcentos = "ÁÍÓÚÉÄÏÖÜËÀÌÒÙÈÃÕÂÎÔÛÊáíóúéäïöüëàìòùèãõâîôûêÇç"
    LetrasSemAcentos = "AIOUEAIOUEAIOUEAOAIOUEaioueaioueaioueaoaioueCc"

    Dim i As Integer

    For i = 1 To Len(LetrasComAcentos)
        If strChar = Mid$(LetrasComAcentos, i, 1) Then
            DLTiraAcentos_GetCorrectChar = Mid$(LetrasSemAcentos, i, 1)
            Exit Function
        End If
    Next
    
    DLTiraAcentos_GetCorrectChar = strChar
End Function

criatividade é uma dádiva:
Function Sem_Acento(Acento)
'Desclara variável
Dim tmp$
tmp = Trim(Acento)
For i = 1 To Len(tmp)
x = Asc(Mid(tmp, i, 1))
Select Case x
Case 192 To 197: x = "A"
Case 200 To 203: x = "E"
Case 204 To 207: x = "I"
Case 209: x = "N"
Case 210 To 214: x = "O"
Case 217 To 220: x = "U"
Case 221: x = "Y"
Case 224 To 229: x = "a"
Case 232 To 235: x = "e"
Case 236 To 239: x = "i"
Case 241: x = "n"
Case 240, 242 To 246: x = "o"
Case 249 To 252: x = "u"
Case 253, 255: x = "y"
Case Else: x = Chr(x)
End Select
Sem_Acento = Sem_Acento & x
Next
End Function '

Tags: VBA, dica, trick, tip, acento, diacrítico, retirar


VBA Lotus Notes - Inserindo arquivo - Insert Attach File

Inline image 1

Blog Office VBA | Blog Excel | Blog Access |


Bem, não tenho o Lotus Notes instalado, este código lhe ensina a anexar:

    Dim AttachME As Object
    Dim EmbedObj1 As Object
    
'   Select Workbook to Attach to E-Mail

    Let notesDocument.SaveMessageOnSend = True
    Let attachment1 = "D:\Bernardes\FileToSend.txt" '    Required File Name

    If attachment1 <> "" Then
        On Error Resume Next
            Set AttachME = MailDoc.CREATERICHTEXTITEM("attachment1")
            Set EmbedObj1 = AttachME.embedobject(1454, "attachment1", "D:\Bernardes\FileToSend.txt", "") 'Required File Name
        On Error Resume Next
    End If


Tags: VBA, Lotus Notes, Lotus, atach, anexar


VBA Tips - Retornando Milissegundos.

Inline image 1


Hello again folks!


Medir o tempo de processamento de certos momentos dentro da nossa aplicação serve para otimizarmos nosso código, processos, acessos, etc.

Talvez deseje medir a performance de suas queries, ou a geração de arquivos em determinando processo de automação. Talvez queira saber qual interface comporta-se melhor no ambiente para o qual está desenvolvendo.

Como fazer isso, como medir, mensurar, detectar?

Fácil, a função abaixo lhe permitirá tal liberdade.

Public Function MilisSeconds() As String


Let 







MilisSeconds
 
 = Strings.Format(Now, "dd-MMM-yyyy HH:nn:ss") & "." & Strings.Right(Strings.Format(Timer, "#0.00"), 2)
End Function


Mas como posso aplicar isso nas minhas procedures e functions ? Segue exemplo:

Private Sub btnSave_Click()

    ' Author:                     Date:               Contact:

    ' André Bernardes             10/05/2011 15:31    bernardess@gmail.com    http://inanyplace.blogspot.com/

    ' Application: ********.

    ' Cria a **************************************.

    ' Listening: Recognizer - Daft Punk - Tron Legacy.

    Dim nStart As String

    DoCmd.RunCommand acCmdSaveRecord

    Let nStart = Right(TimeInMS(), 11) 'Right(Now(), 8)

    Call AdjustSpecialties


    Call AssemblerCentralEngine

    Call AssemblerCentralEngine2

    Call SeedData                                                    ' Arquiva os dados para consulta e análise posteriores

    Me.cmbCenarios.Requery                                    ' Atualiza o Combo de Exclusão de cenários.

    Let Me.cxVersion.Value = Now() & " Versão 00"   ' Atualiza a caixa de texto onde se dá os nomes para novos cenários.

    MsgBox "Tabela criada com sucesso!" & Chr(10) & Chr(13) & _

"" & Chr(10) & Chr(13) & _

           " TABELA: tbl_Bernardes" & Chr(10) & Chr(13) & _

           "" & Chr(10) & Chr(13) & _

           "CENÁRIO: " & ReturnVersion() & Chr(10) & Chr(13) & _

           "" & Chr(10) & Chr(13) & _

           "Iniciou em: " & nStart & " - Finalizou em: " & Right(TimeInMS(), 11) & Chr(10) & Chr(13) & _

           "" & Chr(10) & Chr(13) & _

           "Os dados foram preservados para análises posteriores." & Chr(10) & Chr(13) & _

           "", vbInformation, ".: Informação: Versão " & ReturnVersion()

End Sub


Existe um outro modo de ter este mesmo resultado, utilizando API e DLL. Não acredito que seja mais útil, mas em todo caso, teste-o você mesmo se desejar:

Private Type SYSTEMTIME


wYear As Integer


wMonth As Integer


wDayOfWeek As Integer


wDay As Integer


wHour As Integer


wMinute As Integer


wSecond As Integer


wMilliseconds As Integer

End Type


Private Declare Sub GetSystemTime Lib "kernel32" 

(lpSystemTime As SYSTEMTIME)

Public Function nMillisecond() As String


Dim tSystem As SYSTEMTIME


Dim nRet

On Error Resume Next

GetSystemTime tSystem

Let sRet = Hour(Now()) & ":" & Minute(Now()) & ":" & Second(Now()) & _

":" & tSystem.wMilliseconds

Let nMillisecond = nRet

End Function


Vocês sabem como sou, se existe um outra forma, e a conheço, não deixo de lhes mostrar (medindo processamento em centésimos de segundos com o métodoTimer):

Public Sub TestBernardes()


    Dim fTimeStart As Single

    Dim fTimeEnd As Single

    Let fTimeStart = Timer

SomeProcedure









Let 
 
fTimeEnd = Timer

Debug.Print Format$((fTimeEnd - fTimeStart) * 100!, "0.00 "" Centésimos de segundos""")

End Sub

Public Sub SomeProcedure()

    Dim i As Long, r As Double

    For i = 0& To 10000000

        Let r = Rnd

    Next
End Sub


ReferênciasVBAADUD
                      Excel Forum
                 Stack Overflow

Tags: VBA, Tips, milissegundo, timer, milliseconds


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