[ تمت الإجابة ]عمل مشاركة لأي مجلد برمجيا

اللهم لا سهل إلا ما جعلته سهلا ...

إنك سبحانك تجعل الصعب سهلا ....

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

الكود الاول فتح مجلد والتدقيق بوجوده

Dim fs As Object
Dim a As Object

    Set fs = CreateObject("Scripting.FileSystemObject")
        If fs.FolderExists(Me.txtloc) = True Then
            MsgBox "المجلد موجود سابقاً"
         Else
         If MsgBox("هل تريد فتح مجلد جديد للمنتج الحالي", vbOKCancel) = vbCancel Then
         Exit Sub
         Else
               Set a = fs.Createfolder(Me.txtloc)
            MsgBox "تم عمل المجلد بنجاح"
         End If
         End If

الكود الثاني عمل مشاركة لمجلد برمجيا

Private Const STYPE_DISKTREE As Long = 0 'disk drive
Private Const STYPE_PRINTQ As Long = 1 'printer
Private Const STYPE_DEVICE As Long = 2
Private Const STYPE_IPC As Long = 3
Private Type SHARE_INFO_2
    shi2_netname As String 'LPWSTR
    shi2_type As Long 'DWORD
    shi2_remark As String 'LPWSTR
    shi2_permissions As Long 'DWORD
    shi2_max_uses As Long 'DWORD
    shi2_current_uses As Long 'DWORD
    shi2_path As String 'LPWSTR
    shi2_passwd As String 'LPWSTR
End Type
Private Declare Function NetShareAdd Lib "netapi32.dll" ( _
                        lpwstrServerName As Byte, _
                        ByVal dwordLevel As Long, _
                        ByVal lpbyteBuf As Long, _
                        lpdwordParmErr As Long) As Long
Public Function ShareIt(ByVal CompterName As String, _
                        ByVal SharePath As String, _
                        Optional ShareName As String = " ", _
                        Optional ByVal ShareRemarks As String = " ") As Long
' This function returns 0 if successful and
' a none zero number if the function fails.
Dim si2 As SHARE_INFO_2
Dim parmerr As Long
Dim compname() As Byte

    parmerr = 0
    compname() = CompterName & vbNullChar

    si2.shi2_netname = ShareName 'the name of the share
    si2.shi2_type = STYPE_DISKTREE 'the share is on the disk
    si2.shi2_remark = ShareRemarks & vbNullChar 'the comment
    si2.shi2_permissions = 0 'this should be ignored
    si2.shi2_max_uses = -1 'unlimited connections
    si2.shi2_current_uses = 0 'I don't think this is applicable
    si2.shi2_path = SharePath  'the path to the share
    si2.shi2_passwd = vbNullString ' the password 'this should be ignored

    ShareIt = NetShareAdd(compname(0), 2, VarPtr(si2), parmerr)

End Function

تنفيذ أمر مشاركة المجلد بالاعتماد على الفانكشن السابق

If ShareIt("user-174f906813.", Me.txtloc) = 0 Then
        MsgBox "تم عمل المشاركة للمجلد بنجاح"
    Else
        MsgBox "حدث خطأ ربما المجلد غير موجود أو المجلد مشترك"
    End If

حيث

user-174f906813.

هو اسم الكمبيوتر لدي غير الاسم حسب اسم جهاز الكمبيوتر عندك

اذا لم يظهر كف المشاركة اعمل refresh عند استعراض محرك الأقراص (d) لديك

تحياتي ..

مشاركة مجلد برمجيا.zip

ماشاء الله .. تمام ..

لكن لو كان المجلد موجود مسبقا ... سيظهر رسالة ( المجلد موجود مسبقا ) ... نود أن يضاف على الرسالة : هل تود بعمل مشاركة للمجلد ؟

لا أملك لك إلا دعوة صالحة في ظهر الغيب ...

فتى الوادي كتب:

ماشاء الله .. تمام ..

لكن لو كان المجلد موجود مسبقا ... سيظهر رسالة ( المجلد موجود مسبقا ) ... نود أن يضاف على الرسالة : هل تود بعمل مشاركة للمجلد ؟

لا أملك لك إلا دعوة صالحة في ظهر الغيب ...

جزاك الله خير ..

أعتذر عن التأخير ..

مرفق الملف مرة أخرى حسب طلبك ..

تحياتي ..

مشاركة مجلد برمجيا1.rar

السلام عليكم

أعتذر أخي الكريم عن الرد متأخرا حيث كنت مسافرا خارج البلاد ...

أخي الكريم : جربت المثال المرفق وتظهر رسالة :

مع ان المجلد موجود وغير مشترك ..

فتى الوادي كتب:

السلام عليكم

أعتذر أخي الكريم عن الرد متأخرا حيث كنت مسافرا خارج البلاد ...

أخي الكريم : جربت المثال المرفق وتظهر رسالة :

مع ان المجلد موجود وغير مشترك ..

عدل هذا السطر بالكود الى اسم كمبيوترك

If ShareIt("user-174f906813.", Me.txtloc) = 0 Then

user-174f906813. هذا اسم الكمبيوتر عدله فقط حسب اسم جهازك وسيعمل المثال ان شاء الله ..

تحياتي ..

والله انك خبير...خبير فعلا....عمل رائع اخي محمد

تحياتي

همام ابوعرقوب كتب:

والله انك خبير...خبير فعلا....عمل رائع اخي محمد

تحياتي

جزاك الله خير أخي وأستاذي همام .. بس بالراحة علي شوي لصدق بعدين :)

جرى تعديل على الكود لاحضار اسم الكمبيوتر برمجيا ، وبعد هذا التعديل يلزم فقط تحديد اسم ومسار المجلد المطلوب ..

تم تعديل الكود التالي :

If ShareIt("user-174f906813.", Me.txtloc) = 0 Then

الى

If ShareIt(Me![COMPUTERNAME], Me.txtloc) = 0 Then

وتم استخدام الكود التالي لاحضار اسم الكمبيوتر ..

في الموديول :

Option Compare Database
Option Explicit
Private Declare Function GetComputerName Lib "kernel32" Alias _
    "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Private Function GetMachineName() As String
' This code was originally written by
' Doug Steele, MVP  AccessHelp@rogers.com
' http://I.Am/DougSteele
' You are free to use it in any application
' provided the copyright notice is left unchanged.
'
' Description:  Returns the Machine (aka Computer) name.
'               Uses the GetComputerNameA API call.
'
' Arguments:    None
'
' Returns:      A string representing the name of the machine.

On Error GoTo Err_GetMachineName

Dim lngLen As Long
Dim lngReturn As Long
Dim strComputer

' Need to prefill strComputer with a known number of
' Null characters, then pass that string of Nulls
' (plus the length of the string) to the API call.
' If the call to the API succeeds, the return value
' is nonzero and the variable represented by the Size
' parameter contains the number of characters copied
' to the destination buffer, not including the
' terminating null character.
' If the function fails, the return value is zero.

    lngLen = 16
    strComputer = String$(lngLen, 0)
    lngReturn = GetComputerName(strComputer, lngLen)
    If lngReturn <> 0 Then
        strComputer = Left$(strComputer, lngLen)
    Else
        strComputer = vbNullString
    End If

في النموذج :

في رأس النموذج وعند Option Compare Database اضف التعريف التالي

Private Const MAX_COMPUTERNAME_LENGTH As Long = 31
Private Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long

اضف هذا الكود في نهاية آخر حدث بالنموذج

Public Function setcomputerName()
    Dim dwLen As Long
Dim strString As String

    dwLen = MAX_COMPUTERNAME_LENGTH + 1
    strString = String(dwLen, "X")
    GetComputerName strString, dwLen
    strString = Left(strString, dwLen)
    Me![COMPUTERNAME] = strString
End Function

وعند الفتح اضف الكود التالي بينفذ احضار اسم الكمبيوتر

setcomputerName

وهذا المثال بعد التعديل

تم تصحيح المرفق

تحياتي ..

مشاركة مجلد برمجيا2.rar

بارك الله فيك اخي ابو عدنان

مجهود رائع وعمل مفيد

+1

بارك الله فيك ونفع الله بك البلاد والعباد وزادك الله من علمه ..

بارك الله فيك و فى جهودك اخى أبو عدنان

و جزاك الله خيرا

السلام عليكم :

بعد التجربة ما زالت الرسالة تظهر .. ولا يتم عمل مشاركة للمجلد .!

واعتقد انك نسيت ان تعدل الكود الأخير :

    If ShareIt("user-174f906813.", Me.txtloc) = 0 Then
         MsgBox "Êã Úãá ÇáãÔÇÑßÉ ááãÌáÏ ÈäÌÇÍ"
    Else
        MsgBox "ÍÏË ÎØà ÑÈãÇ ÇáãÌáÏ ÛíÑ ãæÌæÏ Ãæ ÇáãÌáÏ ãÔÊÑß"
    End If

اعتقد أنك أرفق المثال بدون تعديلك الأخير .

الأخوة الأحباء مالك وفتى الوادي وأبو يوسف جزاكم الله خير الجزاء ..

والله أنا آسف جدا أخي فتى الوادي فقد أختلط علي الأمر ووضعت نسخة قديمة قبل التحديث

والمشكلة الآن مو ملاقي النسخة المعدلة :wacko:

لعيونك أخي العزيز تم اعادة تجميع الأكواد بمرفق جديد ارجو ان لا يكون به خطأ وتم تصحيح المرفق الأخير بالنسخة الجديدة :)

نزل النسخة مرة ثانية وجربها وأنا بانتظارك ..

تحياتي ..

بارك الله فيك ونفع الله بك البلاد والعباد وزادك الله من علمه ..

وما على المحسنين من سبيل ...

بارك الله فيك اخي ابو عدنان على جهودك...

واتمنى ان استطيع المساعدة...لكن ظروف خاصة تمنعني من المتابعة

عملك وعطاؤك مهم للمنتدى الان

همام ابوعرقوب كتب:

بارك الله فيك اخي ابو عدنان على جهودك...

واتمنى ان استطيع المساعدة...لكن ظروف خاصة تمنعني من المتابعة

عملك وعطاؤك مهم للمنتدى الان

وفيك أخي همام ... ما هذا الذي أراه ؟

لأمر محزن جدا أن تبعد عنا.... فأنت في القلب والله أعلم وليس كل الكلام يقال ..

مستقبلك وحياتك الخاصة بالتأكيد تهمنا ونتمنى لك مزيدا من النجاح والتوفيق ..

بس لا تطول الغيبة وخليك بالأجواء :)

كل الاحترام والشكر لك أخي همام ..

نعم اخي لقد تركت الاشراف..والله مكرها ...مشكلة حصلت مع عضو في المنتدى..والحمد لله تم انذاره وتم ايقافي عن الاشراف..

لكني وجدتها ايضا فائدة..فانا اتفرغ الان لاعداد نفسي للسفر وكذلك لدي برنامج كبير لنظم المعلومات المدرسية وبه من الافكار والحيل ما احب مشاركتكم به..

قريبا ساطرح المزيد منها

وقد عملت صفحة خاصة بهذا البرنامج على الفيس بوك

http://www.facebook.com/home.php?#!/pages/hmam-abwrqwb-brmjt-anzmt-almlwmat/189724984383751

تحياتي

عذرا أخي العزيز فتى الوادي فلا بد من كلمة حق تقال ..

أخي الحبيب همام قدر الله وما شاء فعل وعسى ان تكروه شيئا ً وهو خيرا ً لكم وعسى ان تحبو شيئا ً وهو شرا ً لكم .. اليس كذلك ..

الله المستعان أخي همام ، ستبقى مشرفنا وأستاذنا والرجال تقدر بأعمالهم وليس بمناصبهم وهذا ليس رأي بل أراهن أن القسم بالكامل يدين لك بالكثير ..

فعمل الخير وتواصلك مع الشباب واجب عليك وتقديره عند العلي القدير سبحانه ..

خليك مع الشباب فلمن تتركهم ؟ وصدقني تواجدك ومساعدتك لأخوتك هو ما يقربك من القلوب ...

لا ترمي الحمل على أخوك الشايب :lol: ..

تحياتي ,,

محمد أبو عدنان كتب:

عذرا أخي العزيز فتى الوادي فلا بد من كلمة حق تقال ..

أخي الحبيب همام قدر الله وما شاء فعل وعسى ان تكروه شيئا ً وهو خيرا ً لكم وعسى ان تحبو شيئا ً وهو شرا ً لكم .. اليس كذلك ..

الله المستعان أخي همام ، ستبقى مشرفنا وأستاذنا والرجال تقدر بأعمالهم وليس بمناصبهم وهذا ليس رأي بل أراهن أن القسم بالكامل يدين لك بالكثير ..

فعمل الخير وتواصلك مع الشباب واجب عليك وتقديره عند العلي القدير سبحانه ..

خليك مع الشباب فلمن تتركهم ؟ وصدقني تواجدك ومساعدتك لأخوتك هو ما يقربك من القلوب ...

لا ترمي الحمل على أخوك الشايب :lol: ..

تحياتي ,,

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

وتاكد انني اقدر جهودك وجهود جميع الاخوة الكرام هنا..وفعلا...الاشراف كان حملا ثقيلا علي حيث اخرني في مرات كثيرة من العمل للحلول مقابل العمل في القسم وترتيب وضعه وتعديل مواضيع باكملها..

اشكرك مرة اخرى..بارك الله فيك..ولا غنى ابدا عن ابداعاتك التي تجعلني تواقا للمزيد منك استاذي العزيز