geedee65
03-08-2008, 06:50 AM
I have a macro that inserts a picture (inlineshape) into a cell within a table when a MacroButton is clicked.
The macro then resizes the picture to the cells dimensions, without distorting the picture and applies a named bookmark to the picture.
Through VBA, is there a way to determine the name of the Bookmark when the user selects any of the pictures already inserted?
I've tried,
Sub ReDoPic()
Dim BMname As String
BMname = Selection.Bookmarks(1).Name
End Sub
but this picks up the bookmark name of the table that picture is within and not the picture (inlineshape)!
As there can be up to 2 pictures in each table, with 21 tables in the document, I need to know which picture is selected.
The reason I want to do this, is to be able to update the picture a user selects, (through the same macro that inserts the original picture) attached to a custom menu.
Because each cell that has a MacroButton to insert a picture is linked to a particular picture file.
here is the macro,
Sub InsertPic(Fldr As String, Ttl As String, Xtn As String, BMname As String)
' 03/02/2008 by Glen D. Atkinson
'Inserts a picture from a determined filepath and resizes according to cell dimensions.
Dim NewPic As InlineShape
Dim ScleFctr As Long
Dim MaxW As Long
Dim MaxH As Long
Dim MinW As Long
Dim MinH As Long
Dim PicW As Long
Dim PicH As Long
Application.ScreenUpdating = False
'Determine size range of pic
If BMname = "PicPhase" Then
MaxW = 355
MaxH = 225
MinW = 340
MinH = 210
Else
MaxW = 265
MaxH = 125
MinW = 250
MinH = 110
End If
' Select the Bookmark (same as MacroButton)
ActiveDocument.Bookmarks(BMname).Range.Select
' Select pic to insert
On Error Resume Next
Set NewPic = Selection.InlineShapes.AddPicture(FileName:=Fldr & Ttl & Xtn, _
LinkToFile:=True, SaveWithDocument:=True)
If NewPic Is Nothing Then
MsgBox "This Picture Does Not Exist!" & vbCrLf & "Check Picture exists" _
& vbCrLf & "Check That Picture Is a .jpg" & vbCrLf & "Check Picture File Name", _
vbOKOnly, "MR Plus"
Set NewPic = Nothing
Exit Sub
Else
'add picture & if not full size, adjust to full size
If NewPic.ScaleHeight <> 100 Then
NewPic.ScaleHeight = 100
End If
If NewPic.ScaleWidth <> 100 Then
NewPic.ScaleWidth = 100
End If
'Determine if pic is bigger than table cell size and re-size
If NewPic.Width > MaxW Or NewPic.Height > MaxH Then
If (NewPic.Width - MaxW) < (NewPic.Height - MaxH) Then
ScleFctr = (MaxW / NewPic.Width) * 100
NewPic.ScaleWidth = ScleFctr
NewPic.ScaleHeight = ScleFctr
Else
ScleFctr = (MaxH / NewPic.Height) * 100
NewPic.ScaleWidth = ScleFctr
NewPic.ScaleHeight = ScleFctr
End If
'Or determine if pic is smaller than table cell size and re-size
ElseIf NewPic.Width < MinW Or NewPic.Height < MinH Then
If (NewPic.Width - MinW) > (NewPic.Height < MinH) Then
ScleFctr = (MaxW / NewPic.Width) * 100
NewPic.ScaleWidth = ScleFctr
NewPic.ScaleHeight = ScleFctr
Else
ScleFctr = (MaxH / NewPic.Height) * 100
NewPic.ScaleWidth = ScleFctr
NewPic.ScaleHeight = ScleFctr
End If
End If
'Re-create bookmark
Selection.Collapse Direction:=wdCollapseStart
Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
ActiveDocument.Bookmarks.Add BMname
Selection.Collapse Direction:=wdCollapseStart
Set NewPic = Nothing
End If
Application.ScreenUpdating = True
I kept the link to the picture, so if the picture was replaced or edited, the link could then be updated, but of course it does not re-size the picture to the dimensions required.
Any suggestions?
And many thanks to those that have posted code for inserting and re-sizing pictures in tables in this forum, it all helped put together the above code.
Also, being a novice at Word vba, any suggestions at improving the above code would be great!
The macro then resizes the picture to the cells dimensions, without distorting the picture and applies a named bookmark to the picture.
Through VBA, is there a way to determine the name of the Bookmark when the user selects any of the pictures already inserted?
I've tried,
Sub ReDoPic()
Dim BMname As String
BMname = Selection.Bookmarks(1).Name
End Sub
but this picks up the bookmark name of the table that picture is within and not the picture (inlineshape)!
As there can be up to 2 pictures in each table, with 21 tables in the document, I need to know which picture is selected.
The reason I want to do this, is to be able to update the picture a user selects, (through the same macro that inserts the original picture) attached to a custom menu.
Because each cell that has a MacroButton to insert a picture is linked to a particular picture file.
here is the macro,
Sub InsertPic(Fldr As String, Ttl As String, Xtn As String, BMname As String)
' 03/02/2008 by Glen D. Atkinson
'Inserts a picture from a determined filepath and resizes according to cell dimensions.
Dim NewPic As InlineShape
Dim ScleFctr As Long
Dim MaxW As Long
Dim MaxH As Long
Dim MinW As Long
Dim MinH As Long
Dim PicW As Long
Dim PicH As Long
Application.ScreenUpdating = False
'Determine size range of pic
If BMname = "PicPhase" Then
MaxW = 355
MaxH = 225
MinW = 340
MinH = 210
Else
MaxW = 265
MaxH = 125
MinW = 250
MinH = 110
End If
' Select the Bookmark (same as MacroButton)
ActiveDocument.Bookmarks(BMname).Range.Select
' Select pic to insert
On Error Resume Next
Set NewPic = Selection.InlineShapes.AddPicture(FileName:=Fldr & Ttl & Xtn, _
LinkToFile:=True, SaveWithDocument:=True)
If NewPic Is Nothing Then
MsgBox "This Picture Does Not Exist!" & vbCrLf & "Check Picture exists" _
& vbCrLf & "Check That Picture Is a .jpg" & vbCrLf & "Check Picture File Name", _
vbOKOnly, "MR Plus"
Set NewPic = Nothing
Exit Sub
Else
'add picture & if not full size, adjust to full size
If NewPic.ScaleHeight <> 100 Then
NewPic.ScaleHeight = 100
End If
If NewPic.ScaleWidth <> 100 Then
NewPic.ScaleWidth = 100
End If
'Determine if pic is bigger than table cell size and re-size
If NewPic.Width > MaxW Or NewPic.Height > MaxH Then
If (NewPic.Width - MaxW) < (NewPic.Height - MaxH) Then
ScleFctr = (MaxW / NewPic.Width) * 100
NewPic.ScaleWidth = ScleFctr
NewPic.ScaleHeight = ScleFctr
Else
ScleFctr = (MaxH / NewPic.Height) * 100
NewPic.ScaleWidth = ScleFctr
NewPic.ScaleHeight = ScleFctr
End If
'Or determine if pic is smaller than table cell size and re-size
ElseIf NewPic.Width < MinW Or NewPic.Height < MinH Then
If (NewPic.Width - MinW) > (NewPic.Height < MinH) Then
ScleFctr = (MaxW / NewPic.Width) * 100
NewPic.ScaleWidth = ScleFctr
NewPic.ScaleHeight = ScleFctr
Else
ScleFctr = (MaxH / NewPic.Height) * 100
NewPic.ScaleWidth = ScleFctr
NewPic.ScaleHeight = ScleFctr
End If
End If
'Re-create bookmark
Selection.Collapse Direction:=wdCollapseStart
Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
ActiveDocument.Bookmarks.Add BMname
Selection.Collapse Direction:=wdCollapseStart
Set NewPic = Nothing
End If
Application.ScreenUpdating = True
I kept the link to the picture, so if the picture was replaced or edited, the link could then be updated, but of course it does not re-size the picture to the dimensions required.
Any suggestions?
And many thanks to those that have posted code for inserting and re-sizing pictures in tables in this forum, it all helped put together the above code.
Also, being a novice at Word vba, any suggestions at improving the above code would be great!