SEMO.Pa3x

موفق ان شاء الله عزيزي.

السلام عليكم ورحمة الله وبركاته.. اقدم لكم مجموعة من واجهات المستخدم (user interface) عسى ان تفيدكم في تحسين مظهر البرامج الخاصة بكم. المصدر: https://github.com/krishKM/Modern-UI-Components-for-VBA لا تنسوني ووالدي من صالح دعائكم.. تحميل المرفق الأول: sample_x64.zip تحميل المرفق الثاني: sample_x86.zip

السلام عليكم ورحمة الله وبركاته.. كما في العنوان هذه بعض من دوال الاكسس VBA عسى ولعل تفيدكم. Public Function createFolder(path As String, Optional failIfAlreadyExists As Boolean = False) As Boolean On Error GoTo handleError Dim FSO As Object Set FSO = CreateObject("Scripting.FileSystemObject") If path <> "" Then FSO.createFolder path End If If folderExists(path) Then createFolder = True Else createFolder = False End If GoTo handleSuccess Exit Function handleSuccess: GoTo cleanUp Exit Function handleError: If Err.Number = 58 And Not failIfAlreadyExists Then createFolder = True Else Call fileSystem.handleError(Err.Number, Err.Description, "createFolder()", path) End If GoTo cleanUp cleanUp: Set FSO = Nothing Exit Function End Function Public Function deleteFile(path As String) As Boolean On Error GoTo handleError Dim FSO As Object Set FSO = CreateObject("Scripting.FileSystemObject") If path <> "" And fileExists(path) Then FSO.deleteFile path Else Exit Function End If If fileExists(path) Then deleteFile = False Else deleteFile = True End If GoTo handleSuccess Exit Function handleSuccess: Call fileSystem.handleSuccess GoTo cleanUp Exit Function handleError: Call fileSystem.handleError(Err.Number, Err.Description, "deleteFolder()", path) GoTo cleanUp Exit Function cleanUp: Set FSO = Nothing Exit Function End Function Public Function deleteFolder(path As String) As Boolean On Error GoTo handleError Dim FSO As Object Set FSO = CreateObject("Scripting.FileSystemObject") If path <> "" And folderExists(path) Then path = IIf(Right(path, 1) = "\", Left(path, Len((path)) - 1), path) FSO.deleteFolder path Else Exit Function End If If folderExists(path) Then deleteFolder = False Else deleteFolder = True End If GoTo handleSuccess Exit Function handleSuccess: Call fileSystem.handleSuccess GoTo cleanUp Exit Function handleError: Call fileSystem.handleError(Err.Number, Err.Description, "deleteFolder()", path) GoTo cleanUp cleanUp: Set FSO = Nothing Exit Function End Function Public Function driveExists(path As String) As Boolean On Error GoTo handleError Dim FSO As Object Set FSO = CreateObject("Scripting.FileSystemObject") If path <> "" Then driveExists = FSO.driveExists(path) End If GoTo handleSuccess Exit Function handleSuccess: Call fileSystem.handleSuccess GoTo cleanUp Exit Function handleError: Call fileSystem.handleError(Err.Number, Err.Description, "driveExists()", path) GoTo cleanUp cleanUp: Set FSO = Nothing Exit Function End Function Public Function fileExists(path As String) As Boolean On Error GoTo handleError Dim FSO As Object Set FSO = CreateObject("Scripting.FileSystemObject") If path <> "" Then fileExists = FSO.fileExists(path) End If GoTo handleSuccess Exit Function handleSuccess: Call fileSystem.handleSuccess GoTo cleanUp Exit Function handleError: Call fileSystem.handleError(Err.Number, Err.Description, "fileExists()", path) GoTo cleanUp cleanUp: Set FSO = Nothing Exit Function End Function Public Function folderExists(path As String) As Boolean On Error GoTo handleError Dim FSO As Object Set FSO = CreateObject("Scripting.FileSystemObject") If path <> "" Then folderExists = FSO.folderExists(path) End If GoTo handleSuccess Exit Function handleSuccess: Call fileSystem.handleSuccess GoTo cleanUp Exit Function handleError: Call fileSystem.handleError(Err.Number, Err.Description, "folderExists()", path) GoTo cleanUp cleanUp: Set FSO = Nothing Exit Function End Function Public Function getComputerName() getComputerName = Environ("COMPUTERNAME") End Function Public Function getUserDesktopPath(Optional endWithSlash As Boolean = True) getUserDesktopPath = getUserProfilePath & "Desktop" & IIf(endWithSlash, "\", "") End Function Public Function getCurrentUsername() getCurrentUsername = Environ("USERNAME") End Function Public Function getUserProfilePath(Optional endWithSlash As Boolean = True) getUserProfilePath = Environ("USERPROFILE") & IIf(endWithSlash, "\", "") End Function Public Function getHomeDrive() getHomeDrive = Environ("HOMEDRIVE") End Function Public Function getHomePath(Optional includeDrive As Boolean = True, Optional endWithSlash As Boolean = True) getHomePath = IIf(includeDrive, getHomeDrive, "") & Environ("HOMEPATH") & IIf(endWithSlash, "\", "") End Function '''''''''''''''''''''''''''' ' ' Name: contains() ' Library: Strings.accda ' Author: Wyatt Castaneda ' Last Update: 23-Mar-19 ' Description: Searchs an arbitary number of strings for a substring ' ' Example(s): contains("wyatt", "wyatt", "james", "amber") --> true ' contains("scott", "wyatt", "james", "amber") --> false ' '''''''''''''''''''''''''''' Public Function contains(toCheck As String, ParamArray searchTerms()) As Boolean Dim term As Variant contains = False For Each term In searchTerms If InStr(toCheck, term) <> 0 Then GoTo doesContainString End If Next Exit Function doesContainString: contains = True Exit Function End Function Public Function lowerCase(toFix As String) As String On Error GoTo failGracefully lowerCase = StrConv(toFix, vbLowerCase) Exit Function failGracefully: lowerCase = toFix Exit Function End Function Public Function upperCase(toFix As String) As String On Error GoTo failGracefully upperCase = StrConv(toFix, vbUpperCase) Exit Function failGracefully: upperCase = toFix Exit Function End Function لا تنسوني ووالدي من صالح دعائكم.

شكرا لكم اساتذتي الافاضل @ابوخليل @jjafferr ربي يحفظكم ويبارك فيكم

الاستاذ @ابوخليل يبدو ان محاولتك قد نجحت بالفعل فقط امهلني ليوم غد حتى اجرب على البرنامج الرئيسي وايضا الباب مفتوح لباقي الاخوان لمن يحب ان يدلو بدلوه فكما يقول استاذي @jjafferr

الاساتذة الكرام: @ابوخليل @jjafferr ارجو ان يتسع صدركم وتتحملوني لاني اواجه مشكلة في توصيل الفكرة في الشرح سأشرح مرة اخرى: عندما اقوم بتحديد مواد من النموذج مثلا ( مدفأة، غسالة ) اريد ان يقوم بجلب الاشخاص الذين لم يستلمو هذه المواد الاثنان يعني لازم يتحقق الشرط مواد اثنان اما لو كان هناك اشخاص استلمو احد هذه المواد لا اريد ان يعرضلي اسمائهم يجب ان يكونو الاشخاص لم يستلمو هذه المواد المواد تتغير مثلا اختار مادة واحدة او مجموعة مواد فيقوم هو بالبحث ويجب ان يكونو الناس لم يستلمو ولا مادة من المواد المختارة لم افهم قصدك

ماهو الخطأ الذي ظهر لك؟ ياحبذا لو صورة للخطأ

عليكم السلام.

للأسف اخي ابو خليل ليس ما اريده اريد من لم يستلمو X مادة وليس العكس واريد الشرط ان يكون اكثر من مادة مثلا من لم يستلم مدفأة، بطانية, مروحة لازم الـ 3 لم يستلم ولا واحدة منهم واذا كان مستلم ولو واحدة منهم لا يعرضلي اسمة شكرا للاطراء

السلام عليكم ورحمة الله وبركاته.. لدي عدد من المستفيدين استلمو العديد من المساعدات على مر السنين الان اريد ان اقوم بعمل فلترة لهم اريد جلب المستفيدين الذين لم يستلمو X مساعدة بين تاريخين مثلا: لدي ( أحمد ) استلم ( طباخ ) لدي ( فاطمة ) استلمت ( طباخ, غسالة ) لدي ( زيد ) استلم ( طباخ, تلفاز ) لدي ( صفاء ) استلمت ( تلفاز، مروحة ) لدي ( نور ) استلمت ( ميكرويف، مكيف ) سأقول للبرنامج اجلب لي الناس الذي لم يستلمو ( طباخ، غسالة ) يعني يجب ان يكون الشخص لم يستلم المادتين معا لو كان مستلم طباخ فقط! او غسالة فقط لا يظهره اما لو كان لم يستلم الاثنين معاً سيظهره لي في الشاشة سيقوم البرنامج بجلب: أحمد زيد صفاء نور لماذا لم يقم بجلب فاطمة؟ لانها استلمت بالفعل طباخ، غسالة يعني تحقق الشرط هنا قلت للبرنامج يجب تحقيق 3 شروط، ان يكون الشخص غير مستلم ( عسل, غذاء سفري, غذائية ) يجب ان يكون غير مستلم لهؤلاء الثلاثة معاً اظهره لي.. قمت باستعمال SubQuery ونجح معي لكن عندما يكون عدد السجلات بالآف يكون بطيئ جدا ويستغرق وقت طويل جدا، ممكن اي احد لديه فكرة او حل لمشكلتي Not In (SELECT BenId FROM tbl_assistances WHERE AssistanceDate Between CDate([Forms]![frm_exist_not_assistance]![FromDate]) And CDate([Forms]![frm_exist_not_assistance]![ToDate]) And MaterialeId IN (select Id from [tbl_materiales] where SEL_EXIST = -1)) ملاحظة: النموذج frm_exist_not_assistance يستغرق وقت طويل جدا بالفتح والسبب ذكرته في الاعلى وشكرا لكم NotExists.accdb

السيد الاستاذ، هل اعتبر الهدف من الموضوع هو تحدي لاي شخص يعدل الاستعلام بطريقته الخاصة بحيث نتيجة الاستعلام تكون سريعة. اذا كان هذا الهدف يرجى توضيح ماهو المطلوب عمله، لكي احاول معه الليلة.

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

قد يقوم البعض بإستعمالها ويرى انها سريعة جدا لانه يملك عدد سجلات قليلة، وهذا ما حصل معي أذكر انني في احد برامجي في سنين سابقا استخدمت Dlookup في الاستعلام وكان الاستعلام سريع جدا، لانني املك 10 سجلات فقط. وعندما وصل عدد السجلات الى الآلاف اصبح برنامجي كالسلحفاة 🐢 ههه

اهلا بالمعلم.. هل يمكن استخدام SubQuery ؟

السلام عليكم.. اداة صغيرة مكتوبة كـ مفتاح registry عند تشغيلها ستقوم باضافة خيار جديد في الزر الايمن للماوس وضيفته جلب مسار الملفات والمجلدات لسرعه الوصول لها في البرامج او غيرها.. الاداة ليست من كتابتي انما فقط قمت بالتعديل عليها.. سورس الاداة: Windows Registry Editor Version 5.00 ; ########################################## ; Application : Get files/directories path by right click windows ; Coded by : Dr.Hassanien (SEMO.Pa3x) ; Date : 28-2-2022 ; ########################################## [HKEY_CLASSES_ROOT\Allfilesystemobjects\shell\windows.copyaspath] "CanonicalName"="{707C7BC6-685A-4A4D-A275-3966A5A3EFAA}" "CommandStateHandler"="{3B1599F9-E00A-4BBF-AD3E-B3F99FA87779}" "CommandStateSync"="" "Description"="@shell32.dll,-30336" "Icon"="imageres.dll,-5302" "InvokeCommandOnSelection"=dword:00000001 "MUIVerb"="@shell32.dll,-30329" "VerbHandler"="{f3d06e7c-1e45-4a26-847e-f9fcdee59be0}" "VerbName"="copyaspath" بعد تشغيل الاداة اضغط كلك يمين على اي ملف في الكومبيوتر او اي مجلد وستظهر لك: بعد نسخ اي مسار قم بلصقه، مثال: تحميل الملف من المرفقات لا تنسوني ووالدي من صالح دعائكم. تم بحمد الله. AddToRightClickWindows.rar

اهلاً بالمعلم.. ابشر ولا يهمك، تفضل سورس الاداة بلغة VB.NET : Imports Google.Apis.Drive.v3 Imports Google.Apis.Drive.v3.Data Imports Google.Apis.Auth.OAuth2 Imports Google.Apis.Services Imports System.Threading Module GDU Dim ClientId As String = "" Dim ClientSecret As String = "" Dim ApplicationName As String = "" Dim FileName As String = "" Dim Extension As String = "" Dim FullPath As String = "" Dim CurrentPath As String = "" Dim IDFolderSave As String = "" Dim IsMessage As Boolean Dim IsCustomeFolder As Boolean ''' ########################################## ''' Application : Google Drive Uploader ''' Coded by : Dr.Hassanien (SEMO.Pa3x) ''' Date : 12-2-2022 ''' ########################################## Sub Main() Try Console.Title = "Google Drive Uploader - coded by Dr.Hassanien (SEMO.Pa3x)" Dim ARGS() As String For Each arg As String In My.Application.CommandLineArgs '--------------------------- '0 = Path '1 = ClientId '2 = ClientSecret '3 = ApplicationName '4 = FileName '--------------------------- ARGS = Split(arg, "~||~") 'split arg to parts FullPath = ARGS(0) Extension = System.IO.Path.GetExtension(FullPath).ToString.ToLower ClientId = ARGS(1) ClientSecret = ARGS(2) ApplicationName = ARGS(3) FileName = ARGS(4) IDFolderSave = ARGS(5) IsCustomeFolder = IIf(IDFolderSave = "", False, True) IsMessage = CBool(ARGS(6)) 'set new path CurrentPath = AppDomain.CurrentDomain.BaseDirectory & "BK" & Extension 'check exist path If System.IO.File.Exists(CurrentPath) Then System.IO.File.Delete(CurrentPath) End If 'copy to other location to use it System.IO.File.Copy(FullPath, CurrentPath) Next Console.ForegroundColor = ConsoleColor.Green Console.WriteLine("Upload process has started, please wait...") UploadFile(CurrentPath) Catch ex As Exception MsgBox(ex.Message) Console.ForegroundColor = ConsoleColor.Red Console.WriteLine(ex.Message) Console.ReadLine() End Try End Sub Private Service As DriveService = New DriveService Private Sub CreateService() Dim MyUserCredential As UserCredential = GoogleWebAuthorizationBroker.AuthorizeAsync(New ClientSecrets() With {.ClientId = ClientId, .ClientSecret = ClientSecret}, {DriveService.Scope.Drive}, "user", CancellationToken.None).Result Service = New DriveService(New BaseClientService.Initializer() With {.HttpClientInitializer = MyUserCredential, .ApplicationName = ApplicationName}) End Sub Public Sub SearchFolder() Try Dim findrequest As FilesResource.ListRequest = Service.Files.List Dim listFolder As Data.FileList = findrequest.Execute For Each item As File In listFolder.Files If item.MimeType = "application/vnd.google-apps.folder" Then If item.Id = IDFolderSave Then IDFolderSave = item.Id.ToString Exit For Else Console.ForegroundColor = ConsoleColor.Red Console.WriteLine("=============================================") Console.WriteLine("ERROR: Folder not found in google drive !") Console.WriteLine("=============================================") Console.ReadLine() End If End If Next Catch ex As Exception Throw ex End Try End Sub Private Sub UploadFile(FilePath As String) 'call service CreateService() 'check custome folder If IsCustomeFolder = True Then SearchFolder() End If Dim TheFile As New File() TheFile.Name = FileName & Extension TheFile.Description = "Description" 'check custome folder If IsCustomeFolder = True Then Dim plist As List(Of String) = New List(Of String) plist.Add(IDFolderSave) 'Set parent folder TheFile.Parents = plist End If Dim ByteArray As Byte() = System.IO.File.ReadAllBytes(FilePath) Dim Stream As New System.IO.MemoryStream(ByteArray) Dim UploadRequest As FilesResource.CreateMediaUpload = Service.Files.Create(TheFile, Stream, TheFile.MimeType) 'You were mmissing the Upload part! UploadRequest.Upload() Dim file As File = UploadRequest.ResponseBody System.IO.File.Delete(CurrentPath) If IsMessage = True Then Console.ForegroundColor = ConsoleColor.Green Console.WriteLine("") Console.WriteLine("") Console.WriteLine("") Console.WriteLine("=============================================") Console.WriteLine("File has been uploaded successfully....") Console.WriteLine("=============================================") Console.WriteLine("") Console.ForegroundColor = ConsoleColor.Gray Console.WriteLine("Press any key to exit...") Console.ReadLine() End If End Sub End Module

اهلا اخي ابو خليل. علامة عادية مثلها مثل اي علامة - , _ اوغيرها استخدمها لعمل split وتقطيع النص في الـ VB.NET مثال:

يوجد اداة اسمها NAPS للتعامل مع السكنر خصوصا السحب المتعدد والفيدر ابحث في مواضيع الاستاذ @jjafferr ان شاء الله في النسخة القادمة

عزيزي، عن اي 2003 تتحدث؟ الناس وصلت لتحديثات 2022

السلام عليكم ورحمة الله وبركاته... عود على بدء في موضوعي هذا: اقدم لكم النسخة الثانية من اداة رفع الملفات ونسخ الباك اب الى Google Drive لكن هذه المرة ستقوم الاداة بضغط الملف وتشفيرة بباسورد بأستخدام winRAR ومن ثم رفعه الى Google Drive لمنع اي شخص من الاطلاع على محتويات الملف المضغوط لان الضغط هنا سيكون Encrypt File Names بعبارة اخرى سيكون الملف المضغوط هكذا شكله: لن تستطيع ان تعرف ما يحويه الملف المضغوط من ملفات الا اذا قمت بوضع الباسورد. اضفت براميتر جديد على الاداة وهو باسورد الضغط، ستجدون كل شيء في ملف الاكسس، وباقي الامور شرحناها في الدرس السابق لا تنسوني ووالدي من صالح دعائكم. تم بحمد الله. GoogleDriveUploader_fixed.rar

حاليا لا يمكن. ربما في نسخة قادمة سيكون هذا الشي متاح.

نعم العدد مفتوح لعدد X من المستخدمين معنى الـ X مثلا لو كان لديك مليون شخص او الف او غيره يمكنك الارسال لهم بدون اي جهد. فقط حدد الاشخاص المطلوبين واكتب الرسالة ودع الاداة تقوم بالباقي.

سرني كثيراً انك وجدت ضالتك واستفدت من موضوعي، لم امر ابدا بنافذة الكريدت كارد لا اعلم ما الذي حدث معك بالضبط. بالمناسبة خطرت ببالي النسخة القادمة ان يقوم بضغط الملف winRAR ومحمي بباسورد ان شاء الله ساقوم بتعديله قريباً وارفاق النسخة في هذا الموضوع.

ارسل الارقام الان ع الخاص

شكرا لك، سأجرب واعود