Kết quả 1 đến 3 của 3

Chủ đề: Học tập từ một Add-in CBList

  1. #1

    Học tập từ một Add-in CBList

    Học tập từ các đọan code của người khác cũng là một cách học.
    Tôi xin giới thiệu với các bạn đọan code của Add-in CBList. Nó sẽ giúp các bạn liệt kê các tên CommandBar, Control ID và Face ID. Nó sẽ giúp ích cho các bạn khi các bạn lập trình với CommandBar.
    Các bạn có thể download từ:
    http://www.oaltd.co.uk/mvp/Default.htm
    Đầu tiên dựa vào sự kiện Open và BeforeClose để tạo và xóa Menu cho add-in
    Mã:
    Option Explicit
    
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ''' Subroutine: Workbook_BeforeClose Event Procedure
    '''
    ''' Purpose:    Hides command bar CBList, if it exists
    '''
    ''' Arguments:  None
    '''
    ''' Date        Developer           Action
    ''' --------------------------------------------------------------------------
    ''' 10 Jun 99   John Green          Created
    '''
    Private Sub Workbook_BeforeClose(Cancel As Boolean)
      On Error Resume Next
      Application.CommandBars("CBList").Visible = False
    End Sub
    
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ''' Subroutine: Workbook_Open Event Procedure
    '''
    ''' Purpose:    Creates new command bar CBList if it does not already exist.
    '''             If it does exist, the controls are processed to ensure that
    '''             their OnAction macros are the ones in the current workbook.
    '''
    '''
    ''' Arguments:  None
    '''
    ''' Date        Developer           Action
    ''' --------------------------------------------------------------------------
    ''' 10 Jun 99   John Green          Created
    '''
    Private Sub Workbook_Open()
      Dim cbList As CommandBar
      Dim lngLeft As Long
      Dim lngTop As Long
      Dim lngPosition As Long
      Dim i As Integer
    
      On Error Resume Next
      Set cbList = Application.CommandBars("CBList")
      On Error GoTo 0
      If cbList Is Nothing Then
        Set cbList = Application.CommandBars.Add(Name:="CBList")
        For i = 1 To 4
          cbList.Controls.Add Type:=msoControlButton
        Next i
      End If
      With cbList.Controls(1)
        .OnAction = "ListAllControls"
        .FaceId = 1826
        .TooltipText = "List All CommandBar Controls"
      End With
      With cbList.Controls(2)
        .OnAction = "ListAllFaces"
        .FaceId = 2104
        .TooltipText = "List All Built-in Button Faces"
      End With
      With cbList.Controls(3)
        .OnAction = "ListPopups"
        .FaceId = 3271
        .TooltipText = "List All PopUp CommandBars"
      End With
      With cbList.Controls(4)
        .OnAction = "ShowHelp"
        .FaceId = 984
        .TooltipText = "Brief explaination of CBList"
      End With
      cbList.Enabled = True
      cbList.Visible = True
    End Sub
    Lê Thanh Nhân

  2. #2
    rungram90 Guest
    Sau đó khi người dùng click vào menu của add-in mà thực hiện việc liệt kê.

    Mã:
    '***************************************************************************
    '*
    '* APPLICATION:     Command Bar Lister
    '* AUTHOR & DATE:   John Green: Execuplan Consulting Pty. Ltd.
    '*                  10th June 1999
    '*
    '* CONTACT:         jgreen@enternet.com.au
    '*
    '* DESCRIPTION:     Lists command bars, command bar controls and button faces.
    '*                  The code was derived from code presented in "Excel 2000
    '*                  VBA Programmer's Reference", Wrox Press, modified according
    '*                  to a suggestion from Bill Manville to use a recursive function
    '*                  to list the control hierarchy.
    '*
    '* THIS MODULE:     Contains all code apart from the Workbook Open and Close
    '*                  event procedures.
    '*
    '* SUB PROCEDURES:
    '*  ListAllControls Lists all command bars and their controls
    '*  ListAllFaces    Lists all Faces and FaceIds
    '*  ListPopUps      Lists all short cut command bars
    '*  ShowHelp        Displays help form
    '*
    '* FUNCTIONS:
    '*ListControls      Recursive Function to list controls
    '*IsEmptyWorksheet  Checks that listing is going to an empty worksheet
    '***************************************************************************
    
    Option Explicit
    
    
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ''' Subroutine: ListAllControls
    '''
    ''' Purpose:    Processes all command bars and calls ListControls function
    '''
    ''' Arguments:  None
    '''
    ''' Date        Developer           Action
    ''' --------------------------------------------------------------------------
    ''' 10 Jun 99   John Green          Created
    '''
    Sub ListAllControls()
      Dim cb As CommandBar
      Dim rng As Range
      Dim ctl As CommandBarControl
    
      If Not IsEmptyWorksheet(ActiveSheet) Then Exit Sub
      Set rng = Range("A1")
      Application.ScreenUpdating = False
      For Each cb In Application.CommandBars
        Application.StatusBar = "Processing Bar " & cb.Name
        rng.Value = cb.Name
        For Each ctl In cb.Controls
          Set rng = rng.Offset(ListControls(ctl, rng))
        Next ctl
      Next cb
      Range("A:I").EntireColumn.AutoFit
      Application.StatusBar = False
    End Sub
    
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ''' Function:   ListControls
    '''
    ''' Purpose:    Lists control Caption, Type, Face and FaceId. Calls itself
    '''             when a control contains other controls. Ignores the contents
    '''             of controls that do not contain listable control information.
    '''             Returns offset of row after added controls.
    '''
    ''' Arguments:  ctl - control object
    '''             rng - current starting cell (Range object) for listing
    '''
    ''' Date        Developer           Action
    ''' --------------------------------------------------------------------------
    ''' 10 Jun 99   John Green          Created
    '''
    Function ListControls(ctl As CommandBarControl, rng As Range) As Long
      Dim lngOffset As Long 'Tracks current row relative to rng
      Dim ctlSub As CommandBarControl 'Control contained in ctl
    
      On Error Resume Next
      lngOffset = 0
      rng.Offset(lngOffset, 1).Value = ctl.Caption
      rng.Offset(lngOffset, 2).Value = ctl.Type
      'Attempt to copy control face. If error, don't paste
      ctl.CopyFace
      If Err.Number = 0 Then
        ActiveSheet.Paste rng.Offset(lngOffset, 3)
        rng.Offset(lngOffset, 3).Value = ctl.FaceId
      End If
      Err.Clear
      'Check Control Type
      Select Case ctl.Type
        Case 1, 2, 4, 6, 7, 13, 18
        'Do nothing for these control types
        Case Else
        'Call function recursively if current control contains other controls
          For Each ctlSub In ctl.Controls
            lngOffset = lngOffset + _
                ListControls(ctlSub, rng.Offset(lngOffset, 2))
          Next ctlSub
          lngOffset = lngOffset - 1
      End Select
      ListControls = lngOffset + 1
    End Function
    
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ''' Function:   IsEmptyWorksheet
    '''
    ''' Purpose:    Checks that worksheet is empty. Returns True or False
    '''
    ''' Arguments:  sht - Worksheet object
    '''
    ''' Date        Developer           Action
    ''' --------------------------------------------------------------------------
    ''' 10 Jun 99   John Green          Created
    '''
    Function IsEmptyWorksheet(sht As Object) As Boolean
      If TypeName(sht) = "Worksheet" Then
        If WorksheetFunction.CountA(sht.UsedRange) = 0 Then
          IsEmptyWorksheet = True
          Exit Function
        End If
      End If
      MsgBox "Please make sure that an empty worksheet is active", vbCritical, _
        "Warning"
    End Function
    
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ''' Subroutine: ListAllFaces
    '''
    ''' Purpose:    Processes all FaceId numbers and lists face images
    '''
    ''' Arguments:  None
    '''
    ''' Date        Developer           Action
    ''' --------------------------------------------------------------------------
    ''' 10 Jun 99   John Green          Created
    '''
    Sub ListAllFaces()
      Dim i As Integer 'Tracks current FaceId
      Dim j As Integer 'Tracks current column in worksheet
      Dim k As Integer 'Tracks current row in worksheet
      Dim ctl As CommandBarControl
      Dim cb As CommandBar
    
    
      If Not IsEmptyWorksheet(ActiveSheet) Then Exit Sub
      On Error Resume Next
      Application.ScreenUpdating = False
      'Create temporary command bar with single control button
      'to hold control button face to be copied to worksheet
      Set cb = CommandBars.Add(Position:=msoBarFloating, _
          MenuBar:=False, _
          temporary:=True)
      Set ctl = cb.Controls.Add(Type:=msoControlButton, _
          temporary:=True)
      k = 1
      Do While Err.Number = 0
        For j = 1 To 10
          i = i + 1
          Application.StatusBar = "FaceID = " & i
          'Set control button to current FaceId
          ctl.FaceId = i
          'Attempt to copy Face image to worksheet
          ctl.CopyFace
          'Abandont For loop and Do loop if there is an error
          If Err.Number <> 0 Then Exit For
          ActiveSheet.Paste Cells(k, j + 1)
          Cells(k, j).Value = i
        Next j
        k = k + 1
      Loop
      Application.StatusBar = False
      cb.Delete
    End Sub
    
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ''' Subroutine: ListPopups
    '''
    ''' Purpose:    Lists all command bars of type msoBarTypePopup and their controls.
    '''             Only lists controls at the top level. Does not list any controls
    '''             contained in the top level controls.
    '''
    ''' Arguments:  None
    '''
    ''' Date        Developer           Action
    ''' --------------------------------------------------------------------------
    ''' 10 Jun 99   John Green          Created
    '''
    Sub ListPopups()
      Dim ctl As CommandBarControl
      Dim cb As CommandBar
      Dim intRow As Integer 'Tracks row in worksheet
    
      If Not IsEmptyWorksheet(ActiveSheet) Then Exit Sub
      On Error Resume Next
      Application.ScreenUpdating = False
      Cells(1, 1).Value = "CommandBar"
      Cells(1, 2).Value = "Control"
      Cells(1, 3).Value = "FaceID"
      Cells(1, 4).Value = "ID"
      Range("A1:D1").Font.Bold = True
      intRow = 2
      For Each cb In CommandBars
        Application.StatusBar = "Processing Bar " & cb.Name
        'Only list command bar if type is Popup
        If cb.Type = msoBarTypePopup Then
          Cells(intRow, 1).Value = cb.Name
          intRow = intRow + 1
          'List controls on command bar
          For Each ctl In cb.Controls
            Cells(intRow, 2).Value = ctl.Caption
            ctl.CopyFace
            If Err.Number = 0 Then
              ActiveSheet.Paste Cells(intRow, 3)
              Cells(intRow, 3).Value = ctl.FaceId
            End If
            Cells(intRow, 4).Value = ctl.Id
            Err.Clear
            intRow = intRow + 1
          Next ctl
        End If
      Next cb
      Range("A:B").EntireColumn.AutoFit
      Application.StatusBar = False
    End Sub
    
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ''' Subroutine: ShowHelp
    '''
    ''' Purpose:    Shows user form with help
    '''
    ''' Arguments:  None
    '''
    ''' Date        Developer           Action
    ''' --------------------------------------------------------------------------
    ''' 10 Jun 99   John Green          Created
    '''
    Sub ShowHelp()
      frmHelp.Show
    End Sub
    Lê Thanh Nhân

  3. #3
    mallboro Guest
    Qua Add-in chúng ta học được gì?
    Các bạn để ý rằng, trước một thủ tục đều có giải thích sơ bộ:

    Mã:
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ''' Subroutine: ListPopups
    '''
    ''' Purpose:    Lists all command bars of type msoBarTypePopup and their controls.
    '''             Only lists controls at the top level. Does not list any controls
    '''             contained in the top level controls.
    '''
    ''' Arguments:  None
    '''
    ''' Date        Developer           Action
    ''' --------------------------------------------------------------------------
    ''' 10 Jun 99   John Green          Created
    '''
    Sub ListPopups()
    Ví dụ: Tên Thủ tục hoặc Hàm. Sau đó là mục đích của thủ tục, hàm. Các Arguments. Ngày tạo, sửa. Người viết thủ tục, hàm...
    Thật rỏ ràng phải không các bạn.
    Nó cũng áp dụng tương tự cho module

    Mã:
    '***************************************************************************
    '*
    '* APPLICATION:     Command Bar Lister
    '* AUTHOR & DATE:   John Green: Execuplan Consulting Pty. Ltd.
    '*                  10th June 1999
    '*
    '* CONTACT:         jgreen@enternet.com.au
    '*
    '* DESCRIPTION:     Lists command bars, command bar controls and button faces.
    '*                  The code was derived from code presented in "Excel 2000
    '*                  VBA Programmer's Reference", Wrox Press, modified according
    '*                  to a suggestion from Bill Manville to use a recursive function
    '*                  to list the control hierarchy.
    '*
    '* THIS MODULE:     Contains all code apart from the Workbook Open and Close
    '*                  event procedures.
    '*
    '* SUB PROCEDURES:
    '*  ListAllControls Lists all command bars and their controls
    '*  ListAllFaces    Lists all Faces and FaceIds
    '*  ListPopUps      Lists all short cut command bars
    '*  ShowHelp        Displays help form
    '*
    '* FUNCTIONS:
    '*ListControls      Recursive Function to list controls
    '*IsEmptyWorksheet  Checks that listing is going to an empty worksheet
    '***************************************************************************
    Các bạn có thể làm điều này bằng việc dùng MzTools với công cụ:
    Add Module header
    Add Procedure header

    Lê Thanh Nhân

Quyền viết bài

  • Bạn Không thể gửi Chủ đề mới
  • Bạn Không thể Gửi trả lời
  • Bạn Không thể Gửi file đính kèm
  • Bạn Không thể Sửa bài viết của mình
  •