Filed under: Excel VBA 範例, Top, Workbook

工作表不能編輯及查看公式-Status bar

by chijanzen on 五月 24th, 2009 | View: 3,145 views

Tags

No Tags

Comments (1)

索引	D0016
主題	工作表不能編輯及查看公式-Status bar
版本	>= 9.0(Office 2000)
說明	本範例在"資料編輯列"新增一個statusbar來取代"資料編輯列"的功能，使用者只能在"資料編輯列"看到儲存格的值，不能編輯及查看公式
參考

Code

Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, _
ByVal nCmdShow As Long) As Long
Private Const SW_HIDE = 0
Private Const SW_SHOW = 5
　

Private Sub Workbook_Activate()
ShowWindow SbarHwnd, SW_SHOW
End Sub
　

Private Sub Workbook_BeforeClose(Cancel As Boolean)
DestroyWindow SbarHwnd
End Sub
　

Private Sub Workbook_Deactivate()
ShowWindow SbarHwnd, SW_HIDE
End Sub
　

Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, _
ByVal Target As Range, Cancel As Boolean)
Cancel = True
End Sub
　

Private Sub Workbook_Open()
SetFormulaBar
End Sub
　

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, _
ByVal Target As Range)
SetText 0, Target(1, 1).Value
End Sub
　

Code

Sub ProtectSheet()
    '刪除先前定義的允許使用者可編輯範圍(Title:="Range1")
    UnProtectSheet
    '工作表處於保護狀態時仍能修改
    Cells.Locked = False
    '工作表處於保護狀態時隱藏公式
    Cells.FormulaHidden = True
    '可在受保護工作表中編輯所有儲存格
    ActiveSheet.Protection.AllowEditRanges.Add Title:="Range1", Range:=Cells
    '保護工作表，但是允許所有的編輯功能
    ActiveSheet.Protect _
            AllowFormattingCells:=True, AllowFormattingColumns:=True, _
            AllowFormattingRows:=True, AllowInsertingColumns:=True, _
            AllowInsertingRows:=True, AllowInsertingHyperlinks:=True, _
            AllowDeletingColumns:=True, AllowDeletingRows:=True, _
            AllowSorting:=True, AllowFiltering:=True, _
            Password:="chijanzen"
End Sub
　

Sub UnProtectSheet()
    On Error Resume Next
    ActiveSheet.Unprotect ("chijanzen")
    ActiveSheet.Protection.AllowEditRanges("Range1").Delete
    Error = 0
End Sub
　　

Code

Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal _
        lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function InitCommonControlsEx Lib "comctl32.dll" _
        (lpInitCtrls As tagInitCommonControlsEx) As Boolean
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" _
        (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, _
        ByVal lpsz2 As String) As Long
Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, _
        lpRect As RECT) As Long
Private Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" _
        (ByVal dwExStyle As Long, ByVal lpClassName As String, _
        ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal X As Long, _
        ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, _
        ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, _
        ByRef lpParam As Any) As Long
Public Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
        (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, _
        lParam As Any) As Long
'// Windows 訊息和風格
Public Const WM_USER = &H400
Public Const WS_VISIBLE = &H10000000
Public Const WS_CHILD = &H40000000
'// 進度條的風格和訊息
'Public Const PROGRESS_CLASS = "msctls_progress32"
'Public Const PBM_SETPOS = (WM_USER + 2)
'Public Const PBM_SETBARCOLOR = (WM_USER + 9)
'// Control 控制的訊息
Public Const CCM_FIRST = &H2000
Public Const CCM_SETBKCOLOR = (CCM_FIRST + 1)
Public Const SB_SETBKCOLOR = CCM_SETBKCOLOR
'Public Const PBS_SMOOTH = 1
Public hwnd As Long, SbarHwnd As Long, pbhWnd As Long
Private Type RECT
    Left As Long
    Top  As Long
    Right As Long
    Bottom As Long
End Type
Private Type tagInitCommonControlsEx
    lngSize As Long
    lngICC As Long
End Type
　

Sub SetFormulaBar()
    Dim hWndP As Long
    Dim rct As RECT, i As Long
    Const SBARS_SIZEGRIP = &H100
    Const CCS_BOTTOM = &H3&
    Const ICC_BAR_CLASSES = &H4
    Const STATUSCLASSNAME = "msctls_statusbar32"   'Status bar 狀態條
    Const SB_SETPARTS = WM_USER + 1  '此消息能幫助應用程序自定義私有消息；
    Dim iccex As tagInitCommonControlsEx, meHwnd As Long
    Dim adwParts(2) As Long, dwRtn As Long, X As Single
    With iccex
        .lngSize = LenB(iccex)
        .lngICC = ICC_BAR_CLASSES
    End With
    Call InitCommonControlsEx(iccex)
    hwnd = FindWindow("XLMAIN", Application.Caption)
    hWndP = FindWindowEx(hwnd, 0, "EXCEL<", vbNullString)
    GetClientRect hWndP, rct
    X = rct.Right - rct.Left
    dwRtn = WS_VISIBLE Or WS_CHILD Or CCS_BOTTOM   ' Or SBARS_SIZEGRIP '小三角形
    SbarHwnd = CreateWindowEx(0, STATUSCLASSNAME, "", _
            dwRtn, 0, 0, 0, 0, hWndP, 0, 0, 0)
    adwParts(0) = X
    SendMessage SbarHwnd, SB_SETPARTS, ByVal 1, adwParts(0)
    SetText 0, ActiveCell.Value
End Sub
　

Sub SetText(Optional bPart As Byte = 0, Optional sText As String = "")
Const SB_SETTEXT = (WM_USER + 1)
SendMessage SbarHwnd, SB_SETTEXT, ByVal bPart, ByVal sText
End Sub
　