[VBA] Dúvida sobre ...
 
Notifications
Clear all

[VBA] Dúvida sobre Salvar Como  

  RSS

eduardo.spaiva
(@eduardo-spaiva)
New Member
Entrou: 1 mês atrás
Posts: 4
12/08/2020 2:13 pm  

Olá, boa tarde. 

Meus amigos, tenho o código abaixo e preciso que ao invés de salvar direto na pasta da pasta de trabalho, eu consiga selecionar a pasta.

Alguém poderia me ajudar? Meu conhecimento é muito básico de VBA.

Muito obrigado!

___________

Sub ExportarAreaParaJPG()

Dim tmpSheet As Worksheet
Dim tmpChart As Chart
Dim tmpImg As Object
Dim img As String
Dim var1 As String

Range("U14:BO83").Select
Range("U83").Activate

On Error GoTo erro

Selection.CopyPicture Appearance:=xlPrinter, Format:=xlPicture

Application.ScreenUpdating = False
Set tmpSheet = Worksheets.Add
Charts.Add
ActiveChart.Location Where:=xlLocationAsObject, Name:=tmpSheet.Name
Set tmpChart = ActiveChart
With tmpChart
.Paste
Set tmpImg = Selection
With .Parent
.Height = 800
.Width = 800
End With
End With

var1 = Range("a5").Text

img = ThisWorkbook.Path & "\" & var1 & ".jpg"

tmpChart.Export Filename:=img, FilterName:="jpg"

Application.DisplayAlerts = False
tmpSheet.Delete
Application.DisplayAlerts = True

Application.ScreenUpdating = True
MsgBox "Imagem exportada para o ficheiro:" & img, _
vbInformation, _
"Exportar para JPG"
GoTo fim

erro:
MsgBox "Erro: " & Err.Description, _
vbCritical, _
"Erro: " & Err.Number

fim:
Set tmpSheet = Nothing
Set tmpChart = Nothing
Set tmpImg = Nothing

End Sub

Sub CroquiBT1_Click()
Dim myPicture As String
Dim pic As Picture
Dim Imagem As Object

confirma = MsgBox("Deseja Adicionar um Croqui?", vbQuestion + vbYesNo, "Croqui")
If confirma = vbNo Then Exit Sub

myPicture = Application.GetOpenFilename _
("Pictures (*.gif; *.jpg; *.bmp; *.tif),*.gif;*.png; *.jpg; *.bmp; *.tif", , "Select Picture to Import")


If myPicture <> "" Then
'Set r = Range("AJ17") 'Vai da coluna A até J'
Set pic = ActiveSheet.Pictures.Insert(myPicture)
Range("Aj15").Select

With pic
.Top = ActiveCell.Top + 3
.Left = ActiveCell.Left + 3
.ShapeRange.LockAspectRatio = msoFalse
.Height = 410 ' Vertical (r.Height)
.Width = 400 'Horizontal (r.Width - para ir até a determinada coluna acima)
.Placement = xlMoveAndSize
End With
End If
ActiveSheet.Shapes.Range(Array("Retângulo 12")).Select
Selection.ShapeRange.ZOrder msoBringToFront

End Sub

 Lista-de-Imóveis.xlsm


Editado pela Moderação. Motivo: Favor utilizar o botão Código (< >) para inserir código VBA ou Fórmulas.


ResponderCitar (Quote)
Televisaos
(@televisaos)
Eminent Member
Entrou: 3 meses atrás
Posts: 28
13/08/2020 4:34 am  

Boa noite @eduardo-spaiva,

Não analisei o seu código com muitos detalhes mas pelo que pude perceber vc poderia tentar inserir acima da linha

 

img = ThisWorkbook.Path & "\" & var1 & ".jpg"

O código:

endereço = InputBox("Digite o caminho da pasta que vc deseja salvar o arquivo: ", "Seleciona pasta")

Altere a linha:

img = ThisWorkbook.Path & "\" & var1 & ".jpg"

Para:

img = endereço & "\" & var1 & ".jpg"

E nas declarações insira:

Dim endereço As String

Att, Televisaos


ResponderCitar (Quote)
MPrudencio
(@mprudencio)
Famed Member
Entrou: 5 anos atrás
Posts: 2731
15/08/2020 9:50 pm  

Troque

 

img = ThisWorkbook.Path & "\" & var1 & ".jpg"

por

Application.Dialogs(xlDialogSaveAs).Show

Marcelo Prudencio
Microsoft Excel Brasil no Facebook

"Começar já é a metade do caminho."
Autor Desconhecido

Simplifica que simples fica.
Nicole Tomazella.

"O Simples é Sempre Melhor Que o Complicado"
Jorge Paulo Lemann.


ResponderCitar (Quote)
srobles
(@srobles)
Estimable Member
Entrou: 5 anos atrás
Posts: 226
17/08/2020 12:32 am  

Eduardo,

 

Experimente sua macro, porém adaptada como segue:

Sub ExportarAreaParaJPG()

Dim tmpSheet As Worksheet
Dim tmpChart As Chart
Dim tmpImg As Object
Dim img As String
Dim var1 As String
Dim caminhoDestino As Office.FileDialog

Range("U14:BO83").Select
Range("U83").Activate

On Error GoTo erro

Selection.CopyPicture Appearance:=xlPrinter, Format:=xlPicture

Application.ScreenUpdating = False
Set tmpSheet = Worksheets.Add
Charts.Add
ActiveChart.Location Where:=xlLocationAsObject, Name:=tmpSheet.Name
Set tmpChart = ActiveChart
With tmpChart
.Paste
Set tmpImg = Selection
With .Parent
.Height = 800
.Width = 800
End With
End With

Set caminhoDestino = Application.FileDialog(msoFileDialogFolderPicker)

With caminhoDestino
.AllowMultiSelect = False
.InitialFileName = ThisWorkbook.Path
.Title = "Selecione o local de destino"
.Show
End With

If caminhoDestino.SelectedItems.Count >= 1 Then
var1 = Range("a5").Text
img = caminhoDestino.SelectedItems(1) & "" & var1 & ".jpg"

tmpChart.Export Filename:=img, FilterName:="jpg"

Application.DisplayAlerts = False
tmpSheet.Delete
Application.DisplayAlerts = True

Application.ScreenUpdating = True
MsgBox "Imagem exportada para o ficheiro:" & img, _
vbInformation, _
"Exportar para JPG"
GoTo fim

erro:
MsgBox "Erro: " & Err.Description, _
vbCritical, _
"Erro: " & Err.Number
GoTo fim
End If

fim:
Set tmpSheet = Nothing
Set tmpChart = Nothing
Set tmpImg = Nothing

End Sub


Espero ter ajudado.

Abs.

Saulo Robles


ResponderCitar (Quote)
eduardo.spaiva
(@eduardo-spaiva)
New Member
Entrou: 1 mês atrás
Posts: 4
17/08/2020 9:33 am  

@televisaos Infelizmente não deu certo. Mesmo colocando alterando o código com o @MPrudencio falou.


ResponderCitar (Quote)
eduardo.spaiva
(@eduardo-spaiva)
New Member
Entrou: 1 mês atrás
Posts: 4
17/08/2020 9:35 am  

@srobles porem na parte

img = caminhoDestino.SelectedItems(1) & "" & var1 & ".jpg" precisei incluir
img = caminhoDestino.SelectedItems(1) & "\" & var1 & ".jpg"

Muito obrigado.


ResponderCitar (Quote)
Compartilhar: