hjælp til VBA
hejjeg har et spørgsmål til nedenstående kode; nemlig hvor jeg ikke i subjektfeltet kan få den til at trække et subject ind fra et eller andet tilfældigt felt. Nedenstående sender bare et tomt felt i mailen.
(Koden gør simpelt sagt det, at den kopiere et faneblab over i et tomt excel ark, og sætter den ind i en email, klar til afsending)
Håber I kan hjælpe...
-----------------------------------
Sub Mail_ActiveSheet1()
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim OutApp As Object
Dim OutMail As Object
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set Sourcewb = ActiveWorkbook
Sheets("Kreditark").Select
ActiveSheet.Copy
Set Destwb = ActiveWorkbook
With Destwb
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
If Sourcewb.Name = .Name Then
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
msgbox "Your answer is NO in the security dialog"
Exit Sub
Else
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If .HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56: FileExtStr = ".xls": FileFormatNum = 56
Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
End If
End With
TempFilePath = Environ$("temp") & "\"
TempFileName = "Kopi af " & Sourcewb.Name & " " & Format(Now, "dd-mmm-yy")
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With Destwb
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
.To = "xx@xx.dk"
.CC = ""
.BCC = ""
.Subject = Sheets("mail").Range("l4").Value
.Body = "Hej - Vil du kigge på denne forespørgsel og give din godkendelse?"
.Attachments.Add Destwb.FullName
.Display 'or use .Send
End With
On Error GoTo 0
.Close savechanges:=False
End With
Kill TempFilePath & TempFileName & FileExtStr
Set OutMail = Nothing
Set OutApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub