FAQ 工作薄及工作表 (Update 8 Aug 2005)

Emily

Sub IsSheetExist()
Dim wSheet As Worksheet
On Error Resume Next
    Set wSheet = Sheets("Sheet6")
        If wSheet Is Nothing Then
            MsgBox "Worksheet does not exist"
            Set wSheet = Nothing
            On Error GoTo 0
        Else
            MsgBox "Sheet does exist"
            Set wSheet = Nothing
            On Error GoTo 0
        End If
End Sub

[此贴子已经被作者于2006-9-27 15:33:32编辑过]

Emily

-----------------  Module

Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, y, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Const HWND_TOPMOST = -1
Private Const HWND_NOTOPMOST = -2
Private Const SWP_NOMOVE = &H2
Private Const SWP_NOSIZE = &H1
Private Const TOPMOST_FLAGS = SWP_NOMOVE Or SWP_NOSIZE

Public Sub MakeNormal(hwnd As Long)
    SetWindowPos hwnd, HWND_NOTOPMOST, 0, 0, 0, 0, TOPMOST_FLAGS
End Sub
Public Sub MakeTopMost(hwnd As Long)
    SetWindowPos hwnd, HWND_TOPMOST, 0, 0, 0, 0, TOPMOST_FLAGS
End Sub

Sub test()
    Call MakeTopMost(Application.hwnd)
    Call MakeNormal(Application.hwnd)
End Sub

[此贴子已经被作者于2006-9-27 15:33:54编辑过]

Emily

Option Explicit

Dim oDpd As Object
Dim sFml1
Dim prvTarget As Range

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    Const dFixedPos As Double = "0.8"
    Const dFixWidth As Double = "16"    'Change here to change WIDTH of the DropDown
    Dim vld As Validation
    Dim lDpdLine As Long

    If Not prvTarget Is Nothing Then
        If Not oDpd Is Nothing Then
            If oDpd.Value = 0 Then
                prvTarget.Value = vbNullString
            Else
                prvTarget.Value = Range(Mid(sFml1, 2)).Item(oDpd.Value)
            End If
            Set prvTarget = Nothing
        End If
    End If

    On Error Resume Next
    oDpd.Delete
    sFml1 = vbNullString
    Set oDpd = Nothing
    On Error GoTo 0

    If Target.Count > 1 Then
        Set oDpd = Nothing
        Exit Sub
    End If

    Set vld = Target.Validation
    On Error GoTo Terminate
    sFml1 = vld.Formula1
    On Error GoTo 0

    Set prvTarget = Target

    lDpdLine = Range(Mid(sFml1, 2)).Rows.Count

    With Target
        Set oDpd = ActiveSheet.DropDowns.Add( _
                                             .Left - dFixedPos, _
                                             .Top - dFixedPos, _
                                             .Width + dFixWidth + dFixedPos * 2, _
                                             .Height + dFixedPos * 2)
    End With
    With oDpd
        .ListFillRange = sFml1
        .DropDownLines = lDpdLine
        .Display3DShading = True
    End With
Terminate:
End Sub

WWyEcAQI.zip (9.13 KB, 下载次数: 462)

2005-4-24 09:48 上传

点击文件名下载附件
FAQ 工作薄及工作表 ｛建立中｝

[此贴子已经被作者于2006-9-27 15:34:31编辑过]

Emily

1.

ActiveWindow.SmallScroll Up:=65536 ActiveWindow.SmallScroll ToLeft:=256 用上面的方法先回到 A1 再用下面的方法到定點 ActiveWindow.SmallScroll Down:=儲存格列號 - 1 ActiveWindow.SmallScroll ToRight:=儲存格欄號 - 1

2.

ActiveCell.Select ActiveWindow.ScrollRow = ActiveCell.Row ActiveWindow.ScrollColumn = ActiveCell.Column

3.

Application.Goto ActiveCell, True

Emily

Sub SaveShtsAsBook() Dim Sheet As Worksheet, SheetName$, MyFilePath$, N& MyFilePath$ = ActiveWorkbook.Path & "\" & _ Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4) With Application .ScreenUpdating = False .DisplayAlerts = False ' End With On Error Resume Next '<< a folder exists MkDir MyFilePath '<< create a folder For N = 1 To Sheets.Count Sheets(N).Activate SheetName = ActiveSheet.Name Cells.Copy Workbooks.Add (xlWBATWorksheet) With ActiveWorkbook With .ActiveSheet .Paste .Name = SheetName [A1].Select End With 'save book in this folder .SaveAs Filename:=MyFilePath _ & "\" & SheetName & ".xls" .Close SaveChanges:=True End With .CutCopyMode = False Next End With Sheet1.Activate End Sub

Emily

Sub BreakExternalLinks()

Dim WS  As Worksheet
Dim Rng1 As Range
Dim Cell As Range

    For Each WS In ActiveWorkbook.Worksheets
        With WS
            On Error Resume Next
            Set Rng1 = Cells.SpecialCells(xlCellTypeFormulas, 23)
            
            '  23 - All formulae
            '  16 - All formulae with errors
            '  2 - All formulae with text
            '  4 - All formulae with logic
            '  6 - All formulae with text or logic

            On Error GoTo 0
            If Not Rng1 Is Nothing Then
                For Each Cell In Rng1
                    If Left(Cell.Formula, 2) = "='" Then
                        Cell.Value = Cell.Value
                    End If
                Next
            End If
            Set Rng1 = Nothing
        End With
    Next
    
End Sub

[此贴子已经被作者于2006-9-27 15:35:13编辑过]

Emily

' chijanzen  (原始) 2003/10/1
' 今天介紹如何讓Excel檔案有使用期限,範例中使用Windows Script"在註冊表上的讀.寫.刪除的用法
' 本範例使用期限設定 0 天,所以檔案只能開啟一次就自動銷毀
' Script 能使用的根鍵值有五個根鍵名稱
HKEY_CURRENT_USER    '縮寫 HKCU
HKEY_LOCAL_MACHINE   '縮寫 HKLM
HKEY_CLASSES_ROOT    '縮寫 HKCR
HKEY_USERS                  '縮寫 HKEY_USERS
HKEY_CURRENT_CONFIG  '縮寫 HKEY_CURRENT_CONFIG

Sub CheckFileDate()
    Dim Counter As Long, LastOpen As String, Msg As String
    If RegRead = "" Then
        Term = 0   '範例用 0 天
        TermDate = DateSerial(Year(Now), Month(Now), Day(Now)) + Term
        MsgBox "本檔案只能使用到" & TermDate & "日" & Chr(13) & "超過期限將自動銷毀"
        RegWrite (Term)
    Else
        If CDate(RegRead) <= Now Then
            RegDelete
            KillMe
        End If
    End If
End Sub
Sub KillMe()
    Application.DisplayAlerts = False
    ActiveWorkbook.ChangeFileAccess xlReadOnly
    Kill ActiveWorkbook.FullName
    ThisWorkbook.Close False
End Sub


Sub RegWrite(Term)
'RegWrite:建立新鍵、將另一個值名稱加入現有鍵 (並將值指派給它)，或變更現有值名稱的值。
    Dim WshShell, bKey
    fname = ThisWorkbook.Name
    TermDate = DateSerial(Year(Now), Month(Now), Day(Now)) + Term
    Regkey = "HKCU\chijanzen\Budget\Date\" & fname
    Set WshShell = CreateObject("WScript.Shell")
    WshShell.RegWrite Regkey, TermDate, "REG_SZ"
End Sub


Function RegRead()
'RegRead: 從註冊傳回鍵的值或值名稱
    On Error Resume Next
    Dim WshShell, bKey
    fname = ThisWorkbook.Name
    Regkey = "HKCU\chijanzen\Budget\Date\" & fname
    Set WshShell = CreateObject("WScript.Shell")
    RegRead = WshShell.RegRead(Regkey)
End Function

Sub RegDelete()
'RegDelete :從註冊刪除某鍵或它的一個值(請小心使用)
    Dim WshShell, bKey
    Regkey = "HKCU\chijanzen\Budget\Date\"
    Set WshShell = CreateObject("WScript.Shell")
    WshShell.RegDelete Regkey    '刪除檔名
End Sub

[此贴子已经被作者于2006-9-27 15:35:46编辑过]

Emily

原碼出自 Tek-Tips Forum

' Module

Option Explicit

'Set Types
Public Type LUID
   LowPart As Long
   HighPart As Long
End Type

Public Type LUID_AND_ATTRIBUTES
        pLuid As LUID
        Attributes As Long
End Type

Public Type TOKEN_PRIVILEGES
    PrivilegeCount As Long
    Privileges(1) As LUID_AND_ATTRIBUTES
End Type

' Declare API functions.
Public Declare Function ExitWindowsEx Lib "user32" (ByVal uFlags As Long, ByVal dwReserved As Long) As Long
Public Declare Function GetCurrentProcess Lib "kernel32" () As Long
Public Declare Function OpenProcessToken Lib "advapi32" (ByVal ProcessHandle As Long, _
   ByVal DesiredAccess As Long, TokenHandle As Long) As Long
Public Declare Function LookupPrivilegeValue Lib "advapi32" Alias "LookupPrivilegeValueA" _
   (ByVal lpSystemName As String, ByVal lpName As String, lpLuid As LUID) As Long
Public Declare Function AdjustTokenPrivileges Lib "advapi32" (ByVal TokenHandle As Long, _
   ByVal DisableAllPrivileges As Long, NewState As TOKEN_PRIVILEGES, ByVal BufferLength _
   As Long, PreviousState As TOKEN_PRIVILEGES, ReturnLength As Long) As Long

' Set Set ShutDown Privilege Constants
Public Const TOKEN_ADJUST_PRIVILEGES = &H20
Public Const TOKEN_QUERY = &H8
Public Const SE_PRIVILEGE_ENABLED = &H2

Public Sub SetShutDownPrivilege()
Dim Phndl As Long, Thndl As Long
Dim MyLUID As LUID
Dim MyPriv As TOKEN_PRIVILEGES, MyNewPriv As TOKEN_PRIVILEGES

Phndl = GetCurrentProcess()
OpenProcessToken Phndl, TOKEN_ADJUST_PRIVILEGES Or TOKEN_QUERY, Thndl
LookupPrivilegeValue "", "SeShutdownPrivilege", MyLUID
MyPriv.PrivilegeCount = 1
MyPriv.Privileges(0).Attributes = SE_PRIVILEGE_ENABLED
MyPriv.Privileges(0).pLuid = MyLUID
' Now to set shutdown privilege for my app
AdjustTokenPrivileges Thndl, False, MyPriv, 4 + (12 * MyPriv.PrivilegeCount), MyNewPriv, 4 + (12 * MyNewPriv.PrivilegeCount)

End Sub

' ThisWorkbook

Option Explicit

Private Sub Workbook_BeforeClose(Cancel As Boolean)
On Error Resume Next
Dim Msg, Style, Title, Response
Dim MyFlag As Long, Ret As String
'Set ShutDown Constants
Const EWX_LOGOFF = 0
Const EWX_SHUTDOWN = 1
Const EWX_REBOOT = 2
Const EWX_FORCE = 4

' Define message.
Msg = "Do you want to continue ?" _
    & vbCr & vbCr & "You are about to exit the excel program." _
    & vbCr & vbCr & "You will need to Reboot Computer" _
    & vbCr & "to restore the program!"
Style = vbYesNoCancel + vbCritical + vbDefaultButton3    ' Define buttons.
Title = "Exiting Program"    ' Define title.
' Display message.
Response = MsgBox(Msg, Style, Title)
'Test the variable Response
Select Case Response
  Case vbYes
    'Save the file, Force Windows Closed
    Me.Save
'   Call Exit_Windows
    Ret = InputBox("Enter Password", "Password Required")
        If Ret = "testing" Then    ' 更改你的密碼
        Ret = InputBox("Exit Excel or Logoff User" _
        & vbCr & " Enter: E or L", "What Action")
        Else
        MsgBox "Invalid Password", vbCritical, "Wrong Password"
        Cancel = False
        Exit Sub
        End If
    If Ret = "E" Or Ret = "e" Then
        Application.Quit
    Else
        If Ret = "L" Or Ret = "l" Then
            SetShutDownPrivilege 'Set the shutdown privilege - else reboot will fail
            ' Always execute a force shutdown if a shutdown is required
            MyFlag = EWX_LOGOFF  'LogOff
            ' Grab the shutdown privilege - else reboot will fail
            SetShutDownPrivilege
            'Do the required action
            Call ExitWindowsEx(MyFlag, 0)
        End If
    End If
  Case vbNo
    Worksheets(1).Activate
    Cancel = True
  Case vbCancel
    Cancel = True
  Case Else
  'Do Nothing
End Select

End Sub

Private Sub Workbook_Open()
On Error Resume Next
    'Activate the 1st worksheet using the workbooks worksheet index
    Worksheets(1).Activate
    'Or If you want to use the actual worksheet name
    'Worksheets("Sheet1").Activate
End Sub

[此贴子已经被作者于2006-9-27 15:36:19编辑过]

Emily

指定电脑上运行

'用 F8 逐句执行篮色编码，取值后更改红色部份

' ThisWorkBook

Private Declare Function w32_GetComputerName Lib "kernel32" _
  Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long

Private Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" _
   (ByVal lpBuffer As String, nSize As Long) As Long
Public LoginTime

Private Sub Workbook_Open()
    Dim TempUName     ' User Name
    Dim TempPCName   ' PC Name
    TempPCName = GetComputerName
    TempUName = UserName
    If TempPCName <> "PCName01" And TempPCName <> "PCName02" And TempUName <> "BeeBee" _
        And TempPCName <> "EMILY" Then
            MsgBox "Sorry, This File is for BeeBee ONLY."
            Application.Quit
    End If
    End Sub

Function GetComputerName()
    Dim sComputerName As String
    Dim lComputerNameLen As Long
    Dim lResult As Long
    lComputerNameLen = 256
    sComputerName = Space(lComputerNameLen)
    lResult = w32_GetComputerName(sComputerName, lComputerNameLen)
    If lResult <> 0 Then
        GetComputerName = Left(sComputerName, lComputerNameLen)
    Else
        GetComputerName = "Unknown"
    End If
End Function

Function UserName() As String
       Dim Buffer As String * 100
       Dim BuffLen As Long
       BuffLen = 100
       GetUserName Buffer, BuffLen
       UserName = Left(Buffer, BuffLen - 1)
End Function

[此贴子已经被作者于2006-9-27 15:37:13编辑过]

Emily

可以监控删除行及列吗

' Module

   Option Explicit

'// Worksheet RowColumn Deleted Event
'// This is NOT a real event but just hack the command button.
'// You can know when the rows or the columns was deleted by user's opelation.

Sub EventHack()       ' 执行监控程序
    AssignMacro "JudgeRng"
End Sub
Sub EventReset()      ' 取消监控程序
    AssignMacro ""
End Sub

Private Sub AssignMacro(ByVal strProc As String)
    Dim lngId As Long
    Dim CtrlCbc As CommandBarControl
    Dim CtrlCbcRet As CommandBarControls
    Dim arrIdNum As Variant

    '// 293=Delete menu of the right click on row
    '// 294=Delete menu of the right click on column
    '// 293=Delete menu of the Edit of main menu
    arrIdNum = Array(293, 294, 478)

    For lngId = LBound(arrIdNum) To UBound(arrIdNum)
        Set CtrlCbcRet = CommandBars.FindControls(ID:=arrIdNum(lngId))
        For Each CtrlCbc In CtrlCbcRet
            CtrlCbc.OnAction = strProc
        Next
        Set CtrlCbcRet = Nothing
    Next
End Sub

Private Sub JudgeRng()
    If Not TypeOf Selection Is Range Then Exit Sub
    With Selection
        If .Address = .EntireRow.Address Then
            Call DelExecute("Row:" & .Row, xlUp)
        ElseIf .Address = .EntireColumn.Address Then
            Call DelExecute("Column:" & .Column, xlToLeft)
        Else
            Application.Dialogs(xlDialogEditDelete).Show
        End If
    End With
End Sub

Private Sub DelExecute(ByVal str, ByVal lngDerec As Long)
    MsgBox "deleted:" & str
    Selection.Delete lngDerec
End Sub

[此贴子已经被作者于2006-9-27 15:37:50编辑过]