VB6 COM EXCEL

KELVINCD 24/02/2017 08:51:52
#471920
E ai Galera tudo tranquilo?

Seguinte, tenho varias planilhas com imagens, e preciso salvar elas, se eu utilizar este código no vba consigo salvar elas sem problemas, porem vo precisar fazer em cada planilha uma aplicação para salvar as imagens.

For Each oShape In ActiveSheet.Shapes
[ô][ô]strImageName = ActiveSheet.Cells(oShape.TopLeftCell.Row, 1).Value

If strImageName = [Ô][Ô] Then
strImageName = 1
Else
strImageName = strImageName
End If
oShape.Select
[ô]Picture format initialization
Selection.ShapeRange.PictureFormat.Contrast = 0.5: Selection.ShapeRange.PictureFormat.Brightness = 0.5: Selection.ShapeRange.PictureFormat.ColorType = msoPictureAutomatic: Selection.ShapeRange.PictureFormat.TransparentBackground = msoFalse: Selection.ShapeRange.Fill.Visible = msoFalse: Selection.ShapeRange.Line.Visible = msoFalse: Selection.ShapeRange.Rotation = 0#: Selection.ShapeRange.PictureFormat.CropLeft = 0#: Selection.ShapeRange.PictureFormat.CropRight = 0#: Selection.ShapeRange.PictureFormat.CropTop = 0#: Selection.ShapeRange.PictureFormat.CropBottom = 0#: Selection.ShapeRange.ScaleHeight 1#, msoTrue, msoScaleFromTopLeft: Selection.ShapeRange.ScaleWidth 1#, msoTrue, msoScaleFromTopLeft
[ô]/Picture format initialization
Application.Selection.CopyPicture
Set oDia = ActiveSheet.ChartObjects.Add(0, 0, oShape.Width, oShape.Height)
Set oChartArea = oDia.Chart
oDia.Activate
With oChartArea
.ChartArea.Select
.Paste
.Export ([Ô]C:\Users\kelvin.dornelles\Desktop\Teste\[Ô] & strImageName & [Ô].jpg[Ô])
End With
oDia.Delete [ô]oChartArea.Delete
strImageName = strImageName + 1
Next

o que quero fazer seria, gerar uma aplicação onde carrego a planilha ou o caminho dela e consiga salvar as imagens sem ter que usar o VBA e as macros.
KELVINCD 24/02/2017 14:50:22
#471927
Pra quem se interessar.

vou usar o VBA mesmo

com este código

Private Sub CommandButton1_Click()
Call Salvar
End Sub

Private Sub Salvar()
Dim Num As String
Dim ws As Worksheet
Num = 1


For Each ws In Worksheets

strProjetoName = ActiveWorkbook.Name
If Dir([Ô]E:\img_cartao\[Ô] & strProjetoName, vbDirectory) = [Ô][Ô] Then
MkDir ([Ô]E:\img_cartao\[Ô] & strProjetoName)
End If

Sheets(ws.Name).Select

strPasteName = ActiveSheet.Name
If Dir([Ô]E:\img_cartao\[Ô] & strProjetoName & [Ô]\[Ô] & strPasteName, vbDirectory) = [Ô][Ô] Then
MkDir ([Ô]E:\img_cartao\[Ô] & strProjetoName & [Ô]\[Ô] & strPasteName)
DirPasta = [Ô]E:\img_cartao\[Ô] & strProjetoName & [Ô]\[Ô] & strPasteName
End If

For Each oShape In ActiveSheet.Shapes
oShape.Select
strImageName = oShape.Name
If Left$(oShape.Name, 7) = [Ô]Picture[Ô] Then
[ô]Picture format initialization
Selection.ShapeRange.PictureFormat.Contrast = 0.5
Selection.ShapeRange.PictureFormat.Brightness = 0.5
Selection.ShapeRange.PictureFormat.ColorType = msoPictureAutomatic
Selection.ShapeRange.PictureFormat.TransparentBackground = msoFalse
Selection.ShapeRange.Fill.Visible = msoFalse
Selection.ShapeRange.Line.Visible = msoFalse
Selection.ShapeRange.Rotation = 0#
Selection.ShapeRange.PictureFormat.CropLeft = 0#
Selection.ShapeRange.PictureFormat.CropRight = 0#
Selection.ShapeRange.PictureFormat.CropTop = 0#
Selection.ShapeRange.PictureFormat.CropBottom = 0#
Selection.ShapeRange.ScaleHeight 1#, msoTrue, msoScaleFromTopLeft
Selection.ShapeRange.ScaleWidth 1#, msoTrue, msoScaleFromTopLeft
[ô]/Picture format initialization
Application.Selection.CopyPicture
Set oDia = ActiveSheet.ChartObjects.Add(0, 0, oShape.Width, oShape.Height)
Set oChartArea = oDia.Chart
oDia.Activate
With oChartArea
.ChartArea.Select
.Paste
If Dir([Ô]E:\img_cartao\[Ô] & strProjetoName & [Ô]\[Ô] & strPasteName & [Ô]\[Ô] & strImageName & [Ô].jpg[Ô], vbDirectory) = [Ô][Ô] Then
.Export [Ô]E:\img_cartao\[Ô] & strProjetoName & [Ô]\[Ô] & strPasteName & [Ô]\[Ô] & strImageName & [Ô].jpg[Ô]
Else
.Export [Ô]E:\img_cartao\[Ô] & strProjetoName & [Ô]\[Ô] & strPasteName & [Ô]\[Ô] & strImageName & [Ô]_[Ô] & Num & [Ô].jpg[Ô]
Num = Num + 1
End If
End With
oDia.Delete [ô]oChartArea.Delete
End If
Next oShape
Next ws
End Sub
Faça seu login para responder
Voltar