اذهب الي المحتوي
أوفيسنا

Trasted Location .. إنشاء موقع أمان لملفات الأكسيس توماتيكى


essam rabea

الردود الموصى بها

عجبنى الموضوع ده قلت أشاركه معكم

بإختصار هو سكريبت لعمل مكان موثوق لملفات الأكسيس من مكان تشغيله .. بمعنى لو شغلته من Desk Top تقدر تفتح أى ملف أكسيس على Desk Top بدون ظهور Enable Content.

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

إنشئ ملف نص بأى إسم وضع فيه ما يلى على أن تغير إمتداده الى vbs.

Const HKEY_CURRENT_USER = &H80000001
 
    Dim oRegistry    
    Dim sPath    
    Dim sDescription    
    Dim bAllowSubFolders    
    Dim bAllowNetworkLocations    
    Dim bAlreadyExists    
    Dim sParentKey    
    Dim iLocCounter    
    Dim arrChildKeys    
    Dim sChildKey    
    Dim sValue    
    Dim sNewKey    

    Set WshShell = CreateObject("WScript.Shell")
    strCurDir = WshShell.CurrentDirectory

    Set oRegistry = GetObject("winmgmts:\\.\root\default:StdRegProv")
    sPath = strCurDir 

    sDescription = "YourTrustedLocationDescriptionGoesHere"
    bAllowSubFolders = True
    bAlreadyExists = False

    sParentKey = "Software\Microsoft\Office\16.0\Access\Security\Trusted Locations"
'    sParentKey = "Software\Microsoft\Office\16.0\Excel\Security\Trusted Locations"
'    sParentKey = "Software\Microsoft\Office\16.0\PowerPoint\Security\Trusted Locations"
'    sParentKey = "Software\Microsoft\Office\16.0\Word\Security\Trusted Locations"
    iLocCounter = 0
    oRegistry.EnumKey HKEY_CURRENT_USER, sParentKey, arrChildKeys
    For Each sChildKey in arrChildKeys
        oRegistry.GetStringValue HKEY_CURRENT_USER, sParentKey & "\" & sChildKey, "Description", sValue
         If sValue = sDescription Then bAlreadyExists = True

        If CInt(Mid(sChildKey, 9)) > iLocCounter Then
                iLocCounter = CInt(Mid(sChildKey, 9))
            End If
    Next

    'If bAlreadyExists = False Then
        sNewKey = sParentKey & "\Location" & CStr(iLocCounter + 1)

        oRegistry.CreateKey HKEY_CURRENT_USER, sNewKey
        oRegistry.SetStringValue HKEY_CURRENT_USER, sNewKey, "Path", sPath
        oRegistry.SetStringValue HKEY_CURRENT_USER, sNewKey, "Description", sDescription

        If bAllowSubFolders Then
            oRegistry.SetDWORDValue HKEY_CURRENT_USER, sNewKey, "AllowSubFolders", 1

        End If

كما يمكن تفعيله للاكسيل والوورد والباور بوينت مع مراعاة نسخة الاوفيس لديك وتغيرها فى الكود:

أوفيس 2019     :   16.0

أوفيس 2016     :   16.0

أوفيس 2013    :    15.0

أوفيس 2010    :    14.0

أوفبس 2007    :    12.0

أوفيس 2003    :    11.0

أظن أنه لا يوجد أحد أعضاء منتدانا الكريم يعمل على أوفيس XP 😊

 

عسى أن يفيد .. إذا اشتغل يعنى

والله الموفق

 

EAR TrustAnyWhere.zip

تم تعديل بواسطه essam rabea
  • Like 11
  • Thanks 5
رابط هذا التعليق
شارك

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

أسأل الله ان يزيدك علما وأن يحفظك من كل مكروه .

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

تحياتي وتقديري .

  • Like 1
  • Thanks 1
رابط هذا التعليق
شارك

  • 4 weeks later...

هوه الكود لو بالقاعدة كان بعد اقوى بس الموجود جميل لابئس بي عاشت ايدك 

-----------------------------

خوية عصام اشلون احول المذكرة الى امتداد vbs اشو اخلي اسم وبعدين الامتداد .vbs اشو يقرا اسم ميحول الى امتداد/ المشكلة وين. ؟

رابط هذا التعليق
شارك

السلام عليكم-استاذ أمير , الأمر فى غاية البساطة

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

ثم تقوم بعمل كليك يمين بالماوس ثم تختار New

وبعد ذلك تختار Text Document

وبعد ذلك  سيفتح لك ملف نصى جديد , يكون هكذا 

New Text Document.txt

تقوم بعد ذلك بلصق كود الأستاذ عصام به ,ثم بعد ذلك حفظ وغلق الملف

وبعد غلقه تقوم بتغيير امتداد الملف من .txt الى ما يطلبه منك استاذ عصام اى الى .Vbs

أتمنى ان يكون الأمر قد تبين وتوضح لك الأن

بارك الله فيكم جميعا

 

  • Like 1
رابط هذا التعليق
شارك

أستاذ @Amir - 4k   ماذا يحدث عندما تفتح ملف vbs 

هل تظهر لك رسالة خطأ  ولو أمكن تقوم بتصوير رسالة الخطأ 

وياحبذا لو ذكرت لنا نوع الأوفس لديك (2019 - 2016 - 2010 - 2003)

وهل قمت بتغير رقم الاصدار داخل الكود وفقا لتعليمات أستاذنا  @essam rabea 

  • Like 1
رابط هذا التعليق
شارك

عدل الكود ليلائم الأوفيس تبعك كالآتى


	Const HKEY_CURRENT_USER = &H80000001
 
	Dim oRegistry	
	Dim sPath				
	Dim sDescription		
	Dim bAllowSubFolders		
	Dim bAllowNetworkLocations 	
	Dim bAlreadyExists
	Dim sParentKey
	Dim iLocCounter
	Dim arrChildKeys
	Dim sChildKey	
	Dim sValue
	Dim sNewKey

	Set WshShell = CreateObject("WScript.Shell")
	strCurDir = WshShell.CurrentDirectory

	Set oRegistry = GetObject("winmgmts:\\.\root\default:StdRegProv")
	sPath = strCurDir  	
	sDescription = "YourTrustedLocationDescriptionGoesHere"
	bAllowSubFolders = True
	bAlreadyExists = False

	sParentKey = "Software\Microsoft\Office\14.0\Access\Security\Trusted Locations"
'	sParentKey = "Software\Microsoft\Office\14.0\Excel\Security\Trusted Locations"
'	sParentKey = "Software\Microsoft\Office\14.0\PowerPoint\Security\Trusted Locations"
'	sParentKey = "Software\Microsoft\Office\14.0\Word\Security\Trusted Locations"
	iLocCounter = 0
	oRegistry.EnumKey HKEY_CURRENT_USER, sParentKey, arrChildKeys
	For Each sChildKey in arrChildKeys
		oRegistry.GetStringValue HKEY_CURRENT_USER, sParentKey & "\" & sChildKey, "Description", sValue
 		If sValue = sDescription Then bAlreadyExists = True

		If CInt(Mid(sChildKey, 9)) > iLocCounter Then
        		iLocCounter = CInt(Mid(sChildKey, 9))
	        End If
	Next

	'If bAlreadyExists = False Then
		sNewKey = sParentKey & "\Location" & CStr(iLocCounter + 1)

		oRegistry.CreateKey HKEY_CURRENT_USER, sNewKey
		oRegistry.SetStringValue HKEY_CURRENT_USER, sNewKey, "Path", sPath
		oRegistry.SetStringValue HKEY_CURRENT_USER, sNewKey, "Description", sDescription

		If bAllowSubFolders Then
			oRegistry.SetDWORDValue HKEY_CURRENT_USER, sNewKey, "AllowSubFolders", 1
		End If
	

ولا تنسى وضع الملف فى نفس مسار قاعدة البيانات

تم تعديل بواسطه essam rabea
  • Thanks 1
رابط هذا التعليق
شارك

بل كل الشكر والتقدير لكم  أستاذنا ومعلمنا القدير عصام ربيع 

زادكم الله فضلا وعلما ونفع بكم أينما حللتم

 

  • Like 1
  • Thanks 1
رابط هذا التعليق
شارك

للاسف لم يعمل معى
 اوفيس 2013   32Bit
ويندوز     8         64bit
قمت بتغيير المسار الى 15.0  ولا كن لا يعمل

هذا الكود المستخدم

 

 Const HKEY_CURRENT_USER = &H80000001
 
    Dim oRegistry    
    Dim sPath    
    Dim sDescription    
    Dim bAllowSubFolders    
    Dim bAllowNetworkLocations    
    Dim bAlreadyExists    
    Dim sParentKey    
    Dim iLocCounter    
    Dim arrChildKeys    
    Dim sChildKey    
    Dim sValue    
    Dim sNewKey    

    Set WshShell = CreateObject("WScript.Shell")
    strCurDir = WshShell.CurrentDirectory

    Set oRegistry = GetObject("winmgmts:\\.\root\default:StdRegProv")
    sPath = strCurDir 

    sDescription = "YourTrustedLocationDescriptionGoesHere"
    bAllowSubFolders = True
    bAlreadyExists = False

    sParentKey = "Software\Microsoft\Office\15.0\Access\Security\Trusted Locations"
'    sParentKey = "Software\Microsoft\Office\15.0\Excel\Security\Trusted Locations"
'    sParentKey = "Software\Microsoft\Office\15.0\PowerPoint\Security\Trusted Locations"
'    sParentKey = "Software\Microsoft\Office\15.0\Word\Security\Trusted Locations"
    iLocCounter = 0
    oRegistry.EnumKey HKEY_CURRENT_USER, sParentKey, arrChildKeys
    For Each sChildKey in arrChildKeys
        oRegistry.GetStringValue HKEY_CURRENT_USER, sParentKey & "\" & sChildKey, "Description", sValue
         If sValue = sDescription Then bAlreadyExists = True

        If CInt(Mid(sChildKey, 9)) > iLocCounter Then
                iLocCounter = CInt(Mid(sChildKey, 9))
            End If
    Next

    'If bAlreadyExists = False Then
        sNewKey = sParentKey & "\Location" & CStr(iLocCounter + 1)

        oRegistry.CreateKey HKEY_CURRENT_USER, sNewKey
        oRegistry.SetStringValue HKEY_CURRENT_USER, sNewKey, "Path", sPath
        oRegistry.SetStringValue HKEY_CURRENT_USER, sNewKey, "Description", sDescription

        If bAllowSubFolders Then
            oRegistry.SetDWORDValue HKEY_CURRENT_USER, sNewKey, "AllowSubFolders", 1

        End If 

 

رابط هذا التعليق
شارك

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information