Word: Save image to jpg file via clipboard or Executemso? 1

[KristianDude]

I am back with another!.. I feel like I am so close to getting this but have exhausted my energies on it. I am taking a screenshot and placing it into word, but would also like the functionality of saving the image to a file. Can anyone see my error in this logic please?!.. or if there is a better cleaner method vs using executemso?? Thank you!! :]

        Set oCC = ActiveDocument.SelectContentControlsByTitle("ctrlPicture").Item(1)
        oCC.Range.Select
        Selection.Paste
        Selection.Copy
        oCC.Range.Select
        CommandBars.ExecuteMso "ObjectSaveAsPicture", fileName:=ActiveDocument.Path & "\Weather " & Format(Date, "mm-dd-yy") & ".jpg"
        Selection.MoveRight
        Selection.Collapse
        clipboard.Clear

Something else I also tried and had no luck with was... anything works for me as long as it works!! :]

SavePicture Clipboard.GetData, ActiveDocument.Path & "\Weather " & Format(Date, "mm-dd-yy") & ".jpg"

 

[KristianDude]

Okay, so I see that the CommandBars.ExecuteMso works only with that command, so there is no way to save it to a specified folder with that function. Can anyone point me in the right direction for saving an image from the clipboard to a file? Everything I seem to be finding on the web is appx 8-10 years old and seem to be pages of coding to do so. Is there anything implemented in the newer VBA scripting that might make this a bit easier and/or cleaner?

 

[strongm]

> Is there anything implemented in the newer VBA scripting that might make this a bit easier

Not in Word. VBA can handle storing pictures reasonably well, as long as you can get hold of a StdPic interface. The problem is that Word doesn't expose that interface for pictures in a document, nor does the Word clipboard.

All those reams of code you have seen are designed, I rather suspect, to get hold of the StdPic interface

 

[KristianDude]

HA okay. Thanks for the info!!

 

[strongm]

I should also point out that even with a StdPic VBA does not know how to save a jpeg - so a bunch more code would be needed to do that (as my old code in thread222-760856 illustrates)

 

[strongm]

>Something else I also tried and had no luck with was
[tt]SavePicture Clipboard.GetData ...[/tt]

Aha!!! No, it wouldn't. Word VBA doesn't have a clipboard object (although it does have some restricted access to the Windows clipboard), which is what you are trying to use here.

But ... there are some nice folk who have written DLLs that provide a more complete implementation of a clipboard object, akin to the one included in VB6. I attach (hopefully) one such DLL (you'll also find a link to it in one of my later posts in thread711-1740171). You'll need to register it before you can use it and then add it as a reference, then a function such as the following should work:

[blue][green]' Saves an image if there is one in the clipboard[/green]
Public Sub SaveClipboardPicBMP(strFilePath As String)
    With New clipboard
        SavePicture .getdata(2), strFilePath [green]' 2 is vbCFBitmap[/green]
    End With
End Sub[/blue]

Note the BMP in the procedure name. This is because SavePicture, as advised in my previous post, knows nothing about jpegs. Simply making the extension jpg has no effect; it gets saved as a bmp.

 

[KristianDude]

Super cool. Thank you!!.. I will be playing with this one today!

 

[strongm]

I now have a (relatively) short solution to saving the clipboard contents as a jpeg now (it does assume that you are on Vista or later; if on XP you'll ned to download and install the WIA 2.0 library from Microsoft):

[blue]Option Explicit

Public Declare Function OleCreatePictureIndirect Lib "olepro32" (PicDesc As PicBmp, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Public Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
Public Declare Function CloseClipboard Lib "user32" () As Long
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

Public Type GUID
   Data1 As Long
   Data2 As Integer
   Data3 As Integer
   Data4(7) As Byte
End Type

Public Type PicBmp
   Size As Long
   Type As Long
   hBmp As Long
   hPal As Long
   Reserved As Long
End Type

Public Const CF_BITMAP = 2
Public Const wiaFormatAsJPEG = "{B96B3CAE-0728-11D3-9D7B-0000F81EF32E}"

Public Sub SaveClipboardasJPEG(strFilePath As String)
    Dim Pic As PicBmp
    Dim IPic As IPicture
    Dim IID_IDispatch As GUID
    Dim hBmp As Long
    Dim myPB As PropertyBag
    Dim getarray() As Byte
    Dim lp As Long

    hBmp = GetClipBoard [green]' get handle to bitmap from clipboard[/green]

    If hBmp Then  [green]' if we got a bitmap handle from the clipboard then turn it into an OLE Picture object
        'Fill in OLE IDispatch Interface ID (short variant of IDispatch, thanks to Karl Peterson)[/green]
        With IID_IDispatch
          .Data1 = &H20400
          .Data4(0) = &HC0
          .Data4(7) = &H46
        End With
        With Pic
            .Size = Len(Pic)         
            .Type = vbPicTypeBitmap  
            .hBmp = hBmp             
            .hPal = 0&               
        End With
        [green]'Create OLE Picture object[/green]
        Call OleCreatePictureIndirect(Pic, IID_IDispatch, True, IPic)
    End If
    
    If Not IPic Is Nothing Then
        
        With New PropertyBag
            .WriteProperty "MyPicture", IPic [green]' call it whatever you like[/green]
            getarray = .Contents
        End With
        
        ' find start of bitmap structure
        For lp = 0 To UBound(getarray) - 1
            If Chr$(getarray(lp)) & Chr$(getarray(lp + 1)) = "BM" Then Exit For
        Next
        
        ReDim bytearray(UBound(getarray) - lp) As Byte [green]' BMP data structure starts at position lp[/green]
        
        CopyMemory bytearray(0), getarray(lp), UBound(bytearray)
        
        [green]' At this point we have a byte array containing a full bitmap structure
        ' that WIA understands (this is not just the raw bitmap bits)
        ' we can now turn this into a jpeg using WIA[/green]
        
        SaveBMPArrayAsJPG bytearray, strFilePath
    End If

End Sub

[green]' returns an hBitmap if bitmap data is on clipboard
' does not return any other clipboard formats[/green]
Public Function GetClipBoard() As Long
    Dim hClipBoard As Long
        
    hClipBoard = OpenClipboard(0&)
     
    If hClipBoard <> 0 Then
        ' Get a handle to the Bitmap
        GetClipBoard = GetClipboardData(CF_BITMAP)
        If GetClipBoard = 0 Then MsgBox "No bitmap data found on clipboard", vbInformation
        CloseClipboard
    End If

End Function

Private Sub SaveBMPArrayAsJPG(BMPArray() As Byte, Optional Filename As String = "newjpeg.jpg", Optional Quality As Long = 20) 
    Dim ImgProc As Object
      
    [green]' OK, set up our bitmap-to-jpeg converter[/green]
    Set ImgProc = CreateObject("WIA.imageprocess")
    With ImgProc
        .Filters.Add .FilterInfos("Convert").FilterID
        .Filters.Item(1).Properties("FormatID").Value = wiaFormatAsJPEG
        .Filters.Item(1).Properties("Quality").Value = Quality [green]' 1 to 100%[/green]
    End With

    [green]' Convert and save[/green]
    With CreateObject("WIA.vector")
        .BinaryData = BMPArray
        ImgProc.Apply(.ImageFile).SaveFile Filename 
    End With
End Sub[/blue]

 

[KristianDude]

Good morning.. this looks really great!.. wow... I add the WIA 2.0 reference and then try to run it. It is having issues with all the Public Declare Function statements. Is there another reference I should add? Here are two lines (below) that are actually staying red and an error message pops up when I try to save the code "Compile Error: Contstants, fixed length strings, arrays, user-defined types and Declare statements not allowed as Public members of object modules"

[COLOR=#CC0000]
Public Const CF_BITMAP = 2
Public Const wiaFormatAsJPEG = "{B96B3CAE-0728-11D3-9D7B-0000F81EF32E}"[/color]

The references I currently have selected if this helps anything?..

Visual Basic for Applications
Microsoft Word 15.0 object library
OLE automation
Normal
Microsoft Office 15.0 library
Microsoft Forms 2.0
Microsoft Windows Common Controls -2 6.0 (SP6)
Microsoft HTML object library
Microsoft Internet Controls
Microsoft Windows Image Acquisition Library v2.0

 

[strongm]

Paste the code into a new Module instead of This Document - however even then it is unlikey to work, since I used a shortcut, a propertybag, that VBA doesn't have ...

Just need a minor rethink to solve it with streams instead.

 

[strongm]

Ok, here we go (you'll need to set a reference to Edanmo's ole type libray, which can be found in this zip file. The only code chage is in the SaveClipboardAsJPEG routine:

[blue][green]' Now requires a reference to Edanmo's ole tlb, which can be found in this zip: [URL unfurl="true"]http://www.mvps.org/emorcillo/download/vb6/tl_ole.zip[/URL][/green]
Public Sub SaveClipboardasJPEG(strFilePath As String)
    Dim Pic As PicBmp
    Dim IPic As IPicture
    Dim IID_IDispatch As GUID
    Dim hBmp As Long
    'Dim myPB As PropertyBag
    Dim getarray() As Byte
    Dim lp As Long
    
    
    Dim oStream As IStream
    Dim Stats As STATSTG

    hBmp = GetClipBoard [green]' get handle to bitmap from clipboard[/green]

    If hBmp Then  [green]' if we got a bitmap handle from the clipboard then turn it into an OLE Picture object
        'Fill in OLE IDispatch Interface ID (short variant of IDispatch, thanks to Karl Peterson)[/green]
        With IID_IDispatch
          .Data1 = &H20400
          .Data4(0) = &HC0
          .Data4(7) = &H46
        End With
        With Pic
            .Size = Len(Pic)
            .Type = 1 [green]'vbPicTypeBitmap[/green]
            .hBmp = hBmp
            .hPal = 0&
        End With
        [green]' Create OLE Picture object[/green]
        Call OleCreatePictureIndirect(Pic, IID_IDispatch, True, IPic)
    End If
    
    If Not IPic Is Nothing Then
             
        [green]' create a new stream then copy contents of picture's hidden persistable stream
        ' to our new stream, then read contents into an array
        ' This replaces the original Propertybag routine[/green]
        Set oStream = CreateStreamOnHGlobal(0&, True)
        OleSaveToStream IPic, oStream
        oStream.Seek 0, STREAM_SEEK_SET
        oStream.Stat Stats
        ReDim getarray(Stats.cbSize * 10000&) As Byte
        oStream.Read getarray(0), UBound(getarray) - 1
        
        [green]' find start of bitmap structure[/green]
        For lp = 0 To UBound(getarray) - 1
            If Chr$(getarray(lp)) & Chr$(getarray(lp + 1)) = "BM" Then Exit For
        Next
        
        ReDim bytearray(UBound(getarray) - lp) As Byte [green]' BMP data structure starts at position lp[/green]
        
        CopyMemory bytearray(0), getarray(lp), UBound(bytearray)
        
        [green]' At this point we have a byte array containing a full bitmap structure
        ' that WIA understands (this is not just the raw bitmap bits)
        ' we can now turn this into a jpeg using WIA[/green]
        
        SaveBMPArrayAsJPG bytearray, strFilePath
    End If

End Sub[/blue]

 

[KristianDude]

This is working fantastic!!.. thank you!!.. wow wow wow... sooooo...

There is one thing that popped up from related to the other thread we were working through. Now when I try to run the Insert Image and StretchCropInline procedure it says "variable not defined" and highlights Set mg2 = ActiveDocument.Range. Is this associated with these changes possibly?? When I place Dim mg2 at the top of the procedure is continues the procedure, but when it gets into StretchCropInline the error also says "variable not defined" when it gets to InsertTextbox CStr(vrtSelectedItem). I checked references, deleted the file, started over and it appears that something has changed in the referencing through all of this? I will keep troubleshooting to make sure I didn't make a mistake here... totally possible

 

[strongm]

There's nothing in the new code that should impact the old code. Assuming you haven't modified it ...

 

[KristianDude]

I was calling the InsertTextBox at the end of StretchCropInline... I just removed it and it is inserting/resizing great. I think it is just the placement. I'll work on that one. Thanks StrongM!