局域网内EXCEL文件自动升级代码

flysky_ng

公司录用数据，常年通过邮件报给我，然后要我用计算器算半天计算数据，后来我就自己做了一套VBA程序，让他们自己打开这个EXCEL文件输入数据进服务器，不用发邮件给我了，不过后来发现程序会很多BUG，需要更新，经过研究，成功开发了更新程序。

公司在10.12.68.1，给了一个目录给我放文件。

Public Sub CheckBanBen()  
    Dim BanBenHao As Integer
    Dim GengXin As String
    Dim DateTime As Date
   
   
    Dim OldPath, OldName As String
   

    CheckSQL    //检测SQL服务器
    OpenSQL     //打开SQL服务器
    SQL = "select top 1 * from dbo.版本 " _
        & "order by 版本号 desc "
    Set rs = cnn.Execute(SQL)
    BanBenHao = rs(0)
    DateTime = rs(1)
    GengXin = rs(2)
    CloseSQL
    If 版本号 < BanBenHao Then
        If MsgBox("发现新版本【企管部自动化表格程序】，是否进行更新？" & vbCrLf & "最近一次更新的主要内容是【" & GengXin & "】" & vbCrLf & "更新时间是【" & DateTime & "】", vbYesNo, "企业管理部自动化表格") = vbYes Then
            If Len(Dir("\\10.12.68.1\device\企管部自动化表格更新\企业管理部自动化表格.xls", vbDirectory)) > 0 Then
                If Dir("\\10.12.68.1\device\企管部自动化表格更新\企业管理部自动化表格.xls") <> "" Then
                    '文件存在
                Else
                    '目录存在，文件不存在
                    MsgBox "更新服务器无法连接，请稍后再试", vbCritical, "企业管理部自动化表格"
                    Exit Sub
                End If
            Else
                '目录不存在
                MsgBox "更新服务器无法使用，请稍后再试", vbCritical, "企业管理部自动化表格"
                Exit Sub
            End If
            
            
            
            '查检C盘中有没有“备份”文件夹
            If Dir("C:\企管部自动化表格备份", vbDirectory) = "" Then
                On Error GoTo 1
                MkDir "C:\企管部自动化表格备份" '没有就建一个“备份”文件夹
            End If
            
            OldPath = ThisWorkbook.Path
            OldName = ThisWorkbook.Name
            
            Application.DisplayAlerts = False '取消提示
            
            ThisWorkbook.SaveAs "C:\企管部自动化表格备份\" & OldName '备份文件
                 // 另存之后，本文件变成了 C:\企管部自动化表格备份的同名文件
            Kill OldPath & "\" & OldName
                              //删除原位置文件
            On Error GoTo 2
            FileCopy "\\10.12.68.1\device\企管部自动化表格更新\企业管理部自动化表格.xls", OldPath & "\" & OldName
            
            
            MsgBox "更新成功！原有文件将保存在【C:\企管部自动化表格备份】中。请重新打开本程序。", vbInformation, "企业管理部自动化表格"
            ThisWorkbook.Close False
            Application.DisplayAlerts = True '恢复提示
        End If
    End If
    Exit Sub
   
1:
    MsgBox "无C:文件操作权限，请调整权限后再进行更新！", vbCritical, "企业管理部自动化表格"
    Exit Sub
2:
    MsgBox "无文件所在目录操作权限，请调整权限后再进行更新！", vbCritical, "企业管理部自动化表格"
    Exit Sub
   
End Sub

[ 本帖最后由 flysky_ng 于 2011-7-29 10:43 编辑 ]

flysky_ng

通过这样，所有负责录入数据的电脑，一打开就自动检测新版本与本机版本的区别，如果有新版本就提示更新了。这样我很方便发现与解决所有问题

ah2005

简单,实用.

wxhnr

不错的方法，谢谢分享。

ks9703

继续关注中

365978279

楼主，你搞得很牛叉，但是我很想看看你做的样本，因为我不知道怎么调用，希望楼主教教我，我正为此事而发愁呢，非常谢谢啊

270665358

学习了 谢谢分享

wss0002

收藏了，谢谢！

yuioplkjh

不错的方法，谢谢分享。

zbapllo

牛人，学习一下，呵呵。。。