Rotating a picture, but resizing to fit range

[RobbieC]

Hi there, I have a script to insert a picture which resizes it to fit the top into a range (AK8:BT8). This works fine and will name the picture "PeoplePlantPlanDrawing" and retains the orientation and scale when inserted into the range... happy days...

Now, my problem is that the image the user imports may sit better if rotated 90 degrees (or 270 degrees). I have this code which successfully rotates the image, but I cannot get it to retain its position or change size accordingly:

Sub rotatePeoplePlantPlanDrawing()

Dim TargetRange As Range, img As Object, t As Double, l As Double, w As Double, h As Double


    ActiveSheet.Shapes("PeoplePlantPlanDrawing").Select
    Selection.ShapeRange.IncrementRotation 270#
    
Set TargetRange = ActiveSheet.Range("AK8:BT8")


Set img = ActiveSheet.Shapes("PeoplePlantPlanDrawing")

With TargetRange
        t = .Top
        l = .Left
        w = .width
        h = .Height
End With



With img
        .Top = t
        .Left = l
        .Height = h
        .width = w

End With


End Sub

The maximum range I have to fit the image is AK8:BT48 if this helps...

If you can help point out where I'm going wrong, that would be fantastic. Thanks

 

[RobbieC]

Has anyone got any thoughts on how I can solve this?

 

[RobbieC]

This has been driving me barmy all week...

Why is it that my code to import the picture will fit it to the range works fine:

Sub AddNewPeoplePlantPlan()


Dim Fname As String


With Application.FileDialog(msoFileDialogOpen)


    .InitialFileName = "Pictures"
    .Filters.Clear
    .Filters.Add "JPEGS", "*.jpg; *.jpeg"
    .Filters.Add "GIF", "*.GIF"
    .Filters.Add "Bitmaps", "*.bmp"
    .AllowMultiSelect = False


If .Show = True Then
        Fname = .SelectedItems(1)
    Else
        Exit Sub
    End If
End With


    InsertPeoplePlantPlan Fname, _
        Range("AK8:BT8")
        
        ActiveSheet.Shapes("addPeoplePlantPlan").Visible = False
        ActiveSheet.Shapes("deletePeoplePlantPlan").Visible = True


End Sub




Function InsertPeoplePlantPlan(PictureFileName As String, TargetCell As Range) As Object


' inserts a picture at the top left position of TargetCell
' the picture can be centered horizontally and/or vertically


Dim p As Object, t As Double, l As Double, w As Double, h As Double
    If TypeName(ActiveSheet) <> "Worksheet" Then Exit Function
    If Dir(PictureFileName) = "" Then Exit Function


 ' import picture
    Set p = ActiveSheet.Pictures.Insert(PictureFileName)


 ' determine positions
    With TargetCell
        t = .Top
        l = .Left
        w = .width
        h = .Height
    End With

 ' position picture
    With p
        .ShapeRange.LockAspectRatio = msoTrue
        .Top = t
        .Left = l
        .Height = h
        .width = w
        .Name = "PeoplePlantPlanDrawing"
    End With
     
    If Not p Is Nothing Then Set InsertPeoplePlantPlan = p
    
End Function

but I cannot then rotate it, move it or resize it?

This is driving me crazy... can anyone help me please?