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

Dashboard - Ford Fusion 2013.

Como as cores influenciam as respostas emocionais

Calma, este não é um arquivo sobre cromoterapia, antes um lançamento revelador feito pela Ford, que pode ajudar em muito a todos nós que, quais desenvolvedores, desejamos entregar interfaces enxutas, produtivas e atraentes.


Será que os estudos sobre cores podem contribuir para o modo como desenvolvemos os nossos Dashboards eletrônicos para análise de dados? 

Leia o artigo a seguir e opte se usará este conhecimento nas suas próximas soluções de desenvolvimentos para a apresentação de resultados.

É desafiador disponibilizar aos motoristas uma interface que:
  • Proporcione maior riqueza de informações.
  • Tenha um formato atraente.
  • Não confunda as informações ou, pior, distraia os condutores.

Gráficos complexos ou prazos de utilização de combustível foram ignorados em favor de alternativas mais iconográficas como por exemplo os medidores de combustível que são representados por uma imagem com um tanque cheio de um líquido amarelo.

[Fonte da imagem: Ford Motor Company]
VEJA O ARTIGO COMPLETO AQUI

Tags: Dashboard, Ford, Fusion, Ford Fusion 2013, LED, Edge, cor, color, influência, Mahendra Dassanayake, Michael Arbaugh 

VBA Tips - Retirando acento - Remove and replace accent characters from a string.

Inline image 1

Sei que você já tem uma função que retira acento, aliás, eu mesmo já postei uma solução destas por aqui. Mas sempre é bom olharmos para mais de uma solução:

Function ConvertAccent(ByVal inputString As String) As String
 
Const AccChars As String = _
      "²—­–ŠŽšžŸÀÁÂÃÄÅÇÈÉÊËÌÍÎÏÐÑÒÓÔÕÖÙÚÛÜÝàáâãäåçèéêëìíîïðñòóôõöùúûüýÿ'"
Const RegChars As String = _
      "2---SZszYAAAAAACEEEEIIIIDNOOOOOUUUUYaaaaaaceeeeiiiidnooooouuuuyy'"
 
Dim i As Long, j As Long
Dim tempString As String
Dim currentCharacter As String
Dim found As Boolean
Dim foundPosition As Long
 
  tempString = inputString
 
  ' loop through the shorter string
 Select Case True
    Case Len(AccChars) <= Len(inputString)
      ' accent character list is shorter (or same)
     ' loop through accent character string
     For i = 1 To Len(AccChars)
 
        ' get next accent character
       currentCharacter = Mid$(AccChars, i, 1)
 
        ' replace with corresponding character in "regular" array
       If InStr(tempString, currentCharacter) > 0 Then
          tempString = Replace(tempString, currentCharacter, _
                               Mid$(RegChars, i, 1))
        End If
      Next i
    Case Len(AccChars) > Len(inputString)
      ' input string is shorter
     ' loop through input string
     For i = 1 To Len(inputString)
 
        ' grab current character from input string and
       ' determine if it is a special char
       currentCharacter = Mid$(inputString, i, 1)
        found = (InStr(AccChars, currentCharacter) > 0)
 
        If found Then
 
          ' find position of special character in special array
         foundPosition = InStr(AccChars, currentCharacter)
 
          ' replace with corresponding character in "regular" array
         tempString = Replace(tempString, currentCharacter, _
                               Mid$(RegChars, foundPosition, 1))
 
        End If
      Next i
  End Select
 
  ConvertAccent = tempString
End Function

Referências
Tags: VBA, Outlook, email, anexar, 


Inline image 2

VBA Access - Adicionando campo em tabela pré-existente

Termo de Responsabilidade


Inserir campos em tabelas que já existem são necessidades freqüentes quando efetuamos manutenções em bancos de dados. Mas qual é o código mais apropriado para isso? Segue:

Function Vai()
    ' Author:                     Date:               Contact:
    ' André Bernardes             06/03/2012 16:32    bernardess@gmail.com     https://sites.google.com/site/bernardescvcurriculumvitae/
    ' Application: MedicalPanelAnalyseBrazil®
    ' Source Code:
    ' Listening:
    ' Cria campo dentro de uma tabela.
    
    Call AddFieldToTable ("PMedico", "TimeStamp", dbDate, , , Now())
End Function

Function AddFieldToTable (ByVal TblName As String, FldName As String, FldType As Integer, Optional FldPos As Integer,Optional FldSize, Optional DefaultValue, Optional FldDes, Optional IsAutoNumber) As Boolean

    ' Author:                     Date:               Contact:
    ' André Bernardes             06/03/2012 16:32    bernardess@gmail.com     https://sites.google.com/site/bernardescvcurriculumvitae/
    ' Application: MedicalPanelAnalyseBrazil®
    ' Source Code:
    ' Listening:
    ' Cria campo dentro de uma tabela.
    
    Dim Db As Database
    Dim DbPath As Variant
    Dim Td As TableDef
    Dim Fd As Field
    Dim p As Property

    On Error Resume Next

    'get back end path of linked table
    DbPath = DLookup("Database", "MSysObjects", "Name='" & TblName & "' And Type=6")
    If IsNull(DbPath) Then
        Set Db = CurrentDb 'if local table
    Else
        Set Db = OpenDatabase(DbPath) 'if linked table
        If Err <> 0 Then
            'failed to open back end database
            Exit Function
        End If
        'in case back end has different table name than front end
        TblName = DLookup("ForeignName", "MSysObjects", "Name='" & TblName & "' And Type=6")
    End If

    'get table
    Set Td = Db.TableDefs(TblName)
    If Err <> 0 Then
        'failed to get table
        GoTo Done
    End If

    'if IsAutoNumber, then use the correct field Type
    If Not IsMissing(IsAutoNumber) Then
        If IsAutoNumber Then
            FldType = dbLong
        End If
    End If

    'add field and properties
    With Td
        'create field
        If FldType = dbText And Not IsMissing(FldSize) Then
            Set Fd = .CreateField(FldName, FldType, FldSize)
        Else
            Set Fd = .CreateField(FldName, FldType)
        End If
        
        'position (0 is first position)
        If Not IsMissing(FldPos) Then
            Dim Num As Integer
            For Num = 0 To FldPos - 1
                Td.Fields(Num).OrdinalPosition = Num
            Next
            For Num = FldPos To .Fields.Count - 1
                Td.Fields(Num).OrdinalPosition = Num + 1
            Next
        End If
        
        'if IsAutoNumber
        If Not IsMissing(IsAutoNumber) Then
            If IsAutoNumber Then
                Fd.Attributes = 17
            End If
        End If
        
        'add field to table
        .Fields.Append Fd
        If Err <> 0 Then
            'failed to add field - probably already exists
            GoTo Done
        End If
        
        'default
        If Not IsMissing(DefaultValue) Then
            .Fields(FldName).DefaultValue = DefaultValue
        End If
        
        'add description property
        If Not IsMissing(FldDes) Then
             Set p = .Fields(FldName).CreateProperty("Description", dbText, FldDes)
             .Fields(FldName).Properties.Append p
        End If
        
        'other properties according to personal preference
        If FldType = dbText Then
            .Fields(FldName).AllowZeroLength = True
        End If
        
        
    End With

    AddFieldToTable = True 'defaults to false if it fails to get here
    
'clean up
Done:
    Set Fd = Nothing
    Set Td = Nothing
    If Not Db Is Nothing Then Db.Close
    Set Db = Nothing
End Function

Sub CallAddField()
    ' Author:                     Date:               Contact:
    ' André Bernardes             06/03/2012 16:32    bernardess@gmail.com     https://sites.google.com/site/bernardescvcurriculumvitae/
    ' Application: MedicalPanelAnalyseBrazil®
    ' Source Code:
    ' Listening:
    ' Cria campo dentro de uma tabela.
    
    Dim Result As Boolean

    'sample call:
    Result = AddFieldToTable("Table1", "NewFieldName", dbText, 2, 10, , "sample description")

    Debug.Print Result

    'Possible values for FldType parameter:
    ' dbBigInt (Decimal)
    ' dbBinary
    ' dbBoolean (Yes/No)
    ' dbByte
    ' dbCurrency
    ' dbDate
    ' dbDouble
    ' dbGUID (Replication ID)
    ' dbInteger
    ' dbLong (Long Integer)
    ' dbLongBinary (OLE Object)
    ' dbMemo
    ' dbSingle
    ' dbText (specify size, or length of text)
    ' dbVarBinary (OLE Object)

    'FldPos parameter is the ordinal position, 0 being position 1,
    '  but it works sporadically - I don't know why.
    'For optional IsAutoNumber parameter, use True or False, or leave blank.
End Sub

References:

Tags: VBA, Access, Add, field, table, campo, tabela



VBA Tips - Avalia o endereço do email - Validating An Email Address

Termo de Responsabilidade


Que tal validar um endereço de e-mail ou uma lista deles?

A função é esta: AvalMail ("bernardess@gmail.com")

Function AvalMail (ByVal EAddress As String) As Boolean
    ' Variáveis dimensionadas.
    Const AllowChars = "1234567890ABCDEFGHIJKLMNOPQRSTUVWXYZ" + "abcdefghijklmnopqrstuvwxyz._-"

    Dim UserName As String
    Dim ServerName As String
    Dim x As Long
    Dim i As Integer
    
    'Validate email address.
    Let x = InStr(1, EAddress, "@")
    
    If x = 0 Then GoTo BadAddress
    If InStr(x + 1, EAddress, "@") > 0 Then GoTo BadAddress
    
    Let UserName = Left$(EAddress, x - 1)
    Let ServerName = Right$(EAddress, Len(EAddress) - x)
    
    If Left$(UserName, 1) = "." Or Right$(UserName, 1) = "." Then GoTo BadAddress
    If Left$(ServerName, 1) = "." Or Right$(ServerName, 1) = "." Or InStr(1, ServerName, ".") = 0 Then GoTo BadAddress
    
    For i = 1 To Len(UserName)
        If InStr(1, AllowChars, Mid$(UserName, i, 1)) = 0 Then GoTo BadAddress
    Next
    
    For i = 1 To Len(ServerName)
        If InStr(1, AllowChars, Mid$(ServerName, i, 1)) = 0 Then GoTo BadAddress
    Next
    
    Let AvalMail = True

    Exit Function

BadAddress:
    Let AvalMail = False
End Function

References:

Tags: VBA, Tips, email, validade, avalia, checa, valida


Inline image 1

VBA Tips - Verifica se uma aplicação está respondendo - Test if an application is responding and terminate application


Termo de Responsabilidade


Que tal verificar se uma aplicação está respondendo e em caso positivo finalizá-la?

Option Explicit

Private Declare Function SendMessageTimeout Lib "user32" Alias "SendMessageTimeoutA" (ByVal hwnd As Long, ByVal msg As Long, ByVal wParam As Long, ByVal lParam As Long, ByVal fuFlags As Long, ByVal uTimeout As Long, pdwResult As Long) As Long

Private Declare Function TerminateProcess Lib "kernel32" (ByVal hProcess As Long, ByVal uExitCode As Long) As Long

Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long) As Long

Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long

Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long

Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long 

'Purpose     :  Terminates an application by finding the process ID of a windows handle.
'Inputs        :  lHwnd               The application window handle
'Outputs     :  Returns True if succeeds
'Notes        :  If you know the applications process ID then you need only call the last three lines of this routine.


Function ApplicationTerminate (lHwnd As Long) As Boolean
    Dim lPid As Long, lReturn As Long, lhwndProcess As Long

    Const PROCESS_ALL_ACCESS = &H1F0FFF

    'Get the PID (process ID) from the application handle
    Let lReturn = GetWindowThreadProcessId(lHwnd, lPid)

    'Terminate the application
    Let lhwndProcess = OpenProcess(PROCESS_ALL_ACCESS, 0&, lPid)
    Let ApplicationTerminate = (TerminateProcess(lhwndProcess, 0&) <> 0)
    Let lReturn = CloseHandle(lhwndProcess) 
End Function

'Purpose     :  Tests the status of an application
'Inputs        :  lHwnd               The application window handle
'                   [lWaitTimeOut]      The time in ms to wait for the application to respond
'Outputs     :  Returns True if application is responding, else returns
'                   false if the application is not responding
'Notes        :  SMTO_ABORTIFHUNG Returns without waiting for the time-out period to elapse if the receiving
'                   process appears to be in a "hung" state.
'                   SMTO_BLOCK Prevents the calling thread from processing any other requests until the function returns.

Function ApplicationResponding (lHwnd As Long, Optional lWaitTimeOut As Long = 2000) As Boolean

    Dim lResult As Long
    Dim lReturn As Long
    Const SMTO_BLOCK = &H1, SMTO_ABORTIFHUNG = &H2, WM_NULL = &H0
    
    Let lReturn = SendMessageTimeout(lHwnd, WM_NULL, 0&, 0&, SMTO_ABORTIFHUNG And SMTO_BLOCK, lWaitTimeOut, lResult)
    
    If lReturn Then
        Let ApplicationResponding = True
    Else
        Let ApplicationResponding = False
    End If
End Function

'Demonstration routine
Sub Test()
    Dim lHwnd As Long
    'Find an instance of internet explorer
    'I used IE to test it as it only takes about 2 mins before it hangs!
    Let lHwnd = FindWindow("IEFrame", vbNullString)

    If lHwnd Then
        If ApplicationResponding(lHwnd) = False Then
            'Application is not responding
            If ApplicationTerminate(lHwnd) = True Then
                MsgBox "Successfully terminated application"
            End If
        End If
    End If
End Sub

References:

Tags: VBA, Tips, application, responding, stop, close, terminate


Inline image 1

VBA Tips - Como fazer Gradientes - How to Make Gradients


Termo de Responsabilidade


O efeito gradiente é muito bonito quando utilizado com moderação em alguns objetos. O código abaixo vai evocar um gradiente em cada formulário ou picturebox ou, eventualmente, qualquer objeto que tenha uma propriedade hDC.

Basta executar a SUB DrawGradient, passando os seguintes valores:

lDestHDC - O hDC do objeto que você deseja desenhar a
lDestWidth - A largura da Gradiente
lDestHeight - A altura da Gradiente
lStartColor - A cor do gradiente começa com
lEndColor - A cor do gradiente termina com
iStyle - 0 para a esquerda para a direita ou gradiente de 1 para cima para baixo gradiente.

Crie um novo módulo e insira este código:

Type RECT
   Left As Long
   Top As Long
   Right As Long
   Bottom As Long
End Type

Declare Function CreateSolidBrush Lib "gdi32" _
  (ByVal crColor As Long) As Long

Declare Function DeleteObject Lib "gdi32" _
  (ByVal hObject As Long) As Long

Declare Function FillRect Lib "user32" _
  (ByVal hDC As Long, lpRect As RECT, _
  ByVal hBrush As Long) As Long

Public Sub DrawGradient (lDestHDC As Long, _
  lDestWidth As Long, lDestHeight As Long, _
  lStartColor As Long, lEndColor As Long, _
  iStyle As Integer)

   Dim udtRect As RECT
   Dim iBlueStart As Integer
   Dim iBlueEnd As Integer
   Dim iRedStart As Integer
   Dim iRedEnd As Integer
   Dim iGreenStart As Integer
   Dim iGreenEnd As Integer
   Dim hBrush As Long

   On Error Resume Next

   'Calculate the beginning colors
   Let iBlueStart = Int(lStartColor / &H10000)
   Let iGreenStart = Int(lStartColor - (iBlueStart * &H10000)) \ CLng(&H100)
   Let iRedStart = lStartColor - (iBlueStart * &H10000) - CLng(iGreenStart * CLng(&H100))

   'Calculate the End colors
   Let iBlueEnd = Int(lEndColor / &H10000)
   Let iGreenEnd = Int(lEndColor - (iBlueEnd * &H10000)) \ CLng(&H100)
   Let iRedEnd = lEndColor - (iBlueEnd * &H10000) - CLng(iGreenEnd * CLng(&H100))

   Const intBANDWIDTH = 1

   Dim sngBlueCur As Single
   Dim sngBlueStep As Single
   Dim sngGreenCur As Single
   Dim sngGreenStep As Single
   Dim sngRedCur As Single
   Dim sngRedStep As Single
   Dim iHeight As Integer
   Dim iWidth As Integer
   Dim intY As Integer
   Dim iDrawEnd As Integer
   Dim lReturn As Long

   Let iHeight = lDestHeight
   Let iWidth = lDestWidth
   Let sngBlueCur = iBlueStart
   Let sngGreenCur = iGreenStart
   Let sngRedCur = iRedStart

   'Calculate the size of the color bars
   If iStyle = 0 Then
      sngBlueStep = intBANDWIDTH * _
         (iBlueEnd - iBlueStart) / (iWidth - 60) * 15
      sngGreenStep = intBANDWIDTH * _
         (iGreenEnd - iGreenStart) / (iWidth - 60) * 15
      sngRedStep = intBANDWIDTH * _
         (iRedEnd - iRedStart) / (iWidth - 60) * 15

      With udtRect
         Let .Left = 0
         Let .Top = 0
         Let .Right = intBANDWIDTH + 2
         Let .Bottom = iHeight / 15 - 2
      End With

      Let iDrawEnd = iWidth
   ElseIf iStyle = 1 Then
      Let sngBlueStep = intBANDWIDTH * _
         (iBlueEnd - iBlueStart) / (iHeight - 60) * 15
      Let sngGreenStep = intBANDWIDTH * _
         (iGreenEnd - iGreenStart) / (iHeight - 60) * 15
      Let sngRedStep = intBANDWIDTH * _
         (iRedEnd - iRedStart) / (iHeight - 60) * 15

      With udtRect
         Let .Left = 0
         Let .Top = 0
         Let .Right = iWidth / 15 - 2
         Let .Bottom = intBANDWIDTH + 2
      End With

      Let iDrawEnd = iHeight
   End If

   'Draw the Gradient
   For intY = 0 To (iDrawEnd / 15) - 5 Step intBANDWIDTH
      Let hBrush = CreateSolidBrush(RGB(sngRedCur, sngGreenCur, sngBlueCur))
      Let lReturn = FillRect(lDestHDC, udtRect, hBrush)

      Let lReturn = DeleteObject(hBrush)
      Let sngBlueCur = sngBlueCur + sngBlueStep
      Let sngGreenCur = sngGreenCur + sngGreenStep
      Let sngRedCur = sngRedCur + sngRedStep

      If iStyle = 0 Then
         Let udtRect.Left = udtRect.Left + intBANDWIDTH
         Let udtRect.Right = udtRect.Right + intBANDWIDTH
      ElseIf iStyle = 1 Then
         Let udtRect.Top = udtRect.Top + intBANDWIDTH
         Let udtRect.Bottom = udtRect.Bottom + intBANDWIDTH
      End If
   Next

End Sub    

'--end code block

No evento de leitura do Form coloque este código (Set Autoredraw to true to reduce flickering while resizing the form.)

Let Me.AutoRedraw = True
DrawGradient Me.hDC, Me.Width, Me.Height, vbBlue, vbRed, 0  
'--end code block

No evento de resize do Form coloque este código

Cls
DrawGradient Me.hDC, Me.Width, Me.Height, vbBlue, vbRed, 0  
'--end code block

References:

Tags: VBA, Tips, gradient, gradiente


Inline image 1

VBA Tips - Manipulando arquivos - All File Operations.

Termo de Responsabilidade


Desenvolver com o VBA prescinde o conhecimento de manipulação de arquivos. Copiar, mover, excluir, ver quantos têm disponível em determinado local, e assim por diante. Acredito que as funcionalidades reunidas abaixo serão muito úteis nesse respeito, para ampliar o seu conhecimento. Aproveite. Aahh e deixe seus comentários.

Crie um módulo e copie tudo isso para dentro dele:

Option Explicit

 Private Declare Function ShellExecute Lib "shell32.dll" Alias _
           "ShellExecuteA" (ByVal hwnd As Long, ByVal lpszOp As _
           String, ByVal lpszFile As String, ByVal lpszParams As String, _
           ByVal lpszDir As String, ByVal FsShowCmd As Long) As Long
 
Private Declare Function GetDesktopWindow Lib "user32" () As Long

           Const SW_SHOWNORMAL = 1

           Const SE_ERR_FNF = 2&
           Const SE_ERR_PNF = 3&
           Const SE_ERR_ACCESSDENIED = 5&
           Const SE_ERR_OOM = 8&
           Const SE_ERR_DLLNOTFOUND = 32&
           Const SE_ERR_SHARE = 26&
           Const SE_ERR_ASSOCINCOMPLETE = 27&
           Const SE_ERR_DDETIMEOUT = 28&
           Const SE_ERR_DDEFAIL = 29&
           Const SE_ERR_DDEBUSY = 30&
           Const SE_ERR_NOASSOC = 31&
           Const ERROR_BAD_FORMAT = 11&

Function StartDoc (DocName As String) As Long
                   Dim Scr_hDC As Long
                   
                   Let Scr_hDC = GetDesktopWindow()
                   Let StartDoc = ShellExecute(Scr_hDC, "Open", DocName, _
                   "", "C:\", SW_SHOWNORMAL)
End Function
     
Function File_Copy (strCopyFrom As String, strCopyTo As String)
       FileCopy strCopyFrom, strCopyTo
End Function

Function Current_Dir() As String
       Let Current_Dir = CurDir
End Function

Function Change_Dir (strChangeTo As String)
       ChDir strChangeTo
End Function

Function Change_Drive (strChangeTo As String) As String
       ChDrive (strChangeTo)
       
        Let Change_Drive = CurDir
End Function

Function File_Exists (strToCheck As String) As Integer       
       Dim retval As String
       
       Let retval = Dir$(strToCheck)
       
       If retval = strToCheck Then
               Let File_Exists = 1
       Else
               Let File_Exists = 0
       End If
End Function

Function File_Rename (strOldName As String, strNewName As String)
       Name strOldName As strNewName
End Function

Function File_Delete (strToDelete As String)
       Kill strToDelete
End Function

Function Create_Dir (strToCreate)
       MkDir strToCreate
End Function

Function Remove_Dir (strToRemove As String)
       RmDir strToRemove
End Function

Function File_Move (strMoveFrom As String, strMoveTo As String)
               Kill strMoveTo
               FileCopy strMoveFrom, strMoveTo
End Function

Function File_ReadLine (strToRead As String, LineNum As Integer) As String
       Dim intCtr As Integer
       Dim strValue As String
       Dim intFNum As Integer
       Dim intMsg As Integer 
       
       Let intFNum = FreeFile

       Open strToRead For Input As #intFNum
               
                 Let intCtr = LineNum

                 Input #intFNum, strValue

                 Let File_ReadLine = strValue
                                           
       Close #intFNum
       
End Function

Function Run_Application (strPathOfFile As String)
       Dim r As Long, msg As String
                   Let r = StartDoc (strPathOfFile)

                   If r <= 32 Then
                           'There was an error
                           Select Case r
                                   Case SE_ERR_FNF
                                           Let msg = "Arquivo não encontrado"
                                   Case SE_ERR_PNF
                                           Let msg = "Caminho não encontrado"
                                   Case SE_ERR_ACCESSDENIED
                                           Let msg = "Accesso protegido"
                                   Case SE_ERR_OOM
                                           Let msg = "Fora da memória"
                                   Case SE_ERR_DLLNOTFOUND
                                           Let msg = "DLL não encontrada"
                                   Case SE_ERR_SHARE
                                           Let msg = "Ocorreu uma violação de compartilhamento"
                                   Case SE_ERR_ASSOCINCOMPLETE
                                          Let msg = "Associação inválida ou incompleta de arquivo"
                                   Case SE_ERR_DDETIMEOUT
                                           Let msg = "DDE Time out"
                                   Case SE_ERR_DDEFAIL
                                           Let msg = "DDE transaction failed"
                                   Case SE_ERR_DDEBUSY
                                           Let msg = "DDE busy"
                                   Case SE_ERR_NOASSOC
                                           Let msg = "Nenhuma associação de arquivo para essa extensão"
                                   Case ERROR_BAD_FORMAT
                                           Let msg = "Invalid EXE file or error in EXE image"
                                   Case Else
                                           Let msg = "Erro desconhecido"
                           End Select                           
                   End If           
End Function

Function File_Time (strFileName As String) As String
       Dim strDate As String
       Dim intcount, intDateLen As Integer
       
       Let strDate = FileDateTime(strFileName)
       Let intcount = InStr(1, strDate, " ", vbTextCompare)
       Let intDateLen = Len(strDate)
       Let File_Time = Mid$(strDate, intcount + 1, intDateLen)       
End Function

Function File_Date (strFileName As String) As String
       Dim strDate As String
       Dim intcount As Integer
       
       Let strDate = FileDateTime (strFileName)
       Let intcount = InStr (1, strDate, " ", vbTextCompare)
       Let File_Date = CDate (Mid$(strDate, 1, intcount)
End Function

References:

Tags: VBA, Tips, File, files, archive, arquivo, arquivos, 


Inline image 1

VBA Tips - Nome do computador - Computer Name

Termo de Responsabilidade


Talvez vc deseje ligar a execução de uma aplicação

'A função abaixo mostra qual o nome do computador atual 

Private Declare Function GetComputerNameA Lib "kernel32" (ByVal lpBuffer As String, nSize As Long) As Long 

' Para usá-la use a função abaixo 
Function GetComputerName() As String 
Dim UserName As String * 255 
Call GetComputerNameA (UserName, 255) 
Let GetComputerName = Left$(UserName, InStr (UserName, Chr$(0)) - 1) 
End Function 

References:

Tags: VBA, Tips, Computer, name



VBA Tips - Criptografando e Decriptografando - Encode and [De]Coding Ascii

Termo de Responsabilidade


Talvez queira tornar um texto, um valor, o conteúdo de uma tabela, inteligível para outras pessoas que olhem para aqueles dados sem a sua autorização.

Isso pode ser feito ao abrir os dados antes de enviá-los a um relatório ou antes de abrir uma planilha ou enviar um e-mail, tanto faz. Certamente não é nenhum código de 128 bits, mas já dá prá você brincar, entender como faz e desenvolver o seu próprio algoritmo. Enjoy!

Public Function nEncript (Data As String, Optional Depth As Integer) As String
    Dim TempChar As String
    Dim TempAsc As Integer
    Dim NewData As String
    Dim vChar As Integer

    For vChar = 1 To Len(Data)
        Let TempChar = Mid$(Data, vChar, 1)
        Let TempAsc = Asc(TempChar)

        If Depth = 0 Then Depth = 40 'DEFAULT DEPTH
        If Depth > 254 Then Depth = 254

        Let TempAsc = TempAsc + Depth

        If TempAsc > 255 Then TempAsc = TempAsc - 255

        Let TempChar = Chr(TempAsc)
        Let NewData = NewData & TempChar
    Next vChar

    Let Encode = NewData
End Function

Public Function nDecript (Data As String, Optional Depth As Integer) As String
    Dim TempChar As String
    Dim TempAsc As Integer
    Dim NewData As String
    Dim vChar As Integer

    For vChar = 1 To Len(Data)
        Let TempChar = Mid$(Data, vChar, 1)
        Let TempAsc = Asc(TempChar)
        
        If Depth = 0 Then Depth = 40 'DEFAULT DEPTH
        If Depth > 254 Then Depth = 254
        
        Let TempAsc = TempAsc - Depth
        
        If TempAsc < 0 Then TempAsc = TempAsc + 255
        
        Let TempChar = Chr(TempAsc)
        Let NewData = NewData & TempChar
    Next vChar

    Decode = NewData
End Function


References:

Tags: VBA, Tips, Criptografando, Decriptografando, encode, 128 bits, 


Inline image 1

VBA Tips - Desabilitando o [CTRL] + [ALT] + [DEL]

Termo de Responsabilidade


Como posso impedir que a combinação de teclas [CTRL] + [ALT] + [DEL] estejam ativas enquanto minhas aplicações rodam? 

No evento ao carregar do seu formulário inicial cole:

Call DesativaCtrlAltDel

Cole o código abaixo em um novo módulo:  

Public Declare Function GetCurrentProcessId _ Lib "kernel32" () As Long

Public Declare Function GetCurrentProcess _ Lib "kernel32" () As Long 

Public Declare Function RegisterServiceProcess _ Lib "kernel32" (ByVal dwProcessID As Long, _ ByVal dwType As Long) As Long 

Public Const RSP_SIMPLE_SERVICE = 1 

Public Const RSP_UNREGISTER_SERVICE = 0 

Public Sub DesativaCtrlAltDel() 
Dim pid As Long, reserv As Long 

Let pid = GetCurrentProcessId() 
Let reserv = RegisterServiceProcess (pid, RSP_SIMPLE_SERVICE) 
End Sub 


References:

Tags: VBA, Tips, [CTRL] + [ALT] + [DEL], key, stop


Inline image 1

VBA Tips: Criar uma tecla de atalho para iniciar o Excel ou Access - Create a Keyboard Hot Key to Start Excel or Access

.header_Curriculo_Microsoft.jpg

Você está constantemente abrindo o MS Excel e o MS Access? 

Por que usar o mouse para clicar sobre o ícone do MS Excel ou MS Access? 

Por que não programar uma tecla no teclado para automatizar isso?


1: Criando um atalho

Clique no Botão direito do mouse do MS Excel ou MS Access em Iniciar -> Programas

Clique em Enviar para -> área de trabalho (criar atalho)


2: Acessando a tecla de atalho

Botão direito do mouse sobre o atalho recém-criado e clique em Propriedades.

Na guia Atalho, coloque o cursor na entrada de tecla de atalho

Pressione a tecla de caracter que deseja usar para abrir o aplicativo de destino.


Lembre-se:

A combinação padrão é CTRL + ALT. Para usar Ctrl + Shift +, basta segurar para baixo, enquanto insere um caractere.

Uma tecla de atalho não vai funcionar se estiver em conflito com uma tecla de combinação já usada no programa ativo no momento.



TagsMicrosoft Office Access, Access, Format


André Luiz Bernardes

A&A® - Work smart, not hard.


VBA Advanced - Adicionando referências dinamicamente no VBA.

header_pesquisa_790x202.png


Introdução

Em diversos projetos mostram-se necessários a utilização de referências. As referências nos permitem habilitar recursos de outras aplicações. 


Por exemplo: 


Caso queiramos atualizar uma apresentação Powerpoint com tabelas e gráficos, onde tais dados estejam conectados a bancos de dados no MS Access. Isso exigiria uma referência a biblioteca do Microsoft Active Data Objects.


Agora suponhamos que a versão ADO utilizada na máquina onde a apresentação será feita é uma versão antiga, desatualizada ou incompatível?


Ou digamos que os arquivos necessários, aqueles com extensão .OCX, ou .DLL não estejam na máquina.


Certamente ocorrerão erros que inviabilizarão a apresentação, podendo até comprometer a credibilidade de quem fará a apresentação.


Um dos objetivos deste artigo é fazê-lo conhecer um modo de verificar essas referências através do código VBA. 


Para que possa compreender o poder daquilo que está aprendendo, basta informá-lo que através do VBA podemos manipular não somente objetos e eventos contidos na própria aplicação que estamos usando no momento, antes podemos, através do próprio VBA, criar módulos, classes, formulários, controles ou mesmo criar referências em qualquer um dos aplicativos da suíte MS Office.


Implementando o acesso

A conexão entre os aplicativos da suíte MS Office e mesmo com recursos de outras aplicações não é natural. Para podermos usufruir é necessário configurarmos isso em Ferramentas | Macro | Segurança. Aparecerá uma caixa de diálogo similar a demonstrada abaixo:



Acione a aba Fontes confiáveis e veja logo abaixo a opção Confiar no acesso ao projeto doVisual Basic. Por padrão está desabilitada. Habilite-a para poder prosseguir com os exemplos e clique em OK.


 Testando o aplicativo

 Para tornar o teste idôneo, é interessante ter disponível mais de uma versão do Office. Para este exemplo, vamos construir o aplicativo em Excel-VBA em que criaremos um novo arquivo doWord.


 Abra o Excel e acione o editor do VBA pelo menu Ferramentas->Macros->Editor do Visual Basic  ou com o atalho Alt+F11. No VBA, acione ao menu Ferramentas->Referências para visualizar as referências existentes e disponíveis. Procure pela referência Microsoft Word XX.0 Object Library onde XX é o numero da versão do Office instalada em seu computador:


Office

Nº Versão

Microsoft Office 97

8.0

Microsoft Office 2000

9.0

Microsoft Office XP

10.0

Microsoft Office 2003

11.0


Como estou fazendo este aplicativo na versão 2003, a biblioteca referenciada será a MicrosoftWord 11.0 Object Library conforme mostra a figura:


 


Figura 2: Referências do aplicativo

 Agora, insira um módulo convencional indo ao menu Inserir->Módulo. Nesse módulo, coloque o seguinte código:

 

  Public Sub AbreWord()

    Dim versao As String
    
'Declara uma variável do tipo Word.Application (aplicativo)
    Dim arqWord As Word.Application
    'Declara uma variável do tipo Word.Document (documento)
    Dim docWord As Word.Document
    'Cria uma nova instância do Word
 
   arqWord = CreateObject("Word.Application")
    'Esta linha serve para criar um documento em branco
    docWord = arqWord.Documents.Add
    'Torna o Word Visível
    arqWord.Visible = True
    'Captura a versão do Word
    Versao = arqWord.Version
    'Escreve texto no arquivo

    arqWord.Selection.TypeText("Olá Word " & versao & "!")

  End Sub


Se a referência estiver sido feita corretamente. será possível usufruir dos recursos do Intellisense para escrever o código. No Word 2003, o resultado da execução do código é uma nova instância e um novo documento do Word com o seguinte texto:


 


Figura 3: Arquivo de Word gerado pela Macro "AbreWord" no Word 2003


A Macro pegou a versão do Word referenciada, criou um novo documento colocando o texto que foi composto com o número da versão do Word, neste caso, 11.0.


 Com a Macro funcionando, vamos agora testá-la em outra versão do Office. Neste caso, utilizarei a versão 2000. Abra a planilha no Excel 2000 e tente executar a Macro. Facilite o acesso com o atalho Alt+F8 para mostrar a Macro e clique em executar:


 

Figura 4: Executando a Macro

 

Se tudo der certo (ou errado), surgirá a seguinte mensagem:

 


Figura 5: Erro gerado pela Macro executada no Excel 2000

 Clique em OK e veja que o editor parou a execução do código na linha em declaramos o ObjetoWord.Application. 


Figura 6: Vericando a linha de erro da Macro 

Verifique as referências feitas inda à caixa de diálogo de referências (Ferramentas->Referências o VBA) e veja que a biblioteca Microsoft Word 11.0 Object Library está marcada como AUSENTE: 


Figura 7: Vericando a ausência da referência 


Para resolver o problema de funcionamento da Macro, bastaria desfazer essa referência e procurar a Microsoft Word 9.0 Object Library que é correspondente ao Office instalado. Após isso, tente executar novamente a Macro. O resultado deverá ser este: 



Figura 8: Arquivo de Word gerado pela Macro AbreWord no Word 2000 

Veja que o texto gerado dinamicamente pela Macro obedeceu ao critério de versão e alterou o número colocado no texto (Se executar a Macro no Office XP, a versão apresentada será 10.0). Feche o arquivo do Word, salve a planilha no Excel 2000 e abra-a no Excel 2003 novamente. Ao executar a Macro, ela funcionará normalmente. Porque? Abra o VBA, acione o menu Ferramentas->Referências e veja que a referência foi atualizada para o Microsoft Word 11.0 Object Library


Neste ponto, chegamos a algumas conclusões e soluções para o problema: 

Desenvolver sempre numa versão mais antiga para garantir o funcionamento em qualquer versão do Office?

O problema é que limitaríamos aos recursos de uma versão mais antiga além do fato de se a o aplicativo for aberto em alguma versão superior e for salvo, ele manterá a referência da última versão do aplicativo em que foi aberto provocando novamente o problema de versionamento. 


Ter instalada todas as versões do Office para incluir todas as referências?

Talvez desse certo, mas quem se disponibiliza tanto financeiramente como em recursos de máquina e conflitos gerados a ter instalada todas as versões do aplicativo? 


Cria e manter a referências dinamicamente?

Essa creio eu ser a melhor saída. Não é completamente infalível, mas já testei em vários ambientes e se comportou muito bem. 





Como adicionar as referências via código 

Além dos conceitos de segurança e permissões discutidos no começo do artigo, é preciso se acostumar um pouco com os elementos das referências. Para que a manipulação funcione, é preciso fazer referência à bilbioteca Microsoft Visual Basic for Applications Extensibility 5.3. Essa é a biblioteca que permite manipular objetos do VBA, tanto do VBA como desde outras ferramentas como Visual Basic 6 ou Visual Basic .NET. Essa bilbioteca é instalada juntamente com o VBA e a garantia que ela esteja presente na máquina cliente é de quase 100%, já que na instalação padrão do Office o VBA é também instalado. 

Vamos fazer um exemplo que use objetos dessa biblioteca. Insira um módulo convencional na mesma planilha que fizemos anteriormente no Excel 2003 e coloque o seguinte código: 


  Public Sub ChecaReferencias()

     Dim mensagem As String
    'Faz a referência ao projeto VBA
    Dim vbProj As VBProject
    'A referencia em si
    Dim chkRef As Reference 

    'Seta a variável para o projeto da pasta de trabalho ativa.
    vbProj = ActiveWorkbook.VBProject
 

    'Checa as referências selecionadas (veja na caixa de diálogo Referências)
    
For Each chkRef In vbProj.References
      
'monta a string que conterá o nome de todas as referências
      mensagem = mensagem & " " & chkRef.Name & Chr(13)
    Next
    'Mostra a mensagem com o nome das referência selecionadas
    MsgBox(mensagem)

  End Sub


Execute a Macro. Não se esqueça de adicionar a referência à biblioteca de manipulação, como dito anteriormente. O resultado deverá ser algo parecido com este: 

Figura 9: Resultado gerado pela Macro ChecaReferencias 


Você pode fazer uma equivalência do resultado desta Macro abrindo a caixa de diálogo Referências do VBA: 

Figura 10: Verificando as referências

 

Teoricamente está tudo OK. Com esse código, podemos saber e aprender mais sobre as referências e seus atributos. Modifique a linha de código que monta a mensagem para o seguinte: 

mensagem = mensagem & "Nome: " & chkRef.Name & " - Caminho: " & chkRef.FullPath & " - Descrição: " & chkRef.Description & Chr(13)


Execute a Macro desta vez. O resultado deve ser o seguinte: 



Figura 11: Resultado gerado pela Macro ChecaReferencias com a mensagem alterada 

Agora temos uma forma simples de obter mais informações sobre as referências com que trabalhamos no VBA. Os atributos mais importantes a serem trabalhados para este artigo são oIsBrokenGUID, Major e Minor

A propriedade IsBroken retorna False se a referência estiver OK e True se estiver quebrada, por exemplo, quando a caixa de diálogo acusa que a referência está AUSENTE, é um caso em que o IsBroken retornará True. Isso nos ajuda a verificar a existência de uma referência que nos disponibiliza determinada funcionalidade, por exemplo, uma .OCX que contenha um controle ActiveX como o Calendar Control. Dependendo do resultado, você pode optar por rodar ou não o projeto. 

A propriedade GUID retorna o identificador único para a referência. Para ver esta identificação, modifique a linha de código que monta a mensagem para o seguinte: 

mensagem = mensagem & "Nome: " & chkRef.Name & " - GUID: " & chkRef.GUID & " - Major: " & chkRef.Major & " - Minor: " & chkRef.Minor & Chr(13)


 Veja o resultado: 


Figura 12: Resultado gerado pela Macro ChecaReferencias com a mensagem alterada 

Com alguma pesquisa, pude confirmar que esse identificador é o mesmo independente de versão. Se você testar em qualquer outra versão o mesmo código, verá que os GUIDs não serão alterados. É essa propriedade que usaremos para adicionar e remover as referências em nossos aplicativos. As propriedades Major e Minor não requerem maiores estudos e serão usadas somente para a execução do método que adiciona a referência, conforme veremos a seguir. 


Os métodos utilizados para adicionar e remover referências são o AddFromGUIDAddFromFileRemove


O método AddFromFile adiciona a referência com base no caminho do arquivo. É uma opção, mas pode ser problemática, pois precisaríamos saber qual o diretório em que foi instalado o aplicativo, o que à vezes pode ser um mistério. Para contornar a situação, podemos usar o métodoApplication.Path que retorna o diretório em que foi instalado o Office para adicionar a referência. 


O método AddFromGUID adiciona a referência com três parâmetros: GUID, Major e Minor, que são as propriedades discutidas anteriormente. O GUID pode ser passado como String e as variáveis Major e Minor devem ser passadas como Long


Pegar os dados requer código como fizemos anteriormente. Com isso, temos para a biblioteca Microsoft Word os seguintes valores: 


GUID: {00020905-0000-0000-C000-000000000046}

Major: 8

Minor: Depende da versão. 


A variável Minor possui um valor que varia conforme a versão do aplicativo. Para regularizar esse valor, a melhor maneira que encontrei foi pegando o valor do Application.Version. A diferença entre os dois valores é sempre de 8 unidades, portanto podemos fazer uma analogia para determinar o valor do parâmetro. Veja a diferença do resultado da Macro ChecaReferenciasexecutada no Excel 2000 e no Excel 2003: 


Figura 13: Resultado gerado pela Macro ChecaReferencias no Excel 2000 


Figura 14: Resultado gerado pela Macro ChecaReferencias no Excel 2003  


O método Remove remove a referência em si. É preciso passar uma variável do tipo Referencepara que funcione. 


Tendo visto todas estas opções, consegui chegar à seguintes soluções para nosso problema. Abaixo proponho um modelo de código que pode tornar o aplicativo VBA praticamente universal para todas as versões do Office: 

  Public Sub AdicionaReferenciaWord()

     'Faz a referência ao projeto VBA
    Dim vbProj As VBProject
    'A referencia em si
    Dim versao As Long
 

    'Seta a variável para o projeto da pasta de trabalho ativa.
    vbProj = ActiveWorkbook.VBProject 

    'Pega a versão atual do Office e corrige a variável
    versao = CLng(Application.Version) / 10 

    'Adiciona a referência do Word via GUID:
    vbProj.References.AddFromGuid("{00020905-0000-0000-C000-000000000046}", 8, versao - 8) 

  End Sub

   Public Sub RemoveReferenciaWord() 

    'Faz a referência ao projeto VBA
    Dim vbProj As VBProject
    'A referencia em si
    Dim chkRef As Reference

    'Seta a variável para o projeto da pasta de trabalho ativa.
    
vbProj = ActiveWorkbook.VBProject

    For Each chkRef In vbProj.References
      
'Verifica se a referência é do Word:
      
If chkRef.GUID = "{00020905-0000-0000-C000-000000000046}" Then
        'Se for, remove
        vbProj.References.Remove(chkRef)
      End If
    
Next

  End Sub


Insira esse código em um módulo vazio de uma na planilha em que estamos trabalhando adicionando a referência ao Microsoft Visual Basic for Applications Extensibility 5.3. Insira também o código para gerar o novo arquivo no Word conforme no começo do artigo. Agora, basta colocar a chamado da Macro AdicionaReferenciaWord no evento Workbook_Open e a Macro RemoveReferenciaWord no Workbook_BeforeClose. O código emEstapasta_de_trabalho fica assim: 

  Private Sub Workbook_BeforeClose(ByVal Cancel As Boolean)
    Call RemoveReferenciaWord()
  End Sub

  Private Sub Workbook_Open()
    
Call AdicionaReferenciaWord()
  End Sub


Agora, feche a planilha e salve no Excel 2003. Em seguida, abra no Excel 2000 ou XP (ativando as Macros) e sem mexer em nada, execute a Macro AbreWord. Veja que o Word é aberto corretamente não gerando mais o erro de versionamento. As Macros trataram de adicionar a referência para a versão correta do aplicativo sem intervenção do usuário. Faça isso várias vezes em diversas versões do aplicativo para testar sua eficácia. 


Você pode também fazer implementações com o método AddFromFile, embora em testes eu tenha concluído que o AddFromGUID é mais eficiente e menos sujeito e erros. 


As funções e recursos oferecidos pela biblioteca Microsoft Visual Basic for Applications Extensibility 5.3 permite ir mais além do que mostrei neste artigo. É possível estender a funcionalidade a outras bibliotecas mais comuns como o ADO e o Microsoft Outlook. A partir da versão 97, o Office teve suas versões regularizadas para todos os aplicativos e isso nos auxilia a trabalhar com as opções de versões como fizemos nos códigos de exemplo. 


Conclusão 

Procurei explanar de maneira enxuta um meio para resolver o problema de versionamento e ausência de componentes que em muito nos auxiliam e azucrinam no desenvolvimento de nossas soluções. 



Referências 

http://msdn.microsoft.com/library/default.asp?url=/library/en-us/modcore/html/deconAutomatingVisualBasicEditor.asp 

http://msdn.microsoft.com/library/default.asp?url=/library/en-us/vbaac11/html/acprominor.asp 

http://msdn.microsoft.com/library/default.asp?url=/library/en-us/vbaac11/html/acproMajor.asp 

http://msdn.microsoft.com/library/default.asp?url=/library/en-us/vbext98/html/vamthaddfromguid.asp 

http://msdn.microsoft.com/library/default.asp?url=/library/en-us/vbext98/html/vamthaddfromguid.asp
 


Tags
Microsoft Office Access, Access, Format


André Luiz Bernardes

A&A® - Work smart, not hard.


LinkWithinBrazilVBAAccessSpecialist

Related Posts Plugin for WordPress, Blogger...

Vitrine