اين الخطأ في هذا الكود

خالد حرب · يناير 17, 2021

السلام عليكم

ما هو الخطأ في هذا الكود

علما بان هذا الكود يشتغل على اوفس 2010

و عند نقل الملف على اوفس 2013 يظهر هذا الخطأ

Private Declare Function SetWindowLong Lib "USER32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal lngWinIdx As Long, ByVal dwNewLong As Long) As Long
Private Declare Function FindWindow Lib "USER32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Dim hWnd As Long: Const GWL_STYLE = -16: Const WS_SYSMENU = &H80000
Dim AA As Integer
Dim Tx_1() As New Ali_Pass_Num
Private Sub CommandButton5_Click()
UserForm2.Show
End Sub
Private Sub CommandButton6_Click()
UserForm5.Show
End Sub

Private Sub UserForm_Deactivate()

End Sub

Private Sub UserForm_Initialize()
Dim t As Integer, hWnd As Long, lStyle As Long: hWnd = FindWindow("ThunderDFrame", Me.Caption): SetWindowLong hWnd, GWL_STYLE, (lStyle And Not WS_SYSMENU)
Dim A_TCoun As Integer, Ct
A_TCoun = 0
For Each Ct In Array("TextBox1", "TextBox4")
A_TCoun = A_TCoun + 1
ReDim Preserve Tx_1(1 To A_TCoun)
Set Tx_1(A_TCoun).A_Tx_1 = Me.Controls(Ct)
Next Ct
t = 4
Do
ComboBox1.AddItem Sheets("MyDate").Cells(t, 1)
t = t + 1
Loop Until Sheets("MyDate").Cells(t, 1) = ""
Me.Label1.Caption = Sheets("MyDate").Cells(3, 1)
Me.Label2.Caption = Sheets("MyDate").Cells(3, 2)
Me.Label3.Caption = Sheets("MyDate").Cells(3, 1)
Me.Label4.Caption = Sheets("MyDate").Cells(3, 2)
End Sub
Private Sub ComboBox1_Change()
TextBox1 = ""
B_A False, False
For i = 4 To Sheets("MyDate").Range("A1000").End(xlUp).Row
If ComboBox1 = Sheets("MyDate").Cells(i, 1) Then
TextBox2 = Sheets("MyDate").Cells(i, 1).Offset(0, 3)
Exit For
End If
Next
If TextBox2 = "مشاهدة وتعديل" Then B_A True, False
End Sub
Private Sub B_A(ByVal V_a As Boolean, ByVal E As Boolean)
If ComboBox1 = "الدعم الفني" Then
CommandButton5.Visible = V_a: CommandButton5.Enabled = E: CommandButton6.Visible = V_a
CommandButton6.Enabled = E: CommandButton4.Visible = V_a: CommandButton4.Enabled = E

 Else
 CommandButton5.Visible = 0: CommandButton5.Enabled = 0
 CommandButton4.Visible = 0: CommandButton4.Enabled = 0
 CommandButton6.Visible = 0: CommandButton6.Enabled = 0
End If
  CommandButton3.Visible = V_a
  TextBox3.Visible = V_a
     TextBox4.Visible = V_a
     TextBox3.Enabled = E
     TextBox4.Enabled = E
     Label3.Visible = V_a
  Label4.Visible = V_a
  CommandButton3.Enabled = E
  
  End Sub
Private Sub CommandButton1_Click()
Dim i As Integer, MyRow As Integer, ii As Integer, Abu_Ahmed As Boolean
Dim Sh_A As Worksheet
On Error Resume Next
Application.ScreenUpdating = False
For i = 4 To Sheets("MyDate").Range("A1000").End(xlUp).Row
If ComboBox1 = Sheets("MyDate").Cells(i, 1) And Val(TextBox1) = Sheets("MyDate").Cells(i, 2) Then
MyRow = Sheets("MyDate").Cells(i, 2).Row
Abu_Ahmed = True
GoTo 1
Exit For
End If
Next
' ========
1:
If Abu_Ahmed = True Then
Application.Visible = True

Sheets("Mydate").DisplayHeadings = False
Sheets("My Account").Cells(19, 5) = ComboBox1 & "   " & Format(Now(), "yyyy/mm/dd     hh:mm")

Sheets("MyDate").Cells(Sheets("MyDate").[C50000].End(xlUp).Row + 1, 3) = ComboBox1 & "  " & Format(Now(), "yyyy/mm/dd  hh:mm")
For ii = 5 To Sheets("MyDate").Range("IT3").End(xlToLeft).Column
If Sheets("MyDate").Cells(MyRow, ii) = "مشاهدة وتعديل" Then
 Sheets(Sheets("MyDate").Cells(3, ii).Text).Visible = -1
End If
If Sheets("MyDate").Cells(MyRow, ii) = "مشاهدة فقط" Then
Sheets(Sheets("MyDate").Cells(3, ii).Text).Visible = -1
Sheets(Sheets("MyDate").Cells(3, ii).Text).Unprotect (Sheets("mydate").Range("b4"))
Sheets(Sheets("MyDate").Cells(3, ii).Text).Cells.Locked = True
Sheets(Sheets("MyDate").Cells(3, ii).Text).Protect (Sheets("mydate").Range("b4"))
End If
'-------------------------------------------------------------------------------------
If Sheets("MyDate").Cells(MyRow, ii) = "مخفي" Then
Sheets(Sheets("MyDate").Cells(3, ii).Text).Visible = xlSheetVeryHidden
End If
'-----------------------------------------------------------------------------------
If Sheets("MyDate").Cells(MyRow, ii) = "مدخل بيانات" Then
Sheets(Sheets("MyDate").Cells(3, ii).Text).Visible = -1
Sheets(Sheets("MyDate").Cells(3, ii).Text).Unprotect (Sheets("mydate").Range("b4"))
Sheets(Sheets("MyDate").Cells(3, ii).Text).Cells.Locked = True
For i = 1 To Sheets(Sheets("MyDate").Cells(3, ii).Text).Cells(1, Columns.Count).End(xlToLeft).Column
If Sheets(Sheets("MyDate").Cells(3, ii).Text).Cells(1, i).Value = "T" Then
Sheets(Sheets("MyDate").Cells(3, ii).Text).Cells(1, i).EntireColumn.Locked = False
End If
Next
Sheets(Sheets("MyDate").Cells(3, ii).Text).Protect (Sheets("mydate").Range("b4"))
End If
'------------------------------------------------------------------------------------
Next
MsgBox "تفضل بالدخول", vbOKOnly, "تنبيه"
Me.Hide
With Sheets("My Account")
.Activate
.[IV1] = ""
.[IV1] = Me.ComboBox1

'----------------------------------------------------------------------------
.[IU1] = Sheets("mydate").Range("b4") 'لتخزين كلمه سر الادمن فى هذة الخليه
'----------------------------------------------------------------------------
End With
Else
MsgBox IIf(AA >= 2, "خروج", "دخول خاطئ حاول مرة أخرى "), vbOKOnly + 524288 + 1048576, "تنبيه"
ComboBox1 = "": TextBox1 = ""
AA = AA + 1
If AA > 2 Then Unload Me
Exit Sub
End If
ActiveWorkbook.Protect (Sheets("mydate").Range("b4")) 'لحمايه المستند بنفس كلمه سر الادمن
Application.ScreenUpdating = True
End Sub
Private Sub CommandButton2_Click()
Unload Me
End Sub
Private Sub CommandButton3_Click()
If TextBox3 = "" Or TextBox4 = "" Then MsgBox "الرجاء إكمال الحقول الناقصة", vbOKOnly, "تنبيه": TextBox3.SetFocus: Exit Sub
lr = Sheets("MyDate").Range("A1000").End(xlUp).Row
 Sheets("MyDate").Cells(lr + 1, 1) = TextBox3
 Sheets("MyDate").Cells(lr + 1, 2) = Val(TextBox4)
With UserForm2
 .CommandButton3.Caption = "حفظ جديد"
 .Label2.Visible = True
 .Label2.Caption = TextBox3
 .ComboBox1.Visible = False
 .Show
End With
End Sub
Private Sub CommandButton4_Click()
If Me.ComboBox1.Value = "الدعم الفني" Then
Dim t As Integer
With UserForm3
 .Label5.Caption = "شاشه تعديل كلمات السر  للمستخدمين"
 .ComboBox1.Value = Me.ComboBox1
t = 4
Do
.ComboBox1.AddItem Sheets("MyDate").Cells(t, 1)
t = t + 1
Loop Until Sheets("MyDate").Cells(t, 1) = ""
.Show
End With
Else
With UserForm3
.ComboBox1.Visible = False
.Label7.Visible = True
.Label5.Caption = "شاشه تعديل كلمات السر  للمستخدم"
.Label7.Caption = Me.ComboBox1
.Show
End With
End If
End Sub
Private Sub TextBox1_Change()
Dim a
If Me.TextBox2 = "مشاهدة وتعديل" Then a = 1 Else a = 0
If Len(d) = 0 Then B_A a, False
For i = 4 To Sheets("MyDate").Range("A1000").End(xlUp).Row
If ComboBox1 = Sheets("MyDate").Cells(i, 1) And Val(TextBox1) = Sheets("MyDate").Cells(i, 2) Then
B_A a, True
Exit For
End If
Next
End Sub
Private Sub B_e(E_a As Boolean)
CommandButton3.Enabled = E_a: TextBox3.Enabled = E_a: TextBox4.Enabled = E_a: CommandButton5.Enabled = E_a: CommandButton6.Enabled = E_a
End Sub
Private Sub B_Con(E_a As Boolean, V_a As Boolean)
 CommandButton3.Enabled = E_a
  CommandButton3.Visible = V_a
  CommandButton4.Enabled = E_a
     CommandButton4.Visible = V_a
      CommandButton6.Enabled = E_a
       CommandButton6.Visible = V_a
     TextBox3.Enabled = E_a
  TextBox3.Visible = V_a
  TextBox4.Enabled = E_a
 TextBox4.Visible = V_a
 Label3.Visible = V_a
 Label4.Visible = V_a
End Sub
Private Sub UserForm_Activate()

B_Con False, False
Application.Visible = False
ComboBox1.SetFocus
Label6.Visible = False
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode = vbFormControlMenu Then Cancel = True
MsgBox " !!! سوف يتم اغلاق البرنامج نهائياً "
Application.DisplayAlerts = False
Application.Quit
End Sub

عبدالله بشير عبدالله · يناير 18, 2021

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

اغتقد ان اوفيس 2010 يشتغل على 32 بث اما الاخر 2013 يشتغل على 64 بث ولهذا يظهر الخطأ

ضع هذه الدالة " PtrSafe " بين كلمتى "Declare" و "Function"فى كل سطر تجد فيه هاتين الكلمتين

Private Declare PtrSafe Function SetWindowLong Lib "User32.dll" Alias "SetWindowLongA" (ByVal HWnd As LongPtr, ByVal nIndex As LongPtr, ByVal dwNewLongPtr As LongPtr) As LongPtr

Private Declare PtrSafe Function FindWindow Lib "USER32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long

ربما هذا الرابط به الافادة

https://xlttn.com/vba/32-bit-and-64-bit-api-declarations-for-vba-developers/

خالد حرب · يناير 18, 2021

السلام عليكم

شكرا استاد عبدالله على الرد

اخي الكريم

تم وضع " PtrSafe " كما تفظلت و لكن اصبحنا في هذا الخطأ

فما هو الحل في وجهة نظرك

عبدالله بشير عبدالله · يناير 18, 2021

اخي لا استطيع ان اجزم سبب الخطأ ولكن هناك اكواد لا تشتغل على 64 حتى ان تم اصلاح هذا الخطأ توقع ظهور اخطاء غيرها استبدل الاربع سطور الاولى بالدالة التالية

Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As Long
Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long

Private Const Gvl_style As Long = (-16)
Private Const ws_thinkfime As Long = &H4000
Const min_box As Long = &H20000
Const max_box As Long = &H10000

Private Declare PtrSafe Function droemenubar Lib "user32.dll" (ByVal hvnd As Long) As Long
Private Declare PtrSafe Function GetForegroundWindow Lib "user32" () As LongPtr

او هذه

#If VBA7 Then
    #If Win64 Then
        Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongPtrA" (ByVal hWnd As LongPtr, ByVal nIndex As Long) As LongPtr
        Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongPtrA" (ByVal hWnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
    #Else
        Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As LongPtr, ByVal nIndex As Long) As Long
        Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
    #End If
    Private Declare PtrSafe Function WindowFromAccessibleObject Lib "oleacc" (ByVal pacc As IAccessible, phwnd As LongPtr) As Long
    Private Declare PtrSafe Function DrawMenuBar Lib "user32.dll" (ByVal hWnd As LongPtr) As Long
    Private Declare PtrSafe Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hWnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As Long
    Private hWnd As LongPtr
    Private lStyle As LongPtr
#Else
    Private Declare Function WindowFromAccessibleObject Lib "oleacc" (ByVal pacc As IAccessible, phwnd As Long) As Long
    Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
    Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
    Private Declare Function DrawMenuBar Lib "user32.dll" (ByVal hWnd As Long) As Long
    Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Private hWnd As Long
    Private lStyle As Long
#End If

Private Const GWL_STYLE = -16
Private Const WS_SYSMENU = &H80000
Private Const WS_MINIMIZEBOX = &H20000
Private Const WS_MAXIMIZEBOX = &H10000
Private Const WS_THICKFRAME = &H40000
Private Const WM_SYSCOMMAND = &H112
Private Const SC_MAXIMIZE = &HF030&

Private dInitWidth As Single
Private dInitHeight As Single

لا أستطيع التجربة لأن الويندوز لدي 32 بت واتمنى من لديه 64 بث تقديم المساعدة

خالد حرب · يناير 18, 2021

ارفق اليكم الملف لاجاء التعديلات اذا امكن

برنامج صلاحيات المستخدمين اصدار .xlsm

عبدالله بشير عبدالله · يناير 18, 2021

لم تنقل الدالة صحيحة الى ملفك

كما اخبرتك لا يمكنني التجربة لان جهازي يعمل على 32 بث

تم اظافة الكود السابق لملفك على الفورم1 ويشتغل على جهازي بكفاءة

جرب الملف وان لم يشتغل نتمنى من لديه نظام 64 تقديم المساعدة

برنامج صلاحيات المستخدمين اصدار (3).xlsm

**هانى محمد** · يناير 18, 2021

بارك الله فيك استاذ عبد الله الملف يعمل معى جيداً والنظام لدى 64 بت

بارك الله فيك

عبدالله بشير عبدالله · يناير 18, 2021

شكرا اخي هاني غلى افادتكم وجزاك الله كل خير

خالد حرب · يناير 18, 2021

السادة

عبدالله الصادي

هاني علي

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

تسجيل الدخول

اين الخطأ في هذا الكود

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

خالد حرب

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

خالد حرب

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

خالد حرب

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

هانى محمد

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

خالد حرب

Join the conversation

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

تصفح الموقع

تصفح جديد الموقع

Support

Important Information