Fóruns
Microsoft Excel - 2...
2024 - VBA & Macros
[VBA] Dúvida sobre ...
 
Notifications
Clear all

[VBA] Dúvida sobre Salvar Como

 
2024 - VBA & Macros
Post Recente por eduardo.spaiva 4 anos atrás
6 Posts
4 Usuários
0 Reactions
1,523 Visualizações
RSS
 eduardo.spaiva
(@eduardo-spaiva)
Posts: 4
New Member
Topic starter
 

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.

 
Postado : 12/08/2020 2:13 pm
Tags do Tópico
pasta selecionar arquivo GetOpenFilename
 Televisaos
(@televisaos)
Posts: 49
Eminent Member
 

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

 
Postado : 13/08/2020 4:34 am
 MPrudencio
(@mprudencio)
Posts: 2749
Famed Member
 

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.

 
Postado : 15/08/2020 9:50 pm
 srobles
(@srobles)
Posts: 231
Estimable Member
 

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

 
Postado : 17/08/2020 12:32 am
 eduardo.spaiva
(@eduardo-spaiva)
Posts: 4
New Member
Topic starter
 

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

 
Postado : 17/08/2020 9:33 am
 eduardo.spaiva
(@eduardo-spaiva)
Posts: 4
New Member
Topic starter
 

@srobles porem na parte

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

Muito obrigado.

 
Postado : 17/08/2020 9:35 am
Forum Jump:
  Tópico Anterior
Próximo Tópico  
Tags do Tópico:  pasta , selecionar arquivo , GetOpenFilename ,