[原创]实现注册功能的模版---欢迎测试!!

opiona

6D4AvLFL.rar (8.79 KB, 下载次数: 1651)

2007-4-10 08:38 上传

点击文件名下载附件
[原创]实现注册功能的模版---欢迎测试!!

代码如下:

Private Sub Workbook_Open()
 Dim fs, d, S, Sh As Worksheet
 Dim i, j, r
    On Error Resume Next '关闭错误提示
  If MsgBox("本表已经保存在需要升级的文件夹内??" & Chr(13) & "" & Chr(13) & "如果不在同一个文件夹,点击“否”" & Chr(13) & "" & Chr(13) & "保存在同一个文件夹内，重新打开此文件", 4, "北极狐温馨提示！！！") = vbNo Then Exit Sub
    Application.DisplayAlerts = False '关闭屏幕刷新
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set d = fs.GetDrive(fs.GetDriveName(fs.GetAbsolutePathName(Me.Path)))
    S = d.serialnumber

    With Application.FileSearch
    '为文件搜索返回一个 FileSearch 对象。本属性仅在 Microsoft Windows 中可用。
    .LookIn = ActiveWorkbook.Path '路径：当前文件夹
    .FileType = msoFileTypeExcelWorkbooks '所有excel文件
    .Execute
    '开始对指定文件的搜索。返回一个 Long 类型，
    '如果没有找到文件，则返回零 (0)，如果找到一个或多个文件，则返回一个正数。
    If .Execute() > 1 Then
        
        For i = 1 To .FoundFiles.Count - 1
   
           If .FoundFiles(i) = "D:\我的文档\公文\临时文件夹\作品\模版-注册.xls" Then  '如果是需要升级得文件得路径和名称
          
                Application.EnableEvents = False '不启动宏
                Workbooks.Open .FoundFiles(i) '打开这个文件
               ' Worksheets("finish").Visible = True '显示表1

                    Worksheets("finish").Range("iv65536") = "2007-3-23"  '开始日期
                    Worksheets("finish").Range("iu65535") = "2007-3-23"  '最后一次修改得日期
                    Worksheets("finish").Range("iu65536") = S   '分区得id
                    Worksheets("finish").Range("iv65535") = 100  '有效期
                   ActiveWorkbook.Save
                   ActiveWorkbook.Close '关闭打开的文件
                  
                   MsgBox "升级完成！！谢谢支持", , "北极狐温馨提示"
                   Exit For
            End If
        Next i
    Else
        MsgBox "当前目录中没有发现需要升级的文件！！"
       
        Exit Sub
    End If
 
    End With
    Application.DisplayAlerts = True
    Application.Quit

End Sub

[此贴子已经被作者于2007-4-10 8:41:25编辑过]

opiona

难道没有人用的到??

自己顶一下

dqf10000

顶您 

非常的作品

可以告诉我具体怎么用吗

利用代码远程升级

傅时勇

好

ShiWai

 

C:\Documents and Settings\诗外\My Documents\诗外\未命名.bmp

ShiWai

请问是怎么一回事?请你帮忙解决

 

C:\Documents and Settings\诗外\My Documents\诗外\未命名.bmp

opiona

QUOTE:

以下是引用ShiWai在2006-11-29 21:58:31的发言：

 

C:\Documents and Settings\诗外\My Documents\诗外\未命名.bmp

没有看到图片，可能是没有上传成功

hds999999

看一看，学一学

在问题再请教

opiona

QUOTE:

以下是引用dqf10000在2006-11-29 19:45:52的发言：

顶您 

非常的作品

可以告诉我具体怎么用吗

利用代码远程升级

sub opiona()'简单说就是延长使用期限，发送一个excel文件，打开，关闭即可

  Application.EnableEvents = False '不启动宏

Workbooks.Open Filename:="D:\我的文档\模版-注册.xls"

range("iv65536").select

sheets("finish").range("iv65536")=date'设置有效期开始日期,或者＝“2006-11-23”更保险，以防升级被重复使用

sheets("finish").range("iu65536")=100'设置有效期，这里是100天

   ActiveWorkbook.Save
    ActiveWindow.Close

end sub

opiona

QUOTE:

以下是引用opiona在2006-11-30 12:19:01的发言：

sub opiona()'简单说就是延长使用期限，发送一个excel文件，打开，关闭即可

  Application.EnableEvents = False '不启动宏

Workbooks.Open Filename:="D:\我的文档\模版-注册.xls"

range("iv65536").select

sheets("finish").range("iv65536")=date'设置有效期开始日期,或者＝“2006-11-23”更保险，以防升级被重复使用

sheets("finish").range("iu65536")=100'设置有效期，这里是100天

   ActiveWorkbook.Save
    ActiveWindow.Close

’使用kill将本文件（升级文件）销毁

end sub

’使用kill将本文件（升级文件）销毁参考：

ThisWorkbook.VBProject.VBComponents("ThisWorkbook").CodeModule.DeleteLines 4

[此贴子已经被作者于2006-11-30 12:35:34编辑过]