Soru Şifreli Butonda Revizyon Yapmak

[TURKOLOG]

Sub Yetki_Sayfasi_MailAt()
    Dim DsyYol, Dsy, OutApp, OutMail, Sifre, MailSayf, InpSifre
    Sifre = "10"
    Set MailSayf = Worksheets("yetki")
Basadon:
    InpSifre = InputBox("Sifre gir..", "Calisma Kitabi Sifresi")
    If InpSifre = "" Then Exit Sub
    If InpSifre = Sifre Then
        Application.ScreenUpdating = False
        ThisWorkbook.Unprotect Sifre
        MailSayf.Visible = True
        On Error Resume Next
        ThisWorkbook.Worksheets(MailSayf.Name).Copy
        DsyYol = CreateObject("WScript.Shell").SpecialFolders("Desktop") + "\"
        Dsy = MailSayf.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")
        Set OutApp = CreateObject("Outlook.Application")
        Set OutMail = OutApp.CreateItem(0)
        ActiveWorkbook.SaveAs DsyYol & Dsy
        With OutMail
            .To = "kumsalfelek@hotmail.com"
            .CC = "kumsalfelek@hotmail.com"
            .Subject = Dsy
            .Body = "Merhaba ," & Chr(13) & Chr(13) & "Bilginize.." & Chr(13) & Chr(13) & "İyi calismalar..."
            .Attachments.Add ActiveWorkbook.FullName
            .Display
            '.Send  Mail atilmasi icin tirnagi kaldir
        End With
        ActiveWorkbook.Close SaveChanges:=False
        Kill DsyYol & Dsy & ".xlsx"
        Set OutMail = Nothing
        Set OutApp = Nothing
        MailSayf.Visible = False
        ActiveWorkbook.Protect Sifre
        Application.ScreenUpdating = False
    Else
        MsgBox "Sifer yanlis tekrar deneyiniz.."
        GoTo Basadon
    End If
End Sub

Yukarıdaki kodla 10 şifresini giren mail atabiliyor . Benim yapmak istediğim şifreyi oraya yazmak değil şifreyi belirli bir konumdak çekmek konum şu:

yer = Worksheets("yetki").Shapes("sifre").OLEFormat.Object.Characters.Text

Şifrenin saklı olduğu yerin tam kodlarını da paylaşayım yardımcı olması açısından

Private Sub CommandButton5_Click()
'MsgBox Worksheets("yetki").Shapes("sifre").OLEFormat.Object.Characters.Text
yer = Worksheets("yetki").Shapes("sifre").OLEFormat.Object.Characters.Text
parametre = InputBox("Yetkileri değiştirebilmeniz için giriş şifresini giriniz  şifre ", "uyarı!")
If parametre <> yer Then
MsgBox "Yanlış şifre girdiniz"
'End
Exit Sub
End If


For k = 1 To MultiPage1.Pages.Count - 1
'MultiPage1.Pages.Item(MultiPage1.Pages(k).Caption).Enabled = True
MultiPage1.Pages(k).Enabled = True
Next k
End Sub

benim istediğim kaba tabiri ile

Sub Yetki_Sayfasi_MailAt()
Dim DsyYol, Dsy, OutApp, OutMail, Sifre, MailSayf, InpSifre
Sifre = "10" BURADAKİ 10 ŞİFRESİ YERİNE

yer = Worksheets("yetki").Shapes("sifre").OLEFormat.Object.Characters.Text Buradaki şifreyi kullanması

 

[TURKOLOG]

Şifre =yer. Diye denedim olmadı

 

[TURKOLOG]

Sub Yetki_Sayfasi_PDF_Yap()
       Dim yer, Sifre, MailSayf, InpSifre, DsyYol, Dsy
      
yer = Worksheets("yetki").Shapes("sifre").OLEFormat.Object.Characters.Text
    Sifre = yer
    Set MailSayf = Worksheets("yetki")
Basadon:
    InpSifre = InputBox("Sifre gir..", "Ana Yetkili Şifresini Giriniz")
    If InpSifre = "" Then Exit Sub
    If InpSifre = Sifre Then
        Application.ScreenUpdating = False
        ThisWorkbook.Unprotect Sifre
        MailSayf.Visible = True
        On Error Resume Next
        ThisWorkbook.Worksheets(MailSayf.Name).Copy
        DsyYol = CreateObject("WScript.Shell").SpecialFolders("Desktop") + "\"
        Dsy = MailSayf.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")
        
        ActiveWorkbook.SaveAs DsyYol & Dsy
        With PDF
            
            
            
            
         Dim yaz, i As Integer, a As Integer, say As Long
Application.DisplayAlerts = False
Application.ScreenUpdating = False
MailSayf = Sheets("yetki").Range("a1:a4").Value
Sheets.Add.Name = "yetki"
For i = 1 To Sheets.Count
    For a = LBound(MailSayf) To UBound(MailSayf)
        If MailSayf(a, 1) = Sheets(i).Name Then
            Sheets(i).Range("a1:ı1000").Copy _
            Sheets("yetki").Range("a" & say + 2)
            say = Sheets("yetki").UsedRange.Rows.Count
        End If
    Next a
Next i
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
        Environ("homedrive") & Environ("homepath") & "\Desktop\evn.pdf", Quality:= _
        xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True

Application.DisplayAlerts = True
Application.ScreenUpdating = True
Erase MailSayf
i = Empty: a = Empty: say = Empty
            
            
            
            
            
            
            
            
            
            
            
        End With
        ActiveWorkbook.Close SaveChanges:=False
        Kill DsyYol & Dsy & ".xlsx"
        Set OutMail = Nothing
        Set OutApp = Nothing
        MailSayf.Visible = False
        ActiveWorkbook.Protect Sifre
        Application.ScreenUpdating = False
    Else
        MsgBox "Sifer yanlis tekrar deneyiniz.."
        GoTo Basadon
    End If

       End Sub

yetki Sayfasını PDF yap bir türlü yapamadım aynı mantıkla yetki sayasını pdf yapacak

 

[TURKOLOG]

Yardımcı olabilecek olan var mi

 

[TURKOLOG]

Pdf sayfasını excel kitabının içerisindeki Sabitler sayfasının A5 hücresinde yazan isimle B5 Hücresindeki yola kaydedecek

 

[TURKOLOG]

Bu konuda yardım edebilecek olan var mı.