Make a copied selection (range) and manipulate height an width

[elvagonumero1]

Hello,

Maybe this question would be solved if I get to the basics, but I'm used to find quick answers checking forums. This one may seam silly, but I was looking and didn't found something that could help me on this.

The whole code is based on Brian Baulsom's showed on http://www.mrexcel.com/forum/excel-questions/344789-copying-embedded-images-directory.html

I'm using excel 2010

Private Sub lblImprimirJPG_Click() 'Exporting the selected range as an image to mspaint
    Dim MiImagen As object    'copied selection that I want to paste into mspaint
    Dim AltoI As Integer         ' original picture height
    Dim AnchoI As Integer          ' original picture width
    Dim RutaNombreArchivo As String    'fullname of the file
    Dim NombreArchivo As String      'the basic name of the file


    Sheets("FormatoEntrega").Select        'the sheet where the range is going to be copied
    ActiveWindow.View = xlNormalView     
[COLOR=#ff0000]    MiImagen = Sheets("FormatoEntrega").Range("A1:Z59").copy[/COLOR]
    AltoI = Int(MiImagen.Height * 1.333)      '1.333 is the point to pixel ratio
    AnchoI = Int(MiImagen.Width * 1.333)
    NombreArchivo = Sheets("FormatoEntrega").Range("v4") & ".jpg"    
    RutaNombreArchivo = ThisWorkbook.Path & "\SOPORTES\" & NombreArchivo    

    'After this comes the routine that pastes and manipulates mspaint and works beatifully

Exit Sub

The highlighted row fires an error and I don't know why, I've already tried some alternatives but nothing did work.

I'd be glad to be enlightened... Thanks in advance

Elvagonumero1

 

[Tetra201]

The highlighted row fires an error and I don't know why...

Because you declared MiImagen as Object.

 

[elvagonumero1]

Because you declared MiImagen as Object.

How do I Have to declare it? What should I do?

I've already tried declarating it as Image, but didn't work.

 

[Tetra201]

How do I Have to declare it? What should I do?

I've already tried declarating it as Image, but didn't work.

The following code snippet will get past that point.
It will copy the range to the Clipboard and will assign values to AltoI and AnchoI.
I have no idea what you are doing next.

Private Sub lblImprimirJPG_Click() 'Exporting the selected range as an image to mspaint
'    Dim MiImagen As Object    'copied selection that I want to paste into mspaint
    Dim AltoI As Integer         ' original picture height
    Dim AnchoI As Integer          ' original picture width
    Dim RutaNombreArchivo As String    'fullname of the file
    Dim NombreArchivo As String      'the basic name of the file


    Sheets("FormatoEntrega").Select        'the sheet where the range is going to be copied
    ActiveWindow.View = xlNormalView
    Sheets("FormatoEntrega").Range("A1:Z59").Copy
    AltoI = Int(Sheets("FormatoEntrega").Range("A1:Z59").Height * 1.333)      '1.333 is the point to pixel ratio
    AnchoI = Int(Sheets("FormatoEntrega").Range("A1:Z59").Width * 1.333)
    NombreArchivo = Sheets("FormatoEntrega").Range("v4") & ".jpg"
    RutaNombreArchivo = ThisWorkbook.Path & "\SOPORTES\" & NombreArchivo

    'After this comes the routine that pastes and manipulates mspaint and works beatifully

Exit Sub

 

[elvagonumero1]

Thanks Tetra it's working but now I've noticed that the image is too big and file is unncessarily big.


Please can you help on making it resizable to a half or quarter size... I think this could be done if the copied selection is contained into something, an Image, chart or object (I suppose) and then changing height and width of that thing.

I'm showing you how it's going... BTW, Everything it's been done on spanish versions because I'm from Venezuela, that's why there's a little mess with words and sendkeys commands.

Private Sub lblImprimirJPG_Click()
    'Const BitmapFileName As String = "XLpicture" 'name without "_00x.bmp"
    
    Const MSPaint As String = "C:\WINDOWS\system32\mspaint.exe"
    '====================================================================
    'Dim MiImagen As Image
    Dim PuntoAPixel As Double   ' convert Excel points size to pixels
    Dim AltoI As Integer         ' original picture height
    Dim AnchoI As Integer          ' original picture width
    Dim Dimension As String                ' height/width value in pixels
    '---------------------------------------------------------------------
    '- Archivo JPG - BITMAP FILE
    Dim RutaNombreArchivo As String '= MyPictureFolder & BitmapFileName & "_00x.bmp"
    Dim NombreArchivo As String     'Código del documento de entrega
    '---------------------------------------------------------------------
    '- MS PAINT
    Const Alt As String = "%"   ' for SendKeys Alt key
    Dim AbrirPaint                  ' Shell error return. Not used here.
    '----------------------------------------------------------------
    
    Sheets("FormatoEntrega").Select
    ActiveWindow.View = xlNormalView
    '.Select
    Sheets("FormatoEntrega").Range("A1:Z59").Copy
    AltoI = Int(Sheets("FormatoEntrega").Range("A1:Z59").Height * 1.333)    '1.333 is the point to pixel ratio
    AnchoI = Int(Sheets("FormatoEntrega").Range("A1:Z59").Width * 1.333)


    NombreArchivo = Sheets("FormatoEntrega").Range("v4") & ".jpg"
    RutaNombreArchivo = ThisWorkbook.Path & "\SOPORTES\" & NombreArchivo
    '-----------------------------------------------------------------
    '- NEXT FILE NAME IN THE SERIES
    'GET_NEXT_FILENAME   ' SUBROUTINE
    '-----------------------------------------------------------------
    '- OPEN MS PAINT
    AbrirPaint = Shell(MSPaint, vbNormalFocus)  ' normal screen
    'Application.StatusBar = " Open MS Paint"
    Application.Wait Now + TimeValue("00:00:02")    ' 2 segundos para abrir
    '- paste ---------------------------------------------------------
    'Application.StatusBar = " Paste picture"
    SendKeys Alt & "E", True    ' Menú Edición - edit menu
    SendKeys "P", True          ' Pegar - paste
    DoEvents
    Application.Wait Now + TimeValue("00:00:01")    ' espera 1 segundo
    '-----------------------------------------------------------------
    '- Image Menu
    SendKeys Alt & "I", True    ' Menú Imagen - image menu
    Application.Wait Now + TimeValue("00:00:01")    ' espera 1 segundo
    SendKeys "A", True    ' Atributos - attributes
    DoEvents
    Application.Wait Now + TimeValue("00:00:01")    ' espera 1 segundo
    '-----------------------------------------------------------------
    '- Set Width
    Dimension = Format(AnchoI, "000")
    SendKeys Alt & "A", True    ' Ancho
    SendKeys Dimension, True
    DoEvents
    Application.Wait Now + TimeValue("00:00:01")    ' espera 1 segundo
    '-----------------------------------------------------------------
    '- Set Height
    Dimension = Format(AltoI, "000")
    SendKeys Alt & "L", True    ' Alto
    SendKeys Dimension, True
    DoEvents
    Application.Wait Now + TimeValue("00:00:01")    ' espera 1 segundo
    '-----------------------------------------------------------------
    '- ENTER
    SendKeys "{ENTER}", True
    DoEvents
    '-----------------------------------------------------------------
    '- save file
    'Application.StatusBar = " Saving " & FullFileName
    SendKeys Alt & "A"              ' Menú Archivo - File menu
    DoEvents
    Application.Wait Now + TimeValue("00:00:01")    ' espera 1 segundo
    SendKeys "M", True              ' Guardar Como - Save As dialog
    DoEvents
    Application.Wait Now + TimeValue("00:00:01")
    SendKeys RutaNombreArchivo, True     ' Ingresa dirección y nombre del archivo - type file name
    DoEvents
    Application.Wait Now + TimeValue("00:00:02")    ' espera 2 segundo
    SendKeys Alt & "G", True        ' Save
    DoEvents
    Application.Wait Now + TimeValue("00:00:03") ' 3 seconds to save
    '- close ---------------------------------------------------------
    'Application.StatusBar = " Closing Paint"
    SendKeys Alt & "{F4}", True
    DoEvents
    'Application.StatusBar = False
End Sub

 

[Tetra201]

Thanks Tetra it's working but now I've noticed that the image is too big and file is unncessarily big.

Please can you help on making it resizable to a half or quarter size... I think this could be done if the copied selection is contained into something, an Image, chart or object (I suppose) and then changing height and width of that thing.

I'm showing you how it's going... BTW, Everything it's been done on spanish versions because I'm from Venezuela, that's why there's a little mess with words and sendkeys commands.

Glad to hear it went through.

I have a different version of MS Paint, so I will not be able to help you with that part. Hopefully somebody else will chime in.

 

[elvagonumero1]

Thanks Tetra, you really helped me!

Now, I think that I found some weird thing with sendkeys method and WinXP's MSPaint... So, when typing in the fullfilename, name that includes path and file extension, on the Save As dialog box, MSPaint doesn't save it as the specified file extension commands, what does really happens is that the file is saved as a .BMP with a filename that ends with the extension that was supposed to.

The weirdest of all is that the icon of the resulting file is consistent with the filename, while the image has a .BMP quality and size... I found that the compression applied by the filetype is only done when a selection is made on the combobox containing filetypes.

Please let me know if I'm wrong. I hope that this could help some out there.

Now, I'll show the last version of the code. As a synthesis it takes an image from excel, paste it on mspaint and save with an specific name.

Private Sub lblImprimirJPG_Click()
    'Const BitmapFileName As String = "XLpicture" 'name without "_00x.bmp"
    
    Const MSPaint As String = "C:\WINDOWS\system32\mspaint.exe"
    '====================================================================
    'Dim MiImagen As Image
    Dim PuntoAPixel As Double   ' convert Excel points size to pixels
    Dim AltoI As Integer         ' original picture height
    Dim AnchoI As Integer          ' original picture width
    Dim Dimension As String                ' height/width value in pixels
    '---------------------------------------------------------------------
    '- Archivo JPG - BITMAP FILE
    Dim RutaNombreArchivo As String '= MyPictureFolder & BitmapFileName & "_00x.bmp"
    Dim NombreArchivo As String     'Código del documento de entrega
    '---------------------------------------------------------------------
    '- MS PAINT
    Const Alt As String = "%"   ' for SendKeys Alt key
    Dim AbrirPaint                  ' Shell error return. Not used here.
    '----------------------------------------------------------------
    
    Sheets("FormatoEntrega").Select
    ActiveWindow.View = xlNormalView
    '.Select
    Sheets("FormatoEntrega").Range("A1:Z59").Copy
    'AltoI = Int(Sheets("FormatoEntrega").Range("A1:Z59").Height * 1.333)    '1.333 is the point to pixel ratio
    'AnchoI = Int(Sheets("FormatoEntrega").Range("A1:Z59").Width * 1.333)


    NombreArchivo = Sheets("FormatoEntrega").Range("v4")
    RutaNombreArchivo = ThisWorkbook.Path & "\SOPORTES\" & NombreArchivo
    '-----------------------------------------------------------------
    '- NEXT FILE NAME IN THE SERIES
    'GET_NEXT_FILENAME   ' SUBROUTINE
    '-----------------------------------------------------------------
    '- OPEN MS PAINT
    AbrirPaint = Shell(MSPaint, vbNormalFocus)  ' normal screen
    Application.Wait Now + TimeValue("00:00:02")    ' 2 segundos para abrir
    SendKeys Alt & "E", True    ' Menú Edición - edit menu
    SendKeys "P", True          ' Pegar - paste
    DoEvents
    Application.Wait Now + TimeValue("00:00:01")    ' espera 1 segundo
    SendKeys Alt & "A"              ' Menú Archivo - File menu
    SendKeys "M", True
    DoEvents
    Application.Wait Now + TimeValue("00:00:01")    ' espera 1 segundo
    SendKeys RutaNombreArchivo, True    ' Ingresa dirección y nombre del archivo - type file name
    DoEvents
    Application.Wait Now + TimeValue("00:00:01")    ' espera 1 segundo
    SendKeys "{TAB}", True
    SendKeys "{DOWN}", True
    SendKeys "{DOWN}", True
    SendKeys Alt & "G", True
    DoEvents
    Application.Wait Now + TimeValue("00:00:02") ' 2 seconds to save
    '- close ---------------------------------------------------------
    'Application.StatusBar = " Closing Paint"
    SendKeys Alt & "{F4}", True
    DoEvents
    'Application.StatusBar = False
End Sub