Signature Macro

[vman5781]

I am using the below macro to insert a signature (jpeg file) into a set cell area. When setting the macro the signature is sized to the cell and saved (fits perfectly). When reopening the spreadsheet and selecting the macro button the signature is large and does not appear in the cell that was set up. Can anyone give me some ideas to rewrite the macro so it automatically sizes according to the cell sixe and places the signature in the cell that the cursor is in?


Sub Macro7()
'
' Macro7 Macro
'
'
ActiveSheet.Pictures.Insert("G:\SIGNATURE\signature.jpg").Select
Selection.ShapeRange.IncrementLeft 18
Selection.ShapeRange.IncrementTop 13.5
Selection.ShapeRange.ScaleWidth 5.0376254181, msoFalse, msoScaleFromTopLeft
Selection.ShapeRange.ScaleHeight 5.0376248072, msoFalse, msoScaleFromTopLeft
Selection.ShapeRange.ScaleHeight 0.8953245728, msoFalse, msoScaleFromTopLeft
Selection.ShapeRange.ScaleWidth 1.2946062448, msoFalse, msoScaleFromTopLeft
Range("C17").Select

End Sub

 

[vman5781]

All,

I have researched an found the below VBA (2004), which works with the exception of the sizing still is a little funky



1) I want to have the "item" inserted into the active cell

2) the active cell will be different on each tab (different people have +/- lines)

3) the inserted item will be the same for all ( file is saved on individual's own g:\signature\signature.jpg)

I have tried several things, but have debugging issues, signature will come in small and not auto size, and will come in the upper left corner (not auto center)

Any help would be appreciated

Thank you





Option Explicit

Sub InsertPicture()

Dim sFileName As String
Dim oPic As Picture

' Prompt user to select a picture
sFileName = Application.GetOpenFilename( _
FileFilter:="Pictures (*.bmp;*.gif;*.jpeg;*.jpg;*.png), *.bmp;*.gif;*.jpeg;*.jpg;*.png", _
Title:="Select a picture . . .")

' If user cancels, exit the sub
If sFileName = "False" Then Exit Sub

' Insert picture in activesheet
Set oPic = ActiveSheet.Pictures.Insert(sFileName)

' Adjust the size of the picture to fit within the entire active cell
With oPic
.ShapeRange.LockAspectRatio = msoFalse
.Left = ActiveCell.Left
.Top = ActiveCell.Top
.Width = ActiveCell.Width
.Height = ActiveCell.Height
End With

End Sub

 

[pbornemeier]

(Responding to PM: Can you look at my threads in regards to inserting a signature. I am having an issue with it resizing and centering)

When I run the code in post #2 the picture is automatically resized to fill the selected cell.
This usually distorts the image (unless the H/W ratio matches between cell and picture)

You say "signature will come in small and not auto size, and will come in the upper left corner (not auto center)" Which is not what is happening when I run the code.

What is the size of a typical selected cell?
What is the size of a typical signature?
If you resize the image to original size and proportions is it smaller than the selected cell?
Please explain the procedure you are using to save the signature.
What exactly do you want to do with your code?

 

[vman5781]

Phil,

I have done some playing around with the above, an realize it does resize it. The only issue I have is if I could have it automatically select G:\signature\signatue.jpg instead of prompting to pick a picture.

Can you help with that ? I have tried changing that line but I get an error - not sure if inserting correctly

John

 

[pbornemeier]

Option Explicit

Sub InsertPicture()

    Dim sFileName As String
    Dim oPic As Picture
    
    'Prompt user to select a picture
    'sFileName = Application.GetOpenFilename( _
    'FileFilter:="Pictures (*.bmp;*.gif;*.jpeg;*.jpg;*.png), *.bmp;*.gif;*.jpeg;*.jpg;*.png", _
    'Title:="Select a picture . . .")
    '
    ''If user cancels, exit the sub
    'If sFileName = "False" Then Exit Sub
    
    sFileName = "G:\Signature\Signature.jpg"

    ' Insert picture in activesheet
    Set oPic = ActiveSheet.Pictures.Insert(sFileName)
    
    ' Adjust the size of the picture to fit within the entire active cell
    With oPic
        .ShapeRange.LockAspectRatio = msoFalse
        .Left = ActiveCell.Left
        .Top = ActiveCell.Top
        .Width = ActiveCell.Width
        .Height = ActiveCell.Height
    End With

End Sub

 

[vman5781]

Phil,

I have adjusted the code to look like the below -- I just need to make one last adjustment. If "Joe" inserts his "signature", and saves, when I go in the area where he put his signature shows my signature. How can I lock the cell after someone inserts their signature?

CODE:

Sub InsertPicture()
Dim sFileName As String
Dim oPic As Picture


sFileName = "G:\Signature\Signature.jpg"
Set oPic = ActiveSheet.Pictures.insert(sFileName)

With oPic
.ShapeRange.LockAspectRatio = msoFalse
.Left = ActiveCell.Left
.Top = ActiveCell.Top
.Width = ActiveCell.Width
.Height = ActiveCell.Height
End With
End Sub


Thank you

 

[pbornemeier]

The code below will prevent a signature from being applied if more than one cell is selected or if the selected cell overlaps any picture.

However...

None of the code in this thread is secure since any picture (even one containing someone elses signature) can be inserted by anyone.

A better (although not perfect in a legal sense) way to verify who signs a worksheet would be to have the user add a comment to a specified signature cell. The system records who was signed in when the comment was added and it is displayed in the bottom left of the screen in the status bar.

The user would then have to protect the sheet by adding a password to prevent further changes.

Option Explicit
 
Sub InsertPicture()
    Dim sFileName As String
    Dim oPic As Picture
    Dim shp As Shape
   
    sFileName = "G:\Signature\Signature.jpg"

   
    'Don't insert if a range is not selected
    If TypeName(Selection) <> "Range" Then
        MsgBox "A range was not selected"
        GoTo End_Sub
    End If
   
    'Don't insert if more than 1 area selected
    If Selection.Areas.Count > 1 Then
        MsgBox "More than one area selected"
        GoTo End_Sub
    End If
   
    'Don't insert if more than 1 cell selected
    If Selection.Cells.Count > 1 Then
        MsgBox "More than one cell selected"
        GoTo End_Sub
    End If
   
    'Don't insert if ANY picture overlaps the selected cell
    For Each shp In ActiveSheet.Shapes
        If Not Intersect(Range(shp.BottomRightCell, shp.TopLeftCell), ActiveCell) Is Nothing Then
            MsgBox "Picture already overlaps " & ActiveCell.Address
            GoTo End_Sub
        End If
    Next
   
    Set oPic = ActiveSheet.Pictures.Insert(sFileName)
   
    With oPic
        .ShapeRange.LockAspectRatio = msoFalse
        .Left = ActiveCell.Left
        .Top = ActiveCell.Top
        .Width = ActiveCell.Width
        .Height = ActiveCell.Height
    End With
   
End_Sub:
 
End Sub

<o></o>