resim alma fonksiyonu olan dosyaya kilit atma

[burhancavus61]

dosyama vba yordamı ile dışarıdan resim alıyorum sayfayı koruma altına aldığım zaman fonksiyon çalışmıyor sayfa kilitsiz oldumu çalışıyor kilitli iken çalışması için ne yapmalıyım yardımlarınız için şimdiden tşk

 

[danersin]

Kod çalışırken korumayı kaldırıp sonra tekrar koyabilirsiniz
Kodların ilk satırına
Worksheets("Sayfa1").Unprotect Password:="şifreniz"

son satırına
Worksheets("Sayfa1").Protect Password:="şifreniz"

 

[burhancavus61]

kodlar burada beceremedim

Option Base 1
Const Vital = "IZIN BIL."
Const Lock_String = "Sayfayı Kilitle/Kilidi Aç"
Const cWorksheet = "Worksheet"
'Logo İçin Gerekli
Sub InsertLogo()

'Kullanıcının özel bir amblem girmesine izin verir
Dim LoopL As Integer
Dim LogpPic As Variant
Dim Err_Flg As Boolean
If Sheets(Vital).DrawingObjects("Lock").Caption = Lock_String Then

ShtMem = ActiveSheet.Index

Sheets(Vital).Activate
Set Mem = ActiveCell

With ActiveSheet.DrawingObjects("LG")
lgl = .Left
lgt = .Top
lgw = .Width
lgh = .Height
End With

On Error GoTo Err_1B

If Application.Dialogs(xlDialogInsertPicture).Show Then

Application.ScreenUpdating = False

ActiveSheet.DrawingObjects("LG").Delete

On Error GoTo Err_2

With Selection
.Left = lgl
.Top = lgt
.Width = lgw
.Height = lgh
.Width = lgw
.Name = "LG"
.OnAction = "Nada"
.Copy
End With

Mem.Select

For Each ThisSheet In Sheets
If TypeName(ThisSheet) = cWorksheet Then

ThisSheet.Activate
Set Mem = ActiveCell
ActiveSheet.DrawingObjects("LG").Select

If Not Err_Flg Then

With ActiveSheet.DrawingObjects("LG")
lgl = .Left
lgt = .Top
lgw = .Width
lgh = .Height
.Delete
End With

ActiveSheet.Paste

With Selection
.Left = lgl
.Top = lgt
.Width = lgw
.Height = lgh
.Name = "LG"
.OnAction = "Nada"
End With

Else
Err_Flg = False
End If

Mem.Select
End If
Next

Sheets(ShtMem).Activate
End If

Else

MsgBox Logo_Error, vbCritical, SheetBar

End If

On Error GoTo 0
'Application.ScreenUpdating = True
Exit Sub

Err_1B:

MsgBox Error(Err), vbCritical + vbOKOnly, SheetBar
Err = 0
'Application.ScreenUpdating = True
On Error GoTo 0
Exit Sub

Err_2:

If Err <> 1004 And Err <> 1006 Then

Msg = Univ_Error & Str(Err) & ": " & Error(Err)
MsgBox Msg, vbCritical, SheetBar
Err = 0
Else
Err_Flg = True
Err = 0
Resume Next
End If

Sheets(ShtMem).Activate
On Error GoTo 0
'Application.ScreenUpdating = True

End Sub


Sub Nada()
'Bu alan bilerek boş bırakılmıştır
End Sub