كود لإنشاء ملف نصي في مجلد النظام system

[فتحي محمد]

الأساتذة الفضلاء دام عزكم واسعد الله صباحكم بكل الخير 

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

اريد من حضراتكم كود يقوم بإنشاء ملف نصي وليكن fs txt مكتوب داخله"fs" ويكون مساره داخل مجلد الويندوز علي الجهاز ولحضراتكم مني جزيل الشكر

[أ / محمد صالح]

عليكم السلام ورحمة الله وبركاته
يمكنك تجربة  كود VBA يقوم بإنشاء ملف نصي باسم **fs.txt** يحتوي على النص `"fs"`، ويتم حفظه داخل مجلد **C:\Windows** على الجهاز:

 

Sub CreateTextFile()
    Dim FilePath As String
    Dim FileNumber As Integer
    
    ' تحديد مسار الملف داخل مجلد Windows
    FilePath = "C:\Windows\fs.txt"
    
    ' الحصول على رقم ملف متاح
    FileNumber = FreeFile
    
    ' إنشاء وكتابة البيانات إلى الملف
    Open FilePath For Output As FileNumber
    Print #FileNumber, "fs"
    Close FileNumber
    
    MsgBox "تم إنشاء الملف بنجاح في: " & FilePath, vbInformation, "نجاح"
End Sub

```

⚠️ **ملاحظة:** تحتاج إلى تشغيل الكود بصلاحيات **المسؤول (Administrator)** لأن الكتابة داخل مجلد **Windows** تتطلب أذونات خاصة. يمكنك تشغيل VBA من داخل **Excel أو Word** ولكن تأكد من أن لديك الصلاحيات الكافية.

بالتوفيق
 

[فتحي محمد]

السلام عليكم  اخي الفاضل جزاك الله خير وجعله الله زخرا لك في الاخرة

غير ان هناك مشكلة عند تشغيل الكود موجودة في الصور المرفق

[فتحي محمد]

[عبدالله بشير عبدالله]

السلام عليكم

انتبه الى الملاحظة التي كتبها معلمنا الاستاذ محمد صالح

في 21‏/4‏/2025 at 10:49, أ / محمد صالح said:

ملاحظة:** تحتاج إلى تشغيل الكود بصلاحيات **المسؤول (Administrator)** لأن الكتابة داخل مجلد **Windows** تتطلب أذونات خاصة

مجلد C:\Windows هو مجلد نظام، ولا يُسمح للبرامج العادية (بدون صلاحيات مسؤول) بإنشاء أو تعديل ملفات بداخله

وهذا هو سبب  ظهور الخطأ

 بالماوس الايمن على تطبيق اكسل وليس ملف الاكسل قم باختيار تشغيل كمسؤول  وسيعمل الكود وينشئ الملف وقد فمت بالتجرية وكانت تاجحة بالتمام والكمال

 نحياني

[محمدسلام]

شكرا علي التوضيح جزاكم الله خيرا

[فتحي محمد]

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

[Foksh]

مساهمة بعد تعديلها لتعمل على اكسل بدلاً من اكسيس ولست متأكد منها :-

في وحدة نمطية جديدة =

Option Compare Database


#If VBA7 Then
    Private Declare PtrSafe Function OpenProcessToken Lib "advapi32.dll" ( _
        ByVal ProcessHandle As LongPtr, _
        ByVal DesiredAccess As Long, _
        ByRef TokenHandle As LongPtr _
    ) As Long

    Private Declare PtrSafe Function GetTokenInformation Lib "advapi32.dll" ( _
        ByVal TokenHandle As LongPtr, _
        ByVal TokenInformationClass As Long, _
        ByRef TokenInformation As Any, _
        ByVal TokenInformationLength As Long, _
        ByRef ReturnLength As Long _
    ) As Long

    Private Declare PtrSafe Function GetCurrentProcess Lib "kernel32" () As LongPtr

    Private Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" ( _
        ByVal hwnd As LongPtr, _
        ByVal lpOperation As String, _
        ByVal lpFile As String, _
        ByVal lpParameters As String, _
        ByVal lpDirectory As String, _
        ByVal nShowCmd As Long _
    ) As LongPtr
#Else
    Private Declare Function OpenProcessToken Lib "advapi32.dll" ( _
        ByVal ProcessHandle As Long, _
        ByVal DesiredAccess As Long, _
        ByRef TokenHandle As Long _
    ) As Long

    Private Declare Function GetTokenInformation Lib "advapi32.dll" ( _
        ByVal TokenHandle As Long, _
        ByVal TokenInformationClass As Long, _
        ByRef TokenInformation As Any, _
        ByVal TokenInformationLength As Long, _
        ByRef ReturnLength As Long _
    ) As Long

    Private Declare Function GetCurrentProcess Lib "kernel32" () As Long

    Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" ( _
        ByVal hwnd As Long, _
        ByVal lpOperation As String, _
        ByVal lpFile As String, _
        ByVal lpParameters As String, _
        ByVal lpDirectory As String, _
        ByVal nShowCmd As Long _
    ) As Long
#End If

Public Function IsRunAsAdmin() As Boolean
    Const TOKEN_QUERY      As Long = &H8
    Const TokenElevation   As Long = 20
    Dim hToken            As LongPtr
    Dim elev              As Long
    Dim retLen            As Long

    If OpenProcessToken(GetCurrentProcess(), TOKEN_QUERY, hToken) <> 0 Then
        If GetTokenInformation(hToken, TokenElevation, elev, LenB(elev), retLen) <> 0 Then
            IsRunAsAdmin = (elev <> 0)
        End If
    End If
End Function

Public Sub RestartAsAdmin()
    Dim exePath   As String
    Dim dbArgument As String

    exePath = Application.FullName
    dbArgument = """" & Application.CurrentProject.FullName & """"

    ShellExecute 0, "runas", exePath, dbArgument, vbNullString, 1

    Application.Quit
End Sub

Public Sub CreateTextFile()
    Dim FilePath   As String
    Dim FileNum    As Integer

    If Not IsRunAsAdmin Then
        MsgBox "البرنامج بحاجة إلى صلاحيات مسؤول (Administrator)." & vbCrLf & _
               "سيتم إعادة تشغيل Access بطلب صلاحيات مرتفعة...", _
               vbExclamation, "تحتاج صلاحيات"
        RestartAsAdmin
        Exit Sub
    End If

    FilePath = "C:\Windows\fs.txt"
    FileNum = FreeFile

    Open FilePath For Output As #FileNum
    Print #FileNum, "fs"
    Close #FileNum

    MsgBox "تم إنشاء الملف بنجاح في:" & vbCrLf & FilePath, _
           vbInformation, "نجاح"
End Sub

 

الإستدعاء سيكون في الزر على سبيل المثال =

CreateTextFile

 

[فتحي محمد]

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

[فتحي محمد]

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

[Foksh]

في 28‏/4‏/2025 at 00:23, فتحي محمد said:

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

استدعاء الدالة يا صديقي من خلال زر على سبيل المثال ..

 

في 28‏/4‏/2025 at 11:47, فتحي محمد said:

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

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

لست ضليع بالمستوى الذي لدى الأخوة هنا في قسم اكسيل ، ولكني في اكسيس أأكد لك أنه ذلك يسير بطرق وحلول كثيرة وكثيرة وكثيرة ,,

[lionheart]

Try

#If VBA7 Then
    Private Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As LongPtr, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As LongPtr
#Else
    Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
#End If

Function CreateElevatedFile(ByVal sFilePath As String, ByVal sFileContent As String) As Boolean
    On Error GoTo ErrorHandler
    Dim fso As Object, sScriptPath As String, psScript As String, EscFilePath As String, EscContent As String
    sScriptPath = Environ("TEMP") & "\create_elevated_file.ps1"
    EscFilePath = Replace(Replace(sFilePath, "'", "''"), """", "\""")
    EscContent = Replace(Replace(sFileContent, "'", "''"), """", "\""")
    psScript = "$t = [System.Diagnostics.ProcessWindowStyle]::Hidden;$p = Start-Process -WindowStyle $t -FilePath 'powershell.exe' -ArgumentList '-Command ""Set-Content -Path \""" & EscFilePath & "\""` -Value \""" & EscContent & "\""""' -Verb RunAs -PassThru;$p.WaitForExit();Exit $p.ExitCode"
    Set fso = CreateObject("Scripting.FileSystemObject")
    With fso.CreateTextFile(sScriptPath, True)
        .WriteLine psScript
        .Close
    End With
    ShellExecute 0, "runas", "powershell.exe", "-ExecutionPolicy Bypass -WindowStyle Hidden -File """ & sScriptPath & """", vbNullString, 0
    CreateElevatedFile = True
    Exit Function
ErrorHandler:
    CreateElevatedFile = False
End Function

Sub Create_File_With_Elevated_Permissions()
    Dim success As Boolean
    success = CreateElevatedFile("C:\Windows\Test.txt", "This Was Created With Elevated Permissions")
    If success Then
        MsgBox "File Created Successfully", vbInformation
    Else
        MsgBox "File Not Created", vbExclamation
    End If
End Sub