Este fórum está sendo desativado

[lucianol]

Caros,
tenho uma planilha onde gostaria que, ao clicar sobre uma determinada célula (Data) abrisse um calendário para escolha do dia, mês, ano.
Isso sem ter que dar duplo clique ou botão para ativar o calendário.
Outra questão é que ao importar fotos para esse relatório elas já viessem em tamanho e posição já pré-definidos para a planilha.
Existe como inserir uma função para assinatura digital, no excel?

Segue anexo modelo da planilha

Alguém teria como auxiliar nesse tópico?

Grato a todos que puderem auxiliar.

[babdallas]

Veja se ajuda.

Código: Selecionar todos

'Código do módulo
Public lArquivo As String
Public lngWidth As Long
Public lngHeight As Long

Public Sub OpenCalendar()
    frmCalendario.Show
End Sub

'Procedimento para selecionar arquivos
'Fonte: Código original de Guia do Excel, adaptado por Bruno Abdalla de Souza
Public Sub lsSelecionarArquivo()
    Dim fDlg As FileDialog

    'Chama o objeto passando os parâmetros
    Set fDlg = Application.FileDialog(FileDialogType:=msoFileDialogOpen)
    With fDlg
        'Alterar esta propriedade para True permitirá a seleção de vários arquivos
        .AllowMultiSelect = False

        'Determina a forma de visualização dos aruqivos
        .InitialView = msoFileDialogViewDetails

        'Filtro de arquivos, pode ser colocado mais do que um filtro separando com ; por exemplo: "*.xls;*.xlsm"
        .Filters.Add "Imagem", "*.emf;*.wmf;*.jpg;*.jpeg;*.jfif;*.jpe;*.png;*.bmp;*.dib;*.rle;*.gif;*.emz;*.wmz;*.pcz;*.tif;*.tiff;*.eps;*.pct;*.pict;*.wpg", 1

        'Determina qual o drive inicial
        .InitialFileName = "C:\"
    End With

    'Retorna o arquivo selecionado
    If fDlg.Show = -1 Then
        lArquivo = fDlg.SelectedItems(1)
    Else
        MsgBox "Não foi selecionado nenhum arquivo"
    End If
End Sub

Public Sub Tamanho_Pixels(rngIntervalo As Range)
    Dim rngCell As Range
    
    lngHeight = 0
    lngWidth = 0
    
    For Each rngCell In rngIntervalo.Cells.Columns(1)
        lngHeight = lngHeight + rngCell.Height
    Next rngCell

    For Each rngCell In rngIntervalo.Cells.Rows(1)
        lngWidth = lngWidth + rngCell.Width
    Next rngCell
End Sub


'Código dentro da worksheet
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim rngFoto         As Range
    Dim fldFoto         As FileDialog
    Dim vrtFotos        As Variant
    Dim shpFoto         As Shape
    Dim rngIntervalo    As Range
    
    With wshDados
        'Abre o calendário caso o usuário clique na célula Data
        If Target.Address = .Range("pData").Address Then OpenCalendar
        
        
        'Verifica se o usuário clicou sobre a região onde quer incluir a foto.
        'Se sim, abre uma janela para escolher o arquivo. Depois de escolhido,
        'adiciona na região escolhida
        Set rngFoto = Application.Union(.Range("Foto01"), _
                                        .Range("Foto02"), _
                                        .Range("Foto03"), _
                                        .Range("Foto04"), _
                                        .Range("Foto05"), _
                                        .Range("Foto06"))
        
        Set fldFoto = Application.FileDialog(FileDialogType:=msoFileDialogFilePicker)
        
        If Not Application.Intersect(Target, rngFoto) Is Nothing Then
            lsSelecionarArquivo
            If lArquivo = vbNullString Then Exit Sub
            
            If Not Application.Intersect(Target, .Range("Foto01")) Is Nothing Then
                Set rngIntervalo = .Range("Foto01")
                GoTo AdicionaImagem
                Exit Sub
            ElseIf Not Application.Intersect(Target, .Range("Foto02")) Is Nothing Then
                Set rngIntervalo = .Range("Foto02")
                GoTo AdicionaImagem
                Exit Sub
            ElseIf Not Application.Intersect(Target, .Range("Foto03")) Is Nothing Then
                Set rngIntervalo = .Range("Foto03")
                GoTo AdicionaImagem
                Exit Sub
            ElseIf Not Application.Intersect(Target, .Range("Foto04")) Is Nothing Then
                Set rngIntervalo = .Range("Foto04")
                GoTo AdicionaImagem
                Exit Sub
            ElseIf Not Application.Intersect(Target, .Range("Foto05")) Is Nothing Then
                Set rngIntervalo = .Range("Foto05")
                GoTo AdicionaImagem
                Exit Sub
            ElseIf Not Application.Intersect(Target, .Range("Foto06")) Is Nothing Then
                Set rngIntervalo = .Range("Foto06")
                GoTo AdicionaImagem
            End If
        End If
        
        Exit Sub
AdicionaImagem:
        Tamanho_Pixels rngIntervalo
        Set shpFoto = .Shapes.AddPicture(lArquivo, msoFalse, msoCTrue, _
                        rngIntervalo.Left, rngIntervalo.Top, lngWidth, lngHeight)
    End With
    lArquivo = vbNullString
End Sub