salvar imagem automatico com qualquer usuario

ad48 · 7 de março de 2017

pode me ajudar?
tenho este código abaixo funciona beleza no meu pc com meu usuário
quando outro usuário vai usar não roda em outro pc

ob: já tentei
ConferePasta = "C:\Users\Public\Desktop\ENVIO WHATSAPP"
no meu pc funciona, meu colega a pasta fica marcada somente leitura não consigo alterar.

Sub CRIAR_PASTA_DESKTOP()
Dim ConferePasta As String
'ConferePasta = "C:\NOVO1"
ConferePasta = "C:\Users\armando\Desktop\ENVIO WHATSAPP"
If Dir(ConferePasta, vbDirectory) = “” Then
MkDir ConferePasta
MsgBox "O diretório: " & ConferePasta & " FOI CRIADO! ARQUIVO SALVO SÓ FAZER O ENVIO", vbInformation, "AVISO"
End If
End Sub

Sub SALVAR_IMAGEM()
call CRIAR_PASTA_DESKTOP
Sheets("IMPRIMIR").Select
Dim rVis As Range, k As Long
For Each rVis In Range("A:A").SpecialCells(xlCellTypeVisible) '(PRIMEIRA COLUNA)
k = k + 1: If k = [A1] + 16 Then Exit For '[SOMA DE LIMHAS]+ TOTAL CABECALHO
Next rVis
Dim rgExp As Range: Set rgExp = Sheets("IMPRIMIR").Range("D4:U" & rVis.Row) '("SELEÇÃO DA AREA
rgExp.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
With ActiveSheet.ChartObjects.Add(Left:=rgExp.Left, TOP:=rgExp.TOP, _
Width:=rgExp.Width, Height:=rgExp.Height)
.Name = "ChartVolumeMetricsDevEXPORT"
.Activate
End With
ActiveChart.Paste
ActiveSheet.ChartObjects("ChartVolumeMetricsDevEXPORT").Chart.Export "C:\Users\armando\Desktop\Envio Whatsapp\" & [G12].Value & " " & [G1].Value & " Marcas ate dia " & [B1].Value & ".jpg"
ActiveSheet.ChartObjects("ChartVolumeMetricsDevEXPORT").Delete
Sheets("MENU").Select
Range("N6").Select
End Sub

ad48 · 16 de março de 2017

Pasta e local quero salvar é "C:\Users\Public\Desktop\ENVIO WHATSAPP"
ex : "C:\Users\armando\Desktop\ENVIO WHATSAPP"" eu consigo rodar.
se enviar por e-mail para meus colegas
outros pc não tem meu usuario armando não funciona.

TESTE.rar