Příspěvky uživatele
< návrat zpět
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 Sub
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
Lugr napsal/a:
Zkuste:
Soubor -> Možnosti -> Upřesnit -> Možnosti úprav->[✓] Povolit operace přetažení úchytem a přetažení buňky
Děkuji mockrát
jsem hned napsal dík, ale nějak jsem to asi neodeslal
Já to mám taky problém mezi mnou a klávesnicí a nemůžu na to přijít.. celou dobu to fungovalo a nejde to roztáhnout..
Omlouvám se za delší kód 
Hola Hekři ,
Chci se zeptat mám kód:
,ale když už je SAP spuštěn tak mi to hodí error. Chtěl bych, když je spuštěn, tak ať to pokračuje dál kódem
Dim Appl As Object
Dim Connection As Object
Dim session As Object
Dim WshShell As Object
Dim SapGui As Object
LS24_text = Range("B2").text
Login = Range("H1").text
Passwd = Range("H2").text
'Of course change for your file directory
Shell "C:\Program Files\SAP\FrontEnd\SAPgui\saplogon.exe", 1
Set WshShell = CreateObject("WScript.Shell")
Do Until WshShell.AppActivate("SAP Logon ")
Application.Wait Now + TimeValue("0:00:01")
Loop
Set WshShell = Nothing
Set SapGui = GetObject("SAPGUI")
Set Appl = SapGui.GetScriptingEngine
Set Connection = Appl.OpenConnection("01 - PRD WINTEL")
Set session = Connection.Children(0)
'session.ActiveWindow.Iconify
'if You need to pass username and password
session.findById("wnd[0]/usr/txtRSYST-MANDT").text = "300"
session.findById("wnd[0]/usr/txtRSYST-BNAME").text = Login
session.findById("wnd[0]/usr/pwdRSYST-BCODE").text = Passwd
session.findById("wnd[0]/usr/txtRSYST-LANGU").text = "CS"
If session.Children.Count > 1 Then
answer = MsgBox("You've got opened SAP already," & _
"please leave and try again", vbOKOnly, "Opened SAP")
session.findById("wnd[1]/usr/radMULTI_LOGON_OPT3").Select
session.findById("wnd[1]/tbar[0]/btn[0]").press
Exit Sub
session.findById("wnd[0]").maximize
session.findById("wnd[0]").sendVKey 0 'ENTER
session.findById("wnd[0]/tbar[0]/okcd").text = "LS24"
session.findById("wnd[0]").sendVKey 0
End If
Děkuji mnohokrát
Po mnoha letech...
A když se jedná o UF ? nevíte někdo ?
Díky
Konkrétnější příklad by nebyl?
elninoslov napsal/a:
Nepíšete, čo sa má s tým diať. Uložiť do listu? Na disk? Do mailu? Ak si dáte do Googlu výraz "vba form screenshot" nájdete väčšinou API, no tento kratučký stačí na screenshot do listu:
Private Sub CommandButton1_Click()
Application.SendKeys "(%{1068})"
DoEvents
Sheets.Add After:=ActiveSheet
ActiveSheet.Paste
End Sub
Díky stačilo mi nakonec jen
Application.SendKeys "(%{1068})"
Zadaval jsem snad vsechno do googlu ale screenshot me nenapadl dekuji mrknu na to vecer v práci..
Zdravím,
jen se chci zeptat jestli jde přes button vyfotografovat aktivní form. Nevíte někdo jestli to jde udělat ?
např.
Díky za jakýkoliv nápad či návrh.
Tak nakonec jsem si to vyřešil sám -> v cestě nesmí být mezera a diakritika u jedné složky to tak bylo proto to nejelo...
Jak mám napsané asi o 5 článků níže...
Private Sub UserForm_Initialize()
Dim Dateiname As String, Graf As Chart
Set Graf = Sheets("Vyhledat").ChartObjects("Graf 7").Chart
Dateiname = ThisWorkbook.Path & "\graf.gif"
Graf.Export Filename:=Dateiname, FilterName:="GIF"
'Image1.Picture = LoadPicture(Dateiname)
Sheets("Lisy - Vedouci smen").Select
'Add Dynamic Image and assign it to object 'Img'
Set Img = UserForm2.Controls.Add("Forms.Image.1")
With Img
'Load Picture to Image Control
.Picture = LoadPicture(Dateiname)
'Align the Picture Size
'.PictureSizeMode = fmPictureSizeModeStretch
.Width = 717
.Height = 460
'Image Position
.Left = 20
.Top = 100
End With
End Sub
Pošli přílohu
Uživatelské menu
\nMenu
On-line nástroje
Formulář Faktura
Formulář Faktura IV
Oblíbený formulář Faktura byl vylepšen a rozšířen.
Více se dočtete zde.
RSS nejnovější články