#1
|
|||
|
|||
Help Creating Macro to Crop/Resize Images
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 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 I'd appreciate any insight you can offer. |
#2
|
|||
|
|||
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 |
|
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 |