Tools for Excel table # Add-Ins

Thảo luận trong 'Ứng dụng Excel' bắt đầu bởi thidinh, 31 Tháng mười hai 2007.

1,812 lượt xem

  1. thidinh

    thidinh Thành viên sơ cấp

    Bài viết:
    9
    Đã được thích:
    0
    Nơi ở:
    BD
    Có Bác nào vui lòng giải thik đoạn code dưới đây giúp nhà em không?
    Có Tool nào tương tự Made in VietNam không?
    Hik...............:confused:

    %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%


    Attribute VB_Name = "Guides"

    ------------------------------------------------
    Option Explicit
    Private Delineatore As clsDelineateSQ31
    Sub prcGuides()
    Dim b As CommandBarButton, bName As String
    Static Linea As Integer
    Dim Desactivar
    Application.ScreenUpdating = True
    DoEvents
    If Linea = 0 Then
    Set Delineatore = Nothing
    Set Delineatore = New clsDelineateSQ31
    Set Delineatore.excelApp = Application
    Dim cel As Range
    Set cel = Selection
    If Not cel Is Nothing Then
    CreateGuideSQ31 cel.Cells(1, 1)
    End If
    Linea = 1
    Else
    disableRulerSQ31
    Linea = 0
    End If
    End Sub

    Sub disableRulerSQ31()
    On Error Resume Next
    BorraGuidesHojaSQ31
    Set Delineatore = Nothing
    End Sub


    Public Function CreateGuideSQ31(RNG As Range)
    Application.ScreenUpdating = False
    deleteAllRulersInSheetSQ31 RNG.Worksheet
    Dim a As Range, beginCell As Range, endcell As Range
    For Each a In RNG.Areas
    If a.Cells.count = 1 Then
    Set beginCell = Nothing
    Set endcell = Nothing
    HorizontalSQ31 RNG, beginCell, a, endcell
    Set beginCell = Nothing
    Set endcell = Nothing
    VerticalSQ31 RNG, beginCell, a, endcell
    End If
    Next
    Application.ScreenUpdating = True
    DoEvents
    End Function

    Sub VerticalSQ31(RNG As Range, beginCell As Range, a As Range, endcell As Range)
    On Error Resume Next
    If RNG.Worksheet.Shapes("JABS V " & a.Column) Is Nothing Then
    Dim r As Long
    r = ActiveWindow.VisibleRange.Rows.count
    Set beginCell = Application.Intersect(ActiveWindow.VisibleRange.Rows(1), a.EntireColumn)
    Set endcell = Application.Intersect(ActiveWindow.VisibleRange.Rows(r), a.EntireColumn)
    With RNG.Worksheet.Shapes.AddLine(beginCell.Left + beginCell.Width, _
    beginCell.Top, _
    endcell.Left + endcell.Width, _
    endcell.Top + endcell.Height)
    .Placement = xlMove
    .name = "JABS V " & a.Column
    If Application.VERSION < 12 Then
    .Line.ForeColor.SchemeColor = 2
    Else
    .Line.ForeColor.SchemeColor = 74
    End If
    End With
    End If
    End Sub

    Sub HorizontalSQ31(RNG As Range, beginCell As Range, a As Range, endcell As Range)
    On Error Resume Next
    If RNG.Worksheet.Shapes("JABS H " & a.Row) Is Nothing Then
    Dim C As Long
    C = ActiveWindow.VisibleRange.Columns.count
    Set beginCell = Application.Intersect(ActiveWindow.VisibleRange.Columns(1), a.EntireRow)
    Set endcell = Application.Intersect(ActiveWindow.VisibleRange.Columns(C), a.EntireRow)
    With RNG.Worksheet.Shapes.AddLine(beginCell.Left, _
    beginCell.Top + beginCell.Height, _
    endcell.Left + endcell.Width, _
    endcell.Top + endcell.Height)
    .Placement = xlMove
    .name = "JABS H " & a.Row
    If Application.VERSION < 12 Then
    .Line.ForeColor.SchemeColor = 2
    Else
    .Line.ForeColor.SchemeColor = 74
    End If
    End With
    End If
    End Sub

    Public Function BorraGuidesHojaSQ31()
    deleteAllRulersInSheetSQ31 ActiveSheet
    End Function


    Private Function deleteAllRulersInSheetSQ31(ws As Worksheet)
    If ws Is Nothing Then Exit Function
    Dim s As Shape
    For Each s In ws.Shapes
    If InStr(1, s.name, "JABS") Then
    s.Delete
    End If
    Next
    End Function

    --------------------------------------------------------------
    Source: http://www.jabsoft.com
     
    #1

Chia sẻ trang này