我设法让代码在共享工作簿中工作，做了一些调整。当然，我必须牺牲自动调整形状的能力，但这不是世界末日。
我不得不把我的文本放在一个单元格中，并获得形状=单元格的值。
代码：
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'On Error GoTo Message
ActiveSheet.DisplayPageBreaks = False
If Target.Address = "$O$2" Then
If Range("A" & Rows.Count).End(xlUp).Row < 5 Then
Range("A5").Select
Else
Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Select
End If
End If
If Target.Address = "$N$2" Then
If Range("A" & Rows.Count).End(xlUp).Row < 5 Then
Range("A5").Select
Else
Range("A7").Select
End If
End If
'On Error GoTo Message:
If Target.Address = "$D$4" Then
UserForm1.show
End If
'Start Phone Book Directory Code
Dim Contact As String
Dim Email As String
Dim Phone As String
Dim Fax As String
Application.EnableEvents = False 'to prevent endless loop
'On Error GoTo Finalize 'to re-enable the events
If Intersect(Target, ThisWorkbook.Worksheets(1).Range("F" & ActiveCell.Row)) Is Nothing Then 'Main IF
ThisWorkbook.Worksheets(1).Shapes("Suggest").Visible = False
ThisWorkbook.Worksheets(1).Shapes("Close").Visible = False
'ActiveSheet.Unprotect Password:="SecretPassword"
Else
If ThisWorkbook.Worksheets(1).Range("E" & ActiveCell.Row).Value = "" Or ThisWorkbook.Worksheets(1).Range("F" & ActiveCell.Row).Value <> "" Then ' Secondary iF
ThisWorkbook.Worksheets(1).Shapes("Suggest").Visible = False
ThisWorkbook.Worksheets(1).Shapes("Close").Visible = False
'ActiveSheet.Unprotect Password:="SecretPassword"
Else
'Start FIND
With Worksheets("Contacts").Range("A1:A10000")
Set c = .Find("*" & ActiveCell.Offset(0, -1).Value & "*", LookIn:=xlValues)
If c Is Nothing Then
'Introduce FailSafe, escape code if no result found
ThisWorkbook.Worksheets(1).Shapes("Suggest").Visible = False
ThisWorkbook.Worksheets(1).Shapes("Close").Visible = False
'ActiveSheet.Unprotect Password:="SecretPassword"
Else
'Check values are not blank
If c.Offset(0, 1).Value <> "" Then
Contact = "Contact: " & c.Offset(0, 1).Value & vbNewLine
Else
Contact = ""
End If
If c.Offset(0, 2).Value <> "" Then
Email = "Email: " & c.Offset(0, 2).Value & vbNewLine
Else
Email = ""
End If
If c.Offset(0, 3).Value <> "" Then
Phone = "Phone: " & c.Offset(0, 3).Value & vbNewLine
Else
Phone = ""
End If
If c.Offset(0, 4).Value <> "" Then
Fax = "Fax: " & c.Offset(0, 4).Value
Else
Fax = "Fax: No Fax Held"
End If
'Show Contacts
ThisWorkbook.Worksheets("Data").Range("I2").Value = "Hello," & vbNewLine & vbNewLine & "Have you tried to contact " & ActiveCell.Offset(0, -1).Value & " about your issue?" & vbNewLine & vbNewLine _
& Contact & Email & Phone & Fax
'ThisWorkbook.Worksheets(1).Shapes("Suggest").TextFrame.AutoSize = True
CenterShape ThisWorkbook.Worksheets(1).Shapes("Suggest")
RightShape ThisWorkbook.Worksheets(1).Shapes("Close")
ThisWorkbook.Worksheets(1).Shapes("Suggest").Visible = True
'Show Close Button
'ThisWorkbook.Worksheets(1).Shapes("Close").OnAction = "HideShape"
ThisWorkbook.Worksheets(1).Shapes("Close").Visible = True
'Protect sheet
'ActiveSheet.Protect Password:="SecretPassword", userinterfaceonly:=True
'ActiveSheet.Shapes("Suggest").Locked = True
End If
End With
End If ' End Main If
End If ' End Secondary If
Finalize:
Application.EnableEvents = True
Exit Sub
Message:
Application.DisplayAlerts = False
Exit Sub
End Sub
Public Sub CenterShape(o As Shape)
o.Left = ActiveWindow.VisibleRange(1).Left + (ActiveWindow.VisibleRange.Width/2.3 - o.Width/2.3)
o.Top = ActiveWindow.VisibleRange(1).Top + (ActiveWindow.VisibleRange.Height/2 - o.Height/2)
End Sub
Public Sub RightShape(o As Shape)
o.Left = ThisWorkbook.Worksheets(1).Shapes("Suggest").Left + (ThisWorkbook.Worksheets(1).Shapes("Suggest").Width/1.01 - o.Width/1.01)
o.Top = ThisWorkbook.Worksheets(1).Shapes("Suggest").Top + (ThisWorkbook.Worksheets(1).Shapes("Suggest").Height/30 - o.Height/30)
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Message
On Error Resume Next
ActiveSheet.DisplayPageBreaks = False
Application.ScreenUpdating = False
Application.DisplayAlerts = False
If Not Intersect(Target, Range("O:O")) Is Nothing And ActiveCell.Value <> "" Then
If Target.Cells.Count < 4 Then
'Set up the objects required for Automation into lotus notes
Dim Maildb As Object 'The mail database
Dim UserName As String 'The current users notes name
Dim MailDbName As String 'THe current users notes mail database name
Dim MailDoc As Object 'The mail document itself
Dim AttachME As Object 'The attachment richtextfile object
Dim session As Object 'The notes session
Dim EmbedObj As Object 'The embedded object (Attachment)
Dim Ref As String
Dim TrueRef As String
Ref = Range("G" & (ActiveCell.Row)).Value
If Ref = "WSM" Then
TrueRef = "WES"
Else
If Ref = "NAY" Then
TrueRef = "NAY"
Else
If Ref = "ENF" Then
TrueRef = "ENF"
Else
If Ref = "LUT" Then
TrueRef = "MAG"
Else
If Ref = "NFL" Then
TrueRef = "NOR"
Else
If Ref = "RUN" Then
TrueRef = "RUN"
Else
If Ref = "SOU" Then
TrueRef = "SOU"
Else
If Ref = "SOU" Then
TrueRef = "SOU"
Else
If Ref = "BRI" Then
TrueRef = "BRI"
Else
If Ref = "LIV" Then
TrueRef = "LIV"
Else
If Ref = "BEL" Then
TrueRef = "BEL"
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
Dim FindString As String
Dim rng As Range
FindString = Ref
With Sheets("Data").Range("C2:C11")
Set rng = .Find(What:=FindString, _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not rng Is Nothing Then
'Start a session to notes
Set session = CreateObject("Notes.NotesSession")
'Next line only works with 5.x and above. Replace password with your password
'Session.Initialize ("password")
'Get the sessions username and then calculate the mail file name
'You may or may not need this as for MailDBname with some systems you
'can pass an empty string or using above password you can use other mailboxes.
UserName = session.UserName
MailDbName = Left$(UserName, 1) & Right$(UserName, (Len(UserName) - InStr(1, UserName, " "))) & ".nsf"
'Open the mail database in notes
Set Maildb = session.GETDATABASE("", MailDbName)
If Maildb.IsOpen = True Then
'Already open for mail
Else
Maildb.OPENMAIL
End If
'Set up the new mail document
Set MailDoc = Maildb.CREATEDOCUMENT
MailDoc.Principal = "Food Specials <mailto: [email protected]>"
MailDoc.ReplyTo = "[email protected]"
'MailDoc.DisplaySent = "[email protected]"
'MailDoc.iNetFrom = "[email protected]"
'MailDoc.iNetPrincipal = "[email protected]"
MailDoc.Form = "Memo"
MailDoc.sendto = "Supplychain-" & TrueRef & "@lidl.co.uk"
MailDoc.subject = "L.O. Delivery Tracker: The status of your Issue has been updated."
MailDoc.body = "Hello," & vbNewLine & vbNewLine & vbNewLine & "Ref: " & Range("A" & ActiveCell.Row).Value & " - " & Range("E" & ActiveCell.Row).Value & vbNewLine & vbNewLine & vbNewLine & "The status of your issue has changed. Please access the Delivery Tracker for more information." & vbNewLine & vbNewLine & vbNewLine & "Supplier: " & vbNewLine & Range("E" & ActiveCell.Row).Value & vbNewLine & vbNewLine & "Issue: " & vbNewLine & Range("H" & ActiveCell.Row).Value & vbNewLine & vbNewLine & "H/O Comments: " & vbNewLine & Range("L" & ActiveCell.Row).Value & vbNewLine & vbNewLine & "Status: " & vbNewLine & Range("O" & ActiveCell.Row).Value & vbNewLine & vbNewLine & vbNewLine & "This information was correct at the time of sending. If you have any questions or concerns, please contact head office food specials." & vbNewLine & vbNewLine & "Thank you and Kind regards/ Dankeschön und Mit freundlichen Grüßen," & vbNewLine & vbNewLine & "Food Specials Team" _
& vbNewLine & " " & vbNewLine
'Send the document
MailDoc.PostedDate = Now() 'Gets the mail to appear in the sent items folder
MailDoc.SEND 0, Recipient
'Clean Up
Set Maildb = Nothing
Set MailDoc = Nothing
Set AttachME = Nothing
Set session = Nothing
Set EmbedObj = Nothing
End If
End With
End If
End If
'Prompt missed on sale
If Not Intersect(Target, Range("O:O")) Is Nothing And ActiveCell.Value = "Issue Complete" Then
If Target.Cells.Count < 4 Then
MSG1 = MsgBox("Did Item Miss On-Sale?", vbYesNo, "Feedback")
If MSG1 = vbYes Then
Range("P" & ActiveCell.Row).Value = "Yes"
Else
Range("P" & ActiveCell.Row).Value = "No"
End If
Range("Q" & ActiveCell.Row).Value = Date - Range("A" & ActiveCell.Row).Value
End If
End If
Application.ScreenUpdating = True
Application.DisplayAlerts = True
If ActiveWorkbook.MultiUserEditing Then
'Auto Save workbook
If Not Intersect(Target, Me.Range("E4")) Is Nothing Then
Application.DisplayAlerts = False
ThisWorkbook.Save
End If
End If
On Error GoTo Message
If e.KeyCode = Keys.Delete Then
'Create log file
Dim FF
FF = FreeFile()
SetAttr "G:\WH DISPO\(3) PROMOTIONS\(18) L.O. Delivery Tracking\Reports\LogFile.txt", vbNormal
Open "G:\WH DISPO\(3) PROMOTIONS\(18) L.O. Delivery Tracking\Reports\LogFile.txt" For Append As #FF
Print #FF, Now() & " - " & Application.UserName & " deleted a line from the Delivery Tracker."
Close #FF
SetAttr "G:\WH DISPO\(3) PROMOTIONS\(18) L.O. Delivery Tracking\Reports\LogFile.txt", vbReadOnly
End If
If Not Intersect(Target, Target.Worksheet.Range("G:G")) Is Nothing Then
If Target.Cells.Count < 5 Then
FF = FreeFile()
SetAttr "G:\WH DISPO\(3) PROMOTIONS\(18) L.O. Delivery Tracking\Reports\LogFile.txt", vbNormal
Open "G:\WH DISPO\(3) PROMOTIONS\(18) L.O. Delivery Tracking\Reports\LogFile.txt" For Append As #FF
Print #FF, Now() & " - " & Application.UserName & " added a new issue to the Delivery Tracker."
Close #FF
SetAttr "G:\WH DISPO\(3) PROMOTIONS\(18) L.O. Delivery Tracking\Reports\LogFile.txt", vbReadOnly
End If
End If
On Error GoTo Message
Static lngRow As Long
Dim rng1 As Range
Set rng1 = ThisWorkbook.Names("RowMarker").RefersToRange
If lngRow = 0 Then
lngRow = rng1.Row
Exit Sub
End If
If rng1.Row = lngRow Then Exit Sub
If rng1.Row < lngRow Then
FF = FreeFile()
SetAttr "G:\WH DISPO\(3) PROMOTIONS\(18) L.O. Delivery Tracking\Reports\LogFile.txt", vbNormal
Open "G:\WH DISPO\(3) PROMOTIONS\(18) L.O. Delivery Tracking\Reports\LogFile.txt" For Append As #FF
Print #FF, Now() & " - " & Application.UserName & " deleted a line from the Delivery Tracker."
Close #FF
SetAttr "G:\WH DISPO\(3) PROMOTIONS\(18) L.O. Delivery Tracking\Reports\LogFile.txt", vbReadOnly
Else
FF = FreeFile()
SetAttr "G:\WH DISPO\(3) PROMOTIONS\(18) L.O. Delivery Tracking\Reports\LogFile.txt", vbNormal
Open "G:\WH DISPO\(3) PROMOTIONS\(18) L.O. Delivery Tracking\Reports\LogFile.txt" For Append As #FF
Print #FF, Now() & " - " & Application.UserName & " added a line to the Delivery Tracker."
Close #FF
SetAttr "G:\WH DISPO\(3) PROMOTIONS\(18) L.O. Delivery Tracking\Reports\LogFile.txt", vbReadOnly
End If
lngRow = rng1.Row
Exit Sub
Message:
Application.DisplayAlerts = False
Exit Sub
End Sub
该代码永远不会在共享工作簿工作，其局限性所致。对于初学者来说，你不能改变共享工作簿中的保护，也不能编辑形状。 – Rory
@Rory请看下面的答案。管理得到的代码工作:) – user7415328
是的，但它不是*代码*任何更多。 :)无论如何，你将有更大的问题与共享工作簿... – Rory