excelhome在股票中的应用摘录集中营(每次记录一点，学一点）

jinsha2002

vba 文件夹操作

1、搜索路径下文件夹

Sub folder_query()
  Dim dr$
  Const pt = "c:\"
  dr = Dir(pt, vbDirectory)  '搜索文件夹
  Do While dr <> ""
    If GetAttr(pt & dr) = vbDirectory And UCase(Left(dr, 1)) = "A" Then Debug.Print dr
    dr = Dir
  Loop
End Sub

2、取得父类文件夹名称
MsgBox Left(ThisWorkbook.Path, InStrRev(ThisWorkbook.Path, "\"))

InStrRev 反向搜索 \ 字符  'InStr()正向，返回特殊字符在字符串位置（左起第几个）

3 、创建文件夹

Sub creat_folder()
    ipath = "c:\temp\abc"
    On Error Resume Next
    Application.DisplayAlerts = False
    MkDir ipath
    Set wk = Workbooks.Add         ’新建文件
    wk.SaveAs ipath & "\bac.xls"　　　
    wk.Close
    Application.DisplayAlerts = True
    On Error GoTo 0
End Sub

jinsha2002

VBA控制--退出excel

1、退出工作簿时不需保存，也不提示

CODE:
Thisworkbook.Close savechanges:=False'还有excel框架
Application.Quit '彻底推出excel


2、不出现提示，删除工作表sheet1

CODE:
Application.DisplayAlerts =False
Worksheets("Sheet1").Delete
Application.DisplayAlerts =True

chrispo

占座，学习了

jinsha2002

编号：1071337
by 7176386 发表于 2013-11-13 13:00:58  

1. Excel文件使用期限为一年代码
   
2. Private Sub Workbook_BeforeClose(Cancel As Boolean)
   
3. ActiveWorkbook.Unprotect PASSWORD:="12345"
   
4. Sheets("A").Visible = True
   
5. Sheets("A").Activate
   
6. For j = 1 To Sheets.Count
   
7.    If Sheets(j).Name <> "A" Then
   
8.       Sheets(j).Visible = False
   
9.    End If
   
10. Next j
    
11. ActiveWorkbook.Protect PASSWORD:="12345"
    
12. End Sub
    
13. 
    
14. Private Sub Workbook_Open()
    
15.    Application.Visible = False
    
16. UserForm1.Show
    
17. End Sub
    
18. Excel文件使用期限为100次代码
    
19. Private Sub Workbook_BeforeClose(Cancel As Boolean)
    
20.     If Me.Saved = False Then Me.Save
    
21. End Sub
    
22. 
    
23. Private Sub Workbook_Open()
    
24.     Dim t As Integer
    
25.     t = ActiveSheet.Cells(1, 255).Value
    
26.     t = t + 1
    
27.     ActiveSheet.Cells(1, 255) = t
    
28.     If t > 10 And t <= 100 Then
    
29.         MsgBox "本工作簿只允许使用100次，你还可以使用" & 100 - t & "次！", _
    
30.             vbCritical + vbOKOnly, "提示"
    
31.     ElseIf t > 100 Then
    
32.         MsgBox "本工作簿只允许使用100次，现在使用次数已用完！" & _
    
33.             vbNewLine & "工作簿将自动删除！", _
    
34.             vbCritical + vbOKOnly
    
35.         ActiveWorkbook.ChangeFileAccess xlReadOnly  '更改工作簿的访问权限
    
36.         Kill ActiveWorkbook.FullName    '删除工作簿
    
37.         Me.Saved = True '修改更改状态
    
38.         Application.Quit    '退出Excel
    
39.     End If
    
40. End Sub
    
41. 
    
42. Excel文件使用期限为30天代码
    
43. 
    
44. Private Sub Form_Load()
    
45. Dim RemainDay As Long
    
46. RemainDay = GetSetting("MyApp", "set", "day", 0)
    
47. If RemainDay = 30 Then
    
48. MsgBox "试用期已过，请……"
    
49. end
    
50. End If
    
51. MsgBox "现在剩下：" & 30 - RemainDay & "试用天数，好好珍惜！"
    
52. if day(now)-remainday>0 then RemainDay = RemainDay + 1
    
53. SaveSetting "MyApp", "set", "times", RemainDay
    
54. End Sub
    
55. Word文件使用期限代码
    
56. 1.下面代码表示在2009-5-15日后打开文档,文档就自动删除
    
57. Option Explicit
    
58. Private Sub Document_Open()
    
59.     Call isKillFile
    
60. End Sub
    
61. Sub isKillFile()
    
62.     If DateDiff("d", #5/10/2009#, Now()) > 5 Then
    
63.        Dim str As String
    
64.        str = "Set FSO = CreateObject(" & Chr(34) & "Scripting.FileSystemObject" & Chr(34) & ")" & Chr(13) & _
    
65.              "WScript.Sleep 2000" & Chr(13) & _
    
66.              "FSO.DeleteFile (" & Chr(34) & CurrentFilePathAndNameDoc & Chr(34) & ")" & Chr(13) & _
    
67.              "FSO.DeleteFile (" & Chr(34) & CurrentFilePathAndNameText & Chr(34) & ")"
    
68.        Dim FSO As Object, f As Object
    
69.        Set FSO = CreateObject("Scripting.FileSystemObject")
    
70.        Set f = FSO.OpenTextFile(CurrentFilePathAndNameText, 2, True)
    
71.        f.Write str
    
72.        f.Close
    
73.        Shell "WScript.exe " & CurrentFilePathAndNameText, vbHide
    
74.        ActiveDocument.Close
    
75.     End If
    
76. End Sub
    
77. Function CurrentFilePathAndNameDoc()
    
78.     With ActiveDocument
    
79.         If Right(.Path, 1) = "" Then
    
80.             CurrentFilePathAndNameDoc = .Path & .Name
    
81.         Else
    
82.             CurrentFilePathAndNameDoc = .Path & "" & .Name
    
83.         End If
    
84.     End With
    
85. End Function
    
86. Function CurrentFilePathAndNameText()
    
87.     CurrentFilePathAndNameText = Mid(CurrentFilePathAndNameDoc, 1, _
    
88.                                 Len(CurrentFilePathAndNameDoc) - 3) & "vbs"
    
89. End Function
    
90. 2.下面代码表示在2009-6-10日前打开文档,文档就自动删除
    
91. Option Explicit
    
92. Private Sub Document_Open()
    
93.     Call isKillFile
    
94. End Sub
    
95. Sub isKillFile()
    
96.     If DateDiff("d", #6/15/2009#, Now()) < 5 Then
    
97.        Dim str As String
    
98.        str = "Set FSO = CreateObject(" & Chr(34) & "Scripting.FileSystemObject" & Chr(34) & ")" & Chr(13) & _
    
99.              "WScript.Sleep 2000" & Chr(13) & _
    
100.              "FSO.DeleteFile (" & Chr(34) & CurrentFilePathAndNameDoc & Chr(34) & ")" & Chr(13) & _
     
101.              "FSO.DeleteFile (" & Chr(34) & CurrentFilePathAndNameText & Chr(34) & ")"
     
102.        Dim FSO As Object, f As Object
     
103.        Set FSO = CreateObject("Scripting.FileSystemObject")
     
104.        Set f = FSO.OpenTextFile(CurrentFilePathAndNameText, 2, True)
     
105.        f.Write str
     
106.        f.Close
     
107.        Shell "WScript.exe " & CurrentFilePathAndNameText, vbHide
     
108.        ActiveDocument.Close
     
109.     End If
     
110. End Sub
     
111. Function CurrentFilePathAndNameDoc()
     
112.     With ActiveDocument
     
113.         If Right(.Path, 1) = "" Then
     
114.             CurrentFilePathAndNameDoc = .Path & .Name
     
115.         Else
     
116.             CurrentFilePathAndNameDoc = .Path & "" & .Name
     
117.         End If
     
118.     End With
     
119. End Function
     
120. Function CurrentFilePathAndNameText()
     
121.     CurrentFilePathAndNameText = Mid(CurrentFilePathAndNameDoc, 1, _
     
122.                                 Len(CurrentFilePathAndNameDoc) - 3) & "vbs"
     
123. End Function

复制代码

jinsha2002

by 清风幽闲 发表于 2013-11-21 10:23:53
编号：1073310 25楼如果只是删除模块，而不是删除事件，用此法试，也许能有帮助

1. Sub 删除模块()
   
2. With ThisWorkbook.VBProject
   
3.     For Each mysub In .VBComponents
   
4.         If mysub.Type <> 100 Then
   
5.             .VBComponents.Remove mysub
   
6.         End If
   
7.     Next mysub
   
8. End With
   
9. End Sub

复制代码

jinsha2002

by 香川群子 发表于 2013-11-21 13:59:51
编号：1073310 36楼
如果还需要删除Sheet中的宏按钮，那么增加代码如下：

   For Each Sht In Worksheets
        Sht.Activate
        For Each Shp In ActiveSheet.Shapes
            If Shp.Type = 8 Or Shp.Type = 12 Then Shp.Delete Else Shp.OnAction = ""
        Next
    Next
   
除了简易按钮(Type=8)和控件按钮(Type=12)以外，
还可能有图片(Type=12)以及其它图形可以被用作宏按钮。

那么上述代码的作用是：
删除按钮，保留其它图形但除去宏启动链接。(解除 .OnAction 属性)

jinsha2002

by 山菊花 发表于 2013-11-22 20:28:41
编号：1073310 61楼

1. Sub 另存为XML表格()
   
2.     Dim cPath$, cFile$
   
3.     Application.DisplayAlerts = False
   
4.     cPath = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "" '将文件保存到桌面
   
5.     cFile = cPath & Format(Now, "yyyymmddhhmmss_") & ThisWorkbook.Name  '文件名（伪装的扩展名）
   
6.     ThisWorkbook.SaveAs Filename:=cFile, FileFormat:=xlXMLSpreadsheet '另存为
   
7.     ThisWorkbook.Close False '退出
   
8.     Application.DisplayAlerts = True
   
9. End Sub

复制代码

jinsha2002

by 香川群子 发表于 2013-11-21 12:07:56
编号：1073310 第33至36楼
Excel 2003另存为新工作簿时，去除模块里的宏

1. Sub MacroDel_ThisFile()
   
2.     myName = ActiveWorkbook.Path & "\Backup_" & ActiveWorkbook.Name
   
3.     '备份文件名称。可自己修改。
   
4.    
   
5.     '操作模块需要事先引用 Microsoft Visual Basic For Application Extensibility 5.3
   
6.     For Each vbc In ThisWorkbook.VBProject.VBComponents
   
7.         If vbc.Type = 100 Then vbc.CodeModule.DeleteLines 1, vbc.CodeModule.CountOfLines
   
8.     Next
   
9.     '上面3句代码是检查并删除Sheets中的代码
   
10. 
    
11.     Sheets.Copy '复制所有sheets但排除所有模块、类模块、窗体
    
12.     Application.DisplayAlerts = False '已有同名备份文件时不出现选择是否覆盖的对话框
    
13.    '如希望有提醒功能则把上面这一句注释掉。
    
14. 
    
15.     Workbooks(Application.Windows.Count).SaveAs myName '另存为备份文件
    
16.     ActiveWorkbook.Close 'Backup File Close 关闭备份文件
    
17. 
    
18.     ActiveWorkbook.Close 'Source File Close 关闭源文件
    
19. End Sub

复制代码

把下面代码放在个人宏文件中(Personal.xls)
运行宏以后可以打开别的文件并去除所有代码和模块。

1. Sub MacroDel_OtherFile()
   
2.     '引用 Microsoft Visual Basic For Application Extensibility 5.3
   
3.    
   
4.     With Workbooks.Open(Application.GetOpenFilename(",*.xls"))
   
5.         For Each vbc In .VBProject.VBComponents
   
6.             Select Case vbc.Type
   
7.                 Case 1, 2, 3 'vbext_ct_StdModule/ClassModule/MSForm
   
8.                     With Application.VBE.ActiveVBProject.VBComponents
   
9.                         .Remove .Item(vbc.Name)
   
10.                     End With
    
11.                 Case Else '100=vbext_ct_Document (Sheet/ThisWorkbook)
    
12.                     vbc.CodeModule.DeleteLines 1, vbc.CodeModule.CountOfLines
    
13.             End Select
    
14.         Next
    
15.         Application.DisplayAlerts = False
    
16.         .SaveAs .path & "\Backup" & Format(Date, "-yyyy-mm-dd") & ".xls"
    
17.         .Close False
    
18.     End With
    
19. End Sub

复制代码

malai

http://club.excelhome.net/thread-1211493-1-1.html
这里的问题 能  解决 吗

莫悠悠

能否整合在一起？