[已解决]保存、还原代码

乐乐2006201506 · 发表于 2016-6-15 22:26

本帖最后由乐乐2006201506 于 2016-6-16 13:34 编辑

1.怎样提取工作簿中宏代码并保存在文本文件中；
2.然后通过提取出来的含宏代码的文本文件，实现还原到原来的工作簿中。
谢谢！

最佳答案

月排行榜 / 总排行榜

老司机带带我

2016-6-16 10:48

代码如下，这个代码共参考！

Sub 导出代码()
Dim h&, j&
Dim fso As Scripting.filesystemobject
Dim na$
Dim mt As Scripting.textstream
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(0, "请选择文件存放位置", 0, 0)
If Not objFolder Is Nothing Then
mypath = objFolder.self.Path
Else
mypath = ""
Exit Sub
End If
Set fso = New Scripting.filesystemobject
myfile = mypath & "" & "测试.txt"
Set mt = fso.CreateTextFile(Filename:=myfile, overwrite:=True)
On Error Resume Next
With ThisWorkbook.VBProject
For j = 1 To .VBComponents.Count
MsgBox .VBComponents(j).Type & .VBComponents(j).Name
If .VBComponents(j).Type = 1 And .VBComponents(j).Name <> "导入导出代码" Then
na = .VBComponents(j).Name
With .VBComponents(na).CodeModule
h = .CountOfLines
mt.Write "模块名称：" & na & vbCrLf
For i = 1 To h
mt.Write .Lines(i, 1) & vbCrLf
Next
End With
.VBComponents.Remove .VBComponents(j)
End If
Next
End With
mt.Close
MsgBox "公式保存成功！"
End Sub
Sub 读取文本文件并放入指定工作表遍历()
Dim fso As Scripting.filesystemobject
Dim mt As Scripting.textstream, cN$
Dim myfile$, i&, str$, b As Boolean, rng$, fm$
myfile = Application.GetOpenFilename("TXT Files (*.txt), *.txt", 0, "选定文件", , False)
If myfile = "" Then Exit Sub
Set fso = New Scripting.filesystemobject
Set mt = fso.OpenTextFile(Filename:=myfile, IOMode:=ForReading)
With mt
Do Until .AtEndOfStream
str = .ReadLine
If Left(str, 5) = "模块名称：" Then
cN = Replace(str, "模块名称：", "")
MsgBox cN
ThisWorkbook.VBProject.VBComponents.Add(1).Name = cN
i = 0
Else
i = i + 1
With ThisWorkbook.VBProject.VBComponents(cN).CodeModule
.InsertLines i, str
End With
End If
Loop
.Close
End With
MsgBox "公式还原成功！"
End Sub

复制代码

跳转到最佳答案楼层

老司机带带我 · 发表于 2016-6-16 10:48

代码如下，这个代码共参考！

Sub 导出代码()
Dim h&, j&
Dim fso As Scripting.filesystemobject
Dim na$
Dim mt As Scripting.textstream
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(0, "请选择文件存放位置", 0, 0)
If Not objFolder Is Nothing Then
mypath = objFolder.self.Path
Else
mypath = ""
Exit Sub
End If
Set fso = New Scripting.filesystemobject
myfile = mypath & "" & "测试.txt"
Set mt = fso.CreateTextFile(Filename:=myfile, overwrite:=True)
On Error Resume Next
With ThisWorkbook.VBProject
For j = 1 To .VBComponents.Count
MsgBox .VBComponents(j).Type & .VBComponents(j).Name
If .VBComponents(j).Type = 1 And .VBComponents(j).Name <> "导入导出代码" Then
na = .VBComponents(j).Name
With .VBComponents(na).CodeModule
h = .CountOfLines
mt.Write "模块名称：" & na & vbCrLf
For i = 1 To h
mt.Write .Lines(i, 1) & vbCrLf
Next
End With
.VBComponents.Remove .VBComponents(j)
End If
Next
End With
mt.Close
MsgBox "公式保存成功！"
End Sub
Sub 读取文本文件并放入指定工作表遍历()
Dim fso As Scripting.filesystemobject
Dim mt As Scripting.textstream, cN$
Dim myfile$, i&, str$, b As Boolean, rng$, fm$
myfile = Application.GetOpenFilename("TXT Files (*.txt), *.txt", 0, "选定文件", , False)
If myfile = "" Then Exit Sub
Set fso = New Scripting.filesystemobject
Set mt = fso.OpenTextFile(Filename:=myfile, IOMode:=ForReading)
With mt
Do Until .AtEndOfStream
str = .ReadLine
If Left(str, 5) = "模块名称：" Then
cN = Replace(str, "模块名称：", "")
MsgBox cN
ThisWorkbook.VBProject.VBComponents.Add(1).Name = cN
i = 0
Else
i = i + 1
With ThisWorkbook.VBProject.VBComponents(cN).CodeModule
.InsertLines i, str
End With
End If
Loop
.Close
End With
MsgBox "公式还原成功！"
End Sub

复制代码

		自动登录	找回密码
密码			注册