How can I add protect/unprotect sheet to this code?

[James Norton]

Good day,

I have the code below on my sheet and want to keep the page protected other
than when this code runs. How can I unprotect at the beginning of this code
and then reprotect it at the end. If I don't unprotect before running this
script I get a error code "400".

Many thanks,

James Norton



Sub test()
Application.ScreenUpdating = False
Dim i As Integer, p As Picture, r As Range, c As Range, ii As Integer
ii = 1
Set r = ActiveSheet.Range("G5:G14")
ActiveSheet.DrawingObjects.Delete
For Each c In r
ii = ii + 1
If c <> "" Then
With Application.FileSearch
..NewSearch
..LookIn = "c:\drugpics"
..SearchSubFolders = False
..Filename = "*" & c & ".jpg"
..Execute
For i = 1 To .FoundFiles.Count
With ActiveSheet
Set p = .Pictures.Insert(Application.FileSearch.FoundFiles(i))
..DrawingObjects(p.Name).Left = .Columns(ii).Left
..DrawingObjects(p.Name).Top = .Rows(16).Top
..DrawingObjects(p.Name).Width = .Columns(ii + 1).Left - .Columns(ii).Left
..DrawingObjects(p.Name).Height = .Rows(17).Top - .Rows(16).Top
..DrawingObjects(p.Name).Placement = xlMoveAndSize
..DrawingObjects(p.Name).PrintObject = True
End With
Exit For
Next i
End With
End If
Next c
Application.ScreenUpdating = True
End Sub

 

[Paul B]

James, you had two ways to do it in your post on the 19th, did it not work?
one way

Sub test()
Application.ScreenUpdating = False
ActiveSheet.Unprotect password:="" ' if you have a password put it between
the "" , like this "mypassword"
Dim i As Integer, p As Picture, r As Range, c As Range, ii As Integer
ii = 1
Set r = ActiveSheet.Range("G5:G14")
ActiveSheet.DrawingObjects.Delete
For Each c In r
ii = ii + 1
If c <> "" Then
With Application.FileSearch
..NewSearch
..LookIn = "c:\drugpics"
..SearchSubFolders = False
..Filename = "*" & c & ".jpg"
..Execute
For i = 1 To .FoundFiles.Count
With ActiveSheet
Set p = .Pictures.Insert(Application.FileSearch.FoundFiles(i))
..DrawingObjects(p.Name).Left = .Columns(ii).Left
..DrawingObjects(p.Name).Top = .Rows(16).Top
..DrawingObjects(p.Name).Width = .Columns(ii + 1).Left - .Columns(ii).Left
..DrawingObjects(p.Name).Height = .Rows(17).Top - .Rows(16).Top
..DrawingObjects(p.Name).Placement = xlMoveAndSize
..DrawingObjects(p.Name).PrintObject = True
End With
Exit For
Next i
End With
End If
Next c
ActiveSheet.Protect password:="" ' if you have a password put it between the
"" , like this "mypassword"
Application.ScreenUpdating = True
End Sub

Or from Ron to protect all sheets on open with user interface only, so the
macros will run on the protected sheet, put in thisworkbook code, save the
workbook colse it and reopen it, her has the password set as ABCD change to
your password or just use "" for no password, please do not post to more
than one group or start another post, if something does not work just post
back

Private Sub Workbook_Open()
Dim sh As Worksheet
Application.ScreenUpdating = False
For Each sh In ThisWorkbook.Worksheets
sh.Protect "ABCD", , , userinterfaceonly:=True
Next sh
Application.ScreenUpdating = True
End Sub

--
Paul B
Always backup your data before trying something new
Please post any response to the newsgroups so others can benefit from it
Feedback on answers is always appreciated!
Using Excel 2000 & 2003
** remove news from my email address to reply by email **

 

[Paul B]

James, text wrap got the other code, copy and paste this one

Sub test()
Application.ScreenUpdating = False
ActiveSheet.Unprotect password:="" ' if you have a password put it between
'the "" , like this "mypassword"
Dim i As Integer, p As Picture, r As Range, c As Range, ii As Integer
ii = 1
Set r = ActiveSheet.Range("G5:G14")
ActiveSheet.DrawingObjects.Delete
For Each c In r
ii = ii + 1
If c <> "" Then
With Application.FileSearch
..NewSearch
..LookIn = "c:\drugpics"
..SearchSubFolders = False
..Filename = "*" & c & ".jpg"
..Execute
For i = 1 To .FoundFiles.Count
With ActiveSheet
Set p = .Pictures.Insert(Application.FileSearch.FoundFiles(i))
..DrawingObjects(p.Name).Left = .Columns(ii).Left
..DrawingObjects(p.Name).Top = .Rows(16).Top
..DrawingObjects(p.Name).Width = .Columns(ii + 1).Left - .Columns(ii).Left
..DrawingObjects(p.Name).Height = .Rows(17).Top - .Rows(16).Top
..DrawingObjects(p.Name).Placement = xlMoveAndSize
..DrawingObjects(p.Name).PrintObject = True
End With
Exit For
Next i
End With
End If
Next c
ActiveSheet.Protect password:="" ' if you have a password put it between
'the "" , like this "mypassword"
Application.ScreenUpdating = True
End Sub


--
Paul B
Always backup your data before trying something new
Please post any response to the newsgroups so others can benefit from it
Feedback on answers is always appreciated!
Using Excel 2000 & 2003
** remove news from my email address to reply by email **

 

[James Norton]

Hi Paul,

Thank you very much for your assistance with this code, it works perfectly!
I responded to the group on the 20th asking for further assistance because
it didn't work.

I am very grateful for your help Paul.

Best regards,

James Norton

 

[Paul B]

James, your welcome

--
Paul B
Always backup your data before trying something new
Please post any response to the newsgroups so others can benefit from it
Feedback on answers is always appreciated!
Using Excel 2000 & 2003
** remove news from my email address to reply by email **