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)
'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
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
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
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
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
