Read code Module

Euler

Administrator
Thành viên BQT
Tôi đặc biệt quan tâm tới chủ đề này.
Liên quan tới Module, trên diễn đàn đã có một topic:

Trong khuôn khổ bài viết này, tôi tham vọng muốn tạo ra chương trình để viết khái quát lại toàn bộ chương trình trong một project.
Tuy nhiên vấn đề đầu tiên tôi vấp phải, đó là làm sao có thể đọc được nội dung code của file Excel. Thực hiện google tôi có được đoạn code sau:
Mã:
Sub TestGetVBAProjString()
  'run this
  'assumes VBA code is not locked
 
  Dim sStr As String, nComps As Integer
  Dim vA As Variant, nTLines As Long
 
  'get whole string
  sStr = GetVBAProjString
 
  'show start of project string
  ThisWorkbook.Sheets(1).Cells(1, 1) = sStr
'  MsgBox sStr
End Sub

Function GetVBAProjString() As String
  'gets ThisWorkbook's whole VBA project string
  'Set reference to Microsoft VBA Extensibility 5.5
 
  Dim VBProj As VBIDE.VBProject, VBComp As VBIDE.VBComponent
  Dim VBMod As VBIDE.CodeModule, sMod As String, sProj As String
  Dim nLines As Long
 
  'get ref to ThisWorkbook project
  Set VBProj = ThisWorkbook.VBProject
    
  'loop through VBComponents collection
  For Each VBComp In VBProj.VBComponents
    Set VBMod = VBComp.CodeModule
    nLines = VBMod.CountOfLines
      If nLines <> 0 Then
        sMod = VBMod.Lines(1, nLines)
        sProj = sProj & vbCrLf & _
            UCase(Chr(39) & VBComp.Name) & _
             vbCrLf & vbCrLf & sMod
      Else 'just accum name of empty component
        sProj = sProj & vbCrLf & _
            UCase(Chr(39) & VBComp.Name) & _
             vbCrLf & vbCrLf
      End If
  Next VBComp
 
  GetVBAProjString = sProj
  Set VBProj = Nothing: Set VBComp = Nothing
  Set VBMod = Nothing
 
End Function
Nguồn:
Bạn chú ý thiết định Microsoft Visual Basic for Applications Extensibility 5.3:
Bạn cần đăng nhập để thấy đính kèm


Tôi đã thử chương trình trên, và thật đáng kinh ngạc, nó lấy được toàn bộ code của UserForm, sheet, Module.
Tạm thời thế đã. Bài sau sẽ viết tiếp.
 

vbano1

SMod
Thành viên BQT
Cho từng dòng dữ liệu ra mảng là được.
Mã:
Sub TestGetVBAProjString()
    Dim linerr  As Variant
    
  'run this
  'assumes VBA code is not locked
 
  Dim sStr As String, nComps As Integer
  Dim vA As Variant, nTLines As Long
 
  'get whole string
  sStr = GetVBAProjString
 
  'show start of project string
'  ThisWorkbook.Sheets(1).Cells(1, 1) = sStr
  linerr = Split(sStr, vbNewLine)
'  MsgBox sStr
End Sub
 
T

thanhphong

Guest
Để lấy tên thủ tục thì dễ, để lấy tên Function thì khó.
Nếu là thủ tục thì dùng code sau:
Mã:
Sub test()
    Dim s As String
    s = "Call thutuc 'abc"
    s = find_fun_n_sub(s)
    MsgBox s
End Sub

'INPUT: Call thutuc()
'OUTPUT:thutuc

Function find_fun_n_sub(ByVal s As String) As String
    Dim s2      As String
    Dim i       As Long
    Dim dodaitem    As Long
    Dim vttem   As Long
    Dim kq      As String
    s2 = Trim(s)
    dodaitem = Len(s2)
    If dodaitem = 0 Then
        Exit Function
    End If

    'Kiem tra co comment khong
    vttem = InStr(1, s2, "'")
    If vttem > 1 Then
        s2 = Left(s2, vttem - 1)
        dodaitem = Len(s2)
    ElseIf vttem = 1 Then
        Exit Function
    End If
    'Kiem tra co phai thu tuc khong
    vttem = InStr(s2, "Call ")
    If vttem > 0 Then
        For i = vttem + 5 To dodaitem Step 1
            If Mid(s2, i, 1) = "(" Then
                Exit For
            Else
                kq = kq & Mid(s2, i, 1)
            End If
        Next i
        find_fun_n_sub = Trim(kq)
        Exit Function
    End If

End Function
 

Euler

Administrator
Thành viên BQT
Trước hết muốn xử lý gì đi nữa, thì chúng ta cũng cần phải bỏ ký tự thừa, là các khoảng trống trước và sau mỗi dòng lệnh nếu có.
Sau đó là đoạn comment, chúng ta cũng không cần phải lưu giữ, nó sẽ dễ làm nhầm lẫn khi tìm kiếm.
Do đó, ta cần một hàm bỏ những ký tự không cần thiết trong một dòng lệnh.
Mã:
Sub test2()
    Dim s As String
    s = " a = b 'comment"
    s = cutkitu(s)
    MsgBox s
End Sub
'INPUT: a = b 'comment"
'OUTPUT: a = b
Function cutkitu(ByVal s As String) As String
    Dim kq  As String
    Dim vt  As Long
    
    kq = Trim(s)
    If Left(kq, 1) = "'" Then
        Exit Function
    End If
    vt = InStr(1, kq, "'", vbTextCompare)
    If vt = 0 Then
        cutkitu = kq
        Exit Function
    Else
        cutkitu = Left(kq, vt - 1)
    End If
End Function
 

vbano1

SMod
Thành viên BQT
Giả sử tôi có code như thế này:
Bạn cần đăng nhập để thấy đính kèm


Tôi mong muốn kiểm tra thủ tục test1A sẽ được kết quả như sau:
Bạn cần đăng nhập để thấy đính kèm


Tôi sử dụng code như sau:
Mã:
Dim p_r As Long, p_c As Long
Sub test3()
    Call TestGetVBAProjString("test1A", 4)
End Sub
'itemp: Sheets(itemp)
Sub TestGetVBAProjString(ByVal tenham As String, ByVal itemp As Byte)
    Dim linerr  As Variant
    Dim i       As Long
    Dim sStr    As String, nComps As Integer
    Dim s       As String
   
    Dim r       As Long, c  As Integer
   
   

    'get whole string
    sStr = GetVBAProjString
    If sStr = "" Then
        MsgBox "Khong tim thay du lieu"
        Exit Sub
    End If
    'show start of project string
    linerr = Split(sStr, vbNewLine)
    p_r = 2
    p_c = 2
    Call subexist(linerr, tenham, itemp, p_c)
End Sub
Sub subexist(ByVal linerr As Variant, ByVal tenham As String, ByVal itemp As Byte, ByVal c As Long)
    Dim i       As Long
    Dim vt1     As Long, vt2 As Long
    Dim s       As String
    vt1 = -1
    'Find Position start Sub
    For i = LBound(linerr) To UBound(linerr) Step 1
        s = cutkitu(CStr(linerr(i)))
        If batdauthutuc(tenham, s) = True Then
            vt1 = i
            Exit For
        End If
    Next i
    If vt1 < 0 Then Exit Sub
    'Find position End Sub
    vt2 = -1
    For i = vt1 To UBound(linerr) Step 1
        s = cutkitu(CStr(linerr(i)))
        If s = "End Sub" Then
            vt2 = i
            Exit For
        End If
    Next i
    If vt2 = vt1 Then
        Exit Sub
    End If
    If vt2 < 0 Then Exit Sub
    'Xac dinh duoc tenham la co ton tai, kiem tra noi dung ben trong cua no xem co cac thu tuc nao co ben trong khong
    For i = vt1 To vt2 Step 1
        s = cutkitu(CStr(linerr(i)))
        s = find_fun_n_sub(s)
        If s <> "" Then
            p_r = p_r + 1
            ThisWorkbook.Sheets(itemp).Cells(p_r, c) = s
            Call subexist(linerr, s, itemp, c + 1)
        End If
    Next i
End Sub

Function batdauthutuc(ByVal tenham As String, ByVal dulieu_row As String) As Boolean
    Dim temp    As String
    temp = "Sub " & tenham
    If InStr(1, dulieu_row, temp, vbTextCompare) > 0 Then
        batdauthutuc = True
    Else
        batdauthutuc = False
    End If
End Function
'INPUT: a = b 'comment"
'OUTPUT: a = b
Function cutkitu(ByVal s As String) As String
    Dim kq  As String
    Dim vt  As Long
   
    kq = Trim(s)
    If Left(kq, 1) = "'" Then
        Exit Function
    End If
    vt = InStr(1, kq, "'", vbTextCompare)
    If vt = 0 Then
        cutkitu = kq
        Exit Function
    Else
        cutkitu = Left(kq, vt - 1)
    End If
End Function
Sub test22()
    Dim s As String
    s = "Call thutuc"
    MsgBox find_fun_n_sub(s)
End Sub
'INPUT: Call thutuc()
'OUTPUT:thutuc

Function find_fun_n_sub(ByVal s As String) As String
    Dim s2      As String
    Dim i       As Long
    Dim dodaitem    As Long
    Dim vttem   As Long
    Dim kq      As String
    s2 = Trim(s)
    dodaitem = Len(s2)
    If dodaitem = 0 Then
        Exit Function
    End If

    'Kiem tra co comment khong
    vttem = InStr(1, s2, "'", vbTextCompare)
    If vttem > 1 Then
        s2 = Left(s2, vttem - 1)
        dodaitem = Len(s2)
    ElseIf vttem = 1 Then
        Exit Function
    End If
    'Kiem tra co phai thu tuc khong
    vttem = InStr(1, s2, "Call ", vbTextCompare)
    If vttem > 0 Then
        For i = vttem + 5 To dodaitem Step 1
            If Mid(s2, i, 1) = "(" Then
                Exit For
            Else
                kq = kq & Mid(s2, i, 1)
            End If
        Next i
        find_fun_n_sub = Trim(kq)
        Exit Function
    End If

End Function
Function GetVBAProjString() As String
  'gets ThisWorkbook's whole VBA project string
  'Set reference to Microsoft VBA Extensibility 5.5

  Dim VBProj As VBIDE.VBProject, VBComp As VBIDE.VBComponent
  Dim VBMod As VBIDE.CodeModule, sMod As String, sProj As String
  Dim nLines As Long

  'get ref to ThisWorkbook project
  Set VBProj = ThisWorkbook.VBProject
   
  'loop through VBComponents collection
  For Each VBComp In VBProj.VBComponents
    Set VBMod = VBComp.CodeModule
    nLines = VBMod.CountOfLines
      If nLines <> 0 Then
        sMod = VBMod.Lines(1, nLines)
        sProj = sProj & vbCrLf & _
            UCase(Chr(39) & VBComp.Name) & _
             vbCrLf & vbCrLf & sMod
      Else 'just accum name of empty component
        sProj = sProj & vbCrLf & _
            UCase(Chr(39) & VBComp.Name) & _
             vbCrLf & vbCrLf
      End If
  Next VBComp

  GetVBAProjString = sProj
  Set VBProj = Nothing: Set VBComp = Nothing
  Set VBMod = Nothing

End Function
 

tuhocvba

Administrator
Thành viên BQT
Thật tuyệt vời. Test thử dự án của @PeterVu được như sau:
Ba phần, tương ứng với ba giai đoạn. Giai đoạn 3 với cấu trúc khá rắc rối với nhiều nhánh con.
Bạn cần đăng nhập để thấy đính kèm
 

Euler

Administrator
Thành viên BQT
Có lẽ chúng ta nên có qui định cho bản thân, với mỗi hàm tự tạo thì nên có từ khóa cố định cho hàm số. Chẳng hạn như chúng ta đăt tên hàm thì có tiền tố cố định là F_tênhàm thì từ đó macro mới dễ xác định được là chương trình sử dụng Function hay không, và là hàm nào. Hiện tại mới chỉ đưa ra được hướng xử lý với Sub. Với hàm số thì không đơn giản, vì có hàm tự tạo (quan tâm) và hàm sẵn có của Excel (không quan tâm), và macro khó có thể xác định được.

Nếu tìm những nơi định nghĩa Function:
Mã:
Function tên_hàm()...
End Function
Chúng ta cũng có thể nhặt được tên hàm, rồi sau đó nạp vào mảng.
Giả thiết nạp được 100 hàm này vào mảng.
Với mỗi dòng code lại phải xác định xem 100 hàm này có được viết trong dòng code đó không, quả là một việc tốn công tốn sức.
 

giaiphapvba

Administrator
Thành viên BQT
Sẽ rất nguy hiểm nếu gặp thủ tục đệ quy, hoặc trong một thủ tục xuất hiện nhiều lần một thủ tục khác.
Ví dụ:
Mã:
Sub thutuc1()
    if(a=b) then
       'xử lý....
       Call thutuc1B
    else
       'xử lý....
       Call thutuc1B
   Endif
End Sub
Vì vậy cần Dic để kiểm tra tránh trùng lặp.
Mã:
Dim p_r As Long, p_c As Long
Sub test4()
    Call TestGetVBAProjString("taoconfigout", 5)
End Sub
'itemp: Sheets(itemp)
Sub TestGetVBAProjString(ByVal tenham As String, ByVal itemp As Byte)
    Dim linerr  As Variant
    Dim i       As Long
    Dim sStr    As String, nComps As Integer
    Dim s       As String
    
    Dim r       As Long, c  As Integer
    
    
 
    'get whole string
    sStr = GetVBAProjString
    If sStr = "" Then
        MsgBox "Khong tim thay du lieu"
        Exit Sub
    End If
    'show start of project string
    linerr = Split(sStr, vbNewLine)
    p_r = 2
    p_c = 2
    ThisWorkbook.Sheets(itemp).Cells(2, 1) = tenham
    Call subexist(linerr, tenham, itemp, p_c)
End Sub
Sub subexist(ByVal linerr As Variant, ByVal tenham As String, ByVal itemp As Byte, ByVal c As Long)
    Dim i       As Long
    Dim vt1     As Long, vt2 As Long
    Dim s       As String
    Dim myDic   As Object
    
    vt1 = -1
    'Find Position start Sub
    For i = LBound(linerr) To UBound(linerr) Step 1
        s = cutkitu(CStr(linerr(i)))
        If batdauthutuc(tenham, s) = True Then
            vt1 = i
            Exit For
        End If
    Next i
    If vt1 < 0 Then Exit Sub
    'Find position End Sub
    vt2 = -1
    For i = vt1 To UBound(linerr) Step 1
        s = cutkitu(CStr(linerr(i)))
        If s = "End Sub" Then
            vt2 = i
            Exit For
        End If
    Next i
    If vt2 = vt1 Then
        Exit Sub
    End If
    If vt2 < 0 Then Exit Sub
    'Xac dinh duoc tenham la co ton tai, kiem tra noi dung ben trong cua no xem co cac thu tuc nao co ben trong khong
    Set myDic = CreateObject("Scripting.Dictionary")
    For i = vt1 To vt2 Step 1
        s = cutkitu(CStr(linerr(i)))
        s = find_fun_n_sub(s)
        If s <> "" Then
            If s <> tenham Then
                If Not myDic.Exists(s) Then
                    myDic.Add s, s
                    p_r = p_r + 1
                    ThisWorkbook.Sheets(itemp).Cells(p_r, c) = s
                    Call subexist(linerr, s, itemp, c + 1)
                End If
            End If
        End If
    Next i
    Set myDic = Nothing
End Sub

Function batdauthutuc(ByVal tenham As String, ByVal dulieu_row As String) As Boolean
    Dim temp    As String
    temp = "Sub " & tenham
    If InStr(1, dulieu_row, temp, vbTextCompare) > 0 Then
        batdauthutuc = True
    Else
        batdauthutuc = False
    End If
End Function
'INPUT: a = b 'comment"
'OUTPUT: a = b
Function cutkitu(ByVal s As String) As String
    Dim kq  As String
    Dim vt  As Long
    
    kq = Trim(s)
    If Left(kq, 1) = "'" Then
        Exit Function
    End If
    vt = InStr(1, kq, "'", vbTextCompare)
    If vt = 0 Then
        cutkitu = kq
        Exit Function
    Else
        cutkitu = Left(kq, vt - 1)
    End If
End Function
Sub test22()
    Dim s As String
    s = "Call thutuc"
    MsgBox find_fun_n_sub(s)
End Sub
'INPUT: Call thutuc()
'OUTPUT:thutuc

Function find_fun_n_sub(ByVal s As String) As String
    Dim s2      As String
    Dim i       As Long
    Dim dodaitem    As Long
    Dim vttem   As Long
    Dim kq      As String
    s2 = Trim(s)
    dodaitem = Len(s2)
    If dodaitem = 0 Then
        Exit Function
    End If

    'Kiem tra co comment khong
    vttem = InStr(1, s2, "'", vbTextCompare)
    If vttem > 1 Then
        s2 = Left(s2, vttem - 1)
        dodaitem = Len(s2)
    ElseIf vttem = 1 Then
        Exit Function
    End If
    'Kiem tra co phai thu tuc khong
    vttem = InStr(1, s2, "Call ", vbTextCompare)
    If vttem > 0 Then
        For i = vttem + 5 To dodaitem Step 1
            If Mid(s2, i, 1) = "(" Then
                Exit For
            Else
                kq = kq & Mid(s2, i, 1)
            End If
        Next i
        find_fun_n_sub = Trim(kq)
        Exit Function
    End If

End Function
Function GetVBAProjString() As String
  'gets ThisWorkbook's whole VBA project string
  'Set reference to Microsoft VBA Extensibility 5.5
 
  Dim VBProj As VBIDE.VBProject, VBComp As VBIDE.VBComponent
  Dim VBMod As VBIDE.CodeModule, sMod As String, sProj As String
  Dim nLines As Long
 
  'get ref to ThisWorkbook project
  Set VBProj = ThisWorkbook.VBProject
    
  'loop through VBComponents collection
  For Each VBComp In VBProj.VBComponents
    Set VBMod = VBComp.CodeModule
    nLines = VBMod.CountOfLines
      If nLines <> 0 Then
        sMod = VBMod.Lines(1, nLines)
        sProj = sProj & vbCrLf & _
            UCase(Chr(39) & VBComp.Name) & _
             vbCrLf & vbCrLf & sMod
      Else 'just accum name of empty component
        sProj = sProj & vbCrLf & _
            UCase(Chr(39) & VBComp.Name) & _
             vbCrLf & vbCrLf
      End If
  Next VBComp
 
  GetVBAProjString = sProj
  Set VBProj = Nothing: Set VBComp = Nothing
  Set VBMod = Nothing
 
End Function
 

tuhocvba

Administrator
Thành viên BQT
Nếu tạo ra được kết quả như thế này thì đẹp:
Bạn cần đăng nhập để thấy đính kèm


Thực tế hiện nay đang như thế này:
Bạn cần đăng nhập để thấy đính kèm


@vothanhthu , @ducdoom nghiên cứu cùng đi.
 
V

vothanhthu

Guest
Tạo cấu trúc Project cho toàn chương trình, Thứ nghĩ nếu ta lập thành Addin, cấu trúc chương trình trên thanh Ribbon sẽ hỗ trợ rất nhiều cho việc viết và hiểu code. Có thể nhấn vào là đến vị trí Sub, Function...
Đây là đoạn mã sau đây có thể tạo thành Ribbon trực tiếp bằng VBA, và gọi sub LoadMenu khi nhấn Load VBAList. Phần còn lại mới là phức tạp
Mã:
Const myPopup = "VBAList"
Sub BuildMenu()
   Dim j As Long
   Dim PopupA As CommandBarControl
   With Application.CommandBars(1)
      On Error Resume Next
      .Controls(myPopup).Delete
      On Error GoTo 0
      Set PopupA = .Controls.Add(Type:=msoControlPopup, _
                                 Before:=.FindControl(ID:=30010).Index, _
                                 Temporary:=True)
   End With
   With PopupA
      .Caption = myPopup
      With .Controls.Add(Type:=msoControlButton)
         .Caption = "Load VBAList"
         .OnAction = "LoadMenu" 'Hanh dong can goi
         .Style = MsoButtonStyle.msoButtonIconAndCaption
         .FaceId = 420
         .Enabled = True
      End With
   End With
End Sub
 

tuhocvba

Administrator
Thành viên BQT
Tiếp theo ý tưởng , cái này phải dựa trực tiếp bảng tính Excel, lợi dụng định dạng kẻ ô.
Bạn cần đăng nhập để thấy đính kèm

Mã:
Dim p_r As Long, p_c As Long
Sub test5()
    Call TestGetVBAProjString("taoconfigout", 5)
End Sub
'itemp: Sheets(itemp)
Sub TestGetVBAProjString(ByVal tenham As String, ByVal itemp As Byte)
    Dim linerr  As Variant
    Dim i       As Long
    Dim sStr    As String, nComps As Integer
    Dim s       As String
    
    Dim r       As Long, c  As Integer
    
    
 
    'get whole string
    sStr = GetVBAProjString
    If sStr = "" Then
        MsgBox "Khong tim thay du lieu"
        Exit Sub
    End If
    'show start of project string
    linerr = Split(sStr, vbNewLine)
    p_r = 2
    p_c = 2
    ThisWorkbook.Sheets(itemp).Cells(2, 1) = tenham
    Call subexist(linerr, tenham, itemp, p_c)
End Sub
Sub subexist(ByVal linerr As Variant, ByVal tenham As String, ByVal itemp As Byte, ByVal c As Long)
    Dim i       As Long, j  As Long
    Dim vt1     As Long, vt2 As Long
    Dim s       As String
    Dim myDic   As Object
    
    vt1 = -1
    'Find Position start Sub
    For i = LBound(linerr) To UBound(linerr) Step 1
        s = cutkitu(CStr(linerr(i)))
        If batdauthutuc(tenham, s) = True Then
            vt1 = i
            Exit For
        End If
    Next i
    If vt1 < 0 Then Exit Sub
    'Find position End Sub
    vt2 = -1
    For i = vt1 To UBound(linerr) Step 1
        s = cutkitu(CStr(linerr(i)))
        If s = "End Sub" Then
            vt2 = i
            Exit For
        End If
    Next i
    If vt2 = vt1 Then
        Exit Sub
    End If
    If vt2 < 0 Then Exit Sub
    'Xac dinh duoc tenham la co ton tai, kiem tra noi dung ben trong cua no xem co cac thu tuc nao co ben trong khong
    Set myDic = CreateObject("Scripting.Dictionary")
    For i = vt1 To vt2 Step 1
        s = cutkitu(CStr(linerr(i)))
        s = find_fun_n_sub(s)
        If s <> "" Then
            If s <> tenham Then
                If Not myDic.Exists(s) Then
                    myDic.Add s, s
                    p_r = p_r + 1
                    ThisWorkbook.Sheets(itemp).Cells(p_r, c) = s
                    '_ _ _ _ _ .
                    With ThisWorkbook.Sheets(itemp).Cells(p_r, c)
                        .Borders(xlEdgeBottom).LineStyle = xlContinuous
                        .Borders(xlEdgeBottom).Weight = xlHairline
                    End With
                    For j = p_r To 2 Step -1
                        If ThisWorkbook.Sheets(itemp).Cells(j, c - 1) <> "" Then Exit For
                    Next j
                    With ThisWorkbook.Sheets(itemp).Range(Cells(j + 1, c), Cells(p_r, c))
                        .Borders(xlEdgeLeft).LineStyle = xlContinuous
                        .Borders(xlEdgeLeft).Weight = xlThin
                    End With
                    Call subexist(linerr, s, itemp, c + 1)
                End If
            End If
        End If
    Next i
    Set myDic = Nothing
End Sub

Function batdauthutuc(ByVal tenham As String, ByVal dulieu_row As String) As Boolean
    Dim temp    As String
    temp = "Sub " & tenham
    If InStr(1, dulieu_row, temp, vbTextCompare) > 0 Then
        batdauthutuc = True
    Else
        batdauthutuc = False
    End If
End Function
'INPUT: a = b 'comment"
'OUTPUT: a = b
Function cutkitu(ByVal s As String) As String
    Dim kq  As String
    Dim vt  As Long
    
    kq = Trim(s)
    If Left(kq, 1) = "'" Then
        Exit Function
    End If
    vt = InStr(1, kq, "'", vbTextCompare)
    If vt = 0 Then
        cutkitu = kq
        Exit Function
    Else
        cutkitu = Left(kq, vt - 1)
    End If
End Function
Sub test22()
    Dim s As String
    s = "Call thutuc"
    MsgBox find_fun_n_sub(s)
End Sub
'INPUT: Call thutuc()
'OUTPUT:thutuc

Function find_fun_n_sub(ByVal s As String) As String
    Dim s2      As String
    Dim i       As Long
    Dim dodaitem    As Long
    Dim vttem   As Long
    Dim kq      As String
    s2 = Trim(s)
    dodaitem = Len(s2)
    If dodaitem = 0 Then
        Exit Function
    End If

    'Kiem tra co comment khong
    vttem = InStr(1, s2, "'", vbTextCompare)
    If vttem > 1 Then
        s2 = Left(s2, vttem - 1)
        dodaitem = Len(s2)
    ElseIf vttem = 1 Then
        Exit Function
    End If
    'Kiem tra co phai thu tuc khong
    vttem = InStr(1, s2, "Call ", vbTextCompare)
    If vttem > 0 Then
        For i = vttem + 5 To dodaitem Step 1
            If Mid(s2, i, 1) = "(" Then
                Exit For
            Else
                kq = kq & Mid(s2, i, 1)
            End If
        Next i
        find_fun_n_sub = Trim(kq)
        Exit Function
    End If

End Function
Function GetVBAProjString() As String
  'gets ThisWorkbook's whole VBA project string
  'Set reference to Microsoft VBA Extensibility 5.5
 
  Dim VBProj As VBIDE.VBProject, VBComp As VBIDE.VBComponent
  Dim VBMod As VBIDE.CodeModule, sMod As String, sProj As String
  Dim nLines As Long
 
  'get ref to ThisWorkbook project
  Set VBProj = ThisWorkbook.VBProject
    
  'loop through VBComponents collection
  For Each VBComp In VBProj.VBComponents
    Set VBMod = VBComp.CodeModule
    nLines = VBMod.CountOfLines
      If nLines <> 0 Then
        sMod = VBMod.Lines(1, nLines)
        sProj = sProj & vbCrLf & _
            UCase(Chr(39) & VBComp.Name) & _
             vbCrLf & vbCrLf & sMod
      Else 'just accum name of empty component
        sProj = sProj & vbCrLf & _
            UCase(Chr(39) & VBComp.Name) & _
             vbCrLf & vbCrLf
      End If
  Next VBComp
 
  GetVBAProjString = sProj
  Set VBProj = Nothing: Set VBComp = Nothing
  Set VBMod = Nothing
 
End Function
Như vậy việc memo các Sub đã xong. Việc memo các Function cần nghiên cứu thêm như đã nêu.
Hiện nay đang phải chèn module code này vào cùng với Project vba của file mà chúng ta muốn memo.
Mong muốn, nếu select vào một file excel macro mà đọc được code của nó thì tốt nhất. (Giả thiết file không để pass). @vothanhthu nghiên cứu điều này nhé.
 

Euler

Administrator
Thành viên BQT
cấu trúc chương trình trên thanh Ribbon sẽ hỗ trợ rất nhiều cho việc viết và hiểu code. Có thể nhấn vào là đến vị trí Sub, Function...
Bạn hiểu nhầm ý rồi, chủ đề là memo lại cấu trúc của một thủ tục. Lý do là vì: Trong thủ tục có nhiều chương trình con. Bên trong chương trình con lại có nhiều chương trình con khác nữa... Chứ không phải tạo nút lệnh Ribbon.
 

tuhocvba

Administrator
Thành viên BQT
Kết quả của như thế này:
Bạn cần đăng nhập để thấy đính kèm
 

giaiphapvba

Administrator
Thành viên BQT
Mang tính chất tham khảo, mình giới thiệu thêm đoạn code này, nó sẽ liệt kê toàn bộ thủ tục và hàm trong code Module:
Mã:
'---------------------------------------------------------------------------------------
' Purpose   :       Prints all subs and functions in a project
' Prerequisites:    Microsoft Visual Basic for Applications Extensibility 5.3 library
'                   CreateLogFile
' How to run:       Run GetFunctionAndSubNames, set a parameter to blnWithParentInfo
'                   If ComponentTypeToString(vbext_ct_StdModule) = "Code Module" Then
'
' Used:             ComponentTypeToString from -> http://www.cpearson.com/excel/vbe.aspx
'---------------------------------------------------------------------------------------
 
 
Private strSubsInfo As String
Public Sub GetFunctionAndSubNames()
 
    Dim item            As Variant
    Dim linerr          As Variant
    
    strSubsInfo = ""
    
    For Each item In ThisWorkbook.VBProject.VBComponents
        
        If ComponentTypeToString(vbext_ct_StdModule) = "Code Module" Then
            ListProcedures item.Name, False
            'Debug.Print item.CodeModule.lines(1, item.CodeModule.CountOfLines)
        End If
        
    Next item
    linerr = Split(strSubsInfo, vbNewLine)
End Sub
 
Private Sub ListProcedures(strName As String, Optional blnWithParentInfo = False)
 
    'Microsoft Visual Basic for Applications Extensibility 5.3 library
 
    Dim VBProj          As VBIDE.VBProject
    Dim VBComp          As VBIDE.VBComponent
    Dim CodeMod         As VBIDE.CodeModule
    Dim LineNum         As Long
    Dim ProcName        As String
    Dim ProcKind        As VBIDE.vbext_ProcKind
 
    Set VBProj = ActiveWorkbook.VBProject
    Set VBComp = VBProj.VBComponents(strName)
    Set CodeMod = VBComp.CodeModule
 
    With CodeMod
        LineNum = .CountOfDeclarationLines + 1
        
        Do Until LineNum >= .CountOfLines
            ProcName = .ProcOfLine(LineNum, ProcKind)
 
            If blnWithParentInfo Then
                strSubsInfo = strSubsInfo & IIf(strSubsInfo = vbNullString, vbNullString, vbCrLf) & strName & "." & ProcName
            Else
                strSubsInfo = strSubsInfo & IIf(strSubsInfo = vbNullString, vbNullString, vbCrLf) & ProcName
            End If
 
            LineNum = .ProcStartLine(ProcName, ProcKind) + .ProcCountLines(ProcName, ProcKind) + 1
        Loop
    End With
End Sub
 
Function ComponentTypeToString(ComponentType As VBIDE.vbext_ComponentType) As String
    'ComponentTypeToString from http://www.cpearson.com/excel/vbe.aspx
    Select Case ComponentType
    
        Case vbext_ct_ActiveXDesigner
            ComponentTypeToString = "ActiveX Designer"
            
        Case vbext_ct_ClassModule
            ComponentTypeToString = "Class Module"
            
        Case vbext_ct_Document
            ComponentTypeToString = "Document Module"
            
        Case vbext_ct_MSForm
            ComponentTypeToString = "UserForm"
            
        Case vbext_ct_StdModule
            ComponentTypeToString = "Code Module"
            
        Case Else
            ComponentTypeToString = "Unknown Type: " & CStr(ComponentType)
            
    End Select
    
End Function
Link nguồn:
 

Euler

Administrator
Thành viên BQT
Tiếp nối chủ đề mà bài viết #11 đã nêu, nếu file A không để pass thì từ đó có thể select file A và đọc code được.
Code:
Mã:
Function GetVBAProjString() As String
  'gets ThisWorkbook's whole VBA project string
  'Set reference to Microsoft VBA Extensibility 5.5
 
  Dim VBProj As VBIDE.VBProject, VBComp As VBIDE.VBComponent
  Dim VBMod As VBIDE.CodeModule, sMod As String, sProj As String
  Dim nLines As Long
  Dim lk As String, wbn As String
 
 
  lk = "C:\\Tool_A.xlsm"
  Workbooks.Open lk
  wbn = ActiveWorkbook.Name
 
  'get ref to ThisWorkbook project
  Set VBProj = Workbooks(wbn).VBProject
    
  'loop through VBComponents collection
  For Each VBComp In VBProj.VBComponents
    Set VBMod = VBComp.CodeModule
    nLines = VBMod.CountOfLines
      If nLines <> 0 Then
        sMod = VBMod.Lines(1, nLines)
        sProj = sProj & vbCrLf & _
            UCase(Chr(39) & VBComp.Name) & _
             vbCrLf & vbCrLf & sMod
      Else 'just accum name of empty component
        sProj = sProj & vbCrLf & _
            UCase(Chr(39) & VBComp.Name) & _
             vbCrLf & vbCrLf
      End If
  Next VBComp
 
  GetVBAProjString = sProj
  Set VBProj = Nothing: Set VBComp = Nothing
  Set VBMod = Nothing
 
End Function
 

tuhocvba

Administrator
Thành viên BQT
Về vấn đề ở #1:
Bạn chú ý thiết định Microsoft Visual Basic for Applications Extensibility 5.3:
Liệu có thể làm tự động được hay không, kiểu như Create Object, mình thử google và ra được cái này, hoạt động rất tốt.
Mã:
Sub AddRefGuid()
    'Add VBIDE (Microsoft Visual Basic for Applications Extensibility 5.3
  
    ThisWorkbook.VBProject.References.AddFromGuid _
        "{0002E157-0000-0000-C000-000000000046}", 2, 0
 
End Sub
Bạn cần đăng nhập để thấy đính kèm

Nguồn:
 
V

vothanhthu

Guest
Tiếp nối #10. Mình xin phép trích lại Addin của Hartmut Gruenhagen (2014). Trang chủ Addin và mọi nguồn tải Addin hiện đã bị xóa khỏi thế giới Internet.
Addin có các chức năng tổng hợp lại các Sub, Function... của tất cả các File đang mở, Và sẽ gọi khi chọn đến.
Bạn cần đăng nhập để thấy đính kèm

Nhấn vào để tải về
 
T

thanhphong

Guest
Mã:
Sub AddRefGuid()
    'Add VBIDE (Microsoft Visual Basic for Applications Extensibility 5.3

    ThisWorkbook.VBProject.References.AddFromGuid _
        "{0002E157-0000-0000-C000-000000000046}", 2, 0

End Sub
Nguồn:
Chưa hiểu đoạn code này xuất phát từ suy nghĩ nào.
Tạm thời có bài viết này rất hay:
List All References in Workbook VBProject
Nguồn:
Code dưới đây sẽ liệt kê hết các thư viện mà file Excel này đang được chọn.
Chú ý file phải có sheet name = "Refs"
Mã:
Sub Grab_References()
    'Comments:
    '
    'Purpose: List all references used in the workbook
    'Additional information: http://www.cpearson.com/Excel/vbe.aspx
    '
    'References: Microsoft Visual Basic for Applications Extensibility 5.3
    '
    'Date       Developer       Action
    '---------------------------------------------
    '01/18/12   ws              Created

    Dim wb As Workbook
    Dim ws As Worksheet
    Dim n As Integer
    Dim x As Integer

    Set wb = ThisWorkbook
    Set ws = wb.Worksheets("Refs")
    
    With wb
        On Error Resume Next
        x = 1
        For n = 1 To .VBProject.References.Count
            ws.Cells(x, 1) = n
            ws.Cells(x, 2) = .VBProject.References.Item(n).Description
            ws.Cells(x, 3) = .VBProject.References.Item(n).Major
            ws.Cells(x, 4) = .VBProject.References.Item(n).Minor
            ws.Cells(x, 5) = .VBProject.References.Item(n).FullPath
            ws.Cells(x, 6) = .VBProject.References.Item(n).GUID
            x = x + 1
        Next n
        ws.Columns("A:G").EntireColumn.AutoFit
    End With
    
    'Tidy up
        Set wb = Nothing
        Set ws = Nothing
End Sub
 

tuhocvba

Administrator
Thành viên BQT
Có lẽ chúng ta nên có qui định cho bản thân, với mỗi hàm tự tạo thì nên có từ khóa cố định cho hàm số. Chẳng hạn như chúng ta đăt tên hàm thì có tiền tố cố định là F_tênhàm thì từ đó macro mới dễ xác định được là chương trình sử dụng Function hay không, và là hàm nào. Hiện tại mới chỉ đưa ra được hướng xử lý với Sub. Với hàm số thì không đơn giản, vì có hàm tự tạo (quan tâm) và hàm sẵn có của Excel (không quan tâm), và macro khó có thể xác định được.

Nếu tìm những nơi định nghĩa Function:
Mã:
Function tên_hàm()...
End Function
Chúng ta cũng có thể nhặt được tên hàm, rồi sau đó nạp vào mảng.
Giả thiết nạp được 100 hàm này vào mảng.
Với mỗi dòng code lại phải xác định xem 100 hàm này có được viết trong dòng code đó không, quả là một việc tốn công tốn sức.
Ý tưởng như thế này :
Bạn cần đăng nhập để thấy đính kèm
 

Euler

Administrator
Thành viên BQT
Nếu một phép gán thông thường:
Mã:
x=Teham(a,b,c)
Nhưng nếu phép toán bây giờ là:
Mã:
If x = tenham1(a,b,c) or x = tenham2(a,b,c)
thì việc liệt kê tên hàm có trong thủ tục hay không sẽ phức tạp hơn ạ.
 
Top