Sub Protect([Password], [DrawingObjects], [Contents], [Scenarios], [UserInterfaceOnly], [AllowFormattingCells], [AllowFormattingColumns], [AllowFormattingRows], [AllowInsertingColumns], [AllowInsertingRows], [AllowInsertingHyperlinks], [AllowDeletingColumns], [AllowDeletingRows], [AllowSorting], [AllowFiltering], [AllowUsingPivotTables])
Member of Excel.Worksheet
如下代码:
Public Function SaveToExcel() As Boolean
On Error GoTo SaveToExcelErr
Dim fs As Scripting.FileSystemObject, f As File
Dim checkNow As Boolean
Dim objWorkSheet As Worksheet
Dim objworkBook As Workbook
Dim objExcel As Excel.Application
Dim intI As Integer
Dim rang As Range
Dim arrTemp() As String
Dim intRow As Integer
Dim intX As Integer
Dim filename As String
Set objExcel = New Excel.Application
Set objworkBook = objExcel.Workbooks.add
Set objWorkSheet = objworkBook.Worksheets.item(1)
'Write Header
For intRow = 1 To 3
'intRow = 65
'intX = 1
arrTemp = Split(arrTagExcel(intRow - 1), "|")
For intX = LBound(arrTemp) + 1 To UBound(arrTemp) + 1
'With objWorkSheet.Range(Chr(intRow) & CStr(intX + 1))
With objWorkSheet.Cells(intRow, intX)
If intRow = 1 Then .Font.size = 13
If intRow = 3 Then .Interior.Pattern = xlPatternGray25
.Font.Bold = True
.value = arrTemp(intX - 1)
.ColumnWidth = Len(arrTemp(intX - 1)) + 1.5
.Locked = True
End With
Next
Next
'Write Content
'rows
For intRow = 4 To UBound(arrTagExcel)
arrTemp = Split(arrTagExcel(intRow - 1), "|")
For intX = LBound(arrTemp) + 1 To UBound(arrTemp) + 1
'objWorkSheet.Range(Chr(intRow) & CStr(intX + 1)).NumberFormatLocal = "@" ' .Select.Activate = arrtemp(intI)
' If intX = UBound(arrtemp) + 1 Then
' Debug.Print "ok"
' End If
objWorkSheet.Cells(intRow, intX) = arrTemp(intX - 1)
'objWorkSheet.Range(intRow, intX + 1).Locked = False
objWorkSheet.Cells(intRow, intX).Locked = False
objWorkSheet.Cells(intRow, intX).NumberFormatLocal = "@"
'objWorkSheet.Cells(intRow, intX)
Next
'intX = intX + 1
objWorkSheet.Cells(intRow, intX - 1).Font.Color = vbRed
Next
objWorkSheet.Protect "", False, True, False, False, True, True, True, False, False, False, False, True, False, False, True
'objWorkSheet.Protect
lblstatus = "Finished!"
Set fs = New Scripting.FileSystemObject
If fs.FileExists(txtFileName) Then
If MsgBox("Excel file already exists,Do you want to replace it.", vbOKCancel + vbQuestion, "Finish") = vbOK Then
fs.DeleteFile txtFileName, True
Else
With CommonDialog1
.DialogTitle = "Please choose another directory..."
.ShowSave
If (.filename <> "") Then filename = .filename
If InStr(filename, ".xls") > 0 Then filename = Left(filename, InStr(filename, ".xls") - 1)
txtFileName.Text = filename + ".xls"
End With
End If
End If
Set f = Nothing
Set fs = Nothing
objworkBook.SaveAs txtFileName
objExcel.Visible = True
SaveToExcel = True
Exit Function
SaveToExcelErr:
' If Not objExcel Is Nothing Then
' objExcel.Workbooks.Close
' objExcel.Quit
' Set objExcel = Nothing
' End If
If Err.number = 70 Then
Set itmX = lvwRst.ListItems.add(, , Err.Source + ":Save Permission Denied!The excel file has been opened already.", , 2)
Else
Set itmX = lvwRst.ListItems.add(, , Err.Source + ":" + Err.Description, , 2)
End If
End Function
如果为 objWorkSheet.Protect "", False, True, False, False, True, True, True, False, False, False, False, True, False, False, True
则结果入 附件1 :
如果为 'objWorkSheet.Protect
则结果如 附件2:
但
Sub Protect([Password], [DrawingObjects], [Contents], [Scenarios], [UserInterfaceOnly], [AllowFormattingCells], [AllowFormattingColumns], [AllowFormattingRows], [AllowInsertingColumns], [AllowInsertingRows], [AllowInsertingHyperlinks], [AllowDeletingColumns], [AllowDeletingRows], [AllowSorting], [AllowFiltering], [AllowUsingPivotTables])
中每个参数什么意思真的还不清楚!
[Password] :设置保护密码
[DrawingObjects] :是否允许修改excel sheet上面的图形之类的物件
[Contents] :是否允许修改内容
[Scenarios] :?
[UserInterfaceOnly] : ?
[AllowFormattingCells] :是否允许Formatting单元格(就是是否允许对单元格进行拖拉了)
[AllowFormattingColumns] :是否允许Formatting列
[AllowFormattingRows] :是否允许Formatting行
[AllowInsertingColumns] :是否允许插入列
[AllowInsertingRows] :是否允许插入行
[AllowInsertingHyperlinks] :是否允许超链接
[AllowDeletingColumns] :是否允许删除列
[AllowDeletingRows] :是否允许删除行
[AllowSorting] :是否允许排序
[AllowFiltering] :是否允许过滤
[AllowUsingPivotTables] :?
从 http://www.microsoft.com/china/msdn/library/office/office/UndstaExcelObjModNETDev.mspx?mfr=true 中得知:
设置 Password 参数来指定一个区分大小写的字符串，这是取消保护工作表所需要的。如果您不指定这个参数，任何人都可以取消保护工作表。
将 Contents 参数设置为 True 来保护工作表的内容（单元格）。默认值为 True，您可能永远不会改变它。
将 DrawingObjects 参数设置为 True 来保护工作表的形状。默认值为 False。
将 Scenarios 参数设置为 True 来保护工作表中的方案。默认值为 True。
将 UserInterfaceOnly 参数设置为 True 可以允许通过代码修改，但是不允许通过用户界面修改。默认值为 False，这意味着通过代码和用户界面项都不可以修改受保护的工作表。这个属性设置只适用于当前会话。如果您想让代码可以在任何会话中都可以操作工作表，那么您需要每次工作簿打开的时候添加设置这个属性的代码。
Member of Excel.Worksheet
如下代码:
Public Function SaveToExcel() As Boolean
On Error GoTo SaveToExcelErr
Dim fs As Scripting.FileSystemObject, f As File
Dim checkNow As Boolean
Dim objWorkSheet As Worksheet
Dim objworkBook As Workbook
Dim objExcel As Excel.Application
Dim intI As Integer
Dim rang As Range
Dim arrTemp() As String
Dim intRow As Integer
Dim intX As Integer
Dim filename As String
Set objExcel = New Excel.Application
Set objworkBook = objExcel.Workbooks.add
Set objWorkSheet = objworkBook.Worksheets.item(1)
'Write Header
For intRow = 1 To 3
'intRow = 65
'intX = 1
arrTemp = Split(arrTagExcel(intRow - 1), "|")
For intX = LBound(arrTemp) + 1 To UBound(arrTemp) + 1
'With objWorkSheet.Range(Chr(intRow) & CStr(intX + 1))
With objWorkSheet.Cells(intRow, intX)
If intRow = 1 Then .Font.size = 13
If intRow = 3 Then .Interior.Pattern = xlPatternGray25
.Font.Bold = True
.value = arrTemp(intX - 1)
.ColumnWidth = Len(arrTemp(intX - 1)) + 1.5
.Locked = True
End With
Next
Next
'Write Content
'rows
For intRow = 4 To UBound(arrTagExcel)
arrTemp = Split(arrTagExcel(intRow - 1), "|")
For intX = LBound(arrTemp) + 1 To UBound(arrTemp) + 1
'objWorkSheet.Range(Chr(intRow) & CStr(intX + 1)).NumberFormatLocal = "@" ' .Select.Activate = arrtemp(intI)
' If intX = UBound(arrtemp) + 1 Then
' Debug.Print "ok"
' End If
objWorkSheet.Cells(intRow, intX) = arrTemp(intX - 1)
'objWorkSheet.Range(intRow, intX + 1).Locked = False
objWorkSheet.Cells(intRow, intX).Locked = False
objWorkSheet.Cells(intRow, intX).NumberFormatLocal = "@"
'objWorkSheet.Cells(intRow, intX)
Next
'intX = intX + 1
objWorkSheet.Cells(intRow, intX - 1).Font.Color = vbRed
Next
objWorkSheet.Protect "", False, True, False, False, True, True, True, False, False, False, False, True, False, False, True
'objWorkSheet.Protect
lblstatus = "Finished!"
Set fs = New Scripting.FileSystemObject
If fs.FileExists(txtFileName) Then
If MsgBox("Excel file already exists,Do you want to replace it.", vbOKCancel + vbQuestion, "Finish") = vbOK Then
fs.DeleteFile txtFileName, True
Else
With CommonDialog1
.DialogTitle = "Please choose another directory..."
.ShowSave
If (.filename <> "") Then filename = .filename
If InStr(filename, ".xls") > 0 Then filename = Left(filename, InStr(filename, ".xls") - 1)
txtFileName.Text = filename + ".xls"
End With
End If
End If
Set f = Nothing
Set fs = Nothing
objworkBook.SaveAs txtFileName
objExcel.Visible = True
SaveToExcel = True
Exit Function
SaveToExcelErr:
' If Not objExcel Is Nothing Then
' objExcel.Workbooks.Close
' objExcel.Quit
' Set objExcel = Nothing
' End If
If Err.number = 70 Then
Set itmX = lvwRst.ListItems.add(, , Err.Source + ":Save Permission Denied!The excel file has been opened already.", , 2)
Else
Set itmX = lvwRst.ListItems.add(, , Err.Source + ":" + Err.Description, , 2)
End If
End Function
如果为 objWorkSheet.Protect "", False, True, False, False, True, True, True, False, False, False, False, True, False, False, True
则结果入 附件1 :
如果为 'objWorkSheet.Protect
则结果如 附件2:
但
Sub Protect([Password], [DrawingObjects], [Contents], [Scenarios], [UserInterfaceOnly], [AllowFormattingCells], [AllowFormattingColumns], [AllowFormattingRows], [AllowInsertingColumns], [AllowInsertingRows], [AllowInsertingHyperlinks], [AllowDeletingColumns], [AllowDeletingRows], [AllowSorting], [AllowFiltering], [AllowUsingPivotTables])
中每个参数什么意思真的还不清楚!
[Password] :设置保护密码
[DrawingObjects] :是否允许修改excel sheet上面的图形之类的物件
[Contents] :是否允许修改内容
[Scenarios] :?
[UserInterfaceOnly] : ?
[AllowFormattingCells] :是否允许Formatting单元格(就是是否允许对单元格进行拖拉了)
[AllowFormattingColumns] :是否允许Formatting列
[AllowFormattingRows] :是否允许Formatting行
[AllowInsertingColumns] :是否允许插入列
[AllowInsertingRows] :是否允许插入行
[AllowInsertingHyperlinks] :是否允许超链接
[AllowDeletingColumns] :是否允许删除列
[AllowDeletingRows] :是否允许删除行
[AllowSorting] :是否允许排序
[AllowFiltering] :是否允许过滤
[AllowUsingPivotTables] :?
从 http://www.microsoft.com/china/msdn/library/office/office/UndstaExcelObjModNETDev.mspx?mfr=true 中得知:
设置 Password 参数来指定一个区分大小写的字符串，这是取消保护工作表所需要的。如果您不指定这个参数，任何人都可以取消保护工作表。
将 Contents 参数设置为 True 来保护工作表的内容（单元格）。默认值为 True，您可能永远不会改变它。
将 DrawingObjects 参数设置为 True 来保护工作表的形状。默认值为 False。
将 Scenarios 参数设置为 True 来保护工作表中的方案。默认值为 True。
将 UserInterfaceOnly 参数设置为 True 可以允许通过代码修改，但是不允许通过用户界面修改。默认值为 False，这意味着通过代码和用户界面项都不可以修改受保护的工作表。这个属性设置只适用于当前会话。如果您想让代码可以在任何会话中都可以操作工作表，那么您需要每次工作簿打开的时候添加设置这个属性的代码。
AllowFormattingCells 参数、AllowFormattingColumns 参数和前面方法语法的完整列表中所示的其余参数允许特定的格式化功能，对应于对话框中（如图 12 所示）的选项。默认情况下，所有这些属性都是 False。
本文转自kenty博客园博客，原文链接http://www.cnblogs.com/kentyshang/archive/2006/05/31/414054.html如需转载请自行联系原作者
kenty
