محمد طاهر عرفه

يمكن التغيير عند فتح الملف بالكود التالي Private Sub Workbook_Open() Application.SendKeys "{f10}" Application.SendKeys "tms" Application.SendKeys "{tab}" Application.SendKeys "l" Application.SendKeys "{ENTER}" End Sub و إضافة الي ذلك ، يمكن السؤال عند غلق الملف ، هل ترغب فى التغيير ام لا و من ثم تحديد هل تريد حماية متوسطة m أم قصوي H و من ثن تنفيذ التغيير قبل غلق الملف و ذلك بالكود التالي Private Sub Workbook_BeforeClose(Cancel As Boolean) Dim z As String X = MsgBox("DO YOU WANT TO MODIFY SECURITY LEVEL ??", vbYesNo, "check for security level") If X = vbNo Then Exit Sub zz: z = UCase(InputBox("Press M for Medium adn H for High")) If z = "M" Then Application.SendKeys "{f10}" Application.SendKeys "tms" Application.SendKeys "{tab}" Application.SendKeys "m" Application.SendKeys "{ENTER}" Exit Sub ElseIf z = "H" Then Application.SendKeys "{f10}" Application.SendKeys "tms" Application.SendKeys "{tab}" Application.SendKeys "h" Application.SendKeys "{ENTER}" Exit Sub Else GoTo zz End If End Sub security2.zip

مثال علي فصل ، و جمع القيم الموجبة و السالبة بطريقتين بالفصل فى عمودين ثم الجمع باستخدام IF او بالجمع مباشرة باستخدام SumIF positive_neg.zip

المثال الثاني مثل السابق مع الحماية باستخدام كلمة سر و هي 1234 لأن الحالة السابقة يمكن فك الحماية من القوائم مباشرة Sub Pr1() ActiveSheet.Protect Password:=1234, DrawingObjects:=True, Contents:=True, Scenarios:=True End Sub Sub Pr2() x = InputBox("please enter PAssword '1234'", "Password", 123) If x <> 1234 Then MsgBox "Sorry You are not Allowed !!! " Exit Sub End If ActiveSheet.Protect Password:=1234, DrawingObjects:=False, Contents:=False, Scenarios:=False End Sub UnprotectSheetPass.xls

المثال الأول يقوم بعمل الحماية Sub Pr1() ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True End Sub ثم فكها اذا كتبنا كلمة السر و هي 123 Sub Pr2() x = InputBox("please enter PAssword '123'", "Password", 123) If x <> 123 Then MsgBox "Sorry !!! " Exit Sub End If ActiveSheet.Protect DrawingObjects:=False, Contents:=False, Scenarios:=False End Sub UnprotectSheet.rar

مرفق ملف به عدد 2 ماكرو الاول يسألك عن رقم اللون ، ثم يختار الخلايا التي بها لون الخط المناظر و الثاني يعرض لك ألوان الخطوط و ارقامها بدءا من الخلية الفعالة Sub list_Cashes() Dim fs, S, A Set fs = CreateObject("Scripting.FileSystemObject") Set A = fs.CreateTextFile("c:\" & "temp.txt", True) A.writeline "Pivots in File named : " & ActiveWorkbook.FullName & " : " A.writeline A.writeline "*********** Prepared By Mohamed Taher *****************" A.writeline For i = 1 To ActiveWorkbook.PivotCaches.Count Dim tmpLine As String tmpLine = "Pivot Cash no. " & i & " : " & ActiveWorkbook.PivotCaches(i).SourceData A.writeline (tmpLine) Next i A.Close Dim x x = Shell("notepad.exe c:\temp.txt", 1) End Sub Sub list_RefreshonopenValue() 'Open "c:\temp.txt" For Output As #1 'Lineinput ,#1 "koko" ' Close #1 Dim fs, S, A Set fs = CreateObject("Scripting.FileSystemObject") Set A = fs.CreateTextFile("c:\" & "temp.txt", True) A.writeline "Pivots in File named : " & ActiveWorkbook.FullName & " : " A.writeline A.writeline "*********** Prepared By Mohamed Taher *****************" A.writeline For i = 1 To ActiveWorkbook.PivotCaches.Count Dim tmpLine As String tmpLine = "Pivot Cash no. " & i & " refresh on open status : " & ActiveWorkbook.PivotCaches(i).RefreshOnFileOpen A.writeline (tmpLine) Next i A.Close Dim x x = Shell("notepad.exe c:\temp.txt", 1) End Sub Sub refresh() For i = 1 To ActiveWorkbook.PivotCaches.Count ActiveWorkbook.PivotCaches(i).refresh Next i End Sub Sub List_PivSources_PerSheet() Dim fs, S, A Set fs = CreateObject("Scripting.FileSystemObject") Set A = fs.CreateTextFile("c:\" & "temp.txt", True) A.writeline "Pivots per Sheet - in File named : " & ActiveWorkbook.FullName & " : " A.writeline A.writeline "*********** Prepared By Mohamed Taher *****************" A.writeline For j = 1 To ActiveWorkbook.Worksheets.Count A.writeline A.writeline "Sheet named : " & ActiveWorkbook.Worksheets(j).Name A.writeline "----------" For k = 1 To ActiveWorkbook.Worksheets(j).PivotTables.Count Dim tmpLine As String tmpLine = "source of pivot no. " & j & " : " & ActiveWorkbook.Worksheets(j).PivotTables(k).SourceData A.writeline (tmpLine) Next k Next j A.Close Dim x x = Shell("notepad.exe c:\temp.txt", 1) 'ActiveWorkbook.Worksheets("Sheet3").PivotTables(1) _ .PivotFields("Year").Orientation = xlRowField End Sub Sub Do_RefreshonOpen() 'True if the PivotTable cache or query table is automatically updated each time the workbook is opened 'For Each pc In ActiveWorkbook.PivotCaches ' pc.RefreshOnFileOpen = True 'Next For i = 1 To ActiveWorkbook.PivotCaches.Count ActiveWorkbook.PivotCaches(i).RefreshOnFileOpen = True Next i End Sub Sub No_RefreshonOpen() 'True if the PivotTable cache or query table is automatically updated each time the workbook is opened 'For Each pc In ActiveWorkbook.PivotCaches ' pc.RefreshOnFileOpen = False 'Next For i = 1 To ActiveWorkbook.PivotCaches.Count ActiveWorkbook.PivotCaches(i).RefreshOnFileOpen = False Next i End Sub Sub Change_PivotCashes_RangeName() Dim fs, S, A Set fs = CreateObject("Scripting.FileSystemObject") Set A = fs.CreateTextFile("c:\" & "temp.txt", True) A.writeline "Change Pivot Sources per Sheet - in File named : " & ActiveWorkbook.FullName & " : " A.writeline A.writeline "*********** Prepared By Mohamed Taher *****************" A.writeline Dim x As String x = InputBox("PLease enter the Pivot Source Range Name", "Range name selection for Pivots", "SalesVillas") For j = 1 To ActiveWorkbook.Worksheets.Count A.writeline A.writeline "Sheet named : " & ActiveWorkbook.Worksheets(j).Name A.writeline "================" For k = 1 To ActiveWorkbook.Worksheets(j).PivotTables.Count On Error GoTo errsub Dim y As String y = ActiveWorkbook.Worksheets(j).PivotTables(k).SourceData A.writeline "Before : " & y ActiveWorkbook.Worksheets(j).PivotTables(k).SourceData = Trim(x) A.writeline "After : " & Trim(x) Next k Next j A.Close Dim z z = Shell("notepad.exe c:\temp.txt", 1) Exit Sub errsub: MsgBox Str(Err.Number) + Err.Description + "Action is cancelled" 'return original source ActiveWorkbook.Worksheets(j).PivotTables(k).SourceData = y Exit Sub End Sub SelectByFontColor.rar

مرفق ملف به عدد 2 ماكرو الاول يسألك عن رقم اللون ، ثم يختار الخلايا التي بها اللون المناظر و الثاني يعرض لك الالوان و ارقامها بدءا من الخلية الفعالة Sub Find_By_foramt() reask: On Error GoTo errnumb Dim x As Byte x = InputBox("Enter the Color index", "enter color index", 4) errnumb: If Err.Number = 13 Then MsgBox "Type Mismatch, choose a number between 0 and 56" End If 'MsgBox Str(Err.Number) + " : " + Err.Description If IsNull(x) Or x > 56 Or Not IsNumeric(x) Then MsgBox " choose a number between 0 and 56" GoTo reask ' Exit Sub End If Dim Myrow As Long, MyCol As Long Myrow = Selection.Rows.Count MyCol = Selection.Columns.Count Mycells = Selection.Cells.Count Dim MyMatrix() As String, Myind As Long 'Dim myMultipleRange As Range, Mytemp As Range ReDim MyMatrix(Mycells) ' to overcome ubsidedown selection 'Dim myr As Range 'myr = ActiveSheet.Selection Selection.Cells(1, 1).Select Selection.Cells(1, 1).Activate 'myr.Select Myind = 0 For i = 0 To Myrow - 1 For j = 0 To MyCol - 1 If ActiveCell.Offset(i, j).Interior.ColorIndex = x Then Myind = Myind + 1 MyMatrix(Myind) = ActiveCell.Offset(i, j).Address End If Next j Next i If Myind = 0 Then Exit Sub Dim mm As String mm = MyMatrix(1) & "," For i = 2 To Myind - 1 mm = mm & MyMatrix(i) & "," Next If Myind > 0 Then mm = mm + MyMatrix(Myind) + "" Range(mm).Select End Sub Sub Listcolors() ActiveCell.Offset(0, 0).Value = "ColorIndex" ActiveCell.Offset(0, 1).Value = "Color" For i = 1 To 56 ' Selection.Cells.Count ActiveCell.Offset(i, 0).Value = i ActiveCell.Offset(i, 1).Interior.ColorIndex = i Next i End Sub SelectByCellColor.rar

فى مشاركة سابقة تم شرح الجداول المحورية من هنا و هذا شرح للمبتدئين اما هذه المشاركة فللمتقدمين فى استخدامها : هذه مجموعة أكواد أعددنها للتغلب علي موضوع تحديث عدد كبير من الجداول المحورية فى نفس الملف و تغيير مصدر بياناتها الي مجال محدد ( اسم ) و عرض و تغيير خاصية التحديث عند فتح الملف لها و عذرا ، فلن يستفيد منها الا من يستخدم الجداول المحورية بالفعل و بكفاءة اولا ملخص للاكواد فى المثال Macros in this Workbook: list_Cashes Lists All Pivot Cashes لسرد جميع مجموعات بيانات الجداول المحورية فى الملف List_PivSources_PerSheet List Pivot Table Sources Per Table Per Sheet للسرد لكل ورقة عمل علي حدة Change_PivotCashes_RangeName Change the Range name used as source for all Pivot Tables تغيير المجال المستخدم كمصدر بيانات refresh Refreshes all Pivot Cashes تحديث كل الجداول المحورية بالكود list_RefreshonopenValue Lists the Refresh on open Property Value for all Cashes سرد قيمة خاصية التحديث عند الفرز Do_RefreshonOpen No_RefreshonOpen To Enable and Disable Autorefresh of Pivot Table on Open للتحكم فى خاصية التحديث عند الفتح ثانيا الاكواد نفسها Sub list_Cashes() 'Open "c:\temp.txt" For Output As #1 'Lineinput ,#1 "koko" ' Close #1 Dim fs, S, A Set fs = CreateObject("Scripting.FileSystemObject") Set A = fs.CreateTextFile("c:\" & "temp.txt", True) A.writeline "Pivots in File named : " & ActiveWorkbook.FullName & " : " A.writeline A.writeline "*********** Prepared By Mohamed Taher *****************" A.writeline For i = 1 To ActiveWorkbook.PivotCaches.Count 'ActiveWorkbook.PivotCaches(i).Refresh 'Debug.Print "source of pivot no. "; 'Debug.Print i; 'Debug.Print " : "; 'Debug.Print ActiveWorkbook.PivotCaches(i).SourceData Dim tmpLine As String tmpLine = "Pivot Cash no. " & i & " : " & ActiveWorkbook.PivotCaches(i).SourceData A.writeline (tmpLine) Next i A.Close Dim x x = Shell("notepad.exe c:\temp.txt", 1) End Sub Sub list_RefreshonopenValue() 'Open "c:\temp.txt" For Output As #1 'Lineinput ,#1 "koko" ' Close #1 Dim fs, S, A Set fs = CreateObject("Scripting.FileSystemObject") Set A = fs.CreateTextFile("c:\" & "temp.txt", True) A.writeline "Pivots in File named : " & ActiveWorkbook.FullName & " : " A.writeline A.writeline "*********** Prepared By Mohamed Taher *****************" A.writeline For i = 1 To ActiveWorkbook.PivotCaches.Count Dim tmpLine As String tmpLine = "Pivot Cash no. " & i & " refresh on open status : " & ActiveWorkbook.PivotCaches(i).RefreshOnFileOpen A.writeline (tmpLine) Next i A.Close Dim x x = Shell("notepad.exe c:\temp.txt", 1) End Sub Sub refresh() For i = 1 To ActiveWorkbook.PivotCaches.Count ActiveWorkbook.PivotCaches(i).refresh Next i End Sub Sub List_PivSources_PerSheet() Dim fs, S, A Set fs = CreateObject("Scripting.FileSystemObject") Set A = fs.CreateTextFile("c:\" & "temp.txt", True) A.writeline "Pivots per Sheet - in File named : " & ActiveWorkbook.FullName & " : " A.writeline A.writeline "*********** Prepared By Mohamed Taher *****************" A.writeline For j = 1 To ActiveWorkbook.Worksheets.Count A.writeline A.writeline "Sheet named : " & Worksheets(j).Name A.writeline "----------" For k = 1 To Worksheets(j).PivotTables.Count Dim tmpLine As String tmpLine = "source of pivot no. " & j & " : " & Worksheets(j).PivotTables(k).SourceData A.writeline (tmpLine) Next k Next j A.Close Dim x x = Shell("notepad.exe c:\temp.txt", 1) 'Worksheets("Sheet3").PivotTables(1) _ .PivotFields("Year").Orientation = xlRowField End Sub Sub Do_RefreshonOpen() 'True if the PivotTable cache or query table is automatically updated each time the workbook is opened 'For Each pc In ActiveWorkbook.PivotCaches ' pc.RefreshOnFileOpen = True 'Next For i = 1 To ActiveWorkbook.PivotCaches.Count ActiveWorkbook.PivotCaches(i).RefreshOnFileOpen = True Next i End Sub Sub No_RefreshonOpen() 'True if the PivotTable cache or query table is automatically updated each time the workbook is opened 'For Each pc In ActiveWorkbook.PivotCaches ' pc.RefreshOnFileOpen = False 'Next For i = 1 To ActiveWorkbook.PivotCaches.Count ActiveWorkbook.PivotCaches(i).RefreshOnFileOpen = False Next i End Sub Sub Change_PivotCashes_RangeName() Dim fs, S, A Set fs = CreateObject("Scripting.FileSystemObject") Set A = fs.CreateTextFile("c:\" & "temp.txt", True) A.writeline "Change Pivot Sources per Sheet - in File named : " & ActiveWorkbook.FullName & " : " A.writeline A.writeline "*********** Prepared By Mohamed Taher *****************" A.writeline Dim x As String x = InputBox("PLease enter the Pivot Source Range Name", "Range name selection for Pivots", "SalesVillas") For j = 1 To ActiveWorkbook.Worksheets.Count A.writeline A.writeline "Sheet named : " & Worksheets(j).Name A.writeline "================" For k = 1 To Worksheets(j).PivotTables.Count On Error GoTo errsub Dim y As String y = Worksheets(j).PivotTables(k).SourceData A.writeline "Before : " & y Worksheets(j).PivotTables(k).SourceData = Trim(x) A.writeline "After : " & Trim(x) Next k Next j A.Close Dim z z = Shell("notepad.exe c:\temp.txt", 1) Exit Sub errsub: MsgBox Str(Err.Number) + Err.Description + "Action is cancelled" 'return original source Worksheets(j).PivotTables(k).SourceData = y Exit Sub End Sub PivotCodes.rar

هذا الكود كان ثاني تجربة لي فى برمجة الباوربوينت و قد أعددته بناء علي طلب أحد الأخوة ، و فى البداية استغربت لطلبه فهناك عدة وسائل للتنقل بين الشرائح المختلفة ، فلماذا تريد التنقل بضغط رقم اللوحة ؟؟ و كانت الاجابة ، أنه يرغب فى إخفاء لوحة المفاتيح ووصلها بأزرار لعمل عرض فيضغط المستخدم علي الزر الاحمر فيذهب للشريحة الاولي ... و هكذا المهم بعد عدة محاولات ، تم اعداد الكود و هو مناظر لاوفيس اكس بي و الشرح داخل الملف و الفكرة عبارة عن عمل add-in لأن تشغيل الاحداث تلقائيا عند تشغيل العرض فى الباوربوينت يتم عن طريق وضع الكود فى add-in مرفق الملف مع شرح كيفية توصيف ال add-in و أصل الكود لل add-in Dim X As New EventClassModule Sub Auto_Open() Call InitializeApp MsgBox "welcome to slide show by Keyboard numbers" & Chr(13) & Chr(13) & "By : Mohamed Taher Arafa " End Sub Public Sub InitializeApp() Set X.App = Application End Sub Public Sub activatef1() ActiveWindow.Selection.SlideRange.Shapes("Frame1").Select End Sub Public Sub moveit(KeyCode) Select Case KeyCode Case 49 MsgBox "You Pressed on 1 and you shall go to slide no 1" With SlideShowWindows(1).View .GotoSlide 1 End With Case 50 MsgBox "You Pressed on 2 and you shall go to slide no 2" With SlideShowWindows(1).View .GotoSlide 2 End With Case 51 MsgBox "You Pressed on 3 and you shall go to slide no 3" With SlideShowWindows(1).View .GotoSlide 3 End With Case 52 MsgBox "You Pressed on 4 and you shall go to slide no 4" With SlideShowWindows(1).View .GotoSlide 4 End With Case 97 MsgBox "You Pressed on 1 and you shall go to slide no 1" With SlideShowWindows(1).View .GotoSlide 1 End With Case 98 MsgBox "You Pressed on 2 and you shall go to slide no 2" With SlideShowWindows(1).View .GotoSlide 2 End With Case 99 MsgBox "You Pressed on 3 and you shall go to slide no 3" With SlideShowWindows(1).View .GotoSlide 3 End With Case 100 MsgBox "You Pressed on 4 and you shall go to slide no 4" With SlideShowWindows(1).View .GotoSlide 4 End With Case 27 MsgBox "You Pressed Esc, Good bye !!" With SlideShowWindows(1).View .Exit End With Case Else MsgBox " Sorry this example is prepared for only 4 slides," & Chr(10) & Chr(13) & _ "Choose a number from 1 to 4 please" & Chr(13) & Chr(13) & "Best Regards from : Mohamed Taher" End Select End Sub Public Sub openit() UserForm1.Show UserForm1.Left = 0 UserForm1.Top = 50 End Sub Public Sub starting() Call InitializeApp End Sub keyboardPresentation2.rar

فى الاكسس اكس بي المرجع الافتراضي هو ADO و اذا أردنا استخدام DAO فعلينا باضافته الي قائمة المراجع

الحكمة منها هو الغاء ارتباط الكائن المتغير mydb بالكائن الاصلي database أي أننا أنشأنا ارتباط فى البداية Dim mydb As database ثم قمنا بالاجراء ثم ألغينا الارتباط فى النهاية

المثال به عدد 2 كود الأول يقوم باخراج محتويات الثلاث خلايا الملونة بعد دمجها الي ملف نص و فتحهد و الثاني يقوم باخراج الخلايا فى سطور مستقلة Sub Macro2() a = Cells(3, 2) & "," & Cells(3, 3) & "," & Cells(3, 4) Dim Filename As String Filename = "c:\testfile.txt" Open Filename For Output As #1 Print #1, a Close #1 Dim x x = Shell("notepad.exe c:\testfile.txt", 1) End Sub Sub Macro3() a1 = Cells(3, 2) a2 = Cells(3, 3) a3 = Cells(3, 4) Dim Filename As String Filename = "c:\testfile.txt" Open Filename For Output As #1 Print #1, a1 Print #1, a2 Print #1, a3 Close #1 Dim x x = Shell("notepad.exe c:\testfile.txt", 1) End Sub و يلاحظ وجود طريقة أخري للكتابة فى ملف نص Sub anotherway() Dim fs, S, A Set fs = CreateObject("Scripting.FileSystemObject") Set A = fs.CreateTextFile("c:\" & "temp.txt", True) A.writeline "Pivots per Sheet - in File named : " & ActiveWorkbook.FullName & " : " A.writeline A.writeline "*********** Prepared By Mohamed Taher *****************" A.writeline A.Close Dim x x = Shell("notepad.exe c:\temp.txt", 1) End Sub WriteTotext.rar

هذا المثال يوضح كيفية استخدام Sumif Dsum Dcount للحصول علي عدد السجلات المختارة ، و مجموع حقل معين للقيم المختارة فى نموذج به مربع اختيار و التعبيرات المستخدمة كالتالي لعد السجلات : =Sum(IIf([HasLoan]=-1;1;0)) و =DCount("[hasloan]";"Table1";"[hasloan]=-1") و لجمع حقل معين : =Sum(IIf([HasLoan]=-1;[salary];0)) و =DSum("[Salary]";"Table1";"[hasloan]=-1") SumIF.rar

لنفرض أن لديك جدولان اللأول به بيانات الموظف ، و منها كود البلد و الثاني به الكود و الاسم للبلاد المختلفة كيف تجعل تسجيل البيانات فى الجدول الاول تم بالاختيار من بيانات الجدول الثاني؟ من وضع تصميم الجدول فى حقل كود البلد في جدول الموظف نختار ال tab المسماة Lookup و في خانة ال row source نختار من خلال المعالج ( الزر ذو الثلاث نقاط الذي يظهر عند الوقوف فى الخانة ) نختار تشغيل المعالج ثم show table و نختار الجدول الثاني و منه نختار حقلي الكود و اسم البلد فيتم بذلك تسجيل القيمة التالية فى خانة ال row source SELECT Table2.ContID, Table2.Contry FROM Table2; و بذلك فى وضع فتح الجدول العادي يمكن تسجيل و تعديل حقل كود البلد فى جدول الموظفين عن طريق الاختيار بين أسماء الدول و أيضا تستمر هذه الخاصية فى حالة ادراج الحقل فى نموذج أو تقرير المثال TableLook.zip

الكود DoCmd.RunSQL "INSERT INTO Table1 ( Name, Salary, Birthday ) select [Forms]![UnboundForm]![Name] as exp1, [Forms]![UnboundForm]![Salary] as exp2, [Forms]![UnboundForm]![Birthday] as exp3;" مرفق المثال UnboundSQL.zip

الكود : Dim mydb As database, mytable As Recordset Set mydb = CurrentDb Set mytable = mydb.OpenRecordset("table1", DB_OPEN_TABLE) mytable.AddNew mytable!Name = [Forms]![UnboundForm]![Name] mytable!Salary = [Forms]![UnboundForm]![Salary] mytable!Birthday = [Forms]![UnboundForm]![Birthday] mytable.Update mytable.Close Set mydb = Nothing مرفق المثال UnboundDAO.zip

الكود Dim mytable As ADODB.Recordset Set mytable = New ADODB.Recordset mytable.Open "TABLE1", ActiveConnection, adOpenDynamic mytable.AddNew mytable!Name = [Forms]![UnboundForm]![Name] mytable!Salary = [Forms]![UnboundForm]![Salary] mytable!Birthday = [Forms]![UnboundForm]![Birthday] mytable.Update mytable.Close مرفق المثال UnboundADO.zip