[Resolvido]Copiar objeto para área de transferência

Bom dia pessoal! Estou precisando criar uma função vba para copiar um objeto de uma pasta para área de transferência e depois o usuário possa dar botão direito colar ou usar o Control V para onde quiser. Importante já tenho a função copiar e colar com destino já pré-determinado e não estou conseguindo adaptar para somente copiar. Preciso somente copiar para área de transferência. Alguém me ajuda.

Grato,

Marcelo

Bom dia MMS,

Faça o seguinte:

Coloque num Módulo:

Código:

Option Compare Database

Option Explicit
Private Declare Function OpenClipboard Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare Function EmptyClipboard Lib "user32.dll" () As Long
Private Declare Function CloseClipboard Lib "user32.dll" () As Long
Private Declare Function IsClipboardFormatAvailable Lib "user32.dll" (ByVal wFormat As Long) As Long
Private Declare Function GetClipboardData Lib "user32.dll" (ByVal wFormat As Long) As Long
Private Declare Function SetClipboardData Lib "user32.dll" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Declare Function GlobalAlloc Lib "kernel32.dll" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalLock Lib "kernel32.dll" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32.dll" (ByVal hMem As Long) As Long
Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function lstrcpy Lib "kernel32.dll" Alias "lstrcpyW" (ByVal lpString1 As Long, ByVal lpString2 As Long) As Long

Public Sub SetClipboard(sUniText As String)
    Dim iStrPtr As Long
    Dim iLen As Long
    Dim iLock As Long
    Const GMEM_MOVEABLE As Long = &H2
    Const GMEM_ZEROINIT As Long = &H40
    Const CF_UNICODETEXT As Long = &HD
    OpenClipboard 0&
    EmptyClipboard
    iLen = LenB(sUniText) + 2&
    iStrPtr = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, iLen)
    iLock = GlobalLock(iStrPtr)
    lstrcpy iLock, StrPtr(sUniText)
    GlobalUnlock iStrPtr
    SetClipboardData CF_UNICODETEXT, iStrPtr
    CloseClipboard
End Sub

Public Function GetClipboard() As String
    Dim iStrPtr As Long
    Dim iLen As Long
    Dim iLock As Long
    Dim sUniText As String
    Const CF_UNICODETEXT As Long = 13&
    OpenClipboard 0&
    If IsClipboardFormatAvailable(CF_UNICODETEXT) Then
        iStrPtr = GetClipboardData(CF_UNICODETEXT)
        If iStrPtr Then
            iLock = GlobalLock(iStrPtr)
            iLen = GlobalSize(iStrPtr)
            sUniText = String$(iLen \ 2& - 1&, vbNullChar)
            lstrcpy StrPtr(sUniText), iLock
            GlobalUnlock iStrPtr
        End If
        GetClipboard = sUniText
    End If
    CloseClipboard
End Function

Para copiar uma String para a área de transferência:

Código:

Dim CopiaString as String
CopiaString = "bla bla bla"
SetClipboard (CopiaString)

Adapte para o seu propósito

Boa tarde! Obrigado pela dica, porém fiz exatamente como me passou , mas não está funcionando. Copiei o módulo e fiz a chamada num botão , mas não vai para área de trabalho. Copilei direitinho e não dá erro, porém não copia. Alguma dica?

Tópico movido por não relacionar-se com formulário.

não entendi o motivo da mudança uma vez que minha necessidade será aplicada num formulário, mas ok se for para melhor, obrigado!

Bom dia MMS,

Veja o exemplo anexo.

Abraço

Bom dia! Agora com seu exemplo descobri o meu erro, nesse caso está copiando a string "texto", porém eu preciso copiar um objeto, exemplo: de uma pasta c:\Fotos\imagem1.jpg para o destino (área de transferência), pois ficará em aberto para o usuário colar onde quiser, por exemplo na área de trabalho.

Tem ótimos exemplos aqui (inclusive tenho um desses funcionando), porém que copia e cola já com destino pré determinado. Não consegui adaptar apenas para copiar que é o que preciso.

O correto é montar o caminho através de uma janela. Tal qual fazem os aplicativos quando clicamos em salvar algo, quando daí abrem uma janela para selecionarmos o caminho de destino.

Eis o código para abrir a janela pedindo pra localizar a pasta de destino.

Código:

Private Function fncLocalizarPasta()
On Error GoTo trataerro

    Dim fd As Office.FileDialog
    
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)
    
    With fd
        .AllowMultiSelect = False
        .ButtonName = "Selecionar"
        .InitialFileName = "c:\"
        .InitialView = msoFileDialogViewList
        .Title = "Selecione a pasta"
    End With
    
    If fd.Show Then fncLocalizarPasta = fd.SelectedItems(1)
    
Sair:
    Exit Function
    
trataerro:
    fncLocalizarPasta = ""
    Resume Sair:
End Function

Daí bastaria usar

Código:

Dim strOrigem as string
dim strDestino as string

strOrigem = "SeuCaminhoOrigemPreDefinido"
strDestino = fncLocalizarPasta
if strDestino = "" then exit sub 'parando o código pois foi clicado em cancelar na janela de localizar pasta
strDestino = strDestino & "\SeuArquivo.Formato"
CreateObject("Scripting.FileSystemObject").CopyFile strOrigem, strDestino

Boa tarde! Essa solução eu tenho aqui, mas precisa ser algo que se mantenha na area de transferência para o usuário dar um Control V ou botão direito colar.

Vou explicar o problema:

Tenho uma aplicação que está num servidor remoto na Nuvem, dentro do sistema há um cadastro de produtos, onde dentro tem o link com várias imagens salvas em pastas (ex. medicamento XX - K:\produtos\imagem1.jpg). O usuário na maioria das vezes está com documentos no word aberto precisando colar imagens que estão nesse servidor. Se eu manualmente abrir a imagem no servidor, copiar e depois colar na máquina local, funciona perfeitamente, tanto na área de trabalho, quanto no próprio Word. Se der a opção do usuário buscar uma pasta para salvar ele irá se perder, pois na nuvem terá que busca uma pasta tsclient, ir navegando até chegar no c: local dele, será muito lento e arriscado e essa necessidade é muito dinâmica. A opção de um botão para copiar e depois ele somente dar um control v (ou botão direito colar) é sensacional.
Bom é por essa razão a busca dessa solução. Obrigado por enquanto.

Bom dia,

Veja se é isto que pretende.

Meu Deus!!!!! Com uma linha de código??? Resolvido, cara você é demais! Obrigado!

Não esqueça o novo Módulo que coloquei no exemplo!

Certo, perfeito!! Muito agradecido.

Quando poder dê o tópico como resolvido!

Achei q já tivesse feito. Valeu!