Tự động chèn code vào sheet của 1 File Excel (1 người xem)

Quang_Hải · 1/5/13

Mình mở chủ đề này để giới thiệu cho các bạn nào quan tâm đến việc tự động chèn code vào 1 file excel nào đó.
Giả định trên file hiện tại có 1 sheet mang tên là "ABC", giờ ta muốn chèn code vào sheet này
Để phát triển thêm ta có thể thay ActiveWorkBook bằng tên của File ta cần chèn code

PHP:

Sub add_code_to_existing_sheet()
Dim CodeLines As Long, sheetCode
   sheetCode = ActiveWorkbook.Sheets("ABC").CodeName
   With ActiveWorkbook.VBProject.VBComponents(sheetCode).CodeModule
        CodeLines = .CountOfLines + 1
        .InsertLines CodeLines, _
            "Private Sub Worksheet_SelectionChange(ByVal Target As Range)" & Chr(13) & _
            "     MsgBox ""Code Created"" " & Chr(13) & _
            "End Sub"
    End With
End Sub

Ta cũng có thể tạo ra 1 sheet mới rồi chèn code vào sheet vừa được tạo bằng code bên dưới.

PHP:

Sub add_code_to_NewSheet()
Dim CodeLines As Long
   Sheets.Add
   With ActiveWorkbook.VBProject.VBComponents(ActiveSheet.CodeName).CodeModule
        CodeLines = .CountOfLines + 1
        .InsertLines CodeLines, _
            "Private Sub Worksheet_SelectionChange(ByVal Target As Range)" & Chr(13) & _
            "     msgbox ""Code Created"" " & Chr(13) & _
            "End Sub"
    End With
End Sub

Nếu cần chèn code vào WorkBook ta áp dụng code này

PHP:

Sub add_code_to_thisworkbook()
Dim CodeLines As Long
   With ActiveWorkbook.VBProject.VBComponents("Thisworkbook").CodeModule
        CodeLines = .CountOfLines + 1
        .InsertLines CodeLines, _
            "Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)" & Chr(13) & _
            "     msgbox ""Code Created"" " & Chr(13) & _
            "End Sub"
    End With
End Sub

Nếu cần thêm 1 module mới rồi chèn code vào module này thì ta làm như code bên dưới.
Chú ý: Để chèn được Module thì phải vào Tools, tìm và chọn mục Microsoft Visual Basic for Appliations extensibility 5.3
Hoặc khi viết code đến dòng ActiveWorkbook.VBProject.VBComponents.Add(vbext_ct_StdModule) thì Excel sẽ tự động hỏi mình có muốn chọn mục này hay không.

PHP:

Sub Add_Module_and_Code()
Dim CodeLines As Long, VBComp
   Set VBComp = ActiveWorkbook.VBProject.VBComponents.Add(vbext_ct_StdModule)
   With ActiveWorkbook.VBProject.VBComponents(VBComp.Name).CodeModule
        CodeLines = .CountOfLines + 1
        .InsertLines CodeLines, _
            "Sub Add_Module_and_Code" & Chr(13) & _
            "     msgbox ""Code Created"" " & Chr(13) & _
            "End Sub"
    End With
End Sub

Hy vọng là bài viết hữu ích cho những bạn mới học VBA

Kh Biet · 29/8/13

Cám ơn bạn Quang Hải , nhưng mình làm theo hướng dẫn để thêm code vào thiswokbook không được, nó báo lỗi mình không sử lý được . Bạn giúp mình viết code để tạo code trong thiswokbook :

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
ActiveWorkbook.Names.Add Name:="curRow", RefersToR1C1:="=1"
ActiveWorkbook.Names.Add Name:="curCol", RefersToR1C1:="=1"
End Sub

nó báo lỗi tô đỏ "curRow" bạn kiểm tra và giúp mình code trên . Xin cám ơn !

ndu96081631 · 29/8/13

Kh Biet đã viết:
Cám ơn bạn Quang Hải , nhưng mình làm theo hướng dẫn để thêm code vào thiswokbook không được, nó báo lỗi mình không sử lý được . Bạn giúp mình viết code để tạo code trong thiswokbook :

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
ActiveWorkbook.Names.Add Name:="curRow", RefersToR1C1:="=1"
ActiveWorkbook.Names.Add Name:="curCol", RefersToR1C1:="=1"
End Sub

nó báo lỗi tô đỏ "curRow" bạn kiểm tra và giúp mình code trên . Xin cám ơn !

Cho "rừng" code này vào 1 Module:

Mã:

Private Sub ChangeVBOM()
  Dim regKey As String
  regKey = "HKEY_LOCAL_MACHINE\Software\Microsoft\Office\" & Application.Version & "\Excel\Security\AccessVBOM"
  CreateObject("WScript.Shell").RegWrite regKey, 1, "REG_DWORD"
End Sub
Private Function IsVBATrusted() As Boolean
  Application.Volatile
  On Error Resume Next
  IsVBATrusted = Not ThisWorkbook.VBProject Is Nothing
End Function
Sub Main()
  Dim strCode As String, bChk As Boolean
  strCode = "Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)" & vbLf & _
            "ActiveWorkbook.Names.Add Name:=""curRow"", RefersToR1C1:=""=1""" & vbLf & _
            "ActiveWorkbook.Names.Add Name:=""curCol"", RefersToR1C1:=""=1""" & vbLf & _
            "End Sub"
  bChk = IsVBATrusted
  If bChk = False Then ChangeVBOM
  bChk = IsVBATrusted
  If bChk Then
    On Error Resume Next
    With ActiveWorkbook.VBProject.VBComponents("Thisworkbook").CodeModule
      .DeleteLines 1, .CountOfLines
      On Error GoTo 0
      .AddFromString (strCode)
    End With
  End If
End Sub

Chạy sub Main và kiểm tra kết quả

Kh Biet · 29/8/13

ndu96081631 đã viết:

Cho "rừng" code này vào 1 Module:

Mã:

Private Sub ChangeVBOM()
  Dim regKey As String
  regKey = "HKEY_LOCAL_MACHINE\Software\Microsoft\Office\" & Application.Version & "\Excel\Security\AccessVBOM"
  CreateObject("WScript.Shell").RegWrite regKey, 1, "REG_DWORD"
End Sub
Private Function IsVBATrusted() As Boolean
  Application.Volatile
  On Error Resume Next
  IsVBATrusted = Not ThisWorkbook.VBProject Is Nothing
End Function
Sub Main()
  Dim strCode As String, bChk As Boolean
  strCode = "Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)" & vbLf & _
            "ActiveWorkbook.Names.Add Name:=""curRow"", RefersToR1C1:=""=1""" & vbLf & _
            "ActiveWorkbook.Names.Add Name:=""curCol"", RefersToR1C1:=""=1""" & vbLf & _
            "End Sub"
  bChk = IsVBATrusted
  If bChk = False Then ChangeVBOM
  bChk = IsVBATrusted
  If bChk Then
    On Error Resume Next
    With ActiveWorkbook.VBProject.VBComponents("Thisworkbook").CodeModule
      .DeleteLines 1, .CountOfLines
      On Error GoTo 0
      .AddFromString (strCode)
    End With
  End If
End Sub

Chạy sub Main và kiểm tra kết quả

Cám ơn thày NDU, thấy code mẫu của bạn Quang Hải chạy được ngay, nhà em áp dụng nhưng không được . Xem code của thày mới biết nếu nhà em "mò" thì không biết bao nhiêu "Mùa quýt" nữa thì mới ra . xin cám ơn thày .

ndu96081631 · 29/8/13

Kh Biet đã viết:
Cám ơn thày NDU, thấy code mẫu của bạn Quang Hải chạy được ngay, nhà em áp dụng nhưng không được . Xem code của thày mới biết nếu nhà em "mò" thì không biết bao nhiêu "Mùa quýt" nữa thì mới ra . xin cám ơn thày .

Thấy vậy chứ code cũng đơn giản lắm. Tôi chia làm 3 đoạn (3 Sub) và "phân công" cho nó làm những công việc chỉ định sẵn:
Trước tiên ta phải biết rằng mọi truy cập vào cửa sổ VBA (như thêm, xóa, sửa code) đều không được anh Bill chấp nhận nếu chưa "đăng ký"
Việc đăng ký đề được phép thao tác trong cửa sổ VBA chỉ là việc check mục "Trust access to VBA project..." trong phần Macro Setting
Vậy làm sao ta biết mục "Trust access to VBA project..." đã được check hay chưa? Làm bằng tay bằng cách vào Excel Options xem và check bằng tay hoặc dùng code để tự động (tôi đang dùng cách này)
- Sub ChangeVBOM là dùng code để check tự động (truy cập Registry)
- Function IsVBATrusted để kiểm tra xem mục "Trust access to VBA project..." đã được check hay chưa?
- Sub Main: Tiến hành kiểm tra "Trust access..." nếu chưa check thì.. check.... Tiếp theo mới chèn code vào
Chỉ vậy thôi
Đương nhiên nếu bạn đã check bằng tay mục "Trust access to VBA project.." rồi thì Sub Main sẽ ngắn gọn hơn. Ở đây tôi viết tổng quát để máy nào xài cũng được nên code hơi dài chút

Kh Biet · 29/8/13

ndu96081631 đã viết:
Thấy vậy chứ code cũng đơn giản lắm. Tôi chia làm 3 đoạn (3 Sub) và "phân công" cho nó làm những công việc chỉ định sẵn:
Trước tiên ta phải biết rằng mọi truy cập vào cửa sổ VBA (như thêm, xóa, sửa code) đều không được anh Bill chấp nhận nếu chưa "đăng ký"
Việc đăng ký đề được phép thao tác trong cửa sổ VBA chỉ là việc check mục "Trust access to VBA project..." trong phần Macro Setting
Vậy làm sao ta biết mục "Trust access to VBA project..." đã được check hay chưa? Làm bằng tay bằng cách vào Excel Options xem và check bằng tay hoặc dùng code để tự động (tôi đang dùng cách này)
- Sub ChangeVBOM là dùng code để check tự động (truy cập Registry)
- Function IsVBATrusted để kiểm tra xem mục "Trust access to VBA project..." đã được check hay chưa?
- Sub Main: Tiến hành kiểm tra "Trust access..." nếu chưa check thì.. check.... Tiếp theo mới chèn code vào
Chỉ vậy thôi
Đương nhiên nếu bạn đã check bằng tay mục "Trust access to VBA project.." rồi thì Sub Main sẽ ngắn gọn hơn. Ở đây tôi viết tổng quát để máy nào xài cũng được nên code hơi dài chút

không những thày giỏi về VBA, giỏi excel mà thày còn giỏi cả về lĩnh vực sư phạm nữa, các bài viết của thày cô đọng, xúc tích, lột tả được ý định muốn truyền đạt tới người khác; mà hình như thày không phải làm nghề giáo thì phải, nếu đúng thì càng xin kính phục thày hơn ! xin cám ơn Thày .

ndu96081631 · 29/8/13

Kh Biet đã viết:
không những thày giỏi về VBA, giỏi excel mà thày còn giỏi cả về lĩnh vực sư phạm nữa, các bài viết của thày cô đọng, xúc tích, lột tả được ý định muốn truyền đạt tới người khác; mà hình như thày không phải làm nghề giáo thì phải, nếu đúng thì càng xin kính phục thày hơn ! xin cám ơn Thày .

Mình làm.. công nhân thôi anh ơi
-------------------------------
Được biết anh cũng đang trong quá trình muốn vấn thân vào con đường đau khổ (VBA). Vậy xin mời anh đến đây tham khảo nhé:
http://www.giaiphapexcel.com/forum/showthread.php?6354-Giới-thiệu-Cơ-bản-về-vòng-lặp-For-next
Ngày trước mình cũng "lớn lên" từ topic ấy và tìm được một sư phụ mà suốt đời mình không quên ơn

Kh Biet · 29/8/13

ndu96081631 đã viết:
Mình làm.. công nhân thôi anh ơi
-------------------------------
Được biết anh cũng đang trong quá trình muốn vấn thân vào con đường đau khổ (VBA). Vậy xin mời anh đến đây tham khảo nhé:
http://www.giaiphapexcel.com/forum/showthread.php?6354-Giới-thiệu-Cơ-bản-về-vòng-lặp-For-next
Ngày trước mình cũng "lớn lên" từ topic ấy và tìm được một sư phụ mà suốt đời mình không quên ơn

Dù thày làm nghề gì thì thày vẫn là thày của nhiều người và nhiều thế hệ của GPE , thày vẫn là một cây đại thụ của GPE được nhiều người ngưỡng mộ và kính phục, xin cám ơn thày cả về đường Link trên nữa .

Kh Biet · 30/8/13

Có chút phát sinh nhờ thầy NDU và các bạn xem giúp, Code trên đối với tập tin mới trong thisworkbook không có code thì tốt rồi . Nhưng nếu trước đó đã có code thì nó xoá sạch . Sub main sửa thế nào để nó chỉ thêm code mới chứ không xóa code cũ ? xin cám ơn !

ndu96081631 · 30/8/13

Kh Biet đã viết:
Có chút phát sinh nhờ thầy NDU và các bạn xem giúp, Code trên đối với tập tin mới trong thisworkbook không có code thì tốt rồi . Nhưng nếu trước đó đã có code thì nó xoá sạch . Sub main sửa thế nào để nó chỉ thêm code mới chứ không xóa code cũ ? xin cám ơn !

Vì sợ cái vụ chạy code 2 lần sẽ sinh ra 2 Sub trùng tên nên mình phải xóa những gì trước đó
Đoạn code:

Mã:

Sub Main()
  Dim strCode As String, bChk As Boolean
  strCode = "Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)" & vbLf & _
            "ActiveWorkbook.Names.Add Name:=""curRow"", RefersToR1C1:=""=1""" & vbLf & _
            "ActiveWorkbook.Names.Add Name:=""curCol"", RefersToR1C1:=""=1""" & vbLf & _
            "End Sub"
  bChk = IsVBATrusted
  If bChk = False Then ChangeVBOM
  bChk = IsVBATrusted
  If bChk Then
    On Error Resume Next
    With ActiveWorkbook.VBProject.VBComponents("Thisworkbook").CodeModule
      [COLOR=#ff0000].DeleteLines 1, .CountOfLines[/COLOR]
      On Error GoTo 0
      .AddFromString (strCode)
    End With
  End If
End Sub

Chổ màu đỏ là để xóa code. Vậy nếu anh không muốn xóa, cứ bỏ dòng đỏ đỏ ấy đi là được
Lý ra nếu làm hoàn chỉnh thì phải có thêm công đoạn kiểm tra xem code ta chuẩn bị chèn đã tồn tại chưa ---> Nhưng làm thế thì code sẽ dài thêm ---> Anh lại "ngợp" thêm thôi

Kh Biet · 30/8/13

ndu96081631 đã viết:
Vì sợ cái vụ chạy code 2 lần sẽ sinh ra 2 Sub trùng tên nên mình phải xóa những gì trước đó
Đoạn code:

Mã:

Sub Main() Dim strCode As String, bChk As Boolean strCode = "Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)" & vbLf & _ "ActiveWorkbook.Names.Add Name:=""curRow"", RefersToR1C1:=""=1""" & vbLf & _ "ActiveWorkbook.Names.Add Name:=""curCol"", RefersToR1C1:=""=1""" & vbLf & _ "End Sub" bChk = IsVBATrusted If bChk = False Then ChangeVBOM bChk = IsVBATrusted If bChk Then On Error Resume Next With ActiveWorkbook.VBProject.VBComponents("Thisworkbook").CodeModule [COLOR=#ff0000].DeleteLines 1, .CountOfLines[/COLOR] On Error GoTo 0 .AddFromString (strCode) End With End If End Sub

Chổ màu đỏ là để xóa code. Vậy nếu anh không muốn xóa, cứ bỏ dòng đỏ đỏ ấy đi là được
Lý ra nếu làm hoàn chỉnh thì phải có thêm công đoạn kiểm tra xem code ta chuẩn bị chèn đã tồn tại chưa ---> Nhưng làm thế thì code sẽ dài thêm ---> Anh lại "ngợp" thêm thôi

Cám ơn thày ! Đúng là nó sẽ bị gọi 2 lần vì tập tin sẽ ghi dạng đuôi .xlam nên người khác ứng dụng sẽ rất dễ mắc lỗi này . Với code này học là phụ, ứng dụng là chính nên thày giúp nhà em , nhà em cứ "bê nguyên si" thế là được .Mà học "bơi" có lẽ cũng phải để vài lần uống nước nó mới nhanh biết bơi thày ạ !

ndu96081631 · 30/8/13

Kh Biet đã viết:
Cám ơn thày ! Đúng là nó sẽ bị gọi 2 lần vì tập tin sẽ ghi dạng đuôi .xlam nên người khác ứng dụng sẽ rất dễ mắc lỗi này . Với code này học là phụ, ứng dụng là chính nên thày giúp nhà em , nhà em cứ "bê nguyên si" thế là được .Mà học "bơi" có lẽ cũng phải để vài lần uống nước nó mới nhanh biết bơi thày ạ !

Nếu vậy anh sửa Sub Main thành vầy đi:

Mã:

Sub Main()
  Dim strCode As String, bChk As Boolean
  strCode = "Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)" & vbLf & _
            "ActiveWorkbook.Names.Add Name:=""curRow"", RefersToR1C1:=""=1""" & vbLf & _
            "ActiveWorkbook.Names.Add Name:=""curCol"", RefersToR1C1:=""=1""" & vbLf & _
            "End Sub"
  bChk = IsVBATrusted
  If bChk = False Then ChangeVBOM
  bChk = IsVBATrusted
  If bChk Then
    On Error Resume Next
    With ActiveWorkbook.VBProject.VBComponents("Thisworkbook").CodeModule
      [COLOR=#ff0000][B]If .ProcBodyLine("Workbook_SheetSelectionChange", 0) = 0 Then .AddFromString strCode[/B][/COLOR]
    End With
  End If
End Sub

Chổ màu đỏ là chổ mới sửa lại: Nếu đã có code thì sẽ không thêm code nữa

Kh Biet · 30/8/13

Gửi tới thày NDU :
- Chiều nhà em đi vắng nên phúc đáp chậm, xin lỗi thày nhé . Xin cám ơn thày ! code chạy tốt rồi ạ .

siwtom · 30/8/13

Kh Biet đã viết:
Cám ơn thày ! Đúng là nó sẽ bị gọi 2 lần vì tập tin sẽ ghi dạng đuôi .xlam nên người khác ứng dụng sẽ rất dễ mắc lỗi này . Với code này học là phụ, ứng dụng là chính nên thày giúp nhà em , nhà em cứ "bê nguyên si" thế là được .Mà học "bơi" có lẽ cũng phải để vài lần uống nước nó mới nhanh biết bơi thày ạ !

Nếu có ai khác nữa quan tâm thì xin mời tham khảo bài #136, #138 và các bài trước nữa.

http://www.giaiphapexcel.com/forum/...g-vba-để-xóa-vba-đc-không&p=450485#post450485

Tôi cũng đã soạn một số sub, function cần thiết có trong bài #9 (cũng có đính kèm tập tin)

http://www.giaiphapexcel.com/forum/showthread.php?80098-Viết-code-cho-sheet&p=496406#post496406
-----------------
Đính kèm tập tin ở link thứ 2 rồi:

Mã:

Sub Main()
Dim strCode As String, bChk As Boolean
    strCode = "Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)" & vbLf & _
            "ActiveWorkbook.Names.Add Name:=""curRow"", RefersToR1C1:=""=1""" & vbLf & _
            "ActiveWorkbook.Names.Add Name:=""curCol"", RefersToR1C1:=""=1""" & vbLf & _
            "End Sub"
'   bChk = IsVBATrusted
'   If bChk = False Then ChangeVBOM
'   bChk = IsVBATrusted
'   If bChk Then
'    On Error Resume Next
        If Not [COLOR=#0000ff]FunctionInModule[/COLOR](ActiveWorkbook, "Thisworkbook", "Workbook_SheetSelectionChange") Then
            [COLOR=#0000ff]AddFunctionFromString[/COLOR] ActiveWorkbook, "ThisWorkbook", strCode
        End If
'    End If
End Sub

Ngoài việc thêm code từ STRING còn có hàm thêm từ tập tin - AddFunctionFromFile
Trong module có một số sub, function hữu ích, có mô tả cách dùng.
-------------
Chú ý: để dùng toàn bộ code trong module đính kèm thì thêm tham chiếu tới Microsoft Visual Basic for Applications Extensibility

Kh Biet · 30/8/13

siwtom đã viết:
Nếu có ai khác nữa quan tâm thì xin mời tham khảo bài #136, #138 và các bài trước nữa.

http://www.giaiphapexcel.com/forum/...g-vba-để-xóa-vba-đc-không&p=450485#post450485

Tôi cũng đã soạn một số sub, function cần thiết có trong bài #9 (cũng có đính kèm tập tin)

http://www.giaiphapexcel.com/forum/showthread.php?80098-Viết-code-cho-sheet&p=496406#post496406
-----------------
Đính kèm tập tin ở link thứ 2 rồi:

Mã:

Sub Main() Dim strCode As String, bChk As Boolean strCode = "Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)" & vbLf & _ "ActiveWorkbook.Names.Add Name:=""curRow"", RefersToR1C1:=""=1""" & vbLf & _ "ActiveWorkbook.Names.Add Name:=""curCol"", RefersToR1C1:=""=1""" & vbLf & _ "End Sub" ' bChk = IsVBATrusted ' If bChk = False Then ChangeVBOM ' bChk = IsVBATrusted ' If bChk Then ' On Error Resume Next If Not [COLOR=#0000ff]FunctionInModule[/COLOR](ActiveWorkbook, "Thisworkbook", "Workbook_SheetSelectionChange") Then [COLOR=#0000ff]AddFunctionFromString[/COLOR] ActiveWorkbook, "ThisWorkbook", strCode End If ' End If End Sub

Ngoài việc thêm code từ STRING còn có hàm thêm từ tập tin - AddFunctionFromFile
Trong module có một số sub, function hữu ích, có mô tả cách dùng.
-------------
Chú ý: để dùng toàn bộ code trong module đính kèm thì thêm tham chiếu tới Microsoft Visual Basic for Applications Extensibility

Cám ơn thày siwtom, nhiều khi biết diễn đàn có chủ đề mình cần nhưng dùng từ khóa để tìm nhiều khi không đúng nên nó không ra . Có những lúc như đi siêu thị hoa hết cả mắt, thấy cái gì cũng đẹp cái gì cũng muốn mua, nhưng tiền thì có hạn . Vì vậy vào GPE cái gì cũng muốn học, nhưng học chẳng được bao nhiêu, Nhà em xin cám ơn thày .

ndu96081631 · 30/8/13

Kh Biet đã viết:
Gửi tới thày NDU :
- Chiều nhà em đi vắng nên phúc đáp chậm, xin lỗi thày nhé . Xin cám ơn thày ! code chạy tốt rồi ạ .

Ở bài trên anh có đề cập đến việc lưu file thành AddIn (xlam). Tôi tò mò muốn biết anh sẽ chạy AddIn này thế nào? Tức là sau khi gọi AddIn lên, anh làm cách nào để chạy Sub Main
(Tôi hỏi thế vì biết anh là người mới học VBA... Nếu như có gì đó khó khăn trong việc sử dụng AddIn, tôi sẽ giúp anh hoàn chỉnh 1 lần luôn)

Quang_Hải · 30/8/13

ndu96081631 đã viết:
Thấy vậy chứ code cũng đơn giản lắm. Tôi chia làm 3 đoạn (3 Sub) và "phân công" cho nó làm những công việc chỉ định sẵn:
Trước tiên ta phải biết rằng mọi truy cập vào cửa sổ VBA (như thêm, xóa, sửa code) đều không được anh Bill chấp nhận nếu chưa "đăng ký"
Việc đăng ký đề được phép thao tác trong cửa sổ VBA chỉ là việc check mục "Trust access to VBA project..." trong phần Macro Setting
Vậy làm sao ta biết mục "Trust access to VBA project..." đã được check hay chưa? Làm bằng tay bằng cách vào Excel Options xem và check bằng tay hoặc dùng code để tự động (tôi đang dùng cách này)
- Sub ChangeVBOM là dùng code để check tự động (truy cập Registry)
- Function IsVBATrusted để kiểm tra xem mục "Trust access to VBA project..." đã được check hay chưa?
- Sub Main: Tiến hành kiểm tra "Trust access..." nếu chưa check thì.. check.... Tiếp theo mới chèn code vào
Chỉ vậy thôi
Đương nhiên nếu bạn đã check bằng tay mục "Trust access to VBA project.." rồi thì Sub Main sẽ ngắn gọn hơn. Ở đây tôi viết tổng quát để máy nào xài cũng được nên code hơi dài chút

Hic, máy tính của em bị báo lỗi
Invalid root in registry key...
Em vào Regedit thì chỉ thấy thế này thôi
HKEY_LOCAL_MACHINE\Software\Microsoft\Office\14.0\
Tới đây thì đường dẫn lạ hoắc so với câu lệnh anh viết trong code

HKEY_LOCAL_MACHINE\Software\Microsoft\Office\" & Application.Version & "\Excel\Security\AccessVBOM"

Kh Biet · 30/8/13

ndu96081631 đã viết:
Ở bài trên anh có đề cập đến việc lưu file thành AddIn (xlam). Tôi tò mò muốn biết anh sẽ chạy AddIn này thế nào? Tức là sau khi gọi AddIn lên, anh làm cách nào để chạy Sub Main
(Tôi hỏi thế vì biết anh là người mới học VBA... Nếu như có gì đó khó khăn trong việc sử dụng AddIn, tôi sẽ giúp anh hoàn chỉnh 1 lần luôn)

Cám ơn thày, nhà em cố gắng tự giải quyết, nếu không được nhà em sẽ phiền các thày . Vì thày đã gọi nó là "con đường đau khổ" thì không thể dễ dang được . Còn sub main nhà em sẽ gán lệnh tắt để gọi nó khi cần ạ !

siwtom · 31/8/13

quanghai1969 đã viết:
Hic, máy tính của em bị báo lỗi
Invalid root in registry key...
Em vào Regedit thì chỉ thấy thế này thôi
HKEY_LOCAL_MACHINE\Software\Microsoft\Office\14.0\
Tới đây thì đường dẫn lạ hoắc so với câu lệnh anh viết trong code

HKEY_LOCAL_MACHINE\Software\Microsoft\Office\" & Application.Version & "\Excel\Security\AccessVBOM"

Bạn không nên dùng HKEY_LOCAL_MACHINE mà dùng HKEY_CURRENT_USER. Đơn giản vì 2 sự thật là: "Nếu khóa có ở HKEY_LOCAL_MACHINE thì chắc chắn có ở HKEY_CURRENT_USER, nhưng có thể có ở HKEY_CURRENT_USER mà không có ở HKEY_LOCAL_MACHINE"

Trong ví dụ sau tôi có hàm đọc "Trust Access" (Trust access.rar).

http://www.giaiphapexcel.com/forum/...được-các-thủ-tục-riêng-lẻ&p=499429#post499429

Nếu là thao tác lịch sự thì: thay đổi các thiết lập --> làm việc của mình --> trả lại các thiết lập. Tôi rất ghét những phần mềm mà khi cài thì tự thay đổi các tùy chọn của tôi nhưng khi tôi đá đít nó thì nó không trả về các thiết lập của tôi.

tuankt007 · 30/5/17

tôi thêm được rồi nhưng khi cho macro chạy thi ko active được
tks

tuankt007 · 30/5/17

Khi chep vo bị lỗi chỗ code : msgbox ""Code Created"" ... tôi add code code vô bỏ msgbox thì lỗi
help me

Trường An Nguyễn · 2/1/18

ndu96081631 đã viết:

Cho "rừng" code này vào 1 Module:

Mã:

Private Sub ChangeVBOM()
  Dim regKey As String
  regKey = "HKEY_LOCAL_MACHINE\Software\Microsoft\Office\" & Application.Version & "\Excel\Security\AccessVBOM"
  CreateObject("WScript.Shell").RegWrite regKey, 1, "REG_DWORD"
End Sub
Private Function IsVBATrusted() As Boolean
  Application.Volatile
  On Error Resume Next
  IsVBATrusted = Not ThisWorkbook.VBProject Is Nothing
End Function
Sub Main()
  Dim strCode As String, bChk As Boolean
  strCode = "Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)" & vbLf & _
            "ActiveWorkbook.Names.Add Name:=""curRow"", RefersToR1C1:=""=1""" & vbLf & _
            "ActiveWorkbook.Names.Add Name:=""curCol"", RefersToR1C1:=""=1""" & vbLf & _
            "End Sub"
  bChk = IsVBATrusted
  If bChk = False Then ChangeVBOM
  bChk = IsVBATrusted
  If bChk Then
    On Error Resume Next
    With ActiveWorkbook.VBProject.VBComponents("Thisworkbook").CodeModule
      .DeleteLines 1, .CountOfLines
      On Error GoTo 0
      .AddFromString (strCode)
    End With
  End If
End Sub

Chạy sub Main và kiểm tra kết quả

Chào ndu,
Mình copy đoạn code này của bạn và phát sinh lỗi như hình. Mình có đổi HKEY_LOCAL_MACHINE thành HKEY_CURRENT_USER như bạn siwtom hướng dẫn, nhưng không thấy code được thêm vào Thiswworkbook.
Nhờ ndu giúp đỡ.
Cảm ơn.

ndu96081631 · 2/1/18

Trường An Nguyễn đã viết:
Chào ndu,
Mình copy đoạn code này của bạn và phát sinh lỗi như hình. Mình có đổi HKEY_LOCAL_MACHINE thành HKEY_CURRENT_USER như bạn siwtom hướng dẫn, nhưng không thấy code được thêm vào Thiswworkbook.
Nhờ ndu giúp đỡ.
Cảm ơn.

Bạn thử làm bằng tay bỏ check (hoặc check) mục "Trust access to.... " trong Excel Options rồi chạy lại code xem sao

ThangCuAnh · 2/1/18

Bạn sửa code hàm ChangeVBOM lại như dưới đây và test thử nhé

Mã:

Private Sub ChangeVBOM()
    Dim regKey As String
    Dim dwRet As Long
    Dim WshShell As Object
  
    Set WshShell = CreateObject("WScript.Shell")
    regKey = "HKCU\Software\Microsoft\Office\" & Application.Version & "\Excel\Security\AccessVBOM"
  
    On Error Resume Next
    dwRet = WshShell.RegRead(regKey)
    If (0 = dwRet) Or (Err.Number <> 0) Then
        Err.Clear
        WshShell.RegWrite regKey, 1, "REG_DWORD"
    End If
End Sub

HKCU = HKEY_CURRENT_USER
HKLM = HKEY_LOCAL_MACHINE
Dùng key nào cũng được, HKLM thì tác dụng với all user, còn HKCU thì tác dụng với current user

ndu96081631 · 2/1/18

Phát hiện ra chuyện "động trời" rằng:
- Cho dù Registry đã thay đổi (AccessVBOM đã được gán = 1) nhưng Excel vẫn chưa cập nhật (Trust access to... vẫn chưa được check)
- Đôi lúc key Security không tồn tại trên một vài máy, mất công phải tạo bằng tay hoặc phải viết code để tạo ra nó trước
vân... vân...
Khá rắc rối!
Thôi thì SendKeys cho khỏe (Alt + T + M + S)

Mã:

Private Function IsVBATrusted() As Boolean
  Application.Volatile
  On Error Resume Next
  IsVBATrusted = Not ThisWorkbook.VBProject Is Nothing
End Function
Sub Main()
  Dim n As Long, strCode As String
  strCode = "Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)" & vbLf & _
            "ActiveWorkbook.Names.Add Name:=""curRow"", RefersToR1C1:=""=1""" & vbLf & _
            "ActiveWorkbook.Names.Add Name:=""curCol"", RefersToR1C1:=""=1""" & vbLf & _
            "End Sub"
  If IsVBATrusted = False Then
    For n = 1 To 3
      SendKeys ("%tms%v{ENTER}")
      DoEvents
      If IsVBATrusted = True Then Exit For
    Next
  End If
  If IsVBATrusted Then
    On Error Resume Next
    With ActiveWorkbook.VBProject.VBComponents("Thisworkbook").CodeModule
      .DeleteLines 1, .CountOfLines
      On Error GoTo 0
      .AddFromString (strCode)
    End With
  End If
End Sub

NguyenNgocThuHien · 2/1/18

ndu96081631 đã viết:
Phát hiện ra chuyện "động trời" rằng:
- Cho dù Registry đã thay đổi (AccessVBOM đã được gán = 1) nhưng Excel vẫn chưa cập nhật (Trust access to... vẫn chưa được check)
- Đôi lúc key Security không tồn tại trên một vài máy, mất công phải tạo bằng tay hoặc phải viết code để tạo ra nó trước
vân... vân...
Khá rắc rối!
Thôi thì SendKeys cho khỏe (Alt + T + M + S)

Mã:

Private Function IsVBATrusted() As Boolean Application.Volatile On Error Resume Next IsVBATrusted = Not ThisWorkbook.VBProject Is Nothing End Function Sub Main() Dim n As Long, strCode As String strCode = "Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)" & vbLf & _ "ActiveWorkbook.Names.Add Name:=""curRow"", RefersToR1C1:=""=1""" & vbLf & _ "ActiveWorkbook.Names.Add Name:=""curCol"", RefersToR1C1:=""=1""" & vbLf & _ "End Sub" If IsVBATrusted = False Then For n = 1 To 3 SendKeys ("%tms%v{ENTER}") DoEvents If IsVBATrusted = True Then Exit For Next End If If IsVBATrusted Then On Error Resume Next With ActiveWorkbook.VBProject.VBComponents("Thisworkbook").CodeModule .DeleteLines 1, .CountOfLines On Error GoTo 0 .AddFromString (strCode) End With End If End Sub

Nếu thế thì chơi kiểu:
1, Check xem nó bật chưa ( dùng IsVBATrusted)
2, Nếu chưa bật thì ta bật nó ( dùng reg)
3, Check lại xem nó bật chưa( IsVBATrusted). Nếu nó vẫn chưa bật thì kểu người dùng khởi động lại Excel.

ndu96081631 · 2/1/18

NguyenNgocThuHien đã viết:
Nếu thế thì chơi kiểu:
1, Check xem nó bật chưa ( dùng IsVBATrusted)
2, Nếu chưa bật thì ta bật nó ( dùng reg)
3, Check lại xem nó bật chưa( IsVBATrusted). Nếu nó vẫn chưa bật thì kểu người dùng khởi động lại Excel.

Thì lúc đầu mình làm vậy đấy!
Vấn đề là khi ghi giá trị AccessVBOM = 1 vào Registry rồi nhưng Excel vẫn chưa cập nhật trạng thái. Khi ấy nếu dùng hàm IsVBATrusted để kiểm tra vẫn nhận giá trị = FALSE
Nếu kêu người dùng khởi động Excel thì thôi thà tôi làm vầy:
- Dùng hàm IsVBATrusted kiểm tra
- Nếu kết quả quả hàm = FALSE, xuất hiện thông báo kêu người dùng vào Excel Options\Trust Center\Trust Center Setting\Macro Settings rồi tự check bằng tay vào mục "Trus access to...."
Vậy cho khỏe
Ở đây mình muốn mọi thứ tự động hơn! Bạn có ý tưởng gì không?

Kiều Mạnh · 2/1/18

ndu96081631 đã viết:
Thì lúc đầu mình làm vậy đấy!
Vấn đề là khi ghi giá trị AccessVBOM = 1 vào Registry rồi nhưng Excel vẫn chưa cập nhật trạng thái. Khi ấy nếu dùng hàm IsVBATrusted để kiểm tra vẫn nhận giá trị = FALSE
Nếu kêu người dùng khởi động Excel thì thôi thà tôi làm vầy:
- Dùng hàm IsVBATrusted kiểm tra
- Nếu kết quả quả hàm = FALSE, xuất hiện thông báo kêu người dùng vào Excel Options\Trust Center\Trust Center Setting\Macro Settings rồi tự check bằng tay vào mục "Trus access to...."
Vậy cho khỏe
Ở đây mình muốn mọi thứ tự động hơn! Bạn có ý tưởng gì không?

Em thấy Anh Quanghai1969 trước đây có viết rùi hay sao ấy ... chạy ok ..........
http://www.giaiphapexcel.com/dienda...ổ-vba-trust-center-bằng-code-vba.99865/page-2

ndu96081631 · 2/1/18

kieu manh đã viết:
Em thấy Anh Quanghai1969 trước đây có viết rùi hay sao ấy ... chạy ok ..........
http://www.giaiphapexcel.com/diendan/threads/làm-sao-đóng-được-cửa-sổ-vba-trust-center-bằng-code-vba.99865/page-2

Thì cũng là SendKeys như tôi thôi

NguyenNgocThuHien · 2/1/18

ndu96081631 đã viết:
Thì lúc đầu mình làm vậy đấy!
Vấn đề là khi ghi giá trị AccessVBOM = 1 vào Registry rồi nhưng Excel vẫn chưa cập nhật trạng thái. Khi ấy nếu dùng hàm IsVBATrusted để kiểm tra vẫn nhận giá trị = FALSE
Nếu kêu người dùng khởi động Excel thì thôi thà tôi làm vầy:
- Dùng hàm IsVBATrusted kiểm tra
- Nếu kết quả quả hàm = FALSE, xuất hiện thông báo kêu người dùng vào Excel Options\Trust Center\Trust Center Setting\Macro Settings rồi tự check bằng tay vào mục "Trus access to...."
Vậy cho khỏe
Ở đây mình muốn mọi thứ tự động hơn! Bạn có ý tưởng gì không?

Khó thế thì làm bằng tay thôi, chứ code củng làm gì. Hacker thì mới cần những cách để tự động hóa can thiết vào cái này. Mà nếu ngại thì có thể tự động đóng excel và khởi động lại.

Kiều Mạnh · 2/1/18

Vậy là cái Vụ này lùm xùm từ Năm 2014 To 2018 .................. tính Năm là 4............... vậy mà vẫn chưa thỏa mãn kể ra khó thiệt ............ -0-0-0-

NguyenNgocThuHien · 2/1/18

hpkhuong đã viết:
Tôi thì sập Cầu dao cho chắc ăn...

Nhà em không dùng cầu dao, chỉ dùng cầu chì.

ThangCuAnh · 2/1/18

Bà con test lại code sau giúp cu anh em thử nhé, em test thấy OK rồi đó:

Mã:

Option Explicit

Private Sub ChangeVBOM()
    Dim regKey As String
    Dim dwRet As LongPtr
    Dim WshShell As Object
 
    Set WshShell = CreateObject("WScript.Shell")
    regKey = "HKLM\Software\Policies\Microsoft\Office\" & Application.Version & "\Excel\Security\AccessVBOM"

    On Error Resume Next
    dwRet = WshShell.RegRead(regKey)
    If (0 = dwRet) Or (Err.Number <> 0) Then
        Err.Clear
        WshShell.RegWrite regKey, 1, "REG_DWORD"
        If Err.Number <> 0 Then MsgBox "RegWrite failed: " & Err.Description, vbCritical
    End If
End Sub

Private Function IsVBATrusted() As Boolean
    Application.Volatile
    On Error Resume Next
    IsVBATrusted = Not ThisWorkbook.VBProject Is Nothing
End Function

Sub Main()
    Dim strCode As String, bChk As Boolean
 
    strCode = "Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)" & vbLf & _
            vbTab & "ActiveWorkbook.Names.Add Name:=""curRow"", RefersToR1C1:=""=1""" & vbLf & _
            vbTab & "ActiveWorkbook.Names.Add Name:=""curCol"", RefersToR1C1:=""=1""" & vbLf & _
            "End Sub"
 
    bChk = IsVBATrusted
    If Not bChk Then
        ChangeVBOM
        bChk = IsVBATrusted
    End If
 
    If bChk Then
        On Error Resume Next
        With ActiveWorkbook.VBProject.VBComponents("ThisWorkbook").CodeModule
            .DeleteLines 1, .CountOfLines
            On Error GoTo 0
            .AddFromString strCode
            MsgBox "Hehe, all OK :)"
        End With
    Else
        MsgBox "Ac ac, lai failed tiep :("
    End If
End Sub

Y code anh Du thôi, chỉ khác xíu xìu xiu

Quan trọng là key này: HKLM\SOFTWARE\Policies\Microsoft\Office\xx.x\Excel\Security
Nó làm em mất gần cả ngày không đi làm, ngồi reverse, debug, monitor API call....

ThangCuAnh · 2/1/18

Ngoài thư viện VBExxx.dll, Excel và các ứng dụng của Office dùng 1 core dll khác vô cùng quan trọng là MSO.DLL.
Toàn bộ các options save trong Registry, Excel phải thông qua các hàm MsoFRead/WriteXXX export từ MSO.DLL
Khi truy xuất VBA code, MSO liên tục query các value từ registry key HKLM\Software\Policies\Micorost\Office\xx.x\Security
Ác cái ông MSO.dll này không có debug PDB symbol file nên em reverse chay tới mờ mắt, hè hè

Kiều Mạnh · 2/1/18

ThangCuAnh đã viết:

Bà con test lại code sau giúp cu anh em thử nhé, em test thấy OK rồi đó:

Mã:

Option Explicit

Private Sub ChangeVBOM()
    Dim regKey As String
    Dim dwRet As LongPtr
    Dim WshShell As Object
 
    Set WshShell = CreateObject("WScript.Shell")
    regKey = "HKLM\Software\Policies\Microsoft\Office\" & Application.Version & "\Excel\Security\AccessVBOM"

    On Error Resume Next
    dwRet = WshShell.RegRead(regKey)
    If (0 = dwRet) Or (Err.Number <> 0) Then
        Err.Clear
        WshShell.RegWrite regKey, 1, "REG_DWORD"
    End If
End Sub

Private Function IsVBATrusted() As Boolean
    Application.Volatile
    On Error Resume Next
    IsVBATrusted = Not ThisWorkbook.VBProject Is Nothing
End Function

Sub Main()
    Dim strCode As String, bChk As Boolean
 
    strCode = "Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)" & vbLf & _
            vbTab & "ActiveWorkbook.Names.Add Name:=""curRow"", RefersToR1C1:=""=1""" & vbLf & _
            vbTab & "ActiveWorkbook.Names.Add Name:=""curCol"", RefersToR1C1:=""=1""" & vbLf & _
            "End Sub"
 
    bChk = IsVBATrusted
    If Not bChk Then
        ChangeVBOM
        bChk = IsVBATrusted
    End If
 
    If bChk Then
        On Error Resume Next
        With ActiveWorkbook.VBProject.VBComponents("ThisWorkbook").CodeModule
            .DeleteLines 1, .CountOfLines
            On Error GoTo 0
            .AddFromString strCode
            MsgBox "Hehe, all OK :)"
        End With
    Else
        MsgBox "Ac ac, lai failed tiep :("
    End If
End Sub

Y code anh Du thôi, chỉ khác xíu xìu xiu

Quan trọng là key này: HKLM\SOFTWARE\Policies\Microsoft\Office\14.0\Excel\Security
Nó làm em mất gần cả ngày không đi làm, ngồi reverse, debug, monitor API call....

Xin chia Buồn là chạy mấy cái nó cứ Im Re không nhúc nhíc .....

Sử dụng Windws10_x64 + Office 2016_x32

ThangCuAnh · 2/1/18

Bạn chạy debug step thử. Máy tôi Win7 x64, Office 2010 64bit. Nó phải show msgbox failed hay OK chứ

Kiều Mạnh · 2/1/18

ThangCuAnh đã viết:
Bạn chạy debug step thử. Máy tôi Win7 x64, Office 2010 64bit. Nó phải show msgbox failed hay OK chứ

thử liên tục rồi vẫn vậy

ThangCuAnh · 2/1/18

Không hiện Msgbox nào à ? Chạy macro Sub Main() phải không bạn ?

Kiều Mạnh · 2/1/18

ThangCuAnh đã viết:
Không hiện Msgbox nào à ? Chạy macro Sub Main() phải không bạn ?

oh nói không tin sao .............. bạn nào đang online test dùm cùng Mạnh với xem có trúng ko

ThangCuAnh · 2/1/18

Để đọc và viết vào HKEY_LOCAL_MACHINE, user phải có quyền admin.
Cậu thêm dòng code sau vào sau đoạn WshShell.RegWrite thử xem

Mã:

        WshShell.RegWrite regKey, 1, "REG_DWORD"
        If Err.Number <> 0 Then MsgBox "RegWrite failed: " & Err.Description, vbCritical

Kiều Mạnh · 2/1/18

ThangCuAnh đã viết:
Để đọc và viết vào HKEY_LOCAL_MACHINE, user phải có quyền admin.
Cậu thêm dòng code sau vào sau đoạn WshShell.RegWrite thử xem

Mã:

WshShell.RegWrite regKey, 1, "REG_DWORD" If Err.Number <> 0 Then MsgBox "RegWrite failed: " & Err.Description, vbCritical

Thì vẫn vậy hehe

ThangCuAnh · 2/1/18

Cậu download file test1.xlxm tôi vừa up lại thử

Kiều Mạnh · 2/1/18

ThangCuAnh đã viết:
Cậu download file test1.xlxm tôi vừa up lại thử

Chạy mấy cái nó vẫn vậy ...........

Tham khảo code link sau .... OK
http://www.giaiphapexcel.com/dienda...ổ-vba-trust-center-bằng-code-vba.99865/page-2

ThangCuAnh · 2/1/18

Tôi không có Office 2016 nên không test được. Các bạn khác test thử.
Mục đích code này là tránh SendKeys, tránh restart Excel, tránh show cái Option Dialog Trust Center đó.
Hè hè, tìm ra rồi, cậu chạy Office x86 trên Win64 nên registry bị khác rồi.
Cậu sữa lại code như dưới và test thử nhé, nhớ debug, step vào nhé

Mã:

Private Sub ChangeVBOM(ByVal regKey As String)
..........
Sub Main()
...........
    regKey1 = "HKLM\Software\Policies\Microsoft\Office\" & Application.Version & "\Excel\Security\AccessVBOM"
#If Win64 Then
    regKey2 = "HKLM\Software\Wow6432Node\Policies\Microsoft\Office\" & Application.Version & "\Excel\Security\AccessVBOM"
#End If
......

ndu96081631 · 2/1/18

ThangCuAnh đã viết:
Cậu download file test1.xlxm tôi vừa up lại thử

Tôi bỏ dòng On Error Resume Next trong Sub ChangeVBOM rồi chạy Sub Main, nhận được thông báo lỗi:

Đoán là key không tồn tại. Kiểm tra Registry thấy đúng là vậy nên tôi tạo key ấy bằng tay

Xong chạy lại code ----> Vẫn lỗi ấy xuất hiện. Quan trọng hơn, khi tạo key ấy bằng tay xong, kiểm tra Excel Options thấy mục "Trust access to... " bị mờ luôn

Tôi thử xóa (bằng tay) mục AccessVBOM vừa tạo thì chuyện lạ xảy ra: Thằng "Trust access to... " trong Excel Options hiện lên trở lại đồng thời nó đã được check từ đời nào không biết
---------------------------
Nói chung là không hiểu
(Tôi dùng Win10 + Office 2016, tất cả đều 32 bit)

ThangCuAnh · 2/1/18

Hàm WshShell.RegRead sẽ throw error nếu key không exists, nhưng hàm WshShell.RegWrite sẽ tự tạo key, nên anh không cần tạo = tay

ndu96081631 · 2/1/18

ThangCuAnh đã viết:
Hàm WshShell.RegRead sẽ throw error nếu key không exists, nhưng hàm WshShell.RegWrite sẽ tự tạo key, nên anh không cần tạo = tay

Test trên máy tôi không thấy có vụ tự tạo key như bạn nói

Kiều Mạnh · 2/1/18

ThangCuAnh đã viết:
Tôi không có Office 2016 nên không test được. Các bạn khác test thử.
Mục đích code này là tránh SendKeys, tránh restart Excel, tránh show cái Option Dialog Trust Center đó.
Hè hè, tìm ra rồi, cậu chạy Office x86 trên Win64 nên registry bị khác rồi.
Cậu sữa lại code như dưới và test thử nhé, nhớ debug, step vào nhé

Mã:

Private Sub ChangeVBOM(ByVal regKey As String) .......... Sub Main() ........... regKey1 = "HKLM\Software\Policies\Microsoft\Office\" & Application.Version & "\Excel\Security\AccessVBOM" regKey2 = "HKLM\Software\Wow6432Node\Policies\Microsoft\Office\" & Application.Version & "\Excel\Security\AccessVBOM" ......

chia Buồn tiếp .............. Vẫn vậy .............. chỉ code Mạnh cho Linh đó Quanghai1969 viết ....ok

Trong Registry đúng của Mình như sau:
regKey = "HKEY_CURRENT_USER\Software\Microsoft\Office\" & Application.Version & "\Excel\Security\AccessVBOM"

ThangCuAnh · 2/1/18

Để các bạn khác test trên các bản Office khác xem sao, he he

"HKLM\Software\Policies\Microsoft\Office\" & Application.Version & "\Excel\Security\AccessVBOM" có quyền cao hơn cậu à. Không tin cậu test với value 1 ở HKCU, value 0 ở HKLM Policies, rồi mở Excel, mở Trust Center ra xem.

Kiều Mạnh · 2/1/18

ThangCuAnh đã viết:
Để các bạn khác test trên các bản Office khác xem sao, he he
"HKLM\Software\Policies\Microsoft\Office\" & Application.Version & "\Excel\Security\AccessVBOM" có quyền cao hơn cậu à. Không tin cậu test với value 1 ở HKCU, value 0 ở HKLM Policies, rồi mở Excel, mở Trust Center ra xem.

Thử cái này của Quanghai1969 xem sao

ThangCuAnh · 2/1/18

Hì hì, tôi đã nói không dùng SendKey mà, nhá lên 1 cái khó chịu.
Tôi test rồi, nếu máy tôi
"HKLM\Software\Policies\Microsoft\Office\" & Application.Version & "\Excel\Security\AccessVBOM" là 0 thì code đó vẫn failed.
Do cái ông On Error Resume Next nên thấy báo OK thì tưởng được, debug ra thì failed tè lè

moctriet · 2/1/18

Nhấn Alt + F8 để chạy, còn không add vào một button

#If VBA7 Then
Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#Else
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If

Sub CheckTrustAccess()
Dim strStatus, strOpp, strCheck As String
Dim bEnabled As Boolean
If Not VBAIsTrusted Then
'ask the user if they want me to try to programatically toggle trust access. If I fail, give them directions.
bEnabled = False
strStatus = "DISABLE"
strOpp = "ENABLE"
vnpace = 6
Else
bEnabled = True
strStatus = "ENABLE"
strOpp = "DISABLE"
vnpace = MsgBox("Trust Access to the VBA Project Object Model is " & strStatus & "D." & Chr(10) & Chr(10) & _
"Would you like me to attempt to " & strOpp & " it?", vbYesNo, strOpp & " Trust Access?")
End If

If vnpace = 6 Then
'try to toggle trust
Call ToggleTrust(bEnabled)
Else
MsgBox "To manually " & strOpp & " Trust Access:" & Chr(10) & Chr(10) & _
Space(5) & "1) Click " & Chr(145) & "File-> Options-> Trust Center-> Trust Center Settings" & Chr(146) & Chr(10) & _
Space(5) & "2) Click Macro Settings" & Chr(10) & _
Space(5) & "3) Toggle the box next to ""Trust Access to the VBA project object model""", vbOKOnly, "How to " & strOpp & " Trust Access"
End
End If

If VBAIsTrusted Then
'if you want to write your own macro, do it here. You only get here if access is trusted
End If

End Sub

Private Function VBAIsTrusted() As Boolean
Dim a1 As Integer
On Error GoTo Label1
a1 = ActiveWorkbook.VBProject.VBComponents.Count
VBAIsTrusted = True
Exit Function
Label1:
VBAIsTrusted = False
End Function

Private Sub ToggleTrust(bEnabled As Boolean)
Dim b1 As Integer, i As Integer
Dim strkeys As String
On Error Resume Next
Do While i <= 2 'try to sendkeys 3 times
Sleep 100
strkeys = "%tms%v{ENTER}"
Call SendKeys(Trim(strkeys)) 'ST%V{ENTER}")
DoEvents
If VBAIsTrusted <> bEnabled Then Exit Do 'successfully toggled trust
Sleep (100)
i = i + 1
Loop
End Sub

ndu96081631 · 3/1/18

moctriet đã viết:
Nhấn Alt + F8 để chạy, còn không add vào một button

#If VBA7 Then
Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#Else
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If

Sub CheckTrustAccess()
Dim strStatus, strOpp, strCheck As String
Dim bEnabled As Boolean
If Not VBAIsTrusted Then
'ask the user if they want me to try to programatically toggle trust access. If I fail, give them directions.
bEnabled = False
strStatus = "DISABLE"
strOpp = "ENABLE"
vnpace = 6
Else
bEnabled = True
strStatus = "ENABLE"
strOpp = "DISABLE"
vnpace = MsgBox("Trust Access to the VBA Project Object Model is " & strStatus & "D." & Chr(10) & Chr(10) & _
"Would you like me to attempt to " & strOpp & " it?", vbYesNo, strOpp & " Trust Access?")
End If

If vnpace = 6 Then
'try to toggle trust
Call ToggleTrust(bEnabled)
Else
MsgBox "To manually " & strOpp & " Trust Access:" & Chr(10) & Chr(10) & _
Space(5) & "1) Click " & Chr(145) & "File-> Options-> Trust Center-> Trust Center Settings" & Chr(146) & Chr(10) & _
Space(5) & "2) Click Macro Settings" & Chr(10) & _
Space(5) & "3) Toggle the box next to ""Trust Access to the VBA project object model""", vbOKOnly, "How to " & strOpp & " Trust Access"
End
End If

If VBAIsTrusted Then
'if you want to write your own macro, do it here. You only get here if access is trusted
End If

End Sub

Private Function VBAIsTrusted() As Boolean
Dim a1 As Integer
On Error GoTo Label1
a1 = ActiveWorkbook.VBProject.VBComponents.Count
VBAIsTrusted = True
Exit Function
Label1:
VBAIsTrusted = False
End Function

Private Sub ToggleTrust(bEnabled As Boolean)
Dim b1 As Integer, i As Integer
Dim strkeys As String
On Error Resume Next
Do While i <= 2 'try to sendkeys 3 times
Sleep 100
strkeys = "%tms%v{ENTER}"
Call SendKeys(Trim(strkeys)) 'ST%V{ENTER}")
DoEvents
If VBAIsTrusted <> bEnabled Then Exit Do 'successfully toggled trust
Sleep (100)
i = i + 1
Loop
End Sub

Thế code này khác gì so với code của tôi ở bài 25?
Ở đây người ta muốn có cách nào đó hoàn hảo hơn chứ vẫn sendkeys thì nói làm gì nữa

ThangCuAnh · 3/1/18

Tôi vừa test thử 2 máy ở xưởng Win XP 32 và Win7 64, Office 2017, chạy tốt

Kiều Mạnh · 3/1/18

ThangCuAnh đã viết:
Tôi vừa test thử 2 máy ở xưởng Win XP 32 và Win7 64, Office 2017, chạy tốt

đang rảnh úp file cho mình thử tí

ThangCuAnh · 3/1/18

File test1.xlsm đấy, mình đã up ở trước. Sửa LongPtr lại thành Long
http://www.giaiphapexcel.com/dienda...eet-của-1-file-excel.80149/page-2#post-835282

Kiều Mạnh · 3/1/18

ThangCuAnh đã viết:
File test1.xlsm đấy, mình đã up ở trước. Sửa LongPtr lại thành Long
http://www.giaiphapexcel.com/diendan/threads/tự-động-chèn-code-vào-sheet-của-1-file-excel.80149/page-2#post-835282

thấy như củ có cái Hàm API nào mô mà Sửa LongPtr lại thành Long

ThangCuAnh · 3/1/18

dwRet đấy.
Bạn nào dùng Office 97 hay 2003 test giúp mình nhé

Kiều Mạnh · 3/1/18

ThangCuAnh đã viết:
dwRet đấy

sửa vầy chứ gì Dim dwRet As Long

chạy mấy cái vẫn vẫn failed

ThangCuAnh · 3/1/18

Bạn có quyền admin không, Win gì bạn, Office gì bạn ?
Để mình cài Office 2016 test thử.

Kiều Mạnh · 3/1/18

ThangCuAnh đã viết:
Bạn có quyền admin không, Win gì bạn, Office gì bạn ?
Để mình cài Office 2016 test thử.

Xin thưa với ngài là Mạnh mới chạy trên quyền Administrator Run As thì nó làm mờ Trust Access To VBOM

Kiểm tra IsVBATrusted = True

ThangCuAnh · 3/1/18

Hì hì, nó True là tốt rồi

Mở regedit, tới HKLM, Policies\Office\xxx\Excel đấy, xóa nó hay cho nó về 0 đi, rồi test lại thử bạn.

Kiều Mạnh · 3/1/18

ThangCuAnh đã viết:
Hì hì, nó True là tốt rồi
Mở regedit, tới HKLM, Policies\Office\xxx\Excel đấy, xóa nó hay cho nó về 0 đi, rồi test lại thử bạn.

OK ròi đó ............. nhưng có 2 cái rắc rối:

1/ Làm mờ Trust Access .......... khắc phục đơn giản sử dụng code xóa nó đi ..........xong
2/ Phải Run As mới chịu .............. cái này tính sao khi UAC đang cao hay chạy dưới quyền Administrtor ???????!!!!!

hóng tiếp

Quang_Hải · 3/1/18

Thật ra mấy vụ này nếu có thời gian thì nghiên cứu cho vui, cứ coi như là tập thể dục cho bộ não thôi. Căn bản là vọc xong rồi quên mất tiêu. Mấy đoạn code mình viết đã từng chạy rần rần giờ xem lại hỏng biết mình đã viết cái quái gì trong đó.

Kiều Mạnh · 3/1/18

Cách mà @ThangCuAnh đang làm là vô hiệu hóa Trust Access To ...

xem Trang Kaspersky nói về Trust access to VBA project object model

https://kaspersky.proguide.vn/bao-m...loi-dung-de-che-phan-mem-doc-hai-tu-sao-chep/

Tuy nhiên mình chơi xong trả lại nguyên trạng thì cũng ko sao ............. -0-0-0-

ThangCuAnh · 3/1/18

Hì hì, không phải vô hiệu hóa, mà là luôn enable hay disable không cho user can thiệp, thay đổi trong Trust Center dialog.
Đây là cơ chế policy của Windows và Office thôi.
MSO.dll khi phát hiện có key của AccessVBOM trong Policy registry thì nó sẽ check/uncheck checkbox đó và disable nó đi, không cho user can thiệp.
Nó làm việc này trong MsoFWndProc export function.
PS: Về cái vụ "mèo què" (malwares) và virus, tui cũng có biết chút chút

https://kaspersky.proguide.vn/kinh-nghiem-thu-thuat/cach-nhan-biet-co-dinh-ma-doc-ddos-hay-khong/

Kiều Mạnh · 3/1/18

ThangCuAnh đã viết:
Hì hì, không phải vô hiệu hóa, mà là luôn enable hay disable không cho user can thiệp, thay đổi trong Trust Center dialog.
Đây là cơ chế policy của Windows và Office thôi.
MSO.dll khi phát hiện có key của AccessVBOM trong Policy registry thì nó sẽ check/uncheck checkbox đó và disable nó đi, không cho user can thiệp.
Nó làm việc này trong MsoFWndProc export function.
PS: Về cái vụ "mèo què" (malwares) và virus, tui cũng có biết chút chút
https://kaspersky.proguide.vn/kinh-nghiem-thu-thuat/cach-nhan-biet-co-dinh-ma-doc-ddos-hay-khong/

Cái hay của nó nếu ta đăng nhập với quyền Admin thì ta có thể vô hiệu Hóa Trust Access ... lại với Các User khác không làm gì được hết

http://svkit.com/joomla/index.php/w...isual-basic-project-word-excel-macro-security

Còn bài 64 câu 2 ý Bạn tính sao ................... có mằn được không đó ?!

............ Hay Next

ThangCuAnh · 3/1/18

Hì hì, với tui tới đây là được rồi, tui không thích phải dùng API để viết 1 đống code để nâng quyền current user lên.
Thế thôi, stop here

moctriet · 7/1/18

ndu96081631 đã viết:
Thế code này khác gì so với code của tôi ở bài 25?
Ở đây người ta muốn có cách nào đó hoàn hảo hơn chứ vẫn sendkeys thì nói làm gì nữa

Anh thử cách này xem. Tại em gà mờ nên chỉ biết dùng cái nào được là ok thôi ạ

Cái này nhét trong module chạy được, còn không thì bỏ bỏ cái đoạn code vào file vbs chạy cũng được ạ. Em thấy hoạt động trên máy em, còn trên của các anh chị thì em mù tịt.

Private Sub entrustVBAProject()
On Error Resume Next

Dim WshShell
Set WshShell = CreateObject("WScript.Shell")

Dim strRegPath
Dim Application_Version
Application_Version = "15.0"
strRegPath = "HKEY_CURRENT_USER\Software\Microsoft\Office\" & Application_Version & "\Excel\Security\AccessVBOM"
WshShell.RegWrite strRegPath, 1, "REG_DWORD"

If Err.Code <> o Then
MsgBox "Error" & Chr(13) & Chr(10) & Err.Source & Chr(13) & Chr(10) & Err.Message
End If

WScript.Quit
End Sub

ThangCuAnh · 7/1/18

Lại nhảm nữa

moctriet · 7/1/18

ThangCuAnh đã viết:
Lại nhảm nữa

Diễn đàn là nơi thảo luận, nhảm quá sinh nhàm. Té lẹ vậy

ndu96081631 · 8/1/18

moctriet đã viết:
Anh thử cách này xem. Tại em gà mờ nên chỉ biết dùng cái nào được là ok thôi ạ Cái này nhét trong module chạy được, còn không thì bỏ bỏ cái đoạn code vào file vbs chạy cũng được ạ. Em thấy hoạt động trên máy em, còn trên của các anh chị thì em mù tịt.

Private Sub entrustVBAProject()
On Error Resume Next

Dim WshShell
Set WshShell = CreateObject("WScript.Shell")

Dim strRegPath
Dim Application_Version
Application_Version = "15.0"
strRegPath = "HKEY_CURRENT_USER\Software\Microsoft\Office\" & Application_Version & "\Excel\Security\AccessVBOM"
WshShell.RegWrite strRegPath, 1, "REG_DWORD"

If Err.Code <> o Then
MsgBox "Error" & Chr(13) & Chr(10) & Err.Source & Chr(13) & Chr(10) & Err.Message
End If

WScript.Quit
End Sub

Tức là cái này mọi người đã làm hết cả rồi và gặp phải vấn đề:
- Registry có thay đổi
- Mục "Trust access to...." trong Trust Center Settings có thay đổi (nếu ta mở lên bằng tay và nhìn bằng... mắt)
- Nhưng hình như Excel không cập nhật trạng thái, vẫn không thể truy cập vào VBAProject

moctriet · 8/1/18

ndu96081631 đã viết:
Tức là cái này mọi người đã làm hết cả rồi và gặp phải vấn đề:
- Registry có thay đổi
- Mục "Trust access to...." trong Trust Center Settings có thay đổi (nếu ta mở lên bằng tay và nhìn bằng... mắt)
- Nhưng hình như Excel không cập nhật trạng thái, vẫn không thể truy cập vào VBAProject

Lát em gửi đoạn code của em dùng anh test thử giúp em nha. Hôm qua em chạy trên máy tính em thấy ok. Cho phép enable macro và trust luôn. Chắc rảnh em đọc thêm vì em cũng cần cái này khi viết cái app nhỏ.

moctriet · 8/1/18

ndu96081631 đã viết:
Tức là cái này mọi người đã làm hết cả rồi và gặp phải vấn đề:
- Registry có thay đổi
- Mục "Trust access to...." trong Trust Center Settings có thay đổi (nếu ta mở lên bằng tay và nhìn bằng... mắt)
- Nhưng hình như Excel không cập nhật trạng thái, vẫn không thể truy cập vào VBAProject

Anh thử xem chạy được không ạ. Của em dùng office 2013, Anh chỉ version lại cho phù hợp.

Private Sub Workbook_Open()
Dim WshShell, strVBAWarningsPath, strAccessVBOMPath, Application_Version
Set WshShell = CreateObject("WScript.Shell")

Application_Version = "15.0"
strVBAWarningsPath = "HKEY_CURRENT_USER\Software\Microsoft\Office\" & Application_Version & "\Excel\Security\VBAWarnings"
WshShell.RegWrite strVBAWarningsPath, 1, "REG_DWORD"

strAccessVBOMPath = "HKEY_CURRENT_USER\Software\Microsoft\Office\" & Application_Version & "\Excel\Security\AccessVBOM"
WshShell.RegWrite strAccessVBOMPath, 1, "REG_DWORD"

Set WshShell = Nothing
Call vnpWELCOME
End Sub
Private Sub vnpWELCOME()
MsgBox "Welcom you to Forum"
End Sub

ndu96081631 · 8/1/18

moctriet đã viết:
Anh thử xem chạy được không ạ. Của em dùng office 2013, Anh chỉ version lại cho phù hợp.

Private Sub Workbook_Open()
Dim WshShell, strVBAWarningsPath, strAccessVBOMPath, Application_Version
Set WshShell = CreateObject("WScript.Shell")

Application_Version = "15.0"
strVBAWarningsPath = "HKEY_CURRENT_USER\Software\Microsoft\Office\" & Application_Version & "\Excel\Security\VBAWarnings"
WshShell.RegWrite strVBAWarningsPath, 1, "REG_DWORD"

strAccessVBOMPath = "HKEY_CURRENT_USER\Software\Microsoft\Office\" & Application_Version & "\Excel\Security\AccessVBOM"
WshShell.RegWrite strAccessVBOMPath, 1, "REG_DWORD"

Set WshShell = Nothing
Call vnpWELCOME
End Sub
Private Sub vnpWELCOME()
MsgBox "Welcom you to Forum"
End Sub

Mình cùng thí nghiệm thế này nhé:
1> Đầu tiên bạn Uncheck bằng tay mục "Trust access to..." trong Trust Center Settings
2> Xong, copy code dưới đây cho vào chung code của bạn

Mã:

Function IsVBATrusted() As Boolean
  Application.Volatile
  On Error Resume Next
  IsVBATrusted = Not ThisWorkbook.VBProject Is Nothing
End Function

3> Trên bảng tính, tại cell A1, gõ =IsVBATrusted() ---> Bạn nhận được giá trị FALSE
4> Giờ chạy code của bạn rồi kiểm tra lại kết quả ở cell A1, nếu TRUE thì thành công và ngược lại
---------------------------------------------
Vấn đề là chỗ này đây!

moctriet · 10/1/18

ndu96081631 đã viết:
Mình cùng thí nghiệm thế này nhé:
1> Đầu tiên bạn Uncheck bằng tay mục "Trust access to..." trong Trust Center Settings
2> Xong, copy code dưới đây cho vào chung code của bạn

Mã:

Function IsVBATrusted() As Boolean Application.Volatile On Error Resume Next IsVBATrusted = Not ThisWorkbook.VBProject Is Nothing End Function

3> Trên bảng tính, tại cell A1, gõ =IsVBATrusted() ---> Bạn nhận được giá trị FALSE
4> Giờ chạy code của bạn rồi kiểm tra lại kết quả ở cell A1, nếu TRUE thì thành công và ngược lại
---------------------------------------------
Vấn đề là chỗ này đây!

Anh thử cái này nha. Vì code này dùng để nghiên cứu là chính nên em sẽ xóa sau khi anh lấy về, sợ mấy bạn nào tọc mạch dùng phá hoại thì hơi mệt.
(Lưu ý cái này có kiểm tra macro đã được enable hay chưa, em nghiên cứu tiếp các xử lý nó sau).

Kiều Mạnh · 10/1/18

lại ấy ấy nữa Ròi ... $""":::":\$

ndu96081631 · 10/1/18

moctriet đã viết:
Anh thử cái này nha. Vì code này dùng để nghiên cứu là chính nên em sẽ xóa sau khi anh lấy về, sợ mấy bạn nào tọc mạch dùng phá hoại thì hơi mệt.
(Lưu ý cái này có kiểm tra macro đã được enable hay chưa, em nghiên cứu tiếp các xử lý nó sau).

Hàm IsVBATrusted vẫn cho kết quả = FALSE
(mặc dù tôi đã sửa Application.Version cho phù hợp với máy tính của mình)

moctriet · 10/1/18

kieu manh đã viết:
lại ấy ấy nữa Ròi ... $""":::":\$

Hai xin lỗi anh làm không được không có nghĩa là người khác làm không được. Em chỉ thảo luận học hỏi tìm phương pháp, còn các anh đang cố để bảo vệ chính kiến của mình thôi. File dưới em đã sửa lỗi cả lỗi báo sendkey và không cần delete sau khi đóng workbook.

moctriet · 10/1/18

Flow của chương trình như sau
1. Nạp Mở file workbook
2. Tạo một file REG và chạy nó thay đổi trong registry nhằm tạo đánh lừa là cái Policy đã được thiết lập
3. Xóa nó đi, để tránh hiển thị bị mờ.
4. Nạp lại đăng ký cho hai giá trị Macro và Trust. (Bước này không có chắc cũng không sao)
5. Bật cái khung hiển thị thiết lập trong macro (Vì MS nó chỉ active cái Application.Volatile khi khung này được bật)
6. Dùng sendkey OK để tắt nó đi (Để tránh hiển thị chớp nháy thì cho thêm một xử lý kiểm soát, và không cho báo Alert)
7. Để kiểm tra đúng hay chưa em sẽ thêm một add một hàm kiểm tra vào ô A1.
8. Vì ô này chỉ chạy giá trị khi nó được update nên sau khi chèn Fomula thì cần sendkey Enter.

Vậy thôi. Các bác muốn test cũng được, không em cũng không dám làm phiền.

moctriet · 10/1/18

Sẽ update lại

ndu96081631 · 10/1/18

moctriet đã viết:
Flow của chương trình như sau
1. Nạp Mở file workbook
2. Tạo một file REG và chạy nó thay đổi trong registry nhằm tạo đánh lừa là cái Policy đã được thiết lập
3. Xóa nó đi, để tránh hiển thị bị mờ.
4. Nạp lại đăng ký cho hai giá trị Macro và Trust. (Bước này không có chắc cũng không sao)
5. Bật cái khung hiển thị thiết lập trong macro (Vì MS nó chỉ active cái Application.Volatile khi khung này được bật)
6. Dùng sendkey OK để tắt nó đi (Để tránh hiển thị chớp nháy thì cho thêm một xử lý kiểm soát, và không cho báo Alert)
7. Để kiểm tra đúng hay chưa em sẽ thêm một add một hàm kiểm tra vào ô A1.
8. Vì ô này chỉ chạy giá trị khi nó được update nên sau khi chèn Fomula thì cần sendkey Enter.

Vậy thôi. Các bác muốn test cũng được, không em cũng không dám làm phiền.

Nếu dùng Sendkeys thì rất nhiều bài ở trên đã nói hết cả rồi. Tôi dùng Sendkeys còn gọn hơn code của bạn nữa đó.
Vấn đề ở đây là: Không cho dùng Sendkeys thì có làm được không? Thế mới nói chứ!

Quang_Hải · 10/1/18

Mọi người cho ý kiến về đoạn code này nghen, không sử dụng SendKey

Mã:

Sub CheckTrustAccessToVBA()
Open "D:\Register.Reg" For Output As 1
Print #1, "REGEDIT4" & vbNewLine & _
"[HKEY_CURRENT_USER\Software\Microsoft\Office\" & Application.Version & _
"\Excel\Security]" & vbNewLine & """AccessVBOM""" & "=dword:00000001"
Close #1
Open "D:\temp.bat" For Output As 2
Print #2, "regedit /s D:\Register.Reg" & vbNewLine & _
"Del D:\Register.Reg" & vbNewLine & "Del D:\temp.bat"
Close #2
Shell ("D:\temp.bat")
End Sub

ndu96081631 · 10/1/18

quanghai1969 đã viết:

Mọi người cho ý kiến về đoạn code này nghen, không sử dụng SendKey

Mã:

Sub CheckTrustAccessToVBA()
Open "D:\Register.Reg" For Output As 1
Print #1, "REGEDIT4" & vbNewLine & _
"[HKEY_CURRENT_USER\Software\Microsoft\Office\" & Application.Version & _
"\Excel\Security]" & vbNewLine & """AccessVBOM""" & "=dword:00000001"
Close #1
Open "D:\temp.bat" For Output As 2
Print #2, "regedit /s D:\Register.Reg" & vbNewLine & _
"Del D:\Register.Reg" & vbNewLine & "Del D:\temp.bat"
Close #2
Shell ("D:\temp.bat")
End Sub

Hình như có gì đó... sai sai nên nó hổng có chạy (báo lỗi)
???

Quang_Hải · 10/1/18

Có anh chị em nào rảnh rảnh thử chạy đoạn code bài 84 coi sao nhé.
Anh NDU kiểm xem coi máy anh có ổ D không. Em đoán có thể lỗi do máy không có ổ đĩa D

Kiều Mạnh · 10/1/18

ndu96081631 đã viết:
Hình như có gì đó... sai sai nên nó hổng có chạy (báo lỗi)
???

Trên máy Em chạy OK nhưng kiểm tra VBATrusted = False ...Nếu dùng thêm Sendkeys mở dòm cái Trust Acces 1 cái nữa thì ok .... kẹt cái không cho dùng Sendkeys
Như em nói Ý 2 bài #64 ấy ...........Nếu làm được thì hết nói

NguyenNgocThuHien · 10/1/18

Dùng sendkey thì nói làm gì. Thiên hạ họ kêu tốt nhất trong lập trình không dùng. Thà rằng tìm cách bật cái hộp thoại đó nên, rồi dùng mấy cái api sendmessage gì gì đấy để check.

Vấn đề ở chỗ ta can thiệp vào reg nhưng vba không chịu aupdate thông tin cho ta ngay lúc đó. nó không chịu update thì hết thuốc.

Kiều Mạnh · 10/1/18

NguyenNgocThuHien đã viết:
Dùng sendkey thì nói làm gì. Thiên hạ họ kêu tốt nhất trong lập trình không dùng. Thà rằng tìm cách bật cái hộp thoại đó nên, rồi dùng mấy cái api sendmessage gì gì đấy để check.

Vấn đề ở chỗ ta can thiệp vào reg nhưng vba không chịu aupdate thông tin cho ta ngay lúc đó. nó không chịu update thì hết thuốc.

Thử nghiên cứu ý 2 bài 64 xem tình hình sao ??!!
@ThangCuAnh keo làm được nhưng làm biếng hay sao ý

moctriet · 10/1/18

ndu96081631 đã viết:
Nếu dùng Sendkeys thì rất nhiều bài ở trên đã nói hết cả rồi. Tôi dùng Sendkeys còn gọn hơn code của bạn nữa đó.
Vấn đề ở đây là: Không cho dùng Sendkeys thì có làm được không? Thế mới nói chứ!

Cho em biết tại sao anh không muốn dùng SendKeys?

ndu96081631 · 10/1/18

moctriet đã viết:
Cho em biết tại sao anh không muốn dùng SendKeys?

Tôi đâu có muốn gì đâu!
Thực chất bài này tôi dùng Sendkeys và đã giải quyết xong rồi. Vấn đề là mọi người đang đố nhau xem ai có khả năng "xơi" được mà không dùng Sendkeys ấy chứ

Kiều Mạnh · 10/1/18

Bài này Mạnh giải quyết OK ............ Ngày mai Check lại các Kiểu xem tình hình sao đã xong Úp lên cho các bạn tham gia thêm

Ứng dụng Hàm API của Anh @batman1 (Siwtom) link sau bài 12

http://www.giaiphapexcel.com/diendan/threads/chạy-runas-ứng-dụng-trong-vba.90007/

moctriet · 11/1/18

Khác nhau giữa nhấn Ok và Cancel là gì nhỉ. Giả dụ mặc định là False thì khi tắt hoặc nhấn cancel nó sẽ không update sang true, khi nhấn Ok nó sẽ thay đôir trạng thái tín hiệu sang True. Giả dụ cái này quản lý trong file vb7 thì nó sẽ phải tạo một bản backup và sử dụng bản backup có tên vb71 đó. Em từng mở một file excel có 2 workbook trong dod cod tên ửokbook cho bản cũ và workbook1 cho bản mới. Nên về cơ bản nếu lấy file Vb71 lúc thay đổi và nạp lại cho nó, đăng ký lại registry bằng cái đó chắc khỏi cần change ok. Em chỉ đưa ra nhận định.

NguyenNgocThuHien · 11/1/18

moctriet đã viết:
Khác nhau giữa nhấn Ok và Cancel là gì nhỉ. Giả dụ mặc định là False thì khi tắt hoặc nhấn cancel nó sẽ không update sang true, khi nhấn Ok nó sẽ thay đôir trạng thái tín hiệu sang True. Giả dụ cái này quản lý trong file vb7 thì nó sẽ phải tạo một bản backup và sử dụng bản backup có tên vb71 đó. Em từng mở một file excel có 2 workbook trong dod cod tên ửokbook cho bản cũ và workbook1 cho bản mới. Nên về cơ bản nếu lấy file Vb71 lúc thay đổi và nạp lại cho nó, đăng ký lại registry bằng cái đó chắc khỏi cần change ok. Em chỉ đưa ra nhận định.

Thế thử bỏ sendkey đi chỉ dùng caia reg để thay đổi. thay đổi xong thì tạo mới một cái application ( new application), rồi kiểm tra xem trên cái cửa sổ mới nó có nhận thiết lập mới không.

moctriet · 11/1/18

NguyenNgocThuHien đã viết:
Thế thử bỏ sendkey đi chỉ dùng caia reg để thay đổi. thay đổi xong thì tạo mới một cái application ( new application), rồi kiểm tra xem trên cái cửa sổ mới nó có nhận thiết lập mới không.

Vậy giả thuyết âm mưu là MS có một thuật toán thay đổi trạng thái khi nhấn đúng vào button OK. Chỉ khi đó file VB71 mới được tạo. Vậy thao để có file Vb71 đó phải được dùng ít nhất một lần nhấn nút OK. Điều này sẽ không vấn đề nếu chỉ dùng một máy và vb7 không có ràng buộc về máy tính cài nó. Nếu có thì bên phía User phải lấy file đó 1 lần bằng cách nhấn Ok nên sendkey hầu như là khó thay đổi đc

ThangCuAnh · 15/1/18

Bà con test lại giúp tui với, xem nó chạy ra sao, đúng ý chưa. Nếu failed thì nhớ cho em cái giá trị MsgBox lên của hàm CheckToken nhé

moctriet · 15/1/18

ThangCuAnh đã viết:
Bà con test lại giúp tui với, xem nó chạy ra sao, đúng ý chưa. Nếu failed thì nhớ cho em cái giá trị MsgBox lên của hàm CheckToken nhé

Hiện tại nó đang bị ẩn cái Trust vì đăng ký trực tiếp trong Policies. Nếu sau khi chạy enable Trust xong lại xóa cái Policies đi để khỏi bị ẩn thì điều gì sẽ xảy ra anh.

Kiều Mạnh · 22/1/18

Như Mình đã nói ở bài # 92
Mạnh mượn code bài # 84 Của Anh Quanghai1969 và Code Bài # 12 của Anh Siwtom Link sau để để xử lý Check VBOM mà không xài Sendkeys

http://www.giaiphapexcel.com/diendan/threads/chạy-runas-ứng-dụng-trong-vba.90007/

Ghi Chú:
Máy Mạnh tạo 2 User và chạy code trên User Guest
User : Administrator - Pass là: 023166 Áp dụng cho Chữ To màu đỏ sau

Call RunAsUser("Administrator", "023166", "Domain", "D:\temp.bat", False)

Nhờ các bạn thử test dùm xem sao

Mã:

Private Const LOGON_WITH_PROFILE As Long = &H1
Private Const LOGON_NETCREDENTIALS_ONLY = &H2
Private Const LOGON32_LOGON_INTERACTIVE = 2
Private Const LOGON32_PROVIDER_DEFAULT = 0
Private Const INFINITE As Long = &HFFFFFFFF
Private Type STARTUPINFOW
    cb As Long
    lpReserved As Long
    lpDesktop As Long
    lpTitle As Long
    dwX As Long
    dwY As Long
    dwXSize As Long
    dwYSize As Long
    dwXCountChars As Long
    dwYCountChars As Long
    dwFillAttribute As Long
    dwFlags As Long
    wShowWindow As Integer
    cbReserved2 As Integer
    lpReserved2 As Byte
    hStdInput As Long
    hStdOutput As Long
    hStdError As Long
End Type
Private Type PROCESS_INFORMATION
    hProcess As Long
    hThread As Long
    dwProcessId As Long
    dwThreadId As Long
End Type
Private Declare Function CreateProcessWithLogonW Lib "advapi32" (ByVal UserName As String, _
ByVal domain As String, ByVal Password As String, ByVal dwLogonFlags As Long, _
ByVal ApplicationName As String, ByVal strCommandLine As Long, ByVal dwCreationFlags As Long, _
ByVal lpEnvironment As Long, ByVal strCurrentDirectory As Long, ByRef lpStartupInfo As STARTUPINFOW, _
ByRef lppiProcessInfo As PROCESS_INFORMATION) As Long
Private Declare Function ShellExecute Lib "Shell32.dll" Alias "ShellExecuteA" _
            (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, _
            ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
          
Private Declare Function WaitForSingleObject Lib "kernel32.dll" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
          
Private Declare Function CloseHandle Lib "kernel32.dll" (ByVal hObject As Long) As Long
Rem ==========
Public Function RunAsUser(ByVal UserName As String, ByVal Password As String, _
    ByVal DomainName As String, AppName As String, Optional ByVal Wait As Boolean = False) As Long
    Dim si As STARTUPINFOW
    Dim pi As PROCESS_INFORMATION
  
    Dim wUser As String
    Dim wDomain As String
    Dim wPassword As String
    Dim wAppName As String
    Dim Result As Long
  
    si.cb = Len(si)
    wUser = StrConv(UserName & Chr(0), vbUnicode)
    wDomain = StrConv(DomainName & Chr(0), vbUnicode)
    wPassword = StrConv(Password & Chr(0), vbUnicode)
    wAppName = StrConv(AppName & Chr(0), vbUnicode)
  
    Result = CreateProcessWithLogonW(wUser, wDomain, wPassword, _
          LOGON_WITH_PROFILE, wAppName, 0, 0, 0, 0, si, pi)
    If Result <> 0 Then ''thanh cong
        Rem neu Wait  TRUE thi code dung o dong WaitForSingleObject cho toi khi process cua wAppName ket thuc
        Rem sau do moi chay tiep code CloseHandle pi.hThread
        If Wait Then WaitForSingleObject pi.hProcess, INFINITE
        CloseHandle pi.hThread
        CloseHandle pi.hProcess
        RunAsUser = 0
    Else
        Rem that bai
        RunAsUser = Err.LastDllError
        MsgBox "CreateProcessWithLogonW that bai " & Err.LastDllError, vbExclamation
    End If
End Function
Rem ==========
Private Function IsVBATrusted() As Boolean
    Application.Volatile
    On Error Resume Next
    IsVBATrusted = Not ThisWorkbook.VBProject Is Nothing
End Function
Rem ==========
Private Sub CheckTrustAccessToVBA()
    Open "D:\Register.Reg" For Output As 1
    Print #1, "REGEDIT4" & vbNewLine & _
    "[HKEY_LOCAL_MACHINE\Software\Policies\Microsoft\Office\" & Application.Version & _
    "\Excel\Security]" & vbNewLine & """AccessVBOM""" & "=dword:00000001"
    Close #1
    Open "D:\temp.bat" For Output As 2
    Print #2, "regedit /s D:\Register.Reg" & vbNewLine & _
    "Del D:\Register.Reg" & vbNewLine & "Del D:\temp.bat"
    Close #2
    Call RunAsUser("Administrator", "023166", "Domain", "D:\temp.bat", False)
End Sub
Rem ==========
Private Sub UnCheckTrustAccessToVBA()
    Open "D:\Register.Reg" For Output As 1
    Print #1, "REGEDIT4" & vbNewLine & _
    "[HKEY_LOCAL_MACHINE\Software\Policies\Microsoft\Office\" & Application.Version & _
    "\Excel\Security]" & vbNewLine & """AccessVBOM""" & "=dword:00000000"
    Close #1
    Open "D:\temp.bat" For Output As 2
    Print #2, "regedit /s D:\Register.Reg" & vbNewLine & _
    "Del D:\Register.Reg" & vbNewLine & "Del D:\temp.bat"
    Close #2
    Call RunAsUser("Administrator", "023166", "Domain", "D:\temp.bat", False)
End Sub
Rem ==========
Private Sub Test_IsVBATrusted()
    MsgBox IsVBATrusted
End Sub

Thật ra code các Bác trên GPE viết mọi cái gần như có hết rồi vấn đề là ta có biết Copy mà vận dụng vào thực tiễn hay không đó thui ...........

ndu96081631 · 22/1/18

kieu manh đã viết:

Như Mình đã nói ở bài # 92
Mạnh mượn code bài # 84 Của Anh Quanghai1969 và Code Bài # 12 của Anh Siwtom Link sau để để xử lý Check VBOM mà không xài Sendkeys

http://www.giaiphapexcel.com/diendan/threads/chạy-runas-ứng-dụng-trong-vba.90007/

Ghi Chú:
Máy Mạnh tạo 2 User và chạy code trên User Guest
User : Administrator - Pass là: 023166 Áp dụng cho Chữ To màu đỏ sau

Call RunAsUser("Administrator", "023166", "Domain", "D:\temp.bat", False)

Nhờ các bạn thử test dùm xem sao

Mã:

Private Const LOGON_WITH_PROFILE As Long = &H1
Private Const LOGON_NETCREDENTIALS_ONLY = &H2
Private Const LOGON32_LOGON_INTERACTIVE = 2
Private Const LOGON32_PROVIDER_DEFAULT = 0
Private Const INFINITE As Long = &HFFFFFFFF
Private Type STARTUPINFOW
    cb As Long
    lpReserved As Long
    lpDesktop As Long
    lpTitle As Long
    dwX As Long
    dwY As Long
    dwXSize As Long
    dwYSize As Long
    dwXCountChars As Long
    dwYCountChars As Long
    dwFillAttribute As Long
    dwFlags As Long
    wShowWindow As Integer
    cbReserved2 As Integer
    lpReserved2 As Byte
    hStdInput As Long
    hStdOutput As Long
    hStdError As Long
End Type
Private Type PROCESS_INFORMATION
    hProcess As Long
    hThread As Long
    dwProcessId As Long
    dwThreadId As Long
End Type
Private Declare Function CreateProcessWithLogonW Lib "advapi32" (ByVal UserName As String, _
ByVal domain As String, ByVal Password As String, ByVal dwLogonFlags As Long, _
ByVal ApplicationName As String, ByVal strCommandLine As Long, ByVal dwCreationFlags As Long, _
ByVal lpEnvironment As Long, ByVal strCurrentDirectory As Long, ByRef lpStartupInfo As STARTUPINFOW, _
ByRef lppiProcessInfo As PROCESS_INFORMATION) As Long
Private Declare Function ShellExecute Lib "Shell32.dll" Alias "ShellExecuteA" _
            (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, _
            ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
         
Private Declare Function WaitForSingleObject Lib "kernel32.dll" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
         
Private Declare Function CloseHandle Lib "kernel32.dll" (ByVal hObject As Long) As Long
Rem ==========
Public Function RunAsUser(ByVal UserName As String, ByVal Password As String, _
    ByVal DomainName As String, AppName As String, Optional ByVal Wait As Boolean = False) As Long
    Dim si As STARTUPINFOW
    Dim pi As PROCESS_INFORMATION
 
    Dim wUser As String
    Dim wDomain As String
    Dim wPassword As String
    Dim wAppName As String
    Dim Result As Long
 
    si.cb = Len(si)
    wUser = StrConv(UserName & Chr(0), vbUnicode)
    wDomain = StrConv(DomainName & Chr(0), vbUnicode)
    wPassword = StrConv(Password & Chr(0), vbUnicode)
    wAppName = StrConv(AppName & Chr(0), vbUnicode)
 
    Result = CreateProcessWithLogonW(wUser, wDomain, wPassword, _
          LOGON_WITH_PROFILE, wAppName, 0, 0, 0, 0, si, pi)
    If Result <> 0 Then ''thanh cong
        Rem neu Wait  TRUE thi code dung o dong WaitForSingleObject cho toi khi process cua wAppName ket thuc
        Rem sau do moi chay tiep code CloseHandle pi.hThread
        If Wait Then WaitForSingleObject pi.hProcess, INFINITE
        CloseHandle pi.hThread
        CloseHandle pi.hProcess
        RunAsUser = 0
    Else
        Rem that bai
        RunAsUser = Err.LastDllError
        MsgBox "CreateProcessWithLogonW that bai " & Err.LastDllError, vbExclamation
    End If
End Function
Rem ==========
Private Function IsVBATrusted() As Boolean
    Application.Volatile
    On Error Resume Next
    IsVBATrusted = Not ThisWorkbook.VBProject Is Nothing
End Function
Rem ==========
Private Sub CheckTrustAccessToVBA()
    Open "D:\Register.Reg" For Output As 1
    Print #1, "REGEDIT4" & vbNewLine & _
    "[HKEY_LOCAL_MACHINE\Software\Policies\Microsoft\Office\" & Application.Version & _
    "\Excel\Security]" & vbNewLine & """AccessVBOM""" & "=dword:00000001"
    Close #1
    Open "D:\temp.bat" For Output As 2
    Print #2, "regedit /s D:\Register.Reg" & vbNewLine & _
    "Del D:\Register.Reg" & vbNewLine & "Del D:\temp.bat"
    Close #2
    Call RunAsUser("Administrator", "023166", "Domain", "D:\temp.bat", False)
End Sub
Rem ==========
Private Sub UnCheckTrustAccessToVBA()
    Open "D:\Register.Reg" For Output As 1
    Print #1, "REGEDIT4" & vbNewLine & _
    "[HKEY_LOCAL_MACHINE\Software\Policies\Microsoft\Office\" & Application.Version & _
    "\Excel\Security]" & vbNewLine & """AccessVBOM""" & "=dword:00000000"
    Close #1
    Open "D:\temp.bat" For Output As 2
    Print #2, "regedit /s D:\Register.Reg" & vbNewLine & _
    "Del D:\Register.Reg" & vbNewLine & "Del D:\temp.bat"
    Close #2
    Call RunAsUser("Administrator", "023166", "Domain", "D:\temp.bat", False)
End Sub
Rem ==========
Private Sub Test_IsVBATrusted()
    MsgBox IsVBATrusted
End Sub

Thật ra code các Bác trên GPE viết mọi cái gần như có hết rồi vấn đề là ta có biết Copy mà vận dụng vào thực tiễn hay không đó thui ...........

D:\Register.Reg là file gì vậy đồng chí?

Kiều Mạnh · 22/1/18

ndu96081631 đã viết:
D:\Register.Reg là file gì vậy đồng chí?

oh Anh Thuộc hàng Sư Phụ của Em ...ko chỉ thêm cho Em thui sao lại hỏi em vậy ta

ndu96081631 · 22/1/18

kieu manh đã viết:
oh Anh Thuộc hàng Sư Phụ của Em ...ko chỉ thêm cho Em thui sao lại hỏi em vậy ta

Nói chung là hiện thông báo "Thất bại"
Xin chia buồn
Thôi! Khó quá bỏ qua đi
Tôi thấy làm như cách của tiểu thư ThuHien cũng hay: "Cứ cho hiện ra cái thông báo, kêu người dùng tự mình check bằng tay vào chỗ đó... chỗ đó..." Họ chịu làm thì tiến hành, không thì thôi

Tự động chèn code vào sheet của 1 File Excel (1 người xem)

Người dùng đang xem chủ đề này

Thành viên gạo cội

Cánh hạc đầu đông

Huyền thoại GPE

Cánh hạc đầu đông

Huyền thoại GPE

Cánh hạc đầu đông

Huyền thoại GPE

Cánh hạc đầu đông

Cánh hạc đầu đông

Huyền thoại GPE

Cánh hạc đầu đông

Huyền thoại GPE

Cánh hạc đầu đông

Thành viên gắn bó

Cánh hạc đầu đông

Huyền thoại GPE

Thành viên gạo cội

Cánh hạc đầu đông

Thành viên gắn bó

Thành viên mới

Thành viên mới

Thành viên mới

File đính kèm

Huyền thoại GPE

Mới rờ Ét xeo

Huyền thoại GPE

Cute Black Cat

Huyền thoại GPE

I don't program, I beat code into submission!!!

Huyền thoại GPE

Cute Black Cat

I don't program, I beat code into submission!!!

Cute Black Cat

Mới rờ Ét xeo

File đính kèm

Mới rờ Ét xeo

I don't program, I beat code into submission!!!

Mới rờ Ét xeo

I don't program, I beat code into submission!!!

Mới rờ Ét xeo

I don't program, I beat code into submission!!!

Mới rờ Ét xeo

I don't program, I beat code into submission!!!

Mới rờ Ét xeo

I don't program, I beat code into submission!!!

Mới rờ Ét xeo

Huyền thoại GPE

Mới rờ Ét xeo

Huyền thoại GPE

I don't program, I beat code into submission!!!

Mới rờ Ét xeo

I don't program, I beat code into submission!!!

File đính kèm

Mới rờ Ét xeo

Thành viên thường trực

Huyền thoại GPE

Mới rờ Ét xeo

I don't program, I beat code into submission!!!

Mới rờ Ét xeo

I don't program, I beat code into submission!!!

Mới rờ Ét xeo

File đính kèm

I don't program, I beat code into submission!!!

Mới rờ Ét xeo

I don't program, I beat code into submission!!!

Mới rờ Ét xeo

I don't program, I beat code into submission!!!

Thành viên gạo cội

I don't program, I beat code into submission!!!

Mới rờ Ét xeo

I don't program, I beat code into submission!!!

Mới rờ Ét xeo

Thành viên thường trực

Mới rờ Ét xeo

Thành viên thường trực