Ahmed mordy

للرفع

السلام عليكم ارجو من السادة الافاضل تعديل على الكود المرفق فى الملف بحيث اضغط على أي خلية ملونة باللون الاخضر ستظهر لك كمبوبكس اريد تعديل على الكود بحيث عند كتابة رقم فى الكمبوبوكس يعمل جمع على الرقم الموجود فى الخلية ولا يقوم بحذف الرقم الموجود فى الخلية وينطبق هذا على العمود A كله ولكم جزيل الشكر texte prédictive 2007.rar

السلام عليكم كل عام وانتم بخير ما هو الحل فى البيانات تظهر في list box مرة يمين و مرة شمال واريدها تظهر فى اتجاه واحد ولكم الشكر

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

السادة خبراء المنتدي ارجو المساعدة في المطلوب هل انا مش قادر اوصل المطلوب ولا المطلوب صعب بس انا استبعد ان المطلوب صعب لان خبراء المنتدي لا يستصعب عليهم امرا ان شاءالله

للرفع

السلام عليكم مهندس طه اشكرك علي التفاعل ولكن انا لم اقوم بالتوضيح هذا الكود قسمين انا اوريد اضافة القسم الاول الي القسم الثاني من الكود الثاني

السلام عليكم أرجو الأفادة أين يوضع هذا الكود For ii = 0 To Frame1.ListCount – 1 '======================================================================= TextBlock = Val(TextBlock) + Val(Format(Frame1.List(ii, 10), "0")) TextPass.Value = Val(TextPass) + Val(Format(Frame1.List(ii, 9), "0")) TextTotal.Value = Val(TextPass) + Val(TextBlock) '================================================================ Next '======================================================================= TextBlock.Value = Format(TextBlock.Value, "###0") TextPass.Value = Format(TextPass.Value, "###0") TextTotal.Value = Format(TexTotal.Value, "###0") '====================================================== فى هذا الكود Option Explicit '****************************************************** '****************************************************** ' اسم ورقة البيانات Private Const Mysh_Name As String = "DATA" '------------------------------------------------------ ' رقم عمود البحث Private Const MyFind_Column As Integer = 2 '------------------------------------------------------ ' ارتفاع الكنترول Private Const iHeight As Integer = 20 '****************************************************** '****************************************************** Private Sub kh_Find(MyText As String) Dim MyHght, MyTp Dim Last As Integer, ii As Integer, T As Integer '=========================================== With Me.Frame1 MyTp = .Controls(0).Top + .Controls(0).Height + 2 T = .Controls.Count End With '=========================================== With Worksheets(Mysh_Name) Last = .Cells(.Rows.Count, MyFind_Column).End(xlUp).Row For ii = 2 To Last If CStr(.Cells(ii, MyFind_Column)) Like IIf(Me.Check_Text.Value, "", "*") & MyText & "*" Then MyHght = .Rows(ii).RowHeight If MyHght < iHeight Then MyHght = iHeight kh_Add_Controls Me.Frame1, MyTp, MyHght, .Cells(ii, MyFind_Column).Row, T MyTp = MyTp + MyHght + 2 End If Next End With If MyTp >= Me.Frame1.Height Then Me.Frame1.ScrollHeight = MyTp End Sub Private Sub kh_Add_Controls(MyCont As Control, MyTop, MyHeight, iRo As Integer, MyCount As Integer) 'On Error Resume Next Dim MyTxt As Control Dim i As Integer For i = 1 To MyCount Set MyTxt = MyCont.Add("Forms.TextBox.1", Cells(iRo, i).Address, True) With MyTxt .Move MyCont.Controls(i - 1).Left, MyTop, MyCont.Controls(i - 1).Width, MyHeight .MultiLine = True '=========================================== .ControlSource = "'" & Mysh_Name & "'!" & Range(.Name).Address '=========================================== End With '======================================== With Worksheets(Mysh_Name).Cells(iRo, i) MyTxt.TextAlign = Me.kh_TextAlign(.HorizontalAlignment) MyTxt.Font.Bold = .Font.Bold MyTxt.Font.size = .Font.size MyTxt.FontName = .Font.Name End With '======================================== Next i '================== Set MyTxt = Nothing '================== 'On Error GoTo 0 '=========================================== End Sub Private Sub kh_Remove() On Error Resume Next Dim MyCon As Control Me.Frame1.ScrollHeight = 0 For Each MyCon In Me.Frame1.Controls If TypeName(MyCon) = "TextBox" Then Me.Frame1.Controls.Remove MyCon.Name End If Next MyCon On Error GoTo 0 End Sub Private Sub Button_Find_Click() Dim WBK As Workbook Set WBK = Workbooks.Open(ThisWorkbook.Path & "\daily Report.xlsb") kh_Remove If Len(Trim(Me.TextBox_Find.text)) Then kh_Find Me.TextBox_Find WBK.Close SaveChanges:=True End If End Sub Private Sub CommandButton12_Click() Shell "calc" End Sub Private Sub CommandButton2_Click() Unload Me End Sub Private Sub Frame1_Click() End Sub Private Sub Label9_Click() End Sub Private Sub TextBox_Find_Change() kh_Remove End Sub Function kh_TextAlign(MyAlign) As Integer Dim Ag Dim A As Integer For A = 1 To 3 Ag = Choose(A, -4131

السلام عليكم كل عام وانتم بخير كيف يتم جمع عمود في ListBox1 وتظهر النتيجة في TextBox1 وجمع محتوي TextBox1 و TextBox2 ولكم الشكر

السلام عليكم كل عام وانتم بخير كيف يتم جمع عمود في ListBox1 وتظهر النتيجة في TextBox1 وجمع محتوي TextBox1 و TextBox2 ولكم الشكر

للرفع

للرفع

هل لا احد يريد المساعدة

السادة الافاضل هذا الكود يتعارض مع اوفيس 2016 حتي بعد اضافة دالة ptrsafe ارجو الافادة وما هو الحل بارك الله فيكم Option Explicit '//////////////////////////////////////////////////////////////////// 'Password masked inputbox 'Allows you to hide characters entered in a VBA Inputbox. ' 'Code written by Daniel Klann 'March 2003 '//////////////////////////////////////////////////////////////////// 'API functions to be used Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, _ ByVal ncode As Long, ByVal wParam As Long, lParam As Any) As Long Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" _ (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, _ ByVal dwThreadId As Long) As Long Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long Private Declare Function SendDlgItemMessage Lib "user32" Alias "SendDlgItemMessageA" _ (ByVal hDlg As Long, ByVal nIDDlgItem As Long, ByVal wMsg As Long, _ ByVal wParam As Long, ByVal lParam As Long) As Long Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, _ ByVal lpClassName As String, _ ByVal nMaxCount As Long) As Long Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long 'Constants to be used in our API functions Private Const EM_SETPASSWORDCHAR = &HCC Private Const WH_CBT = 5 Private Const HCBT_ACTIVATE = 5 Private Const HC_ACTION = 0 Private hHook As Long Public Function NewProc(ByVal lngCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long Dim RetVal Dim strClassName As String, lngBuffer As Long If lngCode < HC_ACTION Then NewProc = CallNextHookEx(hHook, lngCode, wParam, lParam) Exit Function End If strClassName = String$(256, " ") lngBuffer = 255 If lngCode = HCBT_ACTIVATE Then 'A window has been activated RetVal = GetClassName(wParam, strClassName, lngBuffer) If Left$(strClassName, RetVal) = "#32770" Then 'Class name of the Inputbox 'This changes the edit control so that it display the password character *. 'You can change the Asc("*") as you please. SendDlgItemMessage wParam, &H1324, EM_SETPASSWORDCHAR, Asc("*"), &H0 End If End If 'This line will ensure that any other hooks that may be in place are 'called correctly. CallNextHookEx hHook, lngCode, wParam, lParam End Function Public Function InputBoxDK(Prompt, Optional Title, Optional Default, Optional XPos, _ Optional YPos, Optional HelpFile, Optional Context) As String Dim lngModHwnd As Long, lngThreadID As Long lngThreadID = GetCurrentThreadId lngModHwnd = GetModuleHandle(vbNullString) hHook = SetWindowsHookEx(WH_CBT, AddressOf NewProc, lngModHwnd, lngThreadID) ! InputBoxDK = InputBox(Prompt, Title, Default, XPos, YPos, HelpFile, Context) UnhookWindowsHookEx hHook End Function

للرفع

السلام عليكم ارجو من السادة الخبراء مساعدتي في عمل المطلوب

السلام عليكم استاز ناصر بارك الله في حضرتك انظر حضرتك الي المشاركة الاولي هذا جزئ من اكواد تعمل في ملف عندي اما المشكلة فهي نتيجة لتنصيب اوفيس اصدار 2016 علي وندوز 64 ولكن هذا الملف يعمل جيدا علي جميع اصدارات الاوفيس من 2007 الي اوفيس 2013 وتم طرح المشكلة وافادني الاستاز زيزو بارك الله فيه بالداله وتم اضافة الدالة علي حسب توجيهات الاستاز زيزو وهي تعمل الان جيدا الحمد لله باقي الكود الموجود في المشاركة الرابعة وهو كود خاص بإظهار رقم الباسورد علي شكل نجوم

للرفع

للرفع

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

استاذ زيزو اشكرك علي الافادة سوف اجربها لي سوءال بعد وضع هذه الدالة تعمل بشكل طبيعي في باقي الاصدارات ام ستتعارض معها وشكرا

السلام عليكم هذه الاكواد تعطي خطأ في اوفيس 2016 ما هو السبب وما هو التعديل اللازم لكي تعمل علي هذا الاصدار وجميع الاصدارات Private Declare Function GetKeyboardLayoutName Lib "USER32" Alias "GetKeyboardLayoutNameA" (ByVal pwszKLID As String) As Long Private Declare Function LoadKeyboardLayout Lib "USER32" Alias "LoadKeyboardLayoutA" (ByVal pwszKLID As String, ByVal flags As Long) As Long Private Declare Function GetKeyboardLayoutList Lib "USER32" (ByVal size As Long, ByRef Layouts As Long) As Long Private Declare Function ActivateKeyboardLayout Lib "USER32" (ByVal HKL As Long, ByVal flags As Long) As Long ************* Private Declare Function GetActiveWindow Lib "USER32" () As Long 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 GetWindowLong Lib "USER32" Alias "GetWindowLongA" _ (ByVal hWnd As Long, _ ByVal lngWinIdx As Long) As Long Private Declare Function SetLayeredWindowAttributes Lib "USER32" _ (ByVal hWnd As Long, _ ByVal crKey As Integer, _ ByVal bAlpha As Integer, _ ByVal dwFlags As Long) As Long Private Const WS_EX_LAYERED = &H80000 Private Const LWA_ALPHA = &H2 Private Const GWL_EXSTYLE = &HFFEC Dim hWnd As Long Dim Transparancy As Integer Dim Running As Boolean ************* Private Declare Function FindWindow Lib "USER32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) 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, ByVal dwNewLong As Long) As Long Private Declare Function DrawMenuBar Lib "USER32" (ByVal hWnd As Long) As Long Const GWL_STYLE = -16 Const WS_CAPTION = &HC00000 Const WS_SYSMENU = &H80000

ارجو من خبراء المنتدي مساعدتي في المطلوب

للرفع

يشرفني مرور حضرتك ا/حسام مصطفي بالفعل الملفات تعمل جيدا علي ويندوز 32 و 64 وجميع اصدارات الاوفيس ولكن عند نقل الملف علي جهاز يعمل بنسخة اوفيس 2016 لا يعمل وهذا ما احاول اعرفة حتي يعمل الملف علي كل الاصدارات وشكرا لمرور حضرتك ارجو من خبراء المنتدي افادتنا عن السبب حتي لا تقف الاعمال عند اصدار معين