Znalazłem kod, który pozwala mi wysyłać terminy w e-mailu. Próbuję to zmienić, aby połączyć plik Excela z this. Zmienia kolor na niebieski; jednak nie mogę go kliknąć, aby otworzyć. Czy ktoś wie jak mogę to naprawić. Proszę pomóż. Bardzo dziękuję! Pogrubioną czcionką zaznaczyłem fragment, który sam dodałem.
Oto kod:
Publiczna subskrypcja CheckAndSendMail()
'Aktualizowany przez Extendoffice 2018/11/22
Dim xRgDate jako zakres
Dim xRgWyślij jako zakres
Dim xRgText jako zakres
Dim xRgDone jako zakres
Dim xOutApp jako obiekt
Dim xMailItem jako obiekt
Dim xLastRow tak długo
Dim vbCrLf jako ciąg
Dim xMailBody jako ciąg
Dim xRgDateVal jako ciąg
Dim xRgSendVal jako ciąg
Dim xMailSubject jako ciąg
Przyciemnij i tak długo
On Error Resume Next
Ustaw xRgDate = Application.InputBox("Proszę wybrać kolumnę terminu płatności:", "KuTools For Excel", , , , , , 8)
Jeśli xRgDate to nic, wyjdź z Sub
Ustaw xRgSend = Application.InputBox("Proszę wybrać kolumnę odbiorców?e-mail:", "KuTools For Excel", , , , , , 8)
Jeśli xRgSend to nic, to wyjdź z Sub
Set xRgText = Application.InputBox("Wybierz kolumnę z przypomnianą zawartością w wiadomości e-mail:", "KuTools For Excel", , , , , , 8)
Jeśli xRgText to nic, to wyjdź z Sub
xLastRow = xRgDate.Rows.Count
Ustaw xRgDate = xRgDate(1)
Ustaw xRgSend = xRgSend(1)
Ustaw xRgText = xRgText(1)
Ustaw xOutApp = CreateObject("Outlook.Application")
Dla i = 1 To xLastRow
xRgDateVal = ""
xRgDateVal = xRgDate.Offset(i - 1)).Wartość
Jeśli xRgDateVal <> "" Wtedy
Jeśli CDate(xRgDateVal) - Data <= 7 I CDate(xRgDateVal) - Data > 0 Wtedy
xRgSendVal = xRgSend.Offset(i - 1)).Wartość
xMailSubject = xRgText.Offset(i - 1)).Value & " on " & xRgDateVal
vbCrLf = " "
xMailBody = " "
xMailBody = xMailBody & "Witaj, masz dodane nowe elementy" & vbCrLf
xMailBody = xMailBody & "Tekst : " & xRgText.Offset(i - 1).Value & vbCrLf
xMailBody = xMailBody & " L:\Public\23-Plant PDCA\2023\KACI Master 5S PDCA trail2.xlsm" & fpath & " "
xMailBody = xMailBody & " "
Ustaw xMailItem = xOutApp.CreateItem(0)
Z xMailItem
.Temat = xMailTemat
.To = xRgSendVal
.HTMLBody = xMailBody
.Pokaz
'.Wysłać
Kończyć z
Ustaw xMailItem = Nic
End If
End If
Następna
Ustaw xOutApp = Nic
End Sub
Oto kod:
Publiczna subskrypcja CheckAndSendMail()
'Aktualizowany przez Extendoffice 2018/11/22
Dim xRgDate jako zakres
Dim xRgWyślij jako zakres
Dim xRgText jako zakres
Dim xRgDone jako zakres
Dim xOutApp jako obiekt
Dim xMailItem jako obiekt
Dim xLastRow tak długo
Dim vbCrLf jako ciąg
Dim xMailBody jako ciąg
Dim xRgDateVal jako ciąg
Dim xRgSendVal jako ciąg
Dim xMailSubject jako ciąg
Przyciemnij i tak długo
On Error Resume Next
Ustaw xRgDate = Application.InputBox("Proszę wybrać kolumnę terminu płatności:", "KuTools For Excel", , , , , , 8)
Jeśli xRgDate to nic, wyjdź z Sub
Ustaw xRgSend = Application.InputBox("Proszę wybrać kolumnę odbiorców?e-mail:", "KuTools For Excel", , , , , , 8)
Jeśli xRgSend to nic, to wyjdź z Sub
Set xRgText = Application.InputBox("Wybierz kolumnę z przypomnianą zawartością w wiadomości e-mail:", "KuTools For Excel", , , , , , 8)
Jeśli xRgText to nic, to wyjdź z Sub
xLastRow = xRgDate.Rows.Count
Ustaw xRgDate = xRgDate(1)
Ustaw xRgSend = xRgSend(1)
Ustaw xRgText = xRgText(1)
Ustaw xOutApp = CreateObject("Outlook.Application")
Dla i = 1 To xLastRow
xRgDateVal = ""
xRgDateVal = xRgDate.Offset(i - 1)).Wartość
Jeśli xRgDateVal <> "" Wtedy
Jeśli CDate(xRgDateVal) - Data <= 7 I CDate(xRgDateVal) - Data > 0 Wtedy
xRgSendVal = xRgSend.Offset(i - 1)).Wartość
xMailSubject = xRgText.Offset(i - 1)).Value & " on " & xRgDateVal
vbCrLf = " "
xMailBody = " "
xMailBody = xMailBody & "Witaj, masz dodane nowe elementy" & vbCrLf
xMailBody = xMailBody & "Tekst : " & xRgText.Offset(i - 1).Value & vbCrLf
xMailBody = xMailBody & " L:\Public\23-Plant PDCA\2023\KACI Master 5S PDCA trail2.xlsm" & fpath & " "
xMailBody = xMailBody & " "
Ustaw xMailItem = xOutApp.CreateItem(0)
Z xMailItem
.Temat = xMailTemat
.To = xRgSendVal
.HTMLBody = xMailBody
.Pokaz
'.Wysłać
Kończyć z
Ustaw xMailItem = Nic
End If
End If
Następna
Ustaw xOutApp = Nic
End Sub