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

Histats

Vitrine

+Views

Widgets Mundo Blogger

Prever: VBA Excel - Auto-Documentando suas Aplicações


Você que é desenvolvedor de aplicações com o MS Excel, tais como MIS, Dashboards,ou mesmo BSC possivelmente tem inúmeras soluções desenvolvidos por aí, sem que nem todas estejam documentadas.

Como faríamos isso utilizando um código simples e rápido?
Existem documentadores comerciais por aí, mas com o código abaixo poderá, pelo menos, listar todos os seus Módulos e Processos dentro destes das suas respectivas aplicações.

Crie um novo módulo, talvez com o nome de 'mdl_x_DocApplication' e cole nele o código abaixo:


CÓDIGO:

'=============================================================================================
' Microsoft® Office Excel - DashBoard®, Developed by A&A - In Any Place®.
'
' CopyLeft© A&A - In Any Place, all Lefts Reserved.
'
' Cheque se existe referência ao "Microsoft Visual Basic for Applications Extensibility x.xx"
'=============================================================================================

Option Explicit

Const vbext_pp_none As Long = 0
Const vbext_pk_Proc As Long = 0

Dim x As Long
Dim objList()

Sub RetProject()
    ' Author:                     Date:               Contact:                 URL:
    ' André Bernardes             22/09/2010 15:26    bernardess@gmail.com https://sites.google.com/site/vbabernardes/blogs
    ' Lista todos os módulos, e processos (functions & procedures) neles.

    Dim oBJCT As Object
    Dim Wb As Workbook
    
    Let x = 2
    
    For Each Wb In Workbooks
        For Each oBJCT In Workbooks(Wb.Name).VBProject.VBComponents

            If Workbooks(Wb.Name).VBProject.Protection = vbext_pp_none Then

                Call LoadRoutines(Wb.Name, oBJCT.Name)

            End If

        Next
    Next

    With Sheets.Add
        Let .[A1].Resize (, 3).Value = Array ("Aplicação", "Módulo", "Processos (Functions & Subs)")
        Let .[A2].Resize (UBound (objList, 2), UBound(objList, 1)).Value = Application.Transpose (objList)

        .Columns("A:C").Columns.AutoFit
    End With
End Sub


Agora só precisará utilizar a SUB que carregará todo o conteúdo da sua aplicação (planilha)


CÓDIGO:

Sub LoadRoutines(nWBook As String, vbCmp As String)
    ' Author:                     Date:               Contact:                 URL:
    ' André Bernardes             23/11/2010 15:28    bernardess@gmail.com https://sites.google.com/site/vbabernardes/blogs
    ' Retorna detalhes para a SUB 'RetProject'.
    ' Listening: .

    Dim vbCode As Object
    Dim StartRow As Long

    On Error Resume Next
    
    Set vbCode = Workbooks(nWBook).VBProject.VBComponents(vbCmp).vbCode
    
    With vbCode
        Let StartLine = .CountOfDeclarationLines + 1

        Do Until StartLine >= .CountOfLines

            ReDim Preserve aList (1 To 3, 1 To x - 1)

            Let aList(1, x - 1) = nWBook
            Let aList(2, x - 1) = vbCmp
            Let aList(3, x - 1) = .ProcOfLine(StartRow, vbext_pk_Proc)
            Let x = x + 1
            Let StartLine = StartRow + .ProcCountLines(.ProcOfLine(StartRow, vbext_pk_Proc), vbext_pk_Proc)

            If Err Then Exit Sub
        Loop
    End With

    Set vbCode = Nothing
End Sub



Esse código é prático porque pode acrescentar documentação na sua própria planilha. Se desejar pode mantê-la ali mesmo, talvez escondida, e solicitar que esta seja atualizada todas as vezes que for fechada, por exemplo. Ainda mais, poderá ampliar a análise de outros objetos e classes na aplicação.

Boa diversão!


Tags: Excel, auto, document, auto-documentação

André Luiz Bernardes
A&A® - Work smart, not hard.

VBA Excel - Inserindo icone em suas aplicações

Digamos que você tenha diversas planilhas abertas no nosso computador neste momento.

Cada uma delas com conteúdos totalmente distintos. Não seria bom se você pudesse identificá-las somente olhando para os seus ícones na barra do Windows? Como podemos fazer isso?

Na verdade não requer prática, nem tão pouco experiência, basta que siga os passos abaixo:

Crie um novo módulo com um nome como: mdl_Functions_Icon

Dentro do módulo cole o código abaixo:



CÓDIGO: 

Declare Function GetActiveWindow32 Lib "USER32" Alias "GetActiveWindow" () As Integer
Declare Function SendMessage32 Lib "USER32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Declare Function ExtractIcon32 Lib "SHELL32.DLL" Alias "ExtractIconA" (ByVal hInst As Long, ByVal lpszExeFileName As String, ByVal nIconIndex As Long) As Long

Function ChangeApplicationIcon()
    ' Author:                     Date:               Contact:                 URL:
    ' André Bernardes             22/11/2010 13:43    bernardess@gmail.com     https://sites.google.com/site/vbabernardes/
    ' Carrega o icone identificando a planilha.
    ' Listening:

    Dim Icon& ' Pegue o ícone de outro aplicativo como abaixo:
    
    Const NewIcon$ = "C:\PlanIcons\DashBoard.ico"  ' Um arquivo .ICO em um diretório: '
    
    Let Icon = ExtractIcon32(0, NewIcon, 0)
    
    SendMessage32 GetActiveWindow32(), &H80, 1, Icon
End Function



Na pasta de inicialização da sua planilha faça uma chamada a esta função, como demonstrado abaixo:


CÓDIGO: 

Private Sub Workbook_Open()
    ' Author:                     Date:               Contact:                 URL:
    ' André Bernardes             27/09/2010 09:07    bernardess@gmail.com     https://sites.google.com/site/vbabernardes/
    ' Abre a planilha para acesso a dados.
    ' Listening: Don´t Give Hate a Chance - Jamiroquai.

    Let Application.ScreenUpdating = False
    Let Application.Caption = ".: DashBoard®"
    Let Application.StatusBar = "A&A - In Any Place®"

    Call ChangeApplicationIcon

    Sheets("Dashboard").Select
    ActiveSheet.Outline.ShowLevels RowLevels:=1
    
    frmSplash.Show

    Sheets("Menu").Select

    Let Application.ScreenUpdating = True
End Sub


Pronto!

Todas as suas aplicações podem ter ícones distintos, identificando-as mais facilmente até mesmo para seus clientes.


Tags: Bernardes, VBA, Office, Excel, worksheets, sheets, ws, insert, inserindo, pasta


André Luiz Bernardes
A&A® - Work smart, not hard.

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




Retirar os acentos de Planilhas, Textos, Apresentações, Bases 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

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

A 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 '


Veja também:
Retirar acentos


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



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