Copiare range di celle e salvarlo in formato PNG

[SemiuccioPartecipante Semiuccio Karma: 1 pt]

Buongiorno a tutti. Pensavo fosse semplice creare un codice VBA per copiare un range di cella da un foglio excel e salvarlo in formato PNG in una cartella a scelta, per poi aprirlo con PAINT, ad esempio. Ma mi sono perso. Ho chiesto aiuto all’AI, ma non ne vengo a capo. Mi esporta l’immagine, ma quando la apro con Paint, ad esempio, è illeggibile.

Qualcuno può aiutarmi?

Allego uno stralcio del file excel da cui vorrei copiare il range di celle e salvarlo in formato PNG leggibile.

P.S. uso windows 10 con excel 2019

Allegati:

You must be logged in to view attached files.

[alfrimpaPartecipante alfrimpa Karma: 33 pts]

Prova con questa

Sub SalvaImmaginePNG()
    Dim rng As Range
    Dim chartObj As ChartObject
    Dim imgPath As Variant
    If TypeName(Selection) <> "Range" Then
        MsgBox "Seleziona un intervallo di celle prima di eseguire la macro.", vbExclamation
        Exit Sub
    End If
    Set rng = Selection
    imgPath = Application.GetSaveAsFilename(InitialFileName:="ImmagineIntervallo.png", FileFilter:="PNG Files (*.png), *.png", Title:="Salva immagine come")
    If imgPath = False Then Exit Sub
    rng.CopyPicture Appearance:=xlScreen, Format:=xlPicture
    Set chartObj = ActiveSheet.ChartObjects.Add(Left:=100, Top:=100, Width:=rng.Width, Height:=rng.Height)
    chartObj.Activate
    chartObj.Chart.Paste
    chartObj.Chart.Export Filename:=imgPath, FilterName:="PNG"
    chartObj.Delete
    MsgBox "Immagine salvata in: " & imgPath, vbInformation
End Sub

[LukeRedsPartecipante LukeReds Karma: 19 pts]

perchè non riesco ad iserire una risposta? quando clicco invia viene cancellata

Allego il codice, l'immagine deve essere già presente e nominata "Immasgine1"

Allegati:

You must be logged in to view attached files.

[SemiuccioPartecipante Semiuccio Karma: 1 pt]

alfrimpa ha scritto:

Prova con questa

OK. funziona. ora provo a portare qualche modifica e ti faccio sapere. Grazie

[SemiuccioPartecipante Semiuccio Karma: 1 pt]

OK Alfrimpa. Ho apportato alcune modifiche che mi servivano, tipo scegliere il file da aprire, scegliere il percorso di salvataggio e tutto funziona bene. Non capisco dove mi portava l'AI!!   

[SemiuccioPartecipante Semiuccio Karma: 1 pt]

LukeReds ha scritto:

perchè non riesco ad iserire una risposta? quando clicco invia viene cancellata

Grazie anche a te LukeReds   

[sgmmarBloccato sgmmar Karma: 5 pts]

Semiuccio ha scritto:

Non capisco dove mi portava l'AI!!

ciao,

io penso che l'AI sia come un qualsiasi professionista in qualsiasi materia:

affidabile se risolve il problema.

La differenza è che il professionista "umano" è valutabile sotto vari aspetti, 

l'AI solo su quello del risultato cercato....

Tra un professionista umano "onesto" ed uno che "non esiste" tu quale sceglieresti?

 

[alfrimpaPartecipante alfrimpa Karma: 33 pts]

@sgmmar 

Se su questo forum ci fossero stati i like te ne saresti meritato uno grande quanto una casa.

[SemiuccioPartecipante Semiuccio Karma: 1 pt]

sgmmar ha scritto:

Semiuccio ha scritto:

Non capisco dove mi portava l'AI!!

Mi trovi pienamente d'accordo con quello che dici.

[SemiuccioPartecipante Semiuccio Karma: 1 pt]

Vi chiedo scusa ma, come di solito accade, l'appetito viene mangiando! Come si può fare in modo che se io scelgo una cartella, il codice esamini tutti i files presenti e mi prenda, per ciascun file, i primi 6 caratteri (che chiamerò prefisso)? Mi servirebbe per implementare altre sub che trattino ciascuno file il funzione del loro prefisso. 

Grazie 

[LukeRedsPartecipante LukeReds Karma: 19 pts]

ciao, esempio di codice, scrive i 6 caratteri del file in colonna A. 

Sub FileCartella()
Dim nome As String, i As Integer
nome = Dir("C:\Users\lucar\Desktop\vendite\")
i = 1
If nome <> "" Then
   Do While nome <> ""
      Cells(i, 1) = Mid(nome, 1, 6)
      i = i + 1
      nome = Dir
   Loop
End If
End Sub

[Autore]

Articoli