Microsoft Office Forums - View Single Post - [Solved] Help Creating Macro to Crop/Resize Images

ineedmacrohelp · 08-04-2015, 08:30 AM

Hello.

I frequently take a printscreen and then paste into a word doc. I have dual monitors so it takes a printscreen of both and I need to crop the second half off. I do between 1-3 printscreens per word doc.
(I need to date and time so I cannot use alt+PrntScrn)

I am trying to create a macro they allows me to paste the printscreen and have it cropped.

I was having trouble formatting an image in Word VBA so I've been trying to do it in excel and then transfer it to word but keep running into road blocks.

Here is what I have so far:

Code:

 
    ActiveSheet.Paste
 
    Selection.ShapeRange.LockAspectRatio = msoFalse
    Selection.ShapeRange.IncrementLeft 0.00007874015748
    Selection.ShapeRange.ScaleWidth 0.5, msoFalse, msoScaleFromTopLeft
    Selection.ShapeRange.PictureFormat.Crop.PictureWidth = 2879
    Selection.ShapeRange.PictureFormat.Crop.PictureHeight = 809
    Selection.ShapeRange.PictureFormat.Crop.PictureOffsetX = 719
    Selection.ShapeRange.PictureFormat.Crop.PictureOffsetY = 0
 
    Selection.Copy
 
Dim Docname
Docname = "C:\filepath\BlankWord.docx"
 
Dim WordDoc As Object
Dim WordApp As Object
Set WordApp = CreateObject("word.Application")
 
If IsFileOpen("C:\filepath\BlankWord.docx") Then
    WordApp.Visible = True
    Set WordDoc = GetObject(Docname)   """ this seems to be where I run into trouble
Else
    WordApp.Documents.Open (Docname)
End If
 
WordApp.Visible = True
WordApp.Selection.Paste

This is the IsFileOpen function I found online:

Code:

Function IsFileOpen(filename As String)
    Dim filenum As Integer, errnum As Integer
    On Error Resume Next   ' Turn error checking off.
    filenum = FreeFile()   ' Get a free file number.
    ' Attempt to open the file and lock it.
    Open filename For Input Lock Read As #filenum
    Close filenum          ' Close the file.
    errnum = Err           ' Save the error number that occurred.
    On Error GoTo 0        ' Turn error checking back on.
    ' Check to see which error occurred.
    Select Case errnum
        ' No error occurred.
        ' File is NOT already open by another user.
        Case 0
         IsFileOpen = False
        ' Error number for "Permission Denied."
        ' File is already opened by another user.
        Case 70
            IsFileOpen = True
        ' Another error occurred.
        Case Else
            Error errnum
    End Select

So I run this macro in excel and the first time it works fine. It crops the image, opens my word doc, and pastes it in. However, when I want to run the macro for the second image (which needs to go in the first word doc) it doesn't work.

I'd appreciate any insight you can offer.