VBA: salvare il contenuto di un range come immagine Jpg

[draleo]

Dovrei fare in modo (se la cosa fosse possibile) che il contenuto di un range mi venga salvato come immagine Jpg
Attualmente con l’istruzione
Worksheets(1).Range("A1").CopyPicture xlScreen, xlBitmap
Copio l’immagine negli appunti; mi posiziono su paint; incollo ed ottengo l’immagine voluta, che poi salvo come immagine Jpg . Esiste un modo che salvi direttamente l’immagine in Jpg in una cartella prefissata (evitando di passare per paint)?
draleo

[casanmaner]

Questa non la so :-)

[Norman Jones]

Ciao Drealeo,

Prova qualcosa del genere:
'=========>>
Option Explicit

'--------->>
Public Sub Tester()
Dim WB As Workbook
Dim SH As Worksheet
Dim Rng As Range
Dim sFullName As String

Const sPercorsoDestinazione As String = _
"C:\Users\NDJ\Documents\" '<<=== Modifica
Const sNomeJPG As String = "Pippo3.jpg" '<<=== Modifica

Set WB = ThisWorkbook
Set SH = WB.Sheets("Sheet1")
Set Rng = SH.Range("A2:A10")
sFullName = sPercorsoDestinazione & sNomeJPG

Call ExportRangeToJPG(Rng, sFullName)
End Sub

'--------->>
Public Sub ExportRangeToJPG(aRng As Range, sStr)
With aRng
.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
With .Parent.ChartObjects.Add( _
Left:=.Left, Top:=.Top, Width:=.Width, Height:=.Height)
.Name = "TempChart"
.Activate
End With
End With

ActiveChart.Paste
With ActiveSheet.ChartObjects("TempChart")
.Chart.Export sStr
.Delete
End With
End Sub
'<<=========




===
Regards,
Norman

[Norman Jones]

Ciao Draleo,

Meglio sarebbe:

'=========>>
Option Explicit

'--------->>
Public Sub Tester()
Dim WB As Workbook
Dim SH As Worksheet
Dim Rng As Range
Dim sFullName As String

Const sPercorsoDestinazione As String = _
"C:\Users\NDJ\Documents\" '<<=== Modifica

Const sNomeJPG As String = "Pippo.jpg" '<<=== Modifica
Const sFoglio As String = "Sheet1" '<<=== Modifica
Const sIntervallo As String = "A2:A10" '<<=== Modifica

Set WB = ThisWorkbook
Set SH = WB.Sheets(sFoglio)
Set Rng = SH.Range(sIntervallo)

[draleo]

Ottima. Credevo proprio non fosse possibile; ma , con voi guru del VBA, mai dire mai. Comunque sarebbe un peccato sprecare questa chicca per ottenere una sola immagine. In effetti mi servirebbe salvare come immagine Jpg parecchi range. Nel foglio1, nella colonna G , in G1 l’intestazione, da G2 in giù, ho una serie di celle. Alcune sono vuote, altre contengono dei testi. Dovrei scorrerle tutte e , ogni volta che la cella è piena, e solo se la cella è piena, dovrei trasformarla in immagine Jpg, salvandola in una cartella prefissata. Il nome da dargli dovrebbe essere quello della riga interessata. Cioè
se la cella G30, fosse piena, l’immagine dovrebbe chiamarsi 30.Jpg;
se la cella G100 fosse piena, l’immagine dovrebbe chiamarsi 100.Jpg
ecc ecc
Si può fare ?
Grazie
draleo

[Bruno Campanini]

draleo used his keyboard to write :

Aggiungi:
Dim sNomeJPG As String

e sostituisci:
Const SnomeJPG AS String = "Pippo.JPG"
con:
sNomeJPG = Left(sIntervallo, InStr(1, sIntervallo, ":") - 1) &
".jpg"

Bruno

[Norman Jones]

Ciao Draleo,

Prova qualcosa del genere:

'=========>>
Option Explicit

'--------->>
Public Sub Tester()
Dim WB As Workbook
Dim SH As Worksheet

Dim Rng As Range, Rng2 As Range
Dim Rng3 As Range, Rng4 As Range
Dim rCell As Range
Dim sFullName As String, sNomeJPG As String

Const sPercorsoDestinazione As String = _
"C:\Users\NDJ\Documents\" '<<=== Modifica

Const sFoglio As String = "Foglio1" '<<=== Modifica
Const sColonna As String = "G" '<<=== Modifica

Set WB = ThisWorkbook
Set SH = WB.Sheets(sFoglio)

With SH
Set Rng = Intersect(.UsedRange, .Columns(sColonna))
End With

On Error Resume Next
Set Rng2 = Rng.SpecialCells(xlCellTypeConstants)
Set Rng3 = Rng.SpecialCells(xlCellTypeFormulas)
On Error GoTo 0

If Not Rng2 Is Nothing And Not Rng3 Is Nothing Then
Set Rng4 = Intersect(Rng2, Rng3)
ElseIf Not Rng2 Is Nothing Then
Set Rng4 = Rng2
Else
Set Rng4 = Rng3
End If

If Not Rng4 Is Nothing Then
For Each rCell In Rng4.Cells
With rCell
If .Row > 1 Then
sNomeJPG = .Row & ".jpg"

sFullName = sPercorsoDestinazione & sNomeJPG

Call ExportRangeToJPG(rCell, sFullName)
End If
End With
Next rCell
Else
Call MsgBox( _
Prompt:="Nessuna cella riempita è stata trovata in " _
& " colonna G dopo la riga 1", _
Buttons:=vbInformation, _
Title:="REPORT")
End If

[Norman Jones]

Ciai Draleo,

Se, invece di creare un file jpg per ogni cella popolata nella colonna
G, tu dovessi voler creare un file jpg per ogni gruppo popolato di celle
contigui nella colonna di interesse, potrest i provare la seguente
verssione del mio codice:

'=========>>
Option Explicit

'--------->>
Public Sub Tester()
Dim WB As Workbook
Dim SH As Worksheet
Dim Rng As Range, Rng2 As Range
Dim Rng3 As Range, Rng4 As Range

Dim rArea As Range

Dim sFullName As String, sNomeJPG As String

Const sPercorsoDestinazione As String = _
"C:\Users\NDJ\Documents\" '<<=== Modifica
Const sFoglio As String = "Foglio1" '<<=== Modifica
Const sColonna As String = "G"

Set WB = ThisWorkbook
Set SH = WB.Sheets(sFoglio)

With SH
Set Rng = Intersect(.UsedRange, .Columns(sColonna))
End With

On Error Resume Next
Set Rng2 = Rng.SpecialCells(xlCellTypeConstants)
Set Rng3 = Rng.SpecialCells(xlCellTypeFormulas)
On Error GoTo 0

If Not Rng2 Is Nothing And Not Rng3 Is Nothing Then
Set Rng4 = Intersect(Rng2, Rng3)
ElseIf Not Rng2 Is Nothing Then
Set Rng4 = Rng2
Else
Set Rng4 = Rng3
End If

If Not Rng4 Is Nothing Then

For Each rArea In Rng4.Areas
With rArea

If .Row > 1 Then
sNomeJPG = .Row & ".jpg"
sFullName = sPercorsoDestinazione & sNomeJPG

Call ExportRangeToJPG(rArea, sFullName)
End If
End With
Next rArea

[Norman Jones]

On 08/02/2017 15.15, Norman Jones wrote:
> Ciai Draleo,
Ciao

> contigui nella colonna di interesse, potrest i provare la seguente
> verssione del mio codice:
contigui nella colonna di interesse, potresti provare la seguente

versione del mio codice:

Oh, per la capacità di imparare a correggere le bozze! (:-




===
Regards,
Norman

[draleo]

Si. vanno tutte PIU' che bene. E' impressionante la vostra capacità di trovare soluzioni efficaci ad una infinità di quesiti (e lo è anche la vostra cortesia e pazienza nel rispondere). Se poi c'è qualche scemo che non lo capisce, è solo per invidia. Non ti curar di loro, ma guarda e passa...
draleo

[casanmaner]

Beh Norman è un fuori classe :-)
Tra l'altro mi ha dato un'idea per crearmi delle icone con i colori di Excel 2003 per vedere con calma se riesco ad implementare il mio Add-in che imposta gli sfondi con quella "tavolozza" :-)
Adesso gli rubo la funzione e la conservo per quando avrò un momento per vedere se riesco a combinare qualcosa :-)

[Norman Jones]

Ciao Draleo, ciao Casanmaner,

On 08/02/2017 21.31, casanmaner wrote:
> Il giorno mercoledì 8 febbraio 2017 20:45:27 UTC+1, draleo ha scritto:
>> Il giorno mercoledì 8 febbraio 2017 16:20:49 UTC+1, Norman Jones ha scritto:
>>> On 08/02/2017 15.15, Norman Jones wrote:
>>>> Ciai Draleo,
>>> Ciao
>>>
>>>> contigui nella colonna di interesse, potrest i provare la seguente
>>>> verssione del mio codice:
>>> contigui nella colonna di interesse, potresti provare la seguente
>>> versione del mio codice:
>>>
>>> Oh, per la capacità di imparare a correggere le bozze! (:-
>>>
>>>
>>>
>>>
>>> ===
>>> Regards,
>>> Norman
>>
>> Si. vanno tutte PIU' che bene. E' impressionante la vostra capacità di
> trovare soluzioni efficaci ad una infinità di quesiti (e lo è anche la
> vostra cortesia e pazienza nel rispondere). Se poi c'è qualche scemo che
> non lo capisce, è solo per invidia. Non ti curar di loro, ma guarda e
> passa...

>> draleo

> Beh Norman è un fuori classe :-)

Credo che si tratta della consueta grande gentilezza del buon Casanmaner
che. a mio parere, sia il vero eroe di questo forum: lo trovo sempre
imancabilmete generoso, sia con il suo tempo, che la sua capacità
veramente formidabile.

> Tra l'altro mi ha dato un'idea per crearmi delle icone con i colori di
> Excel 2003 per vedere con calma se riesco ad implementare il mio Add-in
> che imposta gli sfondi con quella "tavolozza" :-)
> Adesso gli rubo la funzione e la conservo per quando avrò un momento per
> vedere se riesco a combinare qualcosa :-)

Se Casanmaner volesse condividere il tuo componente aggiuntivo, sarei io
primo in coda, in ginocchio, per pregare una copia!

Concludendo, vorrei ringraziare Draleo per i suoi commenti fin troppo
generosi e, allo stesso tempo, approfittare per scusarmi con tutti i
buon amici di questo forum per i miei risposti poco gentili ad in certo
individuo.

Altrove. Fratello Paolo, che saluto, mi ha suggerito il saggio consiglio
da altri tempi:
Virtus autem est tranquillitas

Vi prometto che, tenendo questo ottimo consiglio in mente, proverò più
assiduamente di tenere a freno la lingua!!



===
Regards,
Norman

[casanmaner]

Ciao Norman, non è niente di eccezionale ed è un po' datato.
In pratica ho creato una barra nel menù contestuale delle celle come da immagine:
https://www.dropbox.com/s/4t0ua1wb84xry5k/Screenshot%202017-02-09%2001.57.28.png?dl=0

Questo è il file:
https://www.dropbox.com/s/ye1wn1trnjcnq73/Tavolozza%20Colori%20Excel%202003.xlam?dl=0

L'idea è di implementare l'AddIns con un ribbon simile a quello dei colori attuali ma con i colori Excel 2003.
Visto che hai postato la procedura per creare le immagini ne ho approfittato per salvare direttamente le immagini e adesso alla prima occasione le carico tramite UI Editor nel componente aggiuntivo e poi creo il componente simile a quello originale.

[Norman Jones]

Ciao Casanmaner,

On 09/02/2017 1.04, casanmaner wrote:
> Ciao Norman, non è niente di eccezionale ed è un po' datato.
> In pratica ho creato una barra nel menù contestuale delle celle come da immagine:
> https://www.dropbox.com/s/4t0ua1wb84xry5k/Screenshot%202017-02-09%2001.57.28.png?dl=0
>
> Questo è il file:
> https://www.dropbox.com/s/ye1wn1trnjcnq73/Tavolozza%20Colori%20Excel%202003.xlam?dl=0
>
> L'idea è di implementare l'AddIns con un ribbon simile a quello dei colori attuali ma con i colori Excel 2003.
> Visto che hai postato la procedura per creare le immagini ne ho approfittato per salvare direttamente le immagini e adesso alla prima occasione le carico tramite UI Editor nel componente aggiuntivo e poi creo il componente simile a quello originale.

Ti ringrazio per il cortese riscontro e, visto che l'ora sia oramai
canonica, guarderò tutto domani.



===
Regards,
Norman

[scib...@gmail.com]

Premetto che non sono molto pratico di VBA.
Ho lo stesso problema di draleo cioè dovrei fare in modo che il contenuto di un range mi venga salvato come immagine Jpg.
Ho provato a copiare la tua soluzione, ma non riesco a farla funzionare.
Potresti riscrivere la macro interamente senza usare la funzione cita testo.
Per favore cerca di scrivere la formula finale completa in maniera tale che il file generato jpg (png o altro formato) venga salvato su una cartella presente sul desktop

PS.
Uso Excel 2007 e ho Windows 7.
Grazie mille.

[Norman Jones]

Ciao scibio87,

On 10/08/2017 12:05, scib...@gmail.com wrote:

> Premetto che non sono molto pratico di VBA.
> Ho lo stesso problema di draleo cioè dovrei fare in modo
>che il contenuto di un range mi venga salvato come immagine
> Jpg. Ho provato a copiare la tua soluzione, ma non riesco a
> farla funzionare.

Quale problema apecifica riscontri ?

> Potresti riscrivere la macro interamente senza usare la funzione

> cita testo..
No, perchè credo che il codice funzioni. Inoltre, non riconosco una
funzione cita testo

> Per favore cerca di scrivere la formula finale completa in maniera
> tale che il file generato jpg (png o altro formato) venga salvato
> su una cartella presente sul desktop

Sostituisci il percorso qui:

> Const sPercorsoDestinazione As String = _
> "C:\Users\NDJ\Documents\" '<<=== Modifica

===
Regards,
Norman

[Ammammata]

Il giorno Thu 10 Aug 2017 01:05:30p, ** ha inviato su
microsoft.public.it.office.excel il messaggio
news:2051c12e-9b21-4625...@googlegroups.com. Vediamo cosa
ha scritto:

> dovrei fare in modo che il contenuto di un range mi venga salvato
> come immagine Jpg

bullzip

dovrebbe essere possibile invocarlo con i parametri per generare un file
jpg invece del solito pdf

a mano, lo fa

--
/-\ /\/\ /\/\ /-\ /\/\ /\/\ /-\ T /-\
-=- -=- -=- -=- -=- -=- -=- -=- - -=-
>>>>> http://www.bb2002.it :) <<<<<
........... [ al lavoro ] ...........