< návrat zpět
MS Excel
Téma: Odeslání obrázku v mailu v JPG formátu -VYŘEŠENO 
Zaslal/a Fantasyk 10.3.2021 23:36
Zdravím,
chtěl bych se zeptat mám kód, který funguje perfektně, ale při zobrazení na telefonu to při přiblížení převrátí bílou za černou viz. obr( mám dojem, že to dělá .png formát ) nevíte jak by to šlo dát do .jpg nebo poradit, aby to neudělalo ?
Děkuji moc za jakoukoliv radu
Sub mailAscreen()
Dim answer As Integer, RNG As Range, PIC As Picture, OUT As Object, OUTMAIL As Object, WRDDOC As Object, adresat As String, vec As String, shift1 As String, shift2 As String, shift3 As String, shiftall As String
answer = MsgBox("Opravdu chceš odeslat report smeny?", vbQuestion + vbYesNo + vbDefaultButton2, "Odeslání Reportu smeny")
If answer = vbYes Then
shift1 = Range("F12").Value2
shift1 = Format(shift1, "0.00%")
shift2 = Range("K12").Value
shift2 = Format(shift2, "0.00%")
shiftall = Range("X3").Value
shiftall = Format(shiftall, "0.00%")
Active = ActiveSheet.Name
With Worksheets(Active)
adresat = "email@email.com"
vec = "Report smeny - (" & .Range("U2").Value & ") -" & .Range("R2").Value & " Denní: " & shift1 & " / Nocní " & shift2 & " / Total: " & shiftall
Set RNG = Range("A1:X150")
RNG.Copy
Set PIC = ActiveSheet.Pictures.Paste
PIC.Cut
Set OUT = CreateObject("Outlook.Application")
Set OUTMAIL = OUT.CreateItem(olMailItem)
With OUTMAIL
.To = adresat
.CC = "email@email2.com"
.Subject = vec
End With
OUTMAIL.Display
Set WRDDOC = OUTMAIL.GetInspector.WordEditor
WRDDOC.Range.Application.Selection.Paste
'MsgBox "Email odeslán!", vbCritical
End With
Else
End If
Beep
End Sub
Příloha: 
50066_screen.png (428kB, staženo 16x)
Je to možné, že Galéria v mobile nezobrazí korektne "priesvitnú" farbu PNG (možno bezfarbé bunky {ColorIndex=xlNone} uloží ako priesvitné???).
Skúste použiť fintu Graf-->JPG. Teda sa dočasne vytvorí list s prázdnym grafom, do ktorého sa vloží skopírovaná oblasť ako obrázok, a graf už umožňuje uložiť ako JPG. dočasný list s grafom sa zmaže. Už to tu bolo určo riešené, len sa mi to nechce hľadať. Mrk na
mrexcel.
Nepamätám si ako to bolo s kvalitou.
Vložíte prílohu JPG a súbor zmažete napr. pomocou Kill.
citovatFantasyk(11.3.2021 2:57)#050068 Tak vyřešeno s trouchou html
dík elninoslov za insipraci
Sub mailAscreen()
Dim OutApp As Object 'Outlook.Application
Dim OutMail As Object 'Outlook.MailItem
Dim OutAttachment As Object 'Outlook.Attachment
Dim OutPropertyAcc As Object 'Outlook.PropertyAccessor
Dim CC As String
Dim ExcelCells As Range
Dim HTML As String
Dim CellsImage As String, tempCellsFile As String
Dim answer As Integer
Dim adresat As String, vec As String, shift1 As String, shift2 As String, shift3 As String, shiftall As String
answer = MsgBox("Opravdu chceš odeslat report smeny?", vbQuestion + vbYesNo + vbDefaultButton2, "Odeslání Reportu smeny")
If answer = vbYes Then
shift1 = Range("F12").Value2
shift1 = Format(shift1, "0.00%")
shift2 = Range("K12").Value
shift2 = Format(shift2, "0.00%")
'shift3 = Range("N12").Value 'PRO 3 SMENY
'shift3 = Format(shift3, "0.00%") 'PRO 3 SMENY
shiftall = Range("X3").Value
shiftall = Format(shiftall, "0.00%")
vec = "Report smeny - (" & Range("U2").Value & ") -" & Range("R2").Value & " Denní: " & shift1 & " / Nocní " & shift2 & " / Total: " & shiftall
Const PR_ATTACH_CONTENT_ID = "http://schemas.microsoft.com/mapi/proptag/0x3712001F"
Active = ActiveSheet.Name
Set ExcelCells = ThisWorkbook.Worksheets(Active).Range("A1:X150") 'range includes cells and charts
adresat = "email@email.cz"
CC = "email@email.com"
CellsImage = Replace(Timer, ".", "") & "image.jpg"
tempCellsFile = Environ("temp") & "\" & CellsImage
Save_Object_As_Picture ExcelCells, tempCellsFile
'Construct email body as HTML string, with the range image in an img tag with corresponding src='cid:xxxx.jpg' attribute
HTML = "<html>"
HTML = HTML & "<img src='cid:" & CellsImage & "'>"
HTML = HTML & "</html>"
Set OutApp = CreateObject("Outlook.Application") 'New Outlook.Application
Set OutMail = OutApp.CreateItem(0) 'olMailItem
'Create the email
With OutMail
.To = adresat
.CC = CC
.Subject = vec
'Attach the file referenced in the img tag
Set OutAttachment = .Attachments.Add(tempCellsFile)
Set OutPropertyAcc = OutAttachment.PropertyAccessor
OutPropertyAcc.SetProperty PR_ATTACH_CONTENT_ID, CellsImage
.HTMLBody = HTML
.Display
End With
'Delete the temporary image file
Kill tempCellsFile
Set OutMail = Nothing
Set OutApp = Nothing
End If
End Sub
Private Sub Save_Object_As_Picture(saveObject As Object, imageFileName As String)
'Save a picture of an object as a JPG/JPEG file
'Arguments
'saveObject - any object in the CopyPicture method's 'Applies To' list, for example a Range or Shape
'imageFileName - the .jpg or .jpeg file name (including folder path if required) the picture will be saved as
Dim temporaryChart As ChartObject
Application.ScreenUpdating = False
saveObject.CopyPicture xlScreen, xlPicture
Set temporaryChart = ActiveSheet.ChartObjects.Add(0, 0, saveObject.Width, saveObject.Height)
With temporaryChart
.Activate
.Border.LineStyle = xlLineStyleNone 'No border
.Chart.Paste
.Chart.Export imageFileName
.Delete
End With
Application.ScreenUpdating = True
Set temporaryChart = Nothing
End Subcitovat
\n
RSS nejnovější články