EXCEL VBA 隐藏了工作表，加密的，如何显示或破解

Posted 2023-04-26

本文件里有二个工作夹被隐藏了。（不是格式，工作表，取消隐藏，这里没有）此种隐藏是VBA加密估计。
我点工作表，查看代码 会提示输入密码。。。百度找了一些密码VBA。过程中都提示要输入VBa密码。希望有高手指点下。或QQ加我121400908
这个软件里破解VBA密码是要正版才能用。也就是收费才可以用。我下了9.0破解的。点是能点。但没那破解功能。求帮助

新建excel，ALT+F11插入以下代码，按住F8执行，浏览到有VBA工程密码的excel文件，确定后，再按F5就可以了。
Private Sub VBAPassword()
'你要解保护的Excel文件路径
Filename = Application.GetOpenFilename("Excel文件（*.xls & *.xla & *.xlt）,*.xls;*.xla;*.xlt", , "VBA破解")

If Dir(Filename) = "" Then
MsgBox "没找到相关文件,清重新设置。"
Exit Sub
Else
FileCopy Filename, Filename & ".bak" '备份文件。
End If

Dim GetData As String * 5
Open Filename For Binary As #1
Dim CMGs As Long
Dim DPBo As Long
For i = 1 To LOF(1)
Get #1, i, GetData
If GetData = "CMG=""" Then CMGs = i
If GetData = "[Host" Then DPBo = i - 2: Exit For
Next

If CMGs = 0 Then
MsgBox "请先对VBA编码设置一个保护密码...", 32, "提示"
Exit Sub
End If

Dim St As String * 2
Dim s20 As String * 1

'取得一个0D0A十六进制字串
Get #1, CMGs - 2, St

'取得一个20十六制字串
Get #1, DPBo + 16, s20

'替换加密部份机码
For i = CMGs To DPBo Step 2
Put #1, i, St
Next

'加入不配对符号
If (DPBo - CMGs) Mod 2 <> 0 Then
Put #1, DPBo + 1, s20
End If
MsgBox "文件解密成功......", 32, "提示"

Close #1
End Sub 参考技术A hi buddy ，你看不到被隐藏的sheet，可能是在vba代码里被深度隐藏了，在后台找到相应的代码 把属性改成true就ok了（前提是已经被破解）。这样问题就来了 你的excel是2007的还是2003的 2003的 在网上就有破解工具，down一个就能搞定的 但要是2007以上版本 误解。。 参考技术B 下一个二次开发的吧
搜索 VBA免密查看

VBA - Excel 中显示的 API 调用

【中文标题】VBA - Excel 中显示的 API 调用

【英文标题】：VBA - API call displayed in Excel

【发布时间】：2018-07-28 20:58:45

【问题描述】：

我试图在 Excel 表格中显示特定加密货币的价格。我正在从 CoinMarketCap 的 API 中提取 JSON 数据 - https://api.coinmarketcap.com/v1/ticker/

最终，我试图获取 Ripple 的价格（第 16 行），然后在我的 Excel 工作表中设置单元格 B1 以显示 Ripple 的价格（第 17 行）。

这是我的脚本，但由于某种原因无法正常工作。

Sub test()

Dim httpObject As Object
Set httpObject = CreateObject("MSXML2.XMLHTTP")

sURL = "https://api.coinmarketcap.com/v1/ticker/"

sRequest = sURL
httpObject.Open "GET", sRequest, False
httpObject.Send
sGetResult = httpObject.ResponseText

Dim oJSON As Object
Set oJSON = JsonConverter.ParseJson(sGetResult)

  If oJSON.Name = "Ripple" Then
  B1 = oJSON("Ripple")("price_usd")

End If
End Sub

API 调用成功（我相信），但出现语法错误等。希望有人能够提供帮助。提前致谢

编辑：这是 Microsoft Excel 2010

编辑 2： 是第 16 行和第 17 行（分别是 If oJSON.Name... 和 B1 = oJSON(... 提出了问题，但到目前为止我一直无法解决它/找到错误。请参阅运行时错误等的 cmets。

编辑 3：我相信我在第 16 行和第 17 行中通过引用 oJSON 而不是项目 (sItem) 犯了一个错误。但是，即使更改此设置（例如If sItem.Name = "Ripple" Then...），它仍然无法正常工作。

编辑 4：我相信我也以错误的方式标记了 excel 单元格。我现在不是简单地写B1 = ...，而是写Range.("B1").Value = ...，它在测试中有效。

【问题讨论】：

请详细说明错误？描述是什么？它们出现在哪一行？

您能否检查响应或写出以便显示相关的 JSON...？

@QHarr “运行时错误 '438'：对象不支持此属性或方法。”当我尝试提取值时，发生在第 16 行和/或第 17 行。

这就是你说 If oJSON......?

要检索price_usd for ripple id，您应该遍历每个对象，找到具有ripple id 的对象并获取price_usd 值。

【参考方案1】：

@omegastripes 建议的这种修改在这里有效。 json对象是字典的集合，所以需要这样对待。

Dim oJSON As Object
Set oJSON = JsonConverter.ParseJson(sGetResult)

Dim V As Object
For Each V In oJSON
    If V("name") = "Ripple" Then
        Cells(1, 2) = V("price_usd")
        Exit For
    End If
Next V

【讨论】：

非常感谢，非常感谢！

【参考方案2】：

看看下面的例子。 将JSON.bas模块导入VBA项目进行JSON处理。

Option Explicit

Sub Test48852376()

    Dim sJSONString As String
    Dim vJSON As Variant
    Dim sState As String
    Dim vElement As Variant
    Dim sValue As String
    Dim aData()
    Dim aHeader()

    ' Retrieve JSON string
    With CreateObject("MSXML2.XMLHTTP")
        .Open "GET", "https://api.coinmarketcap.com/v1/ticker/", False
        .Send
        sJSONString = .responseText
    End With
    ' Parse JSON
    JSON.Parse sJSONString, vJSON, sState
    If sState = "Error" Then MsgBox "Invalid JSON string": Exit Sub
    ' Extract ripple price_usd
    Do
        For Each vElement In vJSON
            Select Case False
                Case vElement.Exists("id")
                Case vElement("id") = "ripple"
                Case vElement.Exists("price_usd")
                Case Else
                    MsgBox "ripple price_usd " & vElement("price_usd")
                    Exit Do
            End Select
        Next
        MsgBox "ripple price_usd not found"
    Loop Until True
    ' Output the entire table to the worksheet
    JSON.ToArray vJSON, aData, aHeader
    With Sheets(1)
        .Cells.Delete
        .Cells.WrapText = False
        OutputArray .Cells(1, 1), aHeader
        Output2DArray .Cells(2, 1), aData
        .Columns.AutoFit
    End With
    MsgBox "Completed"

End Sub

Sub OutputArray(oDstRng As Range, aCells As Variant)

    With oDstRng
        .Parent.Select
        With .Resize(1, UBound(aCells) - LBound(aCells) + 1)
            .NumberFormat = "@"
            .Value = aCells
        End With
    End With

End Sub

Sub Output2DArray(oDstRng As Range, aCells As Variant)

    With oDstRng
        .Parent.Select
        With .Resize( _
                UBound(aCells, 1) - LBound(aCells, 1) + 1, _
                UBound(aCells, 2) - LBound(aCells, 2) + 1)
            .NumberFormat = "@"
            .Value = aCells
        End With
    End With

End Sub

我的输出如下：

顺便说一句，类似的方法适用于in other answers。

【讨论】：

非常感谢您提供详尽的示例以及对早期答案的引用。我非常感谢您的帮助。