نجوم المشاركات

وعليكم السلام ورحمة الله وبركاته ،، باعتقادي ما ينطبق على اكسيس يمكن ان ينطبق على اكسل . فأولاً يلزمك تثبيت مكتبة SDK منموقع الشركة ZKTeco من هذه الصفحة هنا ( يلزمك تسجيل الدخول طبعاً للتحميل من الموقع الرسمي ) . حيث انها تحتوي على مكتبة الوظائف التي تسمح بالاتصال المباشر بالجهاز . بعد تحميل البرنامج من الموقع الرسمي ، قم بتسجيل المكتبة zkemkeeper.dll كما يلي :- افتح موجه الأوامر CMD كمسؤول ، ثم استخدم السطر التالي مع تعديل مسار الملف السابق حسب مسار التثبيت لديك :- regsvr32 "C:\المسار\zkemkeeper.dll" ثم قم بإضافة المكتبة بحيث أن تفعّل خيار: zkemkeeper.dll أو ZKEMkeeper 1.0 Type Library الآن كود VBA بسيط للاتصال بالجهاز :- Dim zk As New zkemkeeper.CZKEM Sub ConnectToDevice() Dim connected As Boolean connected = zk.Connect_Net("192.168.1.201", 4370) If connected Then MsgBox "تم الاتصال بالجهاز بنجاح" Else MsgBox "فشل الاتصال بالجهاز" End If End Sub تأكد من عنوان IP الخاص بالجهاز طبعاً . وهذه دالة لجلب سجلات الحضور :- Option Explicit Dim zk As New zkemkeeper.CZKEM Sub GetAttendanceLogs() Dim ip As String: ip = "192.168.1.201" ' لجهاز البصمة لديك IP غيّر هذا العنوان إلى عنوان Dim port As Long: port = 4370 ' المنفذ الافتراضي عادةً Dim iMachineNumber As Long: iMachineNumber = 1 Dim connected As Boolean connected = zk.Connect_Net(ip, port) If Not connected Then MsgBox "فشل الاتصال بالجهاز. تحقق من الشبكة أو الإعدادات", vbCritical Exit Sub End If zk.EnableDevice iMachineNumber, False If Not zk.ReadGeneralLogData(iMachineNumber) Then MsgBox "لا توجد سجلات متاحة ، أو تعذر قراءتها", vbExclamation zk.EnableDevice iMachineNumber, True zk.Disconnect Exit Sub End If Dim ws As Worksheet Set ws = ThisWorkbook.Sheets("Sheet1") ws.Cells.ClearContents ws.Range("A1:E1").Value = Array("UserID", "DateTime", "State", "Verified", "WorkCode") Dim userID As Long, verifyMode As Long, inOutMode As Long Dim year As Long, month As Long, day As Long Dim hour As Long, minute As Long, second As Long Dim workCode As Long Dim row As Long: row = 2 Do While zk.SSR_GetGeneralLogData(iMachineNumber, CStr(userID), _ verifyMode, inOutMode, year, month, day, hour, minute, second, workCode) Dim dt As String dt = Format(DateSerial(year, month, day) + TimeSerial(hour, minute, second), "yyyy-mm-dd hh:nn:ss") ws.Cells(row, 1).Value = userID ws.Cells(row, 2).Value = dt ws.Cells(row, 3).Value = inOutMode ws.Cells(row, 4).Value = verifyMode ws.Cells(row, 5).Value = workCode row = row + 1 Loop zk.EnableDevice iMachineNumber, True zk.Disconnect MsgBox " تم سحب عدد " & row - 2 & " من سجلات الحضور بنجاح", vbInformation End Sub شرح الأعمدة :- UserID = رقم الموظف DateTime = تاريخ ووقت الحضور/الانصراف State = نوع الحركة (0 = دخول ، 1 = خروج) Verified = طريقة التحقق (بصمة ، كارت ، كلمة مرور) WorkCode = رمز العمل (اختياري ، حيث يعتمد على الجهاز) هذا من وجهة نظري بعد التعديل فيما يتوافق مع اكسل ( مشتق من أكواد آكسيس ) ولكم التجربة طبعاً لأنني حالياً لا أملك جهاز البصمة المذكور نوعه سابقاً ..

و عليكم السلام ورحمة الله و بركاته تفضل نقل البيانات من عمود لاخر(2).xlsx

ولا يهمك اخي الكريم ، خذ راحتك ، واليوم فعلاً انا خارج المنزل وبعيد عن الكمبيوتر الى صباح غد إن شاء الله 🤗😇

الكود الذي عملنا عليه سابقا يقوم بتحويل الأرقام إلى عربية أو إنجليزية لكن يتم ذلك عن طريق تغيير محتوى الخلية مباشرة وهذا يؤدي إلى فقدان أي صيغة كانت موجودة في الخلية للأسف الإكسيل لا يدعم تغيير عرض الأرقام من إنجليزية إلى عربية أو العكس داخل نفس الخلية بدون التأثير على محتواها بمعنى: لا يمكنك تحويل الأرقام داخل الخلية إلى العربية دون تعديل المحتوى نفسه مجرد اقتراح قد يكون مناسبا لتنفيذ طلبك مع الحفاظ على الصيغ: يمكن إظهار الأرقام العربية بصريا فقط وذلك عبر إضافة شكل شفاف (Textbox) فوق الخلية بهذا الأسلوب تبقى الصيغ تعمل كما هي والخلية الأصلية لا تتغير لاكن يمكنك محاكاة المظهر العربي للأرقام بصريا فقط دون التأثير على الصيغ أو البيانات كما في المثال التالي تحويل الورقة بالكامل الى لغة عربية دون تغير لغة الجهاز -v4.xlsb

وعليكم السلام ورحمة الله وبركاته ،، جرب أخي هذا التعديل !! Sub ترحيل_المعاش_ق() Dim wsSource As Worksheet, wsTarget As Worksheet, wsNew As Worksheet Dim sourceData As Variant, outputData() As Variant Dim i As Long, j As Long, lastRowSource As Long, lastRowTarget As Long Dim rowsToDelete As Range, delCount As Long Dim totalCols As Long: totalCols = 13 Dim t As Double: t = Timer Dim professions As Object, profession As Variant Dim colWidths() As Double Dim lastRowAfterInsert As Long ' تخزين أبعاد الأعمدة من ورقة معاشات Set wsTarget = ThisWorkbook.Sheets("معاشات") ReDim colWidths(1 To totalCols) For i = 1 To totalCols colWidths(i) = wsTarget.Columns(i).ColumnWidth Next i Set wsSource = ThisWorkbook.Sheets("DATA") With Application .ScreenUpdating = False .EnableEvents = False .Calculation = xlCalculationManual .StatusBar = "جاري معالجة البيانات..." End With ' تثبيت الخط في الخلية E3 With wsTarget.Range("E3") .Font.Name = "Arial" .Font.Bold = True End With lastRowSource = wsSource.Cells(wsSource.Rows.Count, "M").End(xlUp).Row If lastRowSource < 5 Then GoTo CleanUp sourceData = wsSource.Range("A5:M" & lastRowSource).Value ' إنشاء قاموس للمهن Set professions = CreateObject("Scripting.Dictionary") For i = 1 To UBound(sourceData, 1) If LCase(Trim(sourceData(i, 13))) = "معاش" Then profession = Trim(sourceData(i, 5)) If Not professions.Exists(profession) Then professions.Add profession, Nothing End If End If Next i ' معالجة كل مهنة For Each profession In professions.Keys ' إنشاء أو تحديد الورقة الخاصة بالمهنة On Error Resume Next Set wsNew = ThisWorkbook.Sheets(profession) On Error GoTo 0 If wsNew Is Nothing Then Set wsNew = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)) wsNew.Name = profession Else ' حذف البيانات القديمة مع الحفاظ على التنسيق wsNew.Cells.ClearContents End If ' نسخ الترويسة من ورقة معاشات wsTarget.Range("B3:J3").Copy wsNew.Range("B3").PasteSpecial Paste:=xlPasteAll Application.CutCopyMode = False ' نسخ البيانات الخاصة بالمهنة الحالية delCount = 0 ReDim outputData(1 To UBound(sourceData, 1), 1 To totalCols) For i = 1 To UBound(sourceData, 1) If LCase(Trim(sourceData(i, 13))) = "معاش" And Trim(sourceData(i, 5)) = profession Then delCount = delCount + 1 For j = 1 To totalCols If (j = 9 Or j = 12) And IsDate(sourceData(i, j)) Then outputData(delCount, j) = Format(sourceData(i, j), "yyyy/mm/dd") Else outputData(delCount, j) = sourceData(i, j) End If Next j End If Next i If delCount > 0 Then lastRowTarget = wsNew.Cells(wsNew.Rows.Count, "B").End(xlUp).Row If lastRowTarget < 5 Then lastRowTarget = 4 Set targetRange = wsNew.Range("A" & lastRowTarget + 1).Resize(delCount, totalCols) targetRange.Value = Application.Index(outputData, Evaluate("ROW(1:" & delCount & ")"), Evaluate("COLUMN(A:M)")) ' تطبيق التنسيق With targetRange .Borders.LineStyle = xlContinuous .Borders.Weight = xlMedium .Borders.ColorIndex = xlAutomatic .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter .ShrinkToFit = True With .Font .Name = "Arial" .FontStyle = "غامق" .Size = 12 End With End With With wsNew.Range("B5:B10000") .HorizontalAlignment = xlRight .VerticalAlignment = xlCenter End With ' ضبط ارتفاع الصفوف wsNew.Rows("5:" & (lastRowTarget + delCount)).RowHeight = 20.25 ' ضبط عرض الأعمدة For i = 1 To totalCols wsNew.Columns(i).ColumnWidth = colWidths(i) Next i ' تطبيق التنسيق الشرطي With wsNew.Range("A5:M" & (lastRowTarget + delCount)) .FormatConditions.Delete .FormatConditions.Add Type:=xlExpression, Formula1:="=$M5=""معاش""" With .FormatConditions(1) .Font.Bold = True .Font.Color = -16776961 .Interior.Color = 16764159 .StopIfTrue = False End With End With End If Set wsNew = Nothing Next profession ' حذف الصفوف من ورقة DATA Set rowsToDelete = Nothing For i = 1 To UBound(sourceData, 1) If LCase(Trim(sourceData(i, 13))) = "معاش" Then If rowsToDelete Is Nothing Then Set rowsToDelete = wsSource.Rows(i + 4) Else Set rowsToDelete = Union(rowsToDelete, wsSource.Rows(i + 4)) End If End If Next i If Not rowsToDelete Is Nothing Then rowsToDelete.Delete Shift:=xlUp End If ' تحديث ورقة معاشات With wsTarget lastRowAfterInsert = .Cells(.Rows.Count, "B").End(xlUp).Row If lastRowAfterInsert >= 5 Then With .Range("A4:M" & lastRowAfterInsert) .Sort Key1:=.Columns(12), Order1:=xlAscending, _ Header:=xlYes, Orientation:=xlTopToBottom End With With .Range("A5:M" & lastRowAfterInsert) .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter .ShrinkToFit = True With .Font .Name = "Arial" .FontStyle = "غامق" .Size = 12 End With End With With .Range("B5:B10000") .HorizontalAlignment = xlRight .VerticalAlignment = xlCenter End With .Rows("5:" & lastRowAfterInsert).RowHeight = 20.25 With .Range("A5:M" & lastRowAfterInsert) .FormatConditions.Delete .FormatConditions.Add Type:=xlExpression, Formula1:="=$M5=""معاش""" With .FormatConditions(1) .Font.Bold = True .Font.Color = -16776961 .Interior.Color = 16764159 .StopIfTrue = False End With End With End If End With ' تحديث الصيغ With wsTarget .Columns("D").NumberFormat = "0" .Range("A5").FormulaR1C1 = "=IF(RC[1]<>"""",SUBTOTAL(3,R5C2:RC[1]),"""")" .Range("A6:A10000").FormulaR1C1 = .Range("A5").FormulaR1C1 End With عد_الذكور_والإناث_والمعاشات CleanUp: With Application .Calculation = xlCalculationAutomatic .EnableEvents = True .ScreenUpdating = True .StatusBar = False End With Debug.Print "تم الانتهاء في: " & Round(Timer - t, 2) & " ثانية" End Sub

وعليكم السلام ورحمة الله وبركاته ، أهلاً بك في مشاركتك الأولى معنا أخي الكريم . ونتمنى أن تجد الفائدة والمعلومة التي تبحث عنها , دعني ألفت انتباهك الى ضرورة التقيد بسياسة وقوانين المنتدى ، بحيث يتم ارفاق ملف بسيط للمشكلة وشرح وافي وكافي للمطلوب ، حتى تتوضح اصورة لمن يقرأ مشكلتك ويساهم في ايجاد حل مناسب لها . أهلاً وسهلاً ، وشكراً لك رحابة صدرك كما أود لفت انتباهك الى ان زر اختيار افضل إجابة مخصص لتختار الإجابة التي حققت طلبك بشكل كامل . وهي دلالة على ان الموضوع قد تم انهائه بحل المشكلة .

تفضل أخي Sub test() Dim dest As Worksheet, WS As Worksheet Dim m As String, a As Variant, k As Variant, f As Variant Dim d As Object: Set d = CreateObject("Scripting.Dictionary") Dim ShArr As Variant: ShArr = Array("aaa", "bbb") Dim i As Long, lr As Long, r As Long: r = 2 With Application .ScreenUpdating = False: .EnableEvents = False: .Calculation = xlCalculationManual On Error Resume Next Set dest = Sheets("التقرير") If dest Is Nothing Then Set dest = Sheets.Add: dest.Name = "التقرير" Else dest.Range("A:F").ClearContents On Error GoTo 0 dest.Range("A1").Resize(1, 6).Value _ = Array("الشهر", "اسم الشركة", "عدد النقلات", "مجموع المبلغ للسائق", "مجموع مبلغ العقد", "مجموع الكمية (طن)") For Each WS In Sheets(ShArr) If WS.AutoFilterMode Then WS.AutoFilterMode = False lr = WS.Cells(WS.Rows.Count, "M").End(xlUp).Row For i = 2 To lr If Trim(WS.Cells(i, "M").Text) <> "" And Trim(WS.Cells(i, "L").Text) <> "" Then m = Trim(WS.Cells(i, "M").Text) & "|" & Trim(WS.Cells(i, "L").Text) If Not d.exists(m) Then d(m) = Array(0, 0, 0, 0) d(m) = Array(d(m)(0) + 1, d(m)(1) + tmp(WS.Cells(i, "S").Value), _ d(m)(2) + tmp(WS.Cells(i, "U").Value), d(m)(3) + tmp(WS.Cells(i, "F").Value)) End If Next i Next WS For Each k In d.Keys f = Split(k, "|") a = d(k) dest.Cells(r, 1).Resize(1, 6).Value = Array(f(0), f(1), a(0), a(1), a(2), a(3)) r = r + 1 Next k .ScreenUpdating = True: .EnableEvents = True: .Calculation = xlCalculationAutomatic End With MsgBox "تم إعداد التقرير بنجاح", vbInformation End Sub Private Function tmp(x As Variant) As Double tmp = IIf(IsNumeric(x), x, 0) End Function الشهر والشركة.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته هذا يتطلب ببساطة تحديد حجم ثابت للدوائر بدلا من حسابه بناء على حجم الخلايا يمكنك تغيير هذه القيمة حسب الحجم الذي ترغب فيه tmp = 10 Option Explicit Sub DrawCircles() Const SROW As Long = 6, EROW As Long = 10, SCOL As Long = 2, ECOL As Long = 9 Dim ws As Worksheet, sColName As String, i As Long, j As Long, n As Long, tmp As Double Application.ScreenUpdating = False Call DelShap Set ws = ActiveSheet tmp = 10 For i = SROW To EROW With ws n = .Range("k" & i).Value For j = ECOL To SCOL Step -1 If .Range(.Cells(i, j).Address).Value <> Empty And n > 0 Then sColName = Split(.Cells(1, j).Address, "$")(1) With ActiveSheet.Shapes.AddShape(msoShapeOval, _ .Range(sColName & i).Left + 0.5 * (.Range(sColName & i).Width - 2 * tmp), _ .Range(sColName & i).Top + 0.5 * (.Range(sColName & i).Height - 2 * tmp), _ 2 * tmp, 2 * tmp) .Line.Weight = 2 .Line.ForeColor.RGB = RGB(10, 10, 10) .Fill.Visible = msoFalse End With n = n - 1 End If If n = 0 Then Exit For Next j End With Next i Application.ScreenUpdating = True End Sub

برنامج abbyy finereader https://www.mediafire.com/file/kwf3zbxrd3inavx/ABBYYFineReaderPDF15.0.114.exe/file

وعليكم السلام ورحمة الله وبركاته تفضل حل متواضع بالمعادلات ويمكن التنفيذ للحل بالأكواد يمكن البحث داخل المنتدى عن استدعاء وترحيل البيانات نموذج أوفيسنا 002.xlsm

السلام عليكم ورحمة الله وبركاته منذ مدة وأنا أحاول بشتى الطرق والوسائل لأتعلم والحمد لله تعلمت من هذا المنتدي الكثير هو برنامج بالأساس مخصص للمطابع وتسهيل مهامهم وتيسير أمور حساباتهم في مختلف مجالات الطباعة : الكتب والمجلات والطباعة ديجيتال أو تسيير الفواتير وحتى محلات الحرفيين الذين يستخدمون ماكينات الليزر لقص الخشب وغيرهم ...... الخ سادتي الكرام اخواني الأعزاء أضع بين أيديكم هذا البرنامج رغم أنه في البداية وغير مكتمل إلا أنني وضعت فيه كثير مما تعلمته من هذا المنتدى العملاق وخاصة الأساتذة : شوقي ربيع وضاحي الغريب وخبور وعبد الله باقشير وغيرهم كثير حتى لا انسى أحد هذا البرنامج الذي آمل من أساتذتنا الكرام ان ينقحوه ويعينوننا في انجازه واخراجه بحلة تليق بمقام هذا الصرح مازال جزء الفواتير والكثير الا أنني آثرت ان ارفعه لنتعاون في اتمامه وهو مفتوح المصدر حتى لا اطيل عليكم جربو البرنامج واحكموا بانفسكم ولا تبخلوا علينا بالنصح والتوجيه والمشاركة بالتعديلات اترككم مع البرنامج اسم المستخدم : Tarek كلمة المرور : 23 عذرا الملف كبير نوعا ما لا اعرف السبب لذا رفعة على قوقل درايف ان كان هناك حل آخر نورونا اساتذتي الرابط بالاسفل مطبعتي تم رفع الملف في المنتدي بعد تصغير مساحته من 35 ميجا الي 2.8 ميجا هنا

بعد إذن الأساتذة الأفضل إثرائا للموضوع يمكن ذلك من خلال التالي =IF(J4>0;HYPERLINK(CONCATENATE("PDF/";J4;".pdf");"الاطلاع على العقد");"")

تفضل هناك العديد من الأكواد لتنفيذ طلبك منها : Sub PDF_Show() ActiveWorkbook.FollowHyperlink "C:\Users\Ali\Downloads\ÚÞÏ ÇáÊÃÓíÓ-ãÍæá.pdf" 'يجب عليك تغيير وتعديل عنوان ومكان ملف البى دى اف بما يتوافق عندك بين علامتين التنصيص End Sub وهذا كود ثانى Sub OpenPDF() Dim pdf As String On Error Resume Next pdf = "C:\Users\Ali\Downloads\عقد التأسيس-محول.pdf" 'يجب عليك تغيير وتعديل عنوان ومكان ملف البى دى اف بما يتوافق عندك بين علامتين التنصيص ActiveWorkbook.FollowHyperlink pdf End Sub واليك الملف اوراق الشركة.xlsm

شاهد المرفق اخي لا شئ يصعب علي ال VBA جلب البيانات على ختيار رؤوس الاعمده.xlsm

شكر استاذ عمر وهذا نموذج للحل المطلوب جلب البيانات على ختيار رؤوس الاعمده.xlsm

حل متواضع بالمعادلات بحسب ما فهمت جلب البيانات على ختيار رؤوس الاعمده 001.xlsm

=INDEX(صور;MATCH(رقموظيفي;الرقم;0);0) نقوم يتسمية عمود الرقم الوظيفي ب الرقم نقوم بتسمية عمود الصور ب صور نقوم بتسمية الرقم الوظيفي ب رقموظيفي ثم نستعمل الدالتين لجلب الصورة ثم من الصيغ نقوم بتحديد المعادلة =INDEX(صور;MATCH(رقموظيفي;الرقم;0);0) باسم photo نقوم بجلب اي صورة بعد الظغط في شريط الصيغة =photo يمكنك تغيير التسميات كما تشاء بروف.xlsx

السلام عليكم أخي أبو البراء الغالي: قمت بحذف الكود في الملف ونسخت بدلاً عنه الكود كاملاً مع اقترحت تعديله فلم أفلح إلا بعد نظرت إلى أمر لم يكن بالحسبان لدي .Sheets("Sheet1").Delete حيث أن أسماء الأوراق لدي بالعربية أصبحت كما يلي: ("ورقة 1") بدلاً من ("sheet1").. وقد نجحت المحاولة نجاحاً باهراً.... تهانينا لكم على هذا العمل الررائع والسلام عليكم.

أخى الفاضل أ.ايهاب أولاً : الملف المرفق ليس له علاقة بالايجارات وانتهائها وخلافه فهو مجموعة موظفين ومكتوب به ارسال ايميل لبريد الموظف اذا انتهت الرخصة او الاقامة وغيرها ثانيا : هذه محاولة منى بناءا على الملف المرفق بارسال البريد تلقائي بمجرد فتح الملف للموظفين الذى انتهت بطاقاتهم او رخصهم وتستطيع انت التعديل به كما تريد بناءا على عملك .. استخدمت انا هنا بريد ال gmail لكل الناس سواء البريد الذي سترسل من خلاله الرسائل او الموظفين الذين سيستقبلون هذه الرسائل فبريد الموظف الاول على افتراض انه emp19811@gmail.com والثاني emp19812@gmail.com وهكذا وعلى افتراض ان البريد الذي سترسل من خلاله الرسائل هو Ibn_Egypt@gmail.com >> والباسورد الخاصة به هي A_123456789 يكون الكود بهذا الشكل Sub btnSendEmail() On Error GoTo 1 Dim Mail As New Message Dim ID, Licence As Boolean Dim Config As Configuration: Set Config = Mail.Configuration Dim LR As Long Dim i As Integer LR = Range("A" & Rows.Count).End(xlUp).Row For i = 2 To LR If Range("D" & i).Value < Date Or Range("C" & i).Value < Date Then If Range("E" & i).Value = "" Then Config(cdoSendUsingMethod) = cdoSendUsingPort Config(cdoSMTPServer) = "smtp.gmail.com" Config(cdoSMTPServerPort) = 25 Config(cdoSMTPAuthenticate) = cdoBasic Config(cdoSMTPUseSSL) = True Config(cdoSendUserName) = "Ibn_Egypt@gmail.com" Config(cdoSendPassword) = "A_123456789" Config.Fields.Update Mail.To = Range("A" & i).Value & "@gmail.com" Mail.from = Config(cdoSendUserName) ID = False If Range("C" & i).Value < Date Then ID = True Licence = False If Range("D" & i).Value < Date Then Licence = True If ID = True Then Mail.Subject = "انتهاء البطاقة" Mail.HTMLBody = "انتهاء البطاقة بتاريخ" & Format(Range("C" & i).Value, "yyyy/m/d") & "يرجي التواصل مع أقرب مكتب تجديد" End If If Licence = True Then Mail.Subject = "انتهاء الرخصة" Mail.HTMLBody = "انتهاء الرخصة بتاريخ" & Format(Range("D" & i).Value, "yyyy/m/d") & "يرجي التواصل مع أقرب مكتب تجديد" End If Mail.Send MsgBox "تم ارسال البريد بنجاح الى الموظف" & " " & Range("A", i).Value, vbOKOnly + vbInformation, "تم الارسال" Range("E" & i).Value = "تم التنبيه وارسال بريد" End If End If Next 1 End Sub في الكود السابق لابد ان تعدل البريد Ibn_Egypt@gmail.com... بالبريد الخاص بك وكذلك كلمة المرور اسفله الى كلمة المرور الصحيحة للبريد المكتوب كما انه يلزمك ايضا تفعيل هذه المكتبة من محرر الأكواد تختار Tools ثم References ,وتحدد علامة صح على المكتبة الموجودة بالصورة التى امامك ولكى تجعل الكود يعمل تلقائيا بمجرد فتح الملف .. يتم وضع هذا الامر في حدث فتح الملف Private Sub Workbook_Open() btnSendEmail End Sub مرفق ملف ومن اراد من الاخوة الأعضاء استخدامه يرجي التأكد من تغيير البريد في الكود وكذلك كلمة المرور وتفعيل المكتبة ... الكود مجرب ويعمل بنجاح والايميلات السابقة emp19811@gmail.com >>> emp19812@gmail.com حقيقية تحياتي email.rar