✔ Programação GLOBAL®: icon

Mostrando postagens com marcador icon. Mostrar todas as postagens

VBA Excel - Mudando o ícone da Planilha

É importante para algumas aplicações que o ícone da planilha, especialmente quando se abrem muitas simultaneamente, seja específico, identificando prontamente quais dados estão sendo utilizados. O código abaixo não é nenhuma novidade, apenas o disponibilizo como modo clássico de fazê-lo. Sugiro apenas que uma pequena alteração seja efetuada, propiciando que o Path e o nome do arquivo .ICO, estejam posteriormente parametrizáveis em uma pasta.

É importantíssimo dar o crédito a: Jim Rech. O código abaixo deve ser postado no Workbook:

Sub Workbook_Open()

Let Application.Caption = ".: A&A - Minha planilha personalizada"

ChangeApplicationIcon

End Sub

Agora crie um módulo e coloque o conteúdo abaixo nele:

Option Explicit

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

Crie, no mesmo módulo, a SUB que efetuará a chamada às definições acima:

Sub ChangeApplicationIcon()

Dim Icon& ' Pegue o ícone de outro aplicativo como abaixo:

Const NewIcon$ = "Notepad.exe" ' Ou escolha um arquivo .ICO em um diretório: '

Const NewIcon$ = "F:\A&A\A&A - LogoIcon - 002.ico"

Let Icon = ExtractIcon32 (0, NewIcon, 0)

SendMessage32

GetActiveWindow32(), &H80, 1, Icon '< 1 =" big" 0 =" small">

End Sub

Envie seus comentários e sugestões e compartilhe este artigo!

brazilsalesforceeffectiveness@gmail.com

VBA Excel - Manipule Ícones nas suas Planilhas - Add Icon Sets for Ranges

Consultancy in Excel, Access, VBA & PowerPoint projects

DESENVOLVO APLICAÇÕES

Perguntas, Questões e Esclarecimentos

Este exemplo mostra como adicionar ícones num determinado intervalo de valores no workbook.

Se você se perguntar prá que precisar saber isso, não está pronto para aprendê-lo...

Sub TestAddIconSet()

Dim i As Integer

Dim rng As Range

For i = 1 To 20

' Set up ranges

Set rng = SetupRange(i)

Select Case i

Case 1

SetUpIconSet rng, xl3Arrows

Case 2

SetUpIconSet rng, xl3ArrowsGray

Case 3

SetUpIconSet rng, xl3Flags

Case 4

SetUpIconSet rng, xl3Signs

Case 5

SetUpIconSet rng, xl3Stars

Case 6

SetUpIconSet rng, xl3Symbols

Case 7

SetUpIconSet rng, xl3Symbols2

Case 8

SetUpIconSet rng, xl3TrafficLights1

Case 9

SetUpIconSet rng, xl3TrafficLights2

Case 10

SetUpIconSet rng, xl3Triangles

Case 11

SetUpIconSet rng, xl4Arrows

Case 12

' Reverse the order on this one:

SetUpIconSet rng, xl4ArrowsGray, True

Case 13

SetUpIconSet rng, xl4CRV

Case 14

SetUpIconSet rng, xl4RedToBlack

Case 15

SetUpIconSet rng, xl4TrafficLights

Case 16

SetUpIconSet rng, xl5Arrows

Case 17

' Reverse the order on this one:

SetUpIconSet rng, xl5ArrowsGray, True

Case 18

SetUpIconSet rng, xl5Boxes

Case 19

SetUpIconSet rng, xl5CRV

Case 20

SetUpIconSet rng, xl5Quarters

End Select

Next i

End Sub

Function SetupRange(col As Integer) As Range

' Set up ranges, filled with numbers from 1 to 10.

Set rng = Range(Cells(1, col), Cells(10, col))

Dim rng1 As Range

Set rng1 = Cells(1, col)

rng1.Value = 1

Dim rng2 As Range

Set rng2 = Cells(2, col)

rng2.Value = 2

Range(rng1, rng2).AutoFill Destination:=rng

Set SetupRange = rng

End Function

Sub SetUpIconSet(rng As Range, iconSet As XlIconSet, Optional ReverseOrder As Boolean = False)

' Set up an icon set for the supplied range.

rng.FormatConditions.Delete

Dim isc As IconSetCondition

Set isc = rng.FormatConditions.AddIconSetCondition

With isc

' If specified, show the icons in the reverse ordering:

.ReverseOrder = ReverseOrder

.ShowIconOnly = False

' Select the requested icon set:

.iconSet = ActiveWorkbook.IconSets(iconSet)

End With

End Sub

Deixe os seus comentários! Envie este artigo, divulgue este link na sua rede social...

Tags: VBA, Excel, Icon, ícones, Conditional, Formatting,

VBA Excel - Usando o MS Excel como banco de dados

Consultancy in Excel, Access, VBA & PowerPoint projects

DESENVOLVO APLICAÇÕES

Perguntas, Questões e Esclarecimentos

Sim, às vezes nos é solicitado desenvolver uma solução no MS Excel que devia ser desenvolvida no MS Access. Precisamos desenvolver um formulários para dataentry, um ambiente para o armazenamento dos dados.

Imaginemos termos uma planilha com dados de Fornecedor e outra planilha de Produto. Como faríamos para trazer os produtos de um determinado fornecedor?

Todo o processo precisaria ser feito via código, um loop varrendo os produtos e identificando o fornecedor e copiando o resultado para outro lugar. Ou através do uso de fórmula, que dependendo da massa de dados pode se tornar inviável.

E se fosse possível fazer um SELECT com JOIN? Ficaria bem mais fácil certo?

Se seguíssemos um modelo de desenvolvimento padrão, o nosso código ficaria mais organizado. Precisamos de um segundo arquivo MS Excel pra ser o nosso banco de dados. Nada é perfeito, só é possível executar SELECT e INSERT. Os comandos de UPDATE e DELETE a gente improvisa.

Segue abaixo algumas funções que auxiliam no trabalho com o Excel como banco de dados. E certamente para outras versões do Excel devemos alterar a string de conexão.

Excel para Consulta

Function ConectaXL() As Boolean

'*****************************************

'Nome: ConectaXL

'Autor: Rafael Gomes dos Santos

'Data: 04/05/2010

'Descrição: Conexão ADO com planilha Excel (só consulta)

'Revisão: 04/05/2010

'*****************************************

Let ConectaXL = True

On Error GoTo erro1:

With cn

    .ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & xlDB & ";Extended Properties=""Excel 12.0 Xml;HDR=YES;IMEX=1"";"

    .Open

End With

erro1:

If Err.Number <> 0 Then



    Let ConectaXL = False



End If

End Function

Desconecta Excel

Function DesconectaXL() As Boolean

'*****************************************

'Nome: DesconectaXL

'Autor: Rafael Gomes dos Santos

'Data: 04/05/2010

'Descrição: Desconecta ADO com planilha Excel

'Revisão: 04/05/2010

'*****************************************

On Error GoTo erro1:

    Let DesconectaXL = True

    cn.Close



    Set cn = Nothing



erro1:

If Err.Number <> 0 Then

  Let DesconectaXL = False

End If



End Function

Conecta com Excel (permitindo INSERT)

Function ConectaXLAtualizavel() As Boolean

'*****************************************

'Nome: ConectaXLAtualizavel

'Autor: Rafael Gomes dos Santos

'Data: 04/05/2010

'Descrição: Conexão ADO com planilha Excel (Permite INSERT)

'Revisão: 04/05/2010

'*****************************************

Let ConectaXLAtualizavel = True

On Error GoTo erro1:

With cn

    .ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & xlDB & ";Extended Properties=""Excel 12.0 Xml;HDR=Yes"";"

    .Open

End With

erro1:

If Err.Number <> 0 Then



    ConectaXLAtualizavel = False



End If

End Function

Exclui Registro da Planilha Banco de Dados

Function ExcluiRegistro( _

Tabela As String, _

Campo As String, _

Valor As String _

) As Boolean

  '*****************************************
  'Nome: ExcluiRegistro
    'Autor: Rafael Gomes dos Santos
  'Data: 04/05/2010
  'Descrição: Exclui registro de tabela na planilha banco de dados
  'Revisão: 04/05/2010
  '*****************************************

  Dim xl As New Excel.Application
  Dim wkb As Workbook
  Dim wsh As Worksheet

  Dim c As Integer
  Dim l As Integer

  Let ExcluiRegistro = False

  Set wkb = xl.Workbooks.Open(xlDB)

  Set wsh = wkb.Worksheets(Tabela)

  Let c = 1

  Do While wsh.Cells(1, c) <> ""

  If wsh.Cells(1, c) = Campo Then

  Exit Do

  End If

  Let c = c + 1

  Loop

  If wsh.Cells(1, c) <> "" Then

  Let l = 2

  Do Until wsh.Cells(l, c) = ""

  If wsh.Cells(l, c) = Valor Then

  wsh.Cells(l, c).EntireRow.Delete
  Let ExcluiRegistro = True
  Exit Do

  End If

  Let l = l + 1

  Loop

  End If

  Set wsh = Nothing
  wkb.Close True
  Set wkb = Nothing
  xl.Quit
  Set xl = Nothing

End Function

Checa se o registro existe na planilha

Function RegistroExiste( _

Tabela As String, _

Campo As String, _

Valor As String, _

Optional Tipo As String, _

Optional Campo2 As String, _

Optional Valor2 As String, _

Optional Tipo2 As String, _

Optional Campo3 As String, _

Optional Valor3 As String, _

Optional Tipo3 As String _

) As Boolean

    '*****************************************

    'Nome: RegistroExiste

    'Autor: Rafael Gomes dos Santos

    'Data: 04/05/2010

    'Descrição: Retorna TRUE se o registro existir na planilha banco de dados. Limitado a 3 parâmetros.

    'Revisão: 04/05/2010

    '*****************************************

    Dim rs As New ADODB.Recordset

    Dim strSQL As String

    RegistroExiste = False

    If ConectaXLAtualizavel = False Then



        MsgBox "Impossível conectar"

        Exit Function



    End If



    rs.ActiveConnection = cn



  Let strSQL = "SELECT * FROM [" & Tabela & "$] WHERE "



    If Tipo = "Number" Then

        strSQL = strSQL & Campo & " = " & Valor

    Else

        strSQL = strSQL & Campo & " = '" & Valor & "'"

    End If



    If Campo2 <> "" Then

        If Tipo2 = "Number" Then

            strSQL = strSQL & " " & Campo2 & " = " & Valor2

        Else

            strSQL = strSQL & " " & Campo2 & " = '" & Valor2 & "'"

        End If

    End If



    If Campo3 <> "" Then

        If Tipo3 = "Number" Then

            strSQL = strSQL & " " & Campo3 & " = " & Valor3

        Else

            strSQL = strSQL & " " & Campo3 & " = '" & Valor3 & "'"

        End If

    End If

    rs.Source = strSQL

    rs.LockType = adLockPessimistic

    rs.Open

    If Not rs.EOF Then



        RegistroExiste = True



    End If

    If DesconectaXL = False Then



        MsgBox "Impossível desconectar"

        Exit Function



    End If

End Function

SELECT com JOIN

Fazendo um SELECT com JOIN na planilha Excel.

    If ConectaXL = False Then



        MsgBox "Impossível conectar"

        Exit Sub



    End If



  Let rs.ActiveConnection = cn



  Let strsql = "SELECT [Jurado$].Nome,"

Let strsql = strsql & " [Jurado$].Cargo,"

Let strsql = strsql & " [Jurado$].Empresa,

Let strsql = strsql & " [Jurado$].CargoJuri"

Let strsql = strsql & " FROM [Jurado$]"

Let strsql = strsql & " INNER JOIN [CargoJuri$]"

Let strsql = strsql & " ON [Jurado$].CargoJuri = [CargoJuri$].Cargo"

Let strsql = strsql & " WHERE [Jurado$].RegiaoJuri = 'LESTE/OESTE'"

Let strsql = strsql & " ORDER BY [CargoJuri$].Ordem"

Let rs.Source = strsql

Let rs.LockType = adLockPessimistic



      rs.Open

Atualizar dados

    If ConectaXLAtualizavel = False Then

        MsgBox "Impossível conectar"

        Exit Sub

    End If



  Let rs.ActiveConnection = cn



  Let rs.Source = "SELECT * FROM [Inscritos$] WHERE" _

    & " Categoria = '" & Me.cmbCategoria & "'" _

    & " AND Regiao = '" & Me.cmdRegiao & "'" _

    & " AND Posicao = " & Me.txtPosicao



  Let rs.LockType = adLockPessimistic

    rs.Open



    If Not rs.EOF Then



        rs.MoveFirst



  Let rs("Categoria") = Me.cmbCategoria

  Let rs("Regiao") = Me.cmdRegiao

  Let rs("Duracao") = Me.txtDuracao

  Let rs("Posicao") = Me.txtPosicao

  Let rs("Titulo") = Me.txtTitulo



        rs.Update

        rs.Close

        Set rs = Nothing



    End If

    If DesconectaXL = False Then

        MsgBox "Não foi possível se desconectar do Banco de Dados. por favor reinicie o sistema."

        Exit Sub

    End If