تعديل كود

[Othmaaan]

السلام عليكم ورحمة الله وبركاته

أعضاء منتدى أوفيسنا الكرام

من لديه الخبرة لتعديل الكود التالي فليتفضل مشكوراً

المطلوب / تغير وظيفة الكود بحيث أنه يرفق ملف بصيغة pdf ويرسلة عن طريق الايميل بدل صفحة html التي هو عليها الأن ؟؟؟

تقبلوا خالص تحياتي

Option Explicit

Function Send_Mail(mailto As String)

Dim iMsg As Object

Dim iConf As Object

Dim strbody As String

Dim Flds As Variant

Set iMsg = CreateObject("CDO.Message")

Set iConf = CreateObject("CDO.Configuration")

iConf.Load -1

Set Flds = iConf.Fields

With Flds

.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True

.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1

.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "email@gmail.com"

.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "****"

.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.gmail.com"

.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2

.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25

.Update

End With

With iMsg

Set .Configuration = iConf

.To = mailto

.From = """Othman"" "

.Subject = "Medical Supply"

.CreateMHTMLBody ThisWorkbook.Path & "\test.html"

.Send

End With

End Function

Sub mas()

On Error Resume Next

Dim n As Integer

For n = 2 To 31

If Range("b" & n & "").Value = "" And Date - Range("a" & n & "").Value > 14 Then

If Range("c" & n & "").Value <> "" Then

Kill ThisWorkbook.Path & "\test.html"

generatehtml (n)

Send_Mail (Range("c" & n & "").Value)

Range("d" & n & "").Value = "Êã ÇáÅÑÓÇá"

End If

End If

Next n

MsgBox "Êã ÅÑÓÇá ÌãíÚ ÇáÑÓÇÆá"

End Sub


Function generatehtml(rw As Integer)

Dim fs As Object

Dim A As Object

Dim FileName As String

FileName = ThisWorkbook.Path & "\test.html"

Set fs = CreateObject("Scripting.FileSystemObject")

Set A = fs.CreateTextFile(FileName, True)

A.WriteLine ("

[size=6]

[right]ÚÒíÒí : [color=red]" & Range("F" & rw & "").Value & "[/color]
äÝíÏ ÓíÇÏÊßã ÚáãÇ ÈÃä :
ÇáãÚÇãáÉ ÑÞã : " & Range("E" & rw & "").Value & " æÇáãÄÑÎÉ ÈÊÇÑíÎ : " & Format(Range("a" & rw & "").Value, "yyyy/mm/dd dddd") & " ãÊÃÎÑÉ æÊÓÊæÌÈ ÇáÑÏ
åÐÇ ááÚáã æÇÊÎÇÐ ÇááÇÒã
ãÚ ÊÍíÇÊ :
[color=green]ÇÓã ÔÑßÊß[/color][/size][/right]

")
A.Close
End Function

تم تعديل سبتمبر 25, 2012 بواسطه Othmaaan

[عبدالله المجرب]

ارفق ملف به الكود حتى يتم العمل عليه

[Othmaaan]

أشكركـ أستاذ عبدالله على تفاعلك وجعلها المولى في ميزان حسناتكـ

بالنسبة للملف حاولت أرفقه منذ البداية ولكن المتصفح يرفض إرفاق الملف ولكن كما هو واضح في الصورة المرفقة يوجد الزر باللون الأزرق Send By Email عند الضغط عليه يرسل اتوماتيكياً الى الإيميلين الموجودين مقابل الزر الأزرق ويكتب رسالة تم الإرسال ...

وهذا الرابط يوجد ملف شبية بملف الذي اريده ولكن ارفاق ملف pdf للاستاذ محمد صالح

http://www.officena.net/ib/index.php?showtopic=29748

أمل وأتمنى أن الفكرة وصلت ولك تحياتي ’’’’’

تم تعديل سبتمبر 26, 2012 بواسطه Othmaaan

[عبدالله المجرب]

اضغط الملف قبل ارفاقه

[Othmaaan]

تم رفع الملف على الرابط التالي

http://www.4shared.com/office/kXyu3CBW/___online.html

[Othmaaan]

تـــــــــــــــم حـــــــل الـــمـــشــكـــلــة والـــــــحــمـــدلله

:jump: :jump: