pasif menüleri nasıl açabilirim

[hoguz2]

arkadaslar merhaba değiştirmeye çalıştığım kodlar var. kodlar menüleri pasif yapmış bakablir misiniz acaba excel menülerini tekrar aktif yapmak iicn hangi kodları silmeliyim.

iyi calismalar

Dim blnClosing As Boolean
Dim oApp As clsAppEvent

Private Sub Workbook_Activate()



SetControls
SetToolBar
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim sRepName As String
Dim actWbName As String
blnClosing = True
If toolDel = False Then Exit Sub
'MsgBox "Before Close"
sRepName = Sheets("Main Menu").Range("PRE_REP").Value
actWbName = "Sales Planning File_" & sRepName & "_" & Format(Date, "dd-MMM-yy")
If (ActiveWorkbook.Name = actWbName) Then Exit Sub
Application.CommandBars("Sunrise Tool Lite").Delete
End Sub
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
shtMainMenu.CloseAdminButtons
End Sub

Private Sub Workbook_Deactivate()
'Delete the toolbar
Dim wrkbook As Workbook
Dim wrksheet As Worksheet
Dim iCntBook As Integer
On Error Resume Next
iCntBook = 0
ResetControls
If blnClosing Then
For Each wrkbook In Application.Workbooks
If InStr(LCase(wrkbook.Name), "spancop") > 0 Then
Set wrksheet = wrkbook.Worksheets("Main Menu")
If Not wrksheet Is Nothing Then
If wrksheet.Range("I4").Value = "DSPANCOP" Then
iCntBook = iCntBook + 1
End If
End If
End If
Next
If iCntBook <= 1 Then
If Application.Workbooks.Count > 1 Then
iCntBook = 0
For Each wrkbook In Application.Workbooks
For Each wrksheet In wrkbook.Worksheets
If wrksheet.Name = "Main Menu" Then
If wrksheet.Range("I4").Value = "DSPANCOP" Then
iCntBook = iCntBook + 1
Exit For
End If
End If
Next
If iCntBook > 1 Then Exit For
Next
End If
If iCntBook > 1 Then Exit Sub
Application.CommandBars("Sunrise Tool Lite").Delete
End If
End If
ResetControls
End Sub

Private Sub Workbook_Open()
Dim objNetwork As Object
Dim iResult As VbMsgBoxResult

blnClosing = False
shtMainMenu.CloseAdminButtons
shtSalesPlanning.Unprotect gPASSWORD
'MsgBox "shtSalesPlanning.AutoFilterMode=" & shtSalesPlanning.AutoFilterMode

If Not shtSalesPlanning.AutoFilterMode Then
shtSalesPlanning.Range("A3").AutoFilter
End If

With shtSalesPlanning
.Range("O2").Comment.Text shtRefData.Range("Y68").Value ' S
.Range("P2").Comment.Text shtRefData.Range("Y69").Value ' P
.Range("Q2").Comment.Text shtRefData.Range("Y70").Value ' A
.Range("R2").Comment.Text shtRefData.Range("Y71").Value ' N
.Range("S2").Comment.Text shtRefData.Range("Y72").Value ' C
.Range("T2").Comment.Text shtRefData.Range("Y73").Value ' O
.Range("U2").Comment.Text shtRefData.Range("Y74").Value ' P
End With
shtSalesPlanning.EnableAutoFilter = True
shtSalesPlanning.Protect gPASSWORD, True, True, True, True
'MsgBox "shtSalesPlanning.EnableAutoFilter =" & shtSalesPlanning.EnableAutoFilter

'Update the field header that still marked with old year
If shtRefData.Range("REF_YEAR").Value <> Year(Date) Then
shtAdminLangFields.Unprotect gPASSWORD
shtAdminLangFields.Columns("C:C").Replace shtRefData.Range("REF_YEAR").Value, Year(Date), xlPart, xlByRows, False
shtAdminLangFields.Protect gPASSWORD
shtRefData.Range("REF_YEAR").Value = Year(Date)
End If


If shtMainMenu.Range("PRE_REP").Value = "My_name" Then
'And shtAdminSetting.Range("REF_SYS_REPNAME").Value <> 1 Then
iResult = MsgBox("Do you want to update " & shtMainMenu.Range("B3").Value & " name to your user name now?", vbYesNoCancel + vbDefaultButton3, "Set " & shtMainMenu.Range("B3").Value & " name")
Select Case iResult
Case vbYes
Set objNetwork = CreateObject("wscript.network")
shtMainMenu.Range("PRE_REP").Value = objNetwork.UserName
Set objNetwork = Nothing
shtAdminSetting.Unprotect gPASSWORD
shtAdminSetting.Range("REF_SYS_REPNAME").Value = 1
shtAdminSetting.Protect gPASSWORD, True, True, True, True
Case vbNo
shtAdminSetting.Unprotect gPASSWORD
shtAdminSetting.Range("REF_SYS_REPNAME").Value = 1
shtAdminSetting.Protect gPASSWORD, True, True, True, True
End Select
End If
'Update all Text to localised text
With shtMainMenu
.Unprotect gPASSWORD
.cmdConsolidate.Caption = shtRefData.Range("Y24").Value
.cmdGenerateDataFile.Caption = shtRefData.Range("Y25").Value
.cmdSendEntireFile.Caption = shtRefData.Range("Y22").Value
.cmdSendReportToAdmin.Caption = shtRefData.Range("Y23").Value
.cmdGotoSalesPlanning.Caption = shtRefData.Range("Y26").Value
.cmdGotoSPANCOPSummary.Caption = shtRefData.Range("Y27").Value
.Protect gPASSWORD
End With
With shtReport
.Unprotect gPASSWORD
'-- Incident:GIM03143245 - updated the reference values after formatting the SPANCOP Summary

'.Range("K3").Comment.Text shtRefData.Range("Y57").Value
'.Range("G13").Comment.Text shtRefData.Range("Y59").Value ' Incremental Target
'.Range("G14").Comment.Text shtRefData.Range("Y61").Value ' Cycle Time
'.Range("G15").Comment.Text shtRefData.Range("Y60").Value ' Total hit Ratio
'.Range("G16").Comment.Text shtRefData.Range("Y58").Value ' Pipeline Strength
'.Range("H3").Comment.Text shtRefData.Range("Y69").Value
'.Range("B21").Comment.Text shtRefData.Range("Y69").Value
'.Range("B22").Comment.Text shtRefData.Range("Y70").Value
'.Range("H8").Comment.Text shtRefData.Range("Y71").Value
'.Range("H9").Comment.Text shtRefData.Range("Y72").Value

'Updated the references for new changes for Oct'08 release
.Range("K3").Comment.Text shtRefData.Range("Y63").Value
.Range("G13").Comment.Text shtRefData.Range("Y65").Value ' Incremental Target
.Range("G14").Comment.Text shtRefData.Range("Y67").Value ' Cycle Time
.Range("G15").Comment.Text shtRefData.Range("Y66").Value ' Total hit Ratio
.Range("G16").Comment.Text shtRefData.Range("Y64").Value ' Pipeline Strength
.Range("G16").Comment.Text shtRefData.Range("Y64").Value ' Pipeline Strength

.Range("H3").Comment.Text shtRefData.Range("Y75").Value
.Range("B21").Comment.Text shtRefData.Range("Y75").Value
'.Range("B22").Comment.Text shtRefData.Range("Y76").Value
.Range("H8").Comment.Text shtRefData.Range("Y77").Value
.Range("H9").Comment.Text shtRefData.Range("Y78").Value

.Protect gPASSWORD

End With

shtSummProduct.Unprotect gPASSWORD
shtSummProduct.Range("D5").Comment.Text shtRefData.Range("Y73").Value
shtSummProduct.Protect gPASSWORD

shtSummSalesRep.Unprotect gPASSWORD
shtSummSalesRep.Range("D5").Comment.Text shtRefData.Range("Y73").Value
shtSummSalesRep.Protect gPASSWORD
'UpdateRemarkFields
SetControls
SetToolBar
Set oApp = New clsAppEvent
Set oApp.App = Application

End Sub

Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
On Error Resume Next

If ActiveSheet.Name = "Sales Planning" Then
If Not Intersect(Target, Range("REMARK_COLS_NEW")) Is Nothing Or Not Intersect(Target, Range("REM_COL1_COL2")) Is Nothing Then
shtSalesPlanning.Unprotect gPASSWORD
Else
shtSalesPlanning.Protect gPASSWORD, True, True, True, True
End If
End If
End Sub

Private Sub Workbook_SheetBeforeRightClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)

'On Error Resume Next
'
If ActiveSheet.Name = "Sales Planning" Then

Select Case Not Intersect(Target, Range("REMARK_COLS_NEW")) Is Nothing Or Not Intersect(Target, Range("REM_COL1_COL2")) Is Nothing

Case "True"
shtSalesPlanning.Unprotect gPASSWORD
Application.CommandBars("Cell").Controls.Add ID:=443
Application.CommandBars("Cell").Controls("Freeze Panes").Delete
Case "False"
shtSalesPlanning.Protect gPASSWORD, True, True, True, True
End Select


' If Not Intersect(Target, Range("REMARK_COLS_NEW")) Is Nothing Then
' 'Not Intersect(Target, Range("REM_COL1_COL2")) Or
' 'MsgBox Intersect(Target, Range("REM_COL1_COL2"))
' shtSalesPlanning.Unprotect gPASSWORD
' Application.CommandBars("Cell").Controls.Add ID:=443
' Application.CommandBars("Cell").Controls("Freeze Panes").Delete
' Else
' shtSalesPlanning.Protect gPASSWORD, True, True, True, True
' End If

' If Not Intersect(Target, Range("REMARK_COLS_NEW")) Is Nothing Then
' shtSalesPlanning.Unprotect gPASSWORD
' Application.CommandBars("Cell").Controls.Add ID:=443
' Application.CommandBars("Cell").Controls("Freeze Panes").Delete
' Else
' shtSalesPlanning.Protect gPASSWORD, True, True, True, True
' End If
'' End If
End If
End Sub

Private Sub Workbook_WindowActivate(ByVal Wn As Window)
blnClosing = False
End Sub

Private Sub SetControls()
Dim icbc As CommandBarControl
For Each icbc In Application.CommandBars("edit").Controls 'remove paste special and paste hyperlink command
If icbc.Caption = "Cu&t" Or icbc.Caption = "Paste &Special..." Or icbc.Caption = "Paste as &Hyperlink" Then
icbc.Visible = False
ElseIf icbc.Caption = "&Paste" Then
If icbc.Type <> msoControlSplitButtonPopup Then
icbc.OnAction = "thisworkbook.pastes"
End If
ElseIf icbc.Caption = "&Copy" Then
icbc.OnAction = "thisworkbook.copy"
End If
Next icbc

For Each icbc In Application.CommandBars("Standard").Controls
If icbc.Caption = "Cu&t" Or icbc.Caption = "&Format Painter" Then
icbc.Visible = False
ElseIf icbc.Caption = "&Paste" Then
If icbc.Type <> msoControlSplitButtonPopup Then
icbc.OnAction = "thisworkbook.pastes"
End If
ElseIf icbc.Caption = "&Copy" Then
icbc.OnAction = "thisworkbook.copy"
End If
Next icbc

For Each icbc In Application.CommandBars("cell").Controls
If icbc.Caption = "Cu&t" Or icbc.Caption = "Paste &Special..." Then
icbc.Visible = False
ElseIf icbc.Caption = "&Paste" Then
If icbc.Type <> msoControlSplitButtonPopup Then
icbc.OnAction = "thisworkbook.pastes"
End If
ElseIf icbc.Caption = "&Copy" Then
icbc.OnAction = "thisworkbook.copy"
End If
Next icbc

Application.OnKey "^v", "thisworkbook.pastes" 'change the paste function to paste value only
Application.OnKey "^x", "" 'disable the cut command
Application.OnKey "^c", "thisworkbook.copy"
If oApp Is Nothing Then
Set oApp = New clsAppEvent
Set oApp.App = Application
End If
End Sub

Private Sub ResetControls()
Application.OnKey "^v"
Application.OnKey "^x"
Application.OnKey "^c"
Application.CommandBars("Cell").Reset
Application.CommandBars("Standard").Reset
Application.CommandBars("Edit").Reset
Application.StatusBar = False
End Sub

Private Sub pastes()
On Error Resume Next
If ActiveWindow.RangeSelection.Locked Then Exit Sub
If ActiveSheet Is shtSalesPlanning Then
'ActiveSheet.Protect gPASSWORD, True, True, True, False
ActiveSheet.Protect gPASSWORD, True, True, True, False
Set LastSelection = oApp.LastSelection
Application.Range(LastSelection.Address(External:=True)).Copy
End If
ActiveWindow.RangeSelection.PasteSpecial (xlPasteValues) 'paste value command
If ActiveSheet Is shtSalesPlanning Then
'ActiveSheet.Protect gPASSWORD, True, True, True, True
ActiveSheet.Protect gPASSWORD, True, True, True, True
End If
If Err.Number = 400 Then
MsgBox "Unable to paste due to protected cell(s)", vbCritical, "Excel Error"
ElseIf Err Then
MsgBox Err.Description, vbCritical, "Excel"
End If
End Sub

Private Sub Copy()
Set oApp.LastSelection = Selection
Selection.Copy
End Sub

Private Sub UpdateRemarkFields()
Dim oSheet1 As Worksheet
Dim oSheet2 As Worksheet

Set oSheet1 = ThisWorkbook.Worksheets("REF_DATA")
Set oSheet2 = ThisWorkbook.Worksheets("Sales Planning")
oSheet2.Unprotect gPASSWORD
If Not IsEmpty(oSheet1.Range("REF_REMARK").Cells(1, 1).Value) Then
oSheet2.Range("SP_S").Comment.Text oSheet1.Range("REF_REMARK").Cells(1, 1).Value
oSheet2.Range("SP_S").Offset(-1, 0).Comment.Text oSheet1.Range("REF_REMARK").Cells(1, 1).Value
End If
If Not IsEmpty(oSheet1.Range("REF_REMARK").Cells(2, 1).Value) Then
oSheet2.Range("SP_P").Comment.Text oSheet1.Range("REF_REMARK").Cells(2, 1).Value
oSheet2.Range("SP_P").Offset(-1, 0).Comment.Text oSheet1.Range("REF_REMARK").Cells(2, 1).Value
End If
If Not IsEmpty(oSheet1.Range("REF_REMARK").Cells(3, 1).Value) Then
oSheet2.Range("SP_A").Comment.Text oSheet1.Range("REF_REMARK").Cells(3, 1).Value
oSheet2.Range("SP_A").Offset(-1, 0).Comment.Text oSheet1.Range("REF_REMARK").Cells(3, 1).Value
End If
If Not IsEmpty(oSheet1.Range("REF_REMARK").Cells(4, 1).Value) Then
oSheet2.Range("SP_N").Comment.Text oSheet1.Range("REF_REMARK").Cells(4, 1).Value
oSheet2.Range("SP_N").Offset(-1, 0).Comment.Text oSheet1.Range("REF_REMARK").Cells(4, 1).Value
End If
If Not IsEmpty(oSheet1.Range("REF_REMARK").Cells(5, 1).Value) Then
oSheet2.Range("SP_C").Comment.Text oSheet1.Range("REF_REMARK").Cells(5, 1).Value
oSheet2.Range("SP_C").Offset(-1, 0).Comment.Text oSheet1.Range("REF_REMARK").Cells(5, 1).Value
End If
If Not IsEmpty(oSheet1.Range("REF_REMARK").Cells(6, 1).Value) Then
oSheet2.Range("SP_O").Comment.Text oSheet1.Range("REF_REMARK").Cells(6, 1).Value
oSheet2.Range("SP_O").Offset(-1, 0).Comment.Text oSheet1.Range("REF_REMARK").Cells(6, 1).Value
End If
If Not IsEmpty(oSheet1.Range("REF_REMARK").Cells(7, 1).Value) Then
oSheet2.Range("SP_P2").Comment.Text oSheet1.Range("REF_REMARK").Cells(7, 1).Value
oSheet2.Range("SP_P2").Offset(-1, 0).Comment.Text oSheet1.Range("REF_REMARK").Cells(7, 1).Value
End If
'oSheet2.Protect gPASSWORD, True, True, True, True
oSheet2.Protect gPASSWORD, True, True, True, True
End Sub

Private Sub Workbook_WindowDeactivate(ByVal Wn As Window)
ResetControls
End Sub

Private Sub SetToolBar()
Dim cmdPopup As CommandBarPopup
With Application.CommandBars("Sunrise Tool Lite")
.Controls(1).OnAction = "'" & ThisWorkbook.Name & "'!AddNewRow"
.Controls(2).OnAction = "'" & ThisWorkbook.Name & "'!DeleteRows"
Set cmdPopup = .Controls(3)
cmdPopup.Controls(1).OnAction = "'" & ThisWorkbook.Name & "'!SortData"
cmdPopup.Controls(2).OnAction = "'" & ThisWorkbook.Name & "'!SetAutoColWidth"
cmdPopup.Controls(3).OnAction = "'" & ThisWorkbook.Name & "'!SetColWidth"
End With
Set cmdPopup = Nothing
End Sub

 

[hoguz2]

arkadaşlar sıkıntı gizlenmiş calışma sayfasıymış sorumu biraz değiştiriyorum . shtAdminfilelist diye bir çalışma sayfası olması lazım ama göremiyorum. hangi kodlar shett leri gizliyor.

saygılarımla,

 

[hoguz2]

vba tarafında söz konusu sayfanın properties kısmına gidip aşağıdaki xlhidden yazısını -1 visible yapmaya çalıştığım zaman "worksheet sınıfının visible özelliği kurulamıyor" diye hata veriyoru