第22章应用程序部署策略

最新推荐文章于 2022-06-23 19:48:16 发布

weixin_33918114

最新推荐文章于 2022-06-23 19:48:16 发布

阅读量115

点赞数

原文链接：http://www.cnblogs.com/csl-office-vb-sql-net/archive/2010/01/21/1653262.h

版权

22.1 选择方式

22.1.1 我喜欢原型程序

22.1.2 使用模板重复成功操作

代码清单22.1: 实现伪模板功能

代码

' 代码清单22.1: 实现伪模板功能
' Create new Workbook based on this workbook
Sub SimplePsuedoTemplate()
     Dim wb As Workbook
     Dim sname As String
     Dim sDefault As String
     Dim sFilter As String

     ' Default file name
    sDefault = GetDefaultName
    sFilter = " Microsoft Office Excel Workbook(*.xls),*.xls "
    sname = Application.GetSaveAsFilename(sDefault, sFilter)

     If sname <> " False " Then
         If FileExists(sname) Then
             If OkToOverwrite(sname) Then
                Application.DisplayAlerts = False
                ThisWorkbook.SaveAs sname
                Application.DisplayAlerts = True
             End If
         Else
            ThisWorkbook.SaveAs sname
         End If
     End If

     Set wb = Nothing
End Sub

Function GetDefaultName() As String
     Dim bGotName As Boolean
     Dim sname As String
     Dim nIndex As Integer

    nIndex = 1
    bGotName = False

     Do
         ' 去掉".xls"
        sname = Left (ThisWorkbook.Name, Len (ThisWorkbook.Name) - 4 ) & CStr (nIndex)

　　　　'isWorkbookOpen见代码清单6.2
         If IsWorkbookOpen(sname & " .xls " ) Then
            nIndex = nIndex + 1
         Else
            bGotName = True
         End If
     Loop Until bGotName

    GetDefaultName = sname & " .xls "
End Function

Function OkToOverwrite(sFullName As String ) As Boolean
     Dim sMsg As String
     Dim nButtons As Long
     Dim nResponse As Long
     Dim bOverwrite As Boolean

    bOverwrite = False

    sMsg = sFullName & " already exists. do you want to overwrite it? "
    nButtons = vbYesNoCancel + vbExclamation + vbDefaultButton2

    nResponse = MsgBox (sMsg, nButtons, " Overwrite File? " )
     If nResponse = vbYes Then
        bOverwrite = True
     End If
    OkToOverwrite = bOverwrite
End Function

Function FileExists(sFullName As String ) As String
     Dim bExists As Boolean
     Dim nLength As Integer

    nLength = Len ( Dir (sFullName))

     If nLength > 0 Then
        bExists = True
     Else
        bExists = False
     End If
    FileExists = bExists
End Function

22.1.3 混合使用插件

代码

' 代码清单22.2: 有用的插件函数
Function ViewQueryTableConnection(QueryTableCell As Range) As String
     Dim sResult As String

     On Error Resume Next

    sResult = ""
     If QueryTableCell.QueryTable Is Nothing Then
        sResult = " No query table. "
     Else
        sResult = QueryTableCell.QueryTable.Connection
     End If
    ViewQueryTableConnection = sResult
End Function

Function ListVeryHiddenSheets(AnyCell As Range) As String
     Dim ws As Worksheet
     Dim sResult As String
     On Error Resume Next

    sResult = ""

     For Each ws In Workbooks
         If ws.Visible = xlSheetVeryHidden Then
            sResult = sResult & ws.Name & " , "
         End If
     Next

     If Len (sResult) > 2 Then
        sResult = Left (sResult, Len (sResult) - 2 )
     Else
        sResult = " There are no very hidden worksheets. "
     End If

     Set ws = Nothing
    ListVeryHiddenSheets = sResult
End Function

22.2 管理变更

22.2.1 采用集中化的模板部署模式

22.2.2 实现版本识别

代码清单22.3: 实现基本的版本识别

代码

' 代码清单22.3: 实现基本的版本识别
Sub PerformVersionCheck()
     If IsConnectionAvailable Then
        CheckVersion
     Else
         MsgBox " sorry, can't check version at this time. "
     End If
End Sub

Sub CheckVersion()
     Dim rst As ADODB.Recordset
     Dim nWBVersion As Integer
     Dim sSql As String

     On Error GoTo ErrHandler

    sSql = ""
     Set rst = QueryDB(sSql)

     If rst Is Nothing Then Exit Sub
     If Not rst.EOF Then
        nWBVersion = GetVersionId

         Select Case nWBVersion
             Case - 1
                 MsgBox ""
             Case rst.Fields( " VersionID " ).Value
                 MsgBox ""
             Case Is >= rst.Fields( " MinimumVersionID " ).Value
                 MsgBox ""
             Case Is < rst.Fields( " MinimumVersionID " ).Value
                 MsgBox ""
             Case Else
                 MsgBox ""
         End Select
     Else
         MsgBox ""
     End If
ExitPoint:
     Set rst = Nothing
     Exit Sub
ErrHandler:
     MsgBox ""
     Resume ExitPoint
End Sub

Function GetVersionId() As Integer
     Dim rst As ADODB.Recordset
     Dim oSettings
     Dim sVersion As String
     Dim sSql As String

     On Error GoTo ErrHandler

    sVersion = oSettings.Item( " App version " ).Value
    sSql = ""
     Set rst = QueryDB(sSql)
     If Not rst.EOF Then
        GetVersionId = rst.Fields( 0 ).Value
     Else
        GetVersionId = - 1
     End If
     If rst.State = adStateOpen Then rst.Close

ExitPoint:
     Set rst = Nothing
     Exit Sub
ErrHandler:
     MsgBox ""
     Resume ExitPoint
End Function

Function QueryDB(sSql As String ) As ADODB.Recordset
     Dim sConn As String
     Dim rst As ADODB.Recordset

     On Error GoTo ErrHandler

     Set rst = New ADODB.Recordset
    sConn = GetConnection
    rst.Open sSql, sConn
     Set QueryDB = rst
ExitPoint:
     Set rst = Nothing
     Exit Function
ErrHandler:
    Debug.Print " QueryDb error: " & Err.Description
     Set QueryDB = Nothing
     Resume ExitPoint
End Function

Function GetConnection() As String
     Dim oSettings
     On Error GoTo ErrHandler

    GetConnection = oSettings.Item( " Version Connection " ).Value

ExitPoint:
     Set oSettings = Nothing
     Exit Function
ErrHandler:
    GetConnection = ""
     Resume ExitPoint
End Function

Function IsConnectionAvailable() As Boolean
     Dim sConn As String
     Dim conn As New ADODB.Connection

     On Error GoTo ErrHandler

    sConn = GetConnection
    conn.Open sConn

     If conn.State = adStateOpen Then conn.Close
    IsConnectionAvailable = True

ExitPoint:
     Set conn = Nothing
     Exit Function
ErrHandler:
    IsConnectionAvailable = False
     Resume ExitPoint
End Function

22.2.3 出现问题时不要恐慌

代码清单22.4: 修复工作薄的简单程序

代码

' 代码清单22.4: 修复工作薄的简单程序
Sub FixWorkbook(wb As Workbook)
     Dim ws As Worksheet

     Set ws = wb.Worksheets( " Sheet1 " )

    ws.Range( " A1 " ).Formula = " =b1+c1 "
    ws.Range( " A2 " ).Formula = " =b2+c2 "
    ws.Range( " A3 " ).Formula = " =b3+c3 "

     Set ws = Nothing
End Sub

Sub ProcessFileBatch()
     Dim nIndex As Integer
     Dim vFiles As Variant
     Dim wb As Workbook
     Dim bAlreadyOpen As Boolean
     Dim sFile As String

     On Error GoTo ErrHandler

    vFiles = GetExcelFiles( "" )

     If Not IsArray (vFiles) Then
        Debug.Print ""
         Exit Sub
     End If

    Application.ScreenUpdating = False

     For nIndex = 1 To UBound (vFiles)
         If IsWorkbookOpen( CStr (vFiles(nIndex))) Then
             Set wb = Workbooks(GetShortName( CStr (vFiles(nIndex))))
            Debug.Print "" & wb.Name
            bAlreadyOpen = True
         Else
             Set wb = Workbooks.Open( CStr (vFiles(nIndex)), False )
            Debug.Print "" & wb.Name
            bAlreadyOpen = False
         End If

        Application.StatusBar = "" & wb.Name

        FixWorkbook wb

         If Not bAlreadyOpen Then
            Debug.Print "" & wb.Name
            wb.Close True
         End If

     Next

ErrHandler:
    Application.StatusBar = False
    Application.ScreenUpdating = True
End Sub

' 代码清单6.2
Function IsWorkbookOpen(sWorkbook As String ) As Boolean
End Function

' 代码清单5.6
Function GetExcelFiles(sTitle As String ) As Variant
End Function

' 代码清单5.8
Function GetShortName(sLongName As String ) As Variant
End Function

' 代码清单5.8
Function BreakdownName(sFullName As String , byref sname As String , byref sPath As String ) As Variant
End Function

' 代码清单5.8
Function FileNamePosition(sFullName As String ) As Integer
End Function

转载于:https://www.cnblogs.com/csl-office-vb-sql-net/archive/2010/01/21/1653262.html