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

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


إذهب إلى أفضل إجابة Solved by عبدالله الصاري,

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

السلام عليكم

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

علما بان هذا الكود يشتغل على اوفس 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

Capture147.PNG

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

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

اغتقد ان اوفيس 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/

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

اخي لا استطيع ان اجزم سبب الخطأ ولكن هناك اكواد لا تشتغل على 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 بث تقديم المساعدة

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

  • أفضل إجابة

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

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

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

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

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

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

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