完美Excel

Private m_colContextMenus As Collection
 
Private Sub UserForm_Initialize()
 
    Dim clsContextMenu As CTextBox_ContextMenu
 
    Set m_colContextMenus = New Collection
 
    Set clsContextMenu = New CTextBox_ContextMenu
    With clsContextMenu
        Set .TBox = UserForm1.TextBox1
        Set .Parent = Me
    End With
    m_colContextMenus.Add clsContextMenu, CStr(m_colContextMenus.Count + 1)
 
    Set clsContextMenu = New CTextBox_ContextMenu
    With clsContextMenu
        Set .TBox = UserForm1.TextBox2
        Set .Parent = Me
    End With
    m_colContextMenus.Add clsContextMenu, CStr(m_colContextMenus.Count + 1)
 
    Set clsContextMenu = New CTextBox_ContextMenu
    With clsContextMenu
        Set .TBox = UserForm1.TextBox3
        Set .Parent = Me
    End With
    m_colContextMenus.Add clsContextMenu, CStr(m_colContextMenus.Count + 1)
 
    Set clsContextMenu = New CTextBox_ContextMenu
    With clsContextMenu
        Set .TBox = UserForm1.TextBox4
        Set .Parent = Me
    End With
    m_colContextMenus.Add clsContextMenu, CStr(m_colContextMenus.Count + 1)
 
    Set clsContextMenu = New CTextBox_ContextMenu
    With clsContextMenu
        Set .TBox = UserForm1.TextBox5
        Set .Parent = Me
    End With
    m_colContextMenus.Add clsContextMenu, CStr(m_colContextMenus.Count + 1)
 
End Sub

Public Declare Function SetTimer& Lib "user32" (ByVal hwnd&, _
    ByVal nIDEvent&, ByVal uElapse&, ByVal lpTimerFunc&)
Private Declare Function KillTimer& Lib "user32" (ByVal hwnd&, _
    ByVal nIDEvent&)
Public Const NV_INPUTBOX As Long = &H5000
 
Public Sub TimerProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal idEvent As Long, ByVal dwTime As Long)
    SendKeys "%Y"
    KillTimer hwnd, idEvent
End Sub
 
Sub test()
 
    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
    End With
 
    Dim targetworkbook As Workbook
 
    Dim usersave As VbMsgBoxResult
 
    Set targetworkbook = Workbooks.Open("C:\test2.xls", UpdateLinks:=0)
 
    Calculate
    targetworkbook.Activate
    SetTimer 0, NV_INPUTBOX, 1000, AddressOf TimerProc
    Application.Run targetworkbook.Name & "!tester"
 
    targetworkbook.Activate
 
    With Application
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With
 
End Sub

Sub tester()
    TimedMsgBox
End Sub
 
Sub TimedMsgBox()
    Dim cTime As Long
    Dim WSH As Object
 
    Set WSH = CreateObject("WScript.Shell")
    cTime = 5 '5 秒
    Select Case WSH.Popup("Open an Excel file?!", cTime, "Question", vbOKCancel)
        Case vbOK
            MsgBox "你单击了确定"
        Case vbCancel
            MsgBox "你单击了取消"
        Case -1
            MsgBox "超时"
    End Select
End Sub

Private Sub lbxItem_Change()
    Dim rngCategory As Range
 
    Set rngCategory = Sheet1.Range(Me.lbxItem.Value)
 
    Me.lbxCategory.List = rngCategory.Value
End Sub
 
Private Sub UserForm_Initialize()
    Dim rngItem As Range
 
    Set rngItem = Sheet1.Range("项目")
 
    Me.lbxItem.List = rngItem.Value
End Sub

<customUI xmlns="http://schemas.microsoft.com/office/2006/01/customui">
  <ribbon>
    <tabs>
      <tab id="rxtabCustom"
           label="我自已的选项卡"
           insertBeforeMso="TabHome">
          <group idMso="GroupFont"/>
          <group idMso="GroupZoom"/>
          <group id="myGroup" label="我的组">
              <button id="b1" 
                      imageMso="HyperlinkInsert" 
                      size="large" 
                      label="启动网站" 
                      onAction="surf"/>
              <button id="b2" 
                      imageMso="HappyFace" 
                      label="微笑图标" 
                      onAction="smile"/>
              <button id="b3" 
                      imageMso="FormatPainter" 
                      label="格式刷图标" 
                      onAction="paint"/>
              <button id="b4" 
                      imageMso="AutoFilterClassic" 
                      label="筛选图标" 
                      onAction="filter"/>
           </group>
     </tab>
   </tabs>
  </ribbon>
</customUI>

'Callback for b1 onAction
Sub surf(control As IRibbonControl)
    ActiveWorkbook.FollowHyperlink _
      Address:="http://www.excelperfect.com", _
      NewWindow:=True
End Sub
'Callback for b2 onAction
Sub smile(control As IRibbonControl)
    MsgBox "您单击了微笑图标!呵呵..."
End Sub
'Callback for b3 onAction
Sub paint(control As IRibbonControl)
    MsgBox "您单击了格式刷图标!"
End Sub
 
'Callback for b4 onAction
Sub filter(control As IRibbonControl)
    MsgBox "您单击了筛选图标!"
End Sub

<Relationship Id="customUIRelID" Type="http://schemas.microsoft.com/office/2006/relationships/ui/extensibility" Target="customUI/customUI.xml"/>