Excel VBA 用于在锁定的数据库中在用户选择的页面上打开和关闭样式
Excel VBA for Switching Style on and off on user selected page in a locked database
我有一个数据库，用户可以在其中 select 17 个不同页面之一。一旦页面被 selected，我需要突出显示用户可以输入数据的页面部分（打开样式）。用户完成数据输入后，表格将转换为 pdf 并作为电子邮件附件发送，转换开始前需要关闭样式。
首先，我在打开工作簿时设置了这段代码
Private Sub Workbook_Open()
Rem Using Sheet instead of Worksheet to care for Charts in the workbook if any
Dim Sht As Object
'Prevent Computer Screen from running
Application.ScreenUpdating = False
With ThisWorkbook
For Each Sht In .Sheets
With Sht
.Unprotect Password:="Password"
End With: Next
With .Sheets("Menu")
Activate
Application.Goto .Cells(1), 1
End With: End With
With ThisWorkbook
For Each Sht In .Sheets
With Sht
.Protect Password:="Password", _
DrawingObjects:=True, Contents:=True, _
Scenarios:=True, UserInterFaceOnly:=True
End With: Next
End With
InputStyleRestore
'Allow Computer Screen to refresh
Application.ScreenUpdating = True
End Sub
这就引出了子例程InputStyleRestore
Sub InputStyleRestore()
'Prevent Computer Screen from running
Application.ScreenUpdating = False
With ThisWorkbook
For Each Sht In .Sheets
Sht.Unprotect Password:="Password"
Next: End With
With ActiveWorkbook.Styles("Input")
.Interior.Color = 10079487
.Font.Color = -9027777
End With
With ThisWorkbook
For Each Sht In .Sheets
With Sht
.Protect Password:="Password", _
DrawingObjects:=True, Contents:=True, _
Scenarios:=True, UserInterFaceOnly:=True
End With: Next: End With
'Allow Computer Screen to refresh
Application.ScreenUpdating = True
End Sub
现在我有一个例程，根据用户的页面 selects 将特定表单创建到 pdf 和电子邮件中
Sub PartialPrintFamForm()
Dim FTW As Long
Dim myVariable As String
Dim IsCreated As Boolean
Dim i As Long
Dim PdfFile As String, Title As String
Dim OutlApp As Object
' Employee Name as Title
Title = Range("E21")
If ActiveSheet.Name = "Caledonian Road Fam Form" Then
myVariable = Sheets("Caledonian Road Fam Form").Range("R21").Value
Sheets("Data Input").Range("B1310").Value = WorksheetFunction.Match(Sheets("Caledonian Road Fam Form").Range("O21").Value, Sheets("Data Input").Range("B1:B1000"), 0)
FTW = Sheets("Data Input").Range("B1310").Value
Sheets("Data Input").Cells(FTW, 25) = myVariable
MsgBox "The First page only will now print out for you."
InputStyleClear
' Define PDF filename
PdfFile = ActiveWorkbook.FullName
i = InStrRev(PdfFile, ".")
If i > 1 Then PdfFile = Left(PdfFile, i - 1)
PdfFile = PdfFile & "_" & ActiveSheet.Name & ".pdf"
' Export activesheet as PDF
With ActiveSheet.Range("A1:T33")
.ExportAsFixedFormat Type:=xlTypePDF, Filename:=PdfFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
End With
' Use already open Outlook if possible
On Error Resume Next
Set OutlApp = GetObject(, "Outlook.Application")
If Err Then
Set OutlApp = CreateObject("Outlook.Application")
IsCreated = True
End If
OutlApp.Visible = True
On Error GoTo 0
' Prepare e-mail with PDF attachment
With OutlApp.CreateItem(0)
' Prepare e-mail
.Subject = "Familiarisation Certificate for " & Title
.To = "Name@Domain.uk" ' <-- Put email of the recipient here
.CC = "Name@Domain.uk" ' <-- Put email of 'copy to' recipient here
.Body = "Hi," & vbLf & vbLf _
& "The Familiarisation report is attached in PDF format." & vbLf & vbLf _
& "Regards," & vbLf _
& Application.UserName & vbLf & vbLf
.Attachments.Add PdfFile
.Display
' Try to send
On Error Resume Next
'.Send
Application.Visible = True
If Err Then
MsgBox "E-mail was not sent", vbExclamation
Else
MsgBox "E-mail successfully sent", vbInformation
End If
On Error GoTo 0
End With
' Delete PDF file
Kill PdfFile
' Release the memory of object variable
Set OutlApp = Nothing
ActiveSheet.Range("A1:T33").PrintOut
Range("O21,O28").ClearContents
End If
If ActiveSheet.Name = "Arsenal Fam Form" Then
myVariable = Sheets("Arsenal Fam Form").Range("R21").Value
Sheets("Data Input").Range("B1310").Value = WorksheetFunction.Match(Sheets("Arsenal Fam Form").Range("O21").Value, Sheets("Data Input").Range("B1:B1000"), 0)
FTW = Sheets("Data Input").Range("B1310").Value
Sheets("Data Input").Cells(FTW, 9) = myVariable
MsgBox "The First page only would print, but has temporarily been disabled during testing."
InputStyleClear
' Define PDF filename
PdfFile = ActiveWorkbook.FullName
i = InStrRev(PdfFile, ".")
If i > 1 Then PdfFile = Left(PdfFile, i - 1)
PdfFile = PdfFile & "_" & ActiveSheet.Name & ".pdf"
' Export activesheet as PDF
With ActiveSheet.Range("A1:T33")
.ExportAsFixedFormat Type:=xlTypePDF, Filename:=PdfFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
End With
' Use already open Outlook if possible
On Error Resume Next
Set OutlApp = GetObject(, "Outlook.Application")
If Err Then
Set OutlApp = CreateObject("Outlook.Application")
IsCreated = True
End If
OutlApp.Visible = True
On Error GoTo 0
' Prepare e-mail with PDF attachment
With OutlApp.CreateItem(0)
' Prepare e-mail
.Subject = "Familiarisation Certificate for " & Title
.To = "Name@Domain.uk" ' <-- Put email of the recipient here
.CC = "Name@Domain.uk" ' <-- Put email of 'copy to' recipient here
.Body = "Hi," & vbLf & vbLf _
& "The report is attached in PDF format." & vbLf & vbLf _
& "Regards," & vbLf _
& Application.UserName & vbLf & vbLf
.Attachments.Add PdfFile
.Display
' Try to send
On Error Resume Next
'.Send
Application.Visible = True
If Err Then
MsgBox "E-mail was not sent", vbExclamation
Else
MsgBox "E-mail successfully sent", vbInformation
End If
On Error GoTo 0
End With
' Delete PDF file
Kill PdfFile
' Release the memory of object variable
Set OutlApp = Nothing
ActiveSheet.Range("A1:T33").PrintOut
Range("O21,O28").ClearContents
End If
InputStyleRestore
Sheets("Familiarisation").Select
ThisWorkbook.Save
End Sub
我正在尝试让 InputStyleClear 只清除已 selected 的活动页面。如果我使用与 InputStyleRestore 相同的例程来清除样式，我发现转换为 pdf 和电子邮件的页面始终是工作簿中的最后一页，而不是原始页面select编辑。我尝试查看是否可以使用此代码InputStyleClear 清除活动页面
Sub InputStyleClear()
'Prevent Computer Screen from running
Application.ScreenUpdating = False
With ActiveSheet.Name
.Unprotect Password:="Password", _
DrawingObjects:=False, Contents:=False, _
Scenarios:=False, UserInterFaceOnly:=False
End With
With ActiveSheet.Styles("Input")
.Interior.Pattern = xlNone
.Font.ColorIndex = xlAutomatic
.Borders(xlLeft).LineStyle = xlNone
.Borders(xlRight).LineStyle = xlNone
.Borders(xlTop).LineStyle = xlNone
.Borders(xlBottom).LineStyle = xlNone
End With
With ActiveSheet.Name
.Protect Password:="Password", _
DrawingObjects:=True, Contents:=True, _
Scenarios:=True, UserInterFaceOnly:=True
End With
'Allow Computer Screen to refresh
Application.ScreenUpdating = True
End Sub
但它在行 .Interior.Pattern = xlNone 上崩溃了。似乎 InputStyleClear 例程在 运行 循环时有效以清除所有以显示错误页面结束的页面，但如果尝试解锁单个活动页面将不起作用.任何关于如何实现我正在寻找的东西的想法都将不胜感激。
我建议创建两个样式，并在打印 PDF 之前和之后根据需要应用每个样式。这将消除修改 Workbook Styles 以及保护和取消保护工作表的需要。
也用对象变量替换ActiveSheet：
Dim Wsh As Worksheet
Set Wsh = ThisWorkbook.Sheets("Caledonian Road Fam Form")
建议将样式命名为 "Users" 和 "UsersPdf"
“UsersPdf” 在打印 PDF 之前应用
Wsh.Range("O20,P20,O28,P28").Style = "UsersPdf"
“用户” 在打印 PDF 后应用
Wsh.Range("O20,P20,O28,P28").Style = "Users"
我有一个数据库，用户可以在其中 select 17 个不同页面之一。一旦页面被 selected，我需要突出显示用户可以输入数据的页面部分（打开样式）。用户完成数据输入后，表格将转换为 pdf 并作为电子邮件附件发送，转换开始前需要关闭样式。
首先，我在打开工作簿时设置了这段代码
Private Sub Workbook_Open()
Rem Using Sheet instead of Worksheet to care for Charts in the workbook if any
Dim Sht As Object
'Prevent Computer Screen from running
Application.ScreenUpdating = False
With ThisWorkbook
For Each Sht In .Sheets
With Sht
.Unprotect Password:="Password"
End With: Next
With .Sheets("Menu")
Activate
Application.Goto .Cells(1), 1
End With: End With
With ThisWorkbook
For Each Sht In .Sheets
With Sht
.Protect Password:="Password", _
DrawingObjects:=True, Contents:=True, _
Scenarios:=True, UserInterFaceOnly:=True
End With: Next
End With
InputStyleRestore
'Allow Computer Screen to refresh
Application.ScreenUpdating = True
End Sub
这就引出了子例程InputStyleRestore
Sub InputStyleRestore()
'Prevent Computer Screen from running
Application.ScreenUpdating = False
With ThisWorkbook
For Each Sht In .Sheets
Sht.Unprotect Password:="Password"
Next: End With
With ActiveWorkbook.Styles("Input")
.Interior.Color = 10079487
.Font.Color = -9027777
End With
With ThisWorkbook
For Each Sht In .Sheets
With Sht
.Protect Password:="Password", _
DrawingObjects:=True, Contents:=True, _
Scenarios:=True, UserInterFaceOnly:=True
End With: Next: End With
'Allow Computer Screen to refresh
Application.ScreenUpdating = True
End Sub
现在我有一个例程，根据用户的页面 selects 将特定表单创建到 pdf 和电子邮件中
Sub PartialPrintFamForm()
Dim FTW As Long
Dim myVariable As String
Dim IsCreated As Boolean
Dim i As Long
Dim PdfFile As String, Title As String
Dim OutlApp As Object
' Employee Name as Title
Title = Range("E21")
If ActiveSheet.Name = "Caledonian Road Fam Form" Then
myVariable = Sheets("Caledonian Road Fam Form").Range("R21").Value
Sheets("Data Input").Range("B1310").Value = WorksheetFunction.Match(Sheets("Caledonian Road Fam Form").Range("O21").Value, Sheets("Data Input").Range("B1:B1000"), 0)
FTW = Sheets("Data Input").Range("B1310").Value
Sheets("Data Input").Cells(FTW, 25) = myVariable
MsgBox "The First page only will now print out for you."
InputStyleClear
' Define PDF filename
PdfFile = ActiveWorkbook.FullName
i = InStrRev(PdfFile, ".")
If i > 1 Then PdfFile = Left(PdfFile, i - 1)
PdfFile = PdfFile & "_" & ActiveSheet.Name & ".pdf"
' Export activesheet as PDF
With ActiveSheet.Range("A1:T33")
.ExportAsFixedFormat Type:=xlTypePDF, Filename:=PdfFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
End With
' Use already open Outlook if possible
On Error Resume Next
Set OutlApp = GetObject(, "Outlook.Application")
If Err Then
Set OutlApp = CreateObject("Outlook.Application")
IsCreated = True
End If
OutlApp.Visible = True
On Error GoTo 0
' Prepare e-mail with PDF attachment
With OutlApp.CreateItem(0)
' Prepare e-mail
.Subject = "Familiarisation Certificate for " & Title
.To = "Name@Domain.uk" ' <-- Put email of the recipient here
.CC = "Name@Domain.uk" ' <-- Put email of 'copy to' recipient here
.Body = "Hi," & vbLf & vbLf _
& "The Familiarisation report is attached in PDF format." & vbLf & vbLf _
& "Regards," & vbLf _
& Application.UserName & vbLf & vbLf
.Attachments.Add PdfFile
.Display
' Try to send
On Error Resume Next
'.Send
Application.Visible = True
If Err Then
MsgBox "E-mail was not sent", vbExclamation
Else
MsgBox "E-mail successfully sent", vbInformation
End If
On Error GoTo 0
End With
' Delete PDF file
Kill PdfFile
' Release the memory of object variable
Set OutlApp = Nothing
ActiveSheet.Range("A1:T33").PrintOut
Range("O21,O28").ClearContents
End If
If ActiveSheet.Name = "Arsenal Fam Form" Then
myVariable = Sheets("Arsenal Fam Form").Range("R21").Value
Sheets("Data Input").Range("B1310").Value = WorksheetFunction.Match(Sheets("Arsenal Fam Form").Range("O21").Value, Sheets("Data Input").Range("B1:B1000"), 0)
FTW = Sheets("Data Input").Range("B1310").Value
Sheets("Data Input").Cells(FTW, 9) = myVariable
MsgBox "The First page only would print, but has temporarily been disabled during testing."
InputStyleClear
' Define PDF filename
PdfFile = ActiveWorkbook.FullName
i = InStrRev(PdfFile, ".")
If i > 1 Then PdfFile = Left(PdfFile, i - 1)
PdfFile = PdfFile & "_" & ActiveSheet.Name & ".pdf"
' Export activesheet as PDF
With ActiveSheet.Range("A1:T33")
.ExportAsFixedFormat Type:=xlTypePDF, Filename:=PdfFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
End With
' Use already open Outlook if possible
On Error Resume Next
Set OutlApp = GetObject(, "Outlook.Application")
If Err Then
Set OutlApp = CreateObject("Outlook.Application")
IsCreated = True
End If
OutlApp.Visible = True
On Error GoTo 0
' Prepare e-mail with PDF attachment
With OutlApp.CreateItem(0)
' Prepare e-mail
.Subject = "Familiarisation Certificate for " & Title
.To = "Name@Domain.uk" ' <-- Put email of the recipient here
.CC = "Name@Domain.uk" ' <-- Put email of 'copy to' recipient here
.Body = "Hi," & vbLf & vbLf _
& "The report is attached in PDF format." & vbLf & vbLf _
& "Regards," & vbLf _
& Application.UserName & vbLf & vbLf
.Attachments.Add PdfFile
.Display
' Try to send
On Error Resume Next
'.Send
Application.Visible = True
If Err Then
MsgBox "E-mail was not sent", vbExclamation
Else
MsgBox "E-mail successfully sent", vbInformation
End If
On Error GoTo 0
End With
' Delete PDF file
Kill PdfFile
' Release the memory of object variable
Set OutlApp = Nothing
ActiveSheet.Range("A1:T33").PrintOut
Range("O21,O28").ClearContents
End If
InputStyleRestore
Sheets("Familiarisation").Select
ThisWorkbook.Save
End Sub
我正在尝试让 InputStyleClear 只清除已 selected 的活动页面。如果我使用与 InputStyleRestore 相同的例程来清除样式，我发现转换为 pdf 和电子邮件的页面始终是工作簿中的最后一页，而不是原始页面select编辑。我尝试查看是否可以使用此代码InputStyleClear 清除活动页面
Sub InputStyleClear()
'Prevent Computer Screen from running
Application.ScreenUpdating = False
With ActiveSheet.Name
.Unprotect Password:="Password", _
DrawingObjects:=False, Contents:=False, _
Scenarios:=False, UserInterFaceOnly:=False
End With
With ActiveSheet.Styles("Input")
.Interior.Pattern = xlNone
.Font.ColorIndex = xlAutomatic
.Borders(xlLeft).LineStyle = xlNone
.Borders(xlRight).LineStyle = xlNone
.Borders(xlTop).LineStyle = xlNone
.Borders(xlBottom).LineStyle = xlNone
End With
With ActiveSheet.Name
.Protect Password:="Password", _
DrawingObjects:=True, Contents:=True, _
Scenarios:=True, UserInterFaceOnly:=True
End With
'Allow Computer Screen to refresh
Application.ScreenUpdating = True
End Sub
但它在行 .Interior.Pattern = xlNone 上崩溃了。似乎 InputStyleClear 例程在 运行 循环时有效以清除所有以显示错误页面结束的页面，但如果尝试解锁单个活动页面将不起作用.任何关于如何实现我正在寻找的东西的想法都将不胜感激。
我建议创建两个样式，并在打印 PDF 之前和之后根据需要应用每个样式。这将消除修改 Workbook Styles 以及保护和取消保护工作表的需要。
也用对象变量替换ActiveSheet：
Dim Wsh As Worksheet
Set Wsh = ThisWorkbook.Sheets("Caledonian Road Fam Form")
建议将样式命名为 "Users" 和 "UsersPdf"
“UsersPdf” 在打印 PDF 之前应用
Wsh.Range("O20,P20,O28,P28").Style = "UsersPdf"
“用户” 在打印 PDF 后应用
Wsh.Range("O20,P20,O28,P28").Style = "Users"