Új hozzászólás Aktív témák

• #45187 Pakliman tag Norbika1493 #45186

  Új Válasz 2020-10-30 07:51:37 #45187

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  Pakliman

  tag

  válasz Norbika1493 #45186 üzenetére

  Egy pl...
  Ez egy meglévő táblázatban halad végig és bizonyos cellák értéke alapján színez bizonyos számokat is.
  Készít egy táblázatot az így létrejótt listából és elküldi a megadott címzetteknek:

  Public Enum OlBodyFormat
olFormatUnspecified = 0
olFormatPlain = 1
olFormatHTML = 2
olFormatRichText = 3
End Enum

Private Function TableDataColor(strIn As String, Optional color As String = "") As String
If color = "" Then
TableDataColor = strIn
Else
TableDataColor = "<FONT COLOR=" & color & ">" & strIn & "</FONT>"
End If
End Function

Private Function Table(strIn As String, Optional lBorder As Long = 0) As String
Dim sBorder As String

If lBorder = 0 Then
sBorder = ""
Else
sBorder = " border=" & lBorder
End If

Table = "<TABLE" & sBorder & ">" & strIn & "</TABLE>"
End Function

Private Function TableData(strIn As String, Optional alignment As String = "") As String
TableData = "<TD nowrap align=" & alignment & ">" & strIn & "</TD>"
End Function

Private Function TableRow(strIn As String) As String
TableRow = "<TR>" & strIn & "</TR>"
End Function

Public Sub Email_Humányügyre()
Dim sSzöveg1 As String: sSzöveg1 = "Kedves Lányok!" & "<br /><br />"
Dim sSzöveg2 As String: sSzöveg2 = "Szíves hasznosításra..." & "<br /><br />" & _
"Üdv," & "<br /><br />"

Dim OutApp As Object
Dim OutMail As Object

Dim strFej As String
Dim strTB As String

Dim sDátum As String: sDátum = Format(Format(Range("Z1"), "0000"".""00"".""00"), "yyyy. mmmm")
Dim sTárgy As String: sTárgy = "Külsősök teljesítései " & sDátum
Dim lAktSor As Long
Dim lÚjSor As Long
Dim szín As String

strFej = TableRow( _
TableData("HR") & _
TableData("Név") & _
TableData("Összes óra") _
)

For lAktSor = 3 To Cells.Rows.Count 'Az utolsó sort célszerű először meghatározni...
If IsEmpty(Cells(lAktSor, 1)) Then Exit For
If Cells(lAktSor, 15) = "Külsős" Then
Select Case Cells(lAktSor, 11)
Case 60 To 79.9
szín = "blue"

Case Is > 80
szín = "red"

Case Else
szín = ""
End Select
strTB = strTB & _
TableRow( _
TableData(Cells(lAktSor, 1)) & _
TableData(Cells(lAktSor, 2)) & _
TableData( _
TableDataColor( _
Format(Cells(lAktSor, 11), "0.0"), _
szín _
), _
"right" _
) _
)
End If
Next lAktSor

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

On Error Resume Next
With OutMail
.To = "Humánügyek"
.CC = "hum1@hum.hu; hum2@hum.hu"
.BCC = ""
.Subject = sTárgy
.BodyFormat = 2 'olFormatHTML
.HTMLBody = sSzöveg1 & _
Table( _
"<Caption>Külsős órák</Caption>" & _
strFej & _
strTB _
, 1) & "<br /><br />" & _
sSzöveg2

.Display ' vagy elküldéshez .Send
End With
On Error GoTo 0

Set OutMail = Nothing
Set OutApp = Nothing
End Sub

Új hozzászólás Aktív témák