جرب هذا الملف بعد التعديل . حيث تم تعديل الكود ليصبح :-
Option Explicit
#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 wbPath As String
exePath = Application.Path & "\EXCEL.EXE"
wbPath = """" & ThisWorkbook.FullName & """"
ShellExecute 0, "runas", exePath, wbPath, vbNullString, 1
Application.Quit
End Sub
Public Sub CreateTextFile()
Dim FilePath As String
Dim FileNum As Integer
If Not IsRunAsAdmin Then
MsgBox ". (Administrator) البرنامج بحاجة إلى صلاحيات مسؤول" & vbCrLf & _
"... لطلب صلاحيات المسؤول Excel سيتم اعادة تشغيل", _
vbExclamation + vbMsgBoxRight, "تحتاج صلاحيات"
RestartAsAdmin
Exit Sub
End If
FilePath = "C:\Windows\fs.txt"
FileNum = FreeFile
Open FilePath For Output As #FileNum
Print #FileNum, "https://www.officena.net/"
Close #FileNum
MsgBox "تم إنشاء الملف بنجاح في:" & vbCrLf & FilePath, _
vbInformation + vbMsgBoxRight, "نجاح"
End Sub
Book1.zip