Help Creating Macro to Crop/Resize Images

ineedmacrohelp · #1 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.

ineedmacrohelp · #2 08-06-2015, 06:46 AM

I ended up figuring it out in Word. The Excel thing was getting messy. Here is the code:

Code:

Sub BackupCropperResizer()
'
' BackupCropperResizer Macro
'
'
  Dim sngWidth, sngCrop As Single
 sngCrop = 3.075
 
 
 Selection.WholeStory
 
With Selection.InlineShapes(1)
 sngWidth = .Width
 With .PictureFormat
 .CropRight = sngWidth * sngCrop
 End With
 End With
 
 On Error Resume Next
 With Selection.InlineShapes(2)
 sngWidth = .Width
 With .PictureFormat
 .CropRight = sngWidth * sngCrop
 End With
 End With
 
On Error Resume Next
With Selection.InlineShapes(3)
 sngWidth = .Width
 With .PictureFormat
 .CropRight = sngWidth * sngCrop
 End With
 End With
 
 
 Dim i As Long
With ActiveDocument
 For i = 1 To .InlineShapes.Count
 With .InlineShapes(i)
 .ScaleHeight = 33
 End With
 Next i
End With
 
End Sub

I couldn't get the cropper to work in a For Loop for some reason so I cut the corner and used On Error Resume Next. For my purpose I only have three images max, so this works out fine.

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Help with VBA to resize images	Yuffster	Word VBA	2	01-30-2015 06:05 AM
creating mirror images	gib65	Excel	4	06-12-2014 06:24 AM
save as webpage without creating new images	healthyman	Word	3	04-15-2012 03:51 AM
WORD Macro - import picture - resize - position - page break - loop	Nano07	Word VBA	2	11-02-2011 05:14 AM
Cropped screenshots - lose crop in email	nadder	Office	2	10-20-2010 06:56 PM