جعفر الطريبق

التعديل التالي تقوم بتصغير اليوسرفورم الزاوبة العليا اليسرى للشاشة 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 Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long Private Const GWL_STYLE As Long = (-16) Private Const WS_SYSMENU As Long = &H80000 Private Const WS_MINIMIZEBOX As Long = &H20000 Private Const WS_MAXIMIZEBOX As Long = &H10000 Private Const SW_SHOWMAXIMIZED = 3 Private Declare Function IsIconic Lib "user32" (ByVal hwnd As Long) As Long Private lFormHandle As Long Private Sub UserForm_Activate() Dim lStyle As Long lFormHandle = FindWindow("ThunderDFrame", Me.Caption) lStyle = GetWindowLong(lFormHandle, GWL_STYLE) lStyle = lStyle Or WS_SYSMENU lStyle = lStyle Or WS_MINIMIZEBOX lStyle = lStyle Or WS_MAXIMIZEBOX SetWindowLong lFormHandle, GWL_STYLE, (lStyle) DrawMenuBar lFormHandle End Sub Private Sub CommandButton1_Click() Unload Me End Sub Private Sub UserForm_Resize() If IsIconic(lFormHandle) Then Me.Move 0, 0, 0, 0 End If End Sub

ألقيت نظرة على الملف و وجدت أن ال ProgressBar وراء الزر TEST2 يشتغل على جميع اصدارات الويندوز لأنه يعتمد على ليبل كونترول عادي

الكود التالي يطلب من المستخدم ادخال الباسوورد "123" عند افتتاح الملف لأول مرة على الجهاز ..لو الباسورد غلط فالملف يغلق نفسه تلقائيا ... لو المستخدم عمل كوبي للملف و فتح الكوبي على جهاز أخر فالكود يشتغل من جديد و يتم طلب الباسوورد في المرة الأولى فقط طبعا لو الماكروس غير شغالة ( Macros Disabled ) عند المستخدم فان الكود لن يعمل لكي لا يستطيع المستخدم رؤية الباسورد ينصح حماية ال VBAProject أضف الكود التالي الى ThisWorkbook Module : Private Sub Workbook_Open() Dim bool As Boolean On Error Resume Next bool = [DriveSN] = GetDriveSerialNumber On Error GoTo 0 Application.EnableCancelKey = xlDisabled If bool = False Then If InputBox("Enter the Password") <> "123" Then MsgBox "Wrong Password ..." & vbCrLf & "Workbook Closing !", vbExclamation Application.EnableCancelKey = xlInterrupt Me.Close False Else Names.Add "DriveSN", GetDriveSerialNumber, False: Me.Save End If End If Application.EnableCancelKey = xlInterrupt End Sub Private Function GetDriveSerialNumber() As Long Dim oFso As Object Set oFso = CreateObject("Scripting.FileSystemObject") With oFso.GetDrive(oFso.GetDriveName(Application.Path)) GetDriveSerialNumber = Abs(.SerialNumber) End With Set oFso = Nothing End Function

و الله ما فهمت ... لو أحد فهم يشرح لي هل هدا ما تقصده: 1- أول مرة يتم فتح الملف يطلب الباسوورد .. بعدها لا يطلب الباسوورد 2- في حالة أخد كوبي من الملف فان هدا الملف الجديد *يعني الكوبي* يطلب الباسوورد عند فتحه لأول مرة فقط ثم بعدها لا يطلب الباسوورد ثم هل الكوبي سيتم فتحه في نفس الحاسوب أو في حاسوب أخر

الموضوع غير واضح ... هل تقصد شيئ من هدا القبيل هدا الكود في ال ThisWorkbook Module يطلب من المستخدم الباسوورد اللي هو "123" عندما يفتح الملف و الماكرو مفعل ... لو الباسوورد غلط الملف يغلق نفسه Private Sub Workbook_Open() Application.EnableCancelKey = xlDisabled If InputBox("Enter Password") <> "123" Then MsgBox "Wrong Password" & vbCr & vbCr & "Workbook Closing Now !", vbExclamation Application.EnableCancelKey = xlInterrupt Me.Close True End If End Sub

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

السيد ياسر خليل هو من عرفني بهدا المنتدى و طلب منى الانضمام اليه ... أعرفه من خلال منتدى Excel4us ... انه انسان نشيط و متحمس جدا يحب الاكسيل و ال VBA و شغوف بالتعلم ... كما أنه شخص مرح و عنده روح دعابة ادعو له بالشفاء العاجل ان شاء الله

لم تتاح لي الفرصة لأعرفه و لأرى أعماله كوني التحقت بهدا المنتدى قبل بضعة أيام فقط لكن يبدو لي من خلال التعليقات أنه كان من أفضل و من أحب الأعضاء في المنتدى .. على أية حال هدا خبر حزين .. أتمنى لأسرته و أصدقائه و زملائه الصبر و السلوان و أدعو الله أن يتغمضه بواسع رحمته

ليس لدي الويندوز 8 لأجرب ... على أي جرب هدا التعديل في الملف : https://app.box.com/s/4r8gxnvov5vmqsd2hu029u25b97ero46

هل الويندوز 7- 32Bit أم 64Bit

هل هنالك خطأ ما Debug Error

تفضل هدا الكود بال SeTimer API .. الكود يجعل كل الكونترولات على الفورم تومض و ليس الليبل فقط ملف للتحميل : https://app.box.com/s/v1bq7azcpdyf53ghc1j77mg62obarw7i 1 - كود في Standard Module : Option Explicit Public oUf As Object #If VBA7 And WIN64 Then ' 64-bit Office Public Sub TimerRedirect(ByVal hwnd As Longlong, ByVal nIDEvent As Longlong, ByVal uElapse As Longlong, ByVal lpTimerFunc As Longlong) #Else ' 32-bit Office Public Sub TimerRedirect(ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) #End If CallByName oUf, "TimerProc", VbMethod, hwnd, nIDEvent, uElapse, lpTimerFunc End Sub 2 - كود في موديول الفورم UserForm Module : Option Explicit Private Enum BackForeColor Background ForeGround End Enum #If VBA7 And WIN64 Then Private Declare PtrSafe Function SetTimer Lib "user32" ( ByVal HWnd As LongLong, ByVal nIDEvent As LongLong, ByVal uElapse As LongLong,ByVal lpTimerFunc As LongLong) As LongLong Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal HWnd As LongLong,ByVal nIDEvent As LongLong) As LongLong Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr) #Else Private Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long Private Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDst As Any, pSrc As Any, ByVal ByteLen As Long) #End If Private Sub UserForm_Initialize() Set oUf = Me Call Flash(Me.Label1, Background, 1, vbRed) Call Flash(Me.Label2, ForeGround, 2, vbRed) Call Flash(Me.Label3, Background, 1, vbYellow) Call Flash(Me.TextBox1, Background, 3, vbGreen) Call Flash(Me.CommandButton1, Background, 1, vbMagenta) End Sub Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) Dim oCtl As Control For Each oCtl In Me.Controls KillTimer Application.hwnd, ObjPtr(oCtl) Next Set oUf = Nothing End Sub Private Sub Flash( _ ByVal obj As Object, _ ByVal What As BackForeColor, _ ByVal FlashesPerSecond As Long, _ ByVal FlashColor As Long _ ) obj.Tag = IIf(What = Background, "BackColor", "ForeColor") & "*" & FlashColor & "*" & _ IIf(What = Background, obj.BackColor, obj.ForeColor) Call SetTimer(Application.hwnd, ObjPtr(obj), FlashesPerSecond * 1000, AddressOf TimerRedirect) End Sub #If VBA7 And WIN64 Then ' 64-bit Office Public Sub TimerProc(ByVal hwnd As Longlong, ByVal nIDEvent As Longlong, ByVal uElapse As Longlong, ByVal lpTimerFunc As Longlong) #Else ' 32-bit Office Public Sub TimerProc(ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) #End If Dim obj As Object Dim FlashCl As Long Dim sProp As String Dim initColor As Long CopyMemory obj, uElapse, 4 sProp = Split(obj.Tag, "*")(0) FlashCl = Split(obj.Tag, "*")(1) initColor = Split(obj.Tag, "*")(2) If CallByName(obj, sProp, VbGet) <> FlashCl Then CallByName obj, sProp, VbLet, FlashCl Else CallByName obj, sProp, VbLet, initColor End If CopyMemory obj, 0&, 4 End Sub

يمكن استعمال ال SetTimer API ما هو اصدار الويندوز و الاكسيل لديك

أي نوع من ال InputBox تستخدم .. هل هو ال VBA.InputBox أم ال Application.InputBox ما هو اصدار الاكسيل الدي تستعمل و كدالك اصدار للويندوز أكيد في علمك أن بامكانك استخدام UserForm عوض ال InputBox ...مثلا بامكانك اضافة TextBox الى ال UserForm ثم تكبير حجم خط ال TextBox .. هدا أسهل من تغيير حجم خط ال InputBox عن طريق ال APIs

أضف ليبل label1 و جرب هدا الكود في UserForm Module Option Explicit Private Enum BackForeColor Background ForeGround End Enum Private Enum FlashSpeed Slow Fast End Enum Private bExiting As Boolean Private lLabelBackColor As Long Private lLabelForeColor As Long Private Sub UserForm_Activate() lLabelBackColor = Me.Label1.BackColor lLabelForeColor = Me.Label1.ForeColor Flash Obj:=Me.Label1, What:=Background, Speed:=Fast, FlashColor:=vbGreen End Sub Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) bExiting = True End Sub Private Sub Flash( _ ByVal Obj As Object, _ ByVal What As BackForeColor, _ ByVal Speed As FlashSpeed, _ ByVal FlashColor As Long _ ) Dim sProperty As String Dim iSpeed As Integer Dim lInitialColor As Long sProperty = IIf(What = Background, "BackColor", "ForeColor") lInitialColor = IIf(What = Background, lLabelBackColor, lLabelForeColor) iSpeed = IIf(Speed = Slow, 4, 2) Do If Int(Timer) Mod iSpeed And CallByName(Obj, sProperty, VbGet) <> FlashColor Then CallByName Obj, sProperty, VbLet, FlashColor End If If Int(Timer) Mod iSpeed = 0 And CallByName(Obj, sProperty, VbGet) <> lInitialColor Then CallByName Obj, sProperty, VbLet, lInitialColor End If DoEvents Loop Until bExiting End Sub ال Flash Sub هي ماكرو عامة تتقبل أي كونترول و تتقبل تغيير ال BackColor او ال ForeColor كما تحدد لون و سرعة الفلاش

جرب التعديل التالي Private Sub CommandButton1_Click() Dim Answer As String Dim initialWidth As Long Dim t As Single Answer = MsgBox("åá äÑíÏ ØÈÇÚÉ ÇáÈíÇäÇÊ ÇáÈíÇäÇÊ äÚã Çã áÇ", vbYesNo, "ÊäÈíå") If Answer = vbYes Then Me.Frame1.Left = 4 Me.Frame2.Visible = False Me.CommandButton1.Visible = False Me.CommandButton2.Visible = False Me.BackColor = &HFFFFFF Me.Frame1.BackColor = &HFFFFFF initialWidth = Me.Width Me.Width = Me.Frame1.Width + 15 t = Timer Do DoEvents Loop Until Timer - t >= 2 Me.PrintMe Me.Width = initialWidth Me.Frame1.Left = 396 Me.Frame2.Visible = True Me.CommandButton1.Visible = True Me.CommandButton2.Visible = True Me.BackColor = &HE0E0E0 Me.Frame1.BackColor = &HE0E0E0 MsgBox "ÊãÊ ÇáØÈÇÚå ", vbOKOnly, "ÊäÈíå" ElseIf Answer = vbNo Then MsgBox "Êã ÅáÛÇÁ ÚãáíÉ ÇáØÈÇÚå", vbOKOnly, "ÊäÈíå" End If End Sub

جرب هدا الملف : https://app.box.com/s/hs9uvmo0458b45rgn6ppdmh07ue0a67h

نعم لو غير تاريخ الجهاز هايفتح عادي و كدالك لو الماكروس غير شغالين اكسيل ليس تطبيقا أمن .. من السهل اختراقه ... ممكن حساب عدد الاستعمالات عوض عدد الأيام لتفادي اللعب في تاريخ الجهاز

نعم هده مشكلة عند طباعة الفورم .. قبل بضعة أعوام كنت انشات كودا يستخدم الويندوز API لطباعة WebBrowser مغروس داخل احدى صفحات الاكسيل ... لقد عدلت نفس الكود بعض الشيئ ليطبع الفورم أضف الكود التالي داخل موديول الفورم UserForm Module و فعل الماكرو CommandButton1_Click : Private Sub CommandButton1_Click() Me.PrintMe End Sub Option Explicit Private Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type Private Type DOCINFO cbSize As Long lpszName As String lpszOutput As Long End Type Private Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long Private Declare Function StretchBlt Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHght As Long, ByVal hSrcDC As Long, ByVal XSrc As Long, ByVal YSrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal XSrc As Long, ByVal YSrc As Long, ByVal dwRop As Long) As Long Private Declare Function GetDefaultPrinter Lib "winspool.drv" Alias "GetDefaultPrinterA" (ByVal sPrinterName As String, lPrinterNameBufferSize As Long) As Long Private Declare Function CreateDC Lib "gdi32" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, ByVal lpInitData As Any) As Long Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long Private Declare Function StartDoc Lib "gdi32" Alias "StartDocA" (ByVal hcs As Long, lpDI As DOCINFO) As Long Private Declare Function EndDoc Lib "gdi32" (ByVal hcs As Long) As Long Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long Private Const SRCCOPY As Long = &HCC0020 Private Sub CommandButton1_Click() Me.PrintMe End Sub Public Sub PrintMe() Dim hDCSrc As Long Dim hDCMemory As Long Dim hPrintDC As Long Dim hwnd As Long Dim StrechedWidth As Long Dim StrechedHeight As Long Dim hBmp As Long Dim hBmpPrev As Long Dim WidthSrc As Long Dim HeightSrc As Long Dim tRect As RECT Dim MyDoc As DOCINFO hwnd = FindWindow(vbNullString, Me.Caption) GetWindowRect hwnd, tRect WidthSrc = tRect.Right - tRect.Left HeightSrc = tRect.Bottom - tRect.Top If WidthSrc > HeightSrc Then StrechedWidth = WidthSrc + 4000 StrechedHeight = HeightSrc + (4000 * (HeightSrc / WidthSrc)) Else StrechedHeight = HeightSrc + 4000 StrechedWidth = WidthSrc + (4000 * (WidthSrc / HeightSrc)) End If hDCSrc = GetWindowDC(hwnd) hDCMemory = CreateCompatibleDC(hDCSrc) hBmp = CreateCompatibleBitmap(hDCSrc, WidthSrc, HeightSrc) hBmpPrev = SelectObject(hDCMemory, hBmp) Call BitBlt(hDCMemory, 0, 0, WidthSrc, HeightSrc, hDCSrc, 0, 0, SRCCOPY) hPrintDC = GetPrinterDC If hPrintDC <> 0 Then MyDoc.lpszName = "Form_PrintOut" MyDoc.lpszOutput = 0 MyDoc.cbSize = Len(MyDoc) Call StartDoc(hPrintDC, MyDoc) Call StretchBlt(hPrintDC, 0, 0, StrechedWidth, _ StrechedHeight, hDCMemory, 0, 0, WidthSrc, HeightSrc, SRCCOPY) Call EndDoc(hPrintDC) Call DeleteDC(hPrintDC) End If Call DeleteDC(hDCMemory) Call ReleaseDC(hwnd, hDCSrc) End Sub Private Function GetPrinterDC() As Long Dim sBuffer As String Dim sPrinterName As String Dim hPrinter As Long sBuffer = Space(128) If GetDefaultPrinter(sBuffer, 128) Then sPrinterName = Left(sBuffer, 128 - 1) GetPrinterDC = CreateDC("WINSPOOL", sPrinterName, vbNullString, 0&) End If End Function

هل تقصد الاسم اللدي على الشريط الأزرق فوق و هل تستخدم الكود التالي UserForm1.PrintForm

لو عندك اكسيل 2007 أو ما فوق جرب الكود التالي Application.ExecuteExcel4Macro "SHOW.TOOLBAR(""Ribbon"",False)"

الحل يعتمد على vba المشكلة هي أن لو المستخدم لديه ال VBA غير شغال عند فتح الملف فان الكود لن يشتغل على أية حال ... جرب هدا الكود ... أضف الكود الى ThisWorkbook Module Private Sub Workbook_Open() Dim lDaysDiff As Long On Error Resume Next lDaysDiff = DateDiff("d", [LastOpen], Now) If Err = 13 Then Names.Add "LastOpen", Now, False: ThisWorkbook.Save On Error GoTo 0 If lDaysDiff > 2 Then If InputBox("Enter Password") = "EnterYourPasswordHere" Then Names.Add "LastOpen", Now, False: ThisWorkbook.Save Else MsgBox "Wrong Password", vbCritical Me.Close True End If End If End Sub

ينبغي استعمال Named Range 1 - اعطي اسما للنطاق الدي توجد عليه القائمة .. مثلا : MyList 2- ثم .. Validation - List و ادخل =MyList في خانة المصدر Source

لتحديد اسم الصفحة التي يتم فيها الحساب اسبق الرينج باسم الشيت كالتالي Sheet1.Range("A1:H20") Function CountNonEmpty(ByVal Rng As Range) As Long CountNonEmpty = WorksheetFunction.CountA(Rng) End Function Function CountIf(ByVal Rng As Range, ByVal Val As Variant) As Long CountIf = WorksheetFunction.CountIf(Rng, Val) End Function Sub Test() MsgBox CountNonEmpty(Sheet1.Range("A1:H20")) MsgBox CountIf(Sheet1.Range("A1:H20"),"نعم") End Sub

أضف الكود التالي في موديول المصنف Private Sub Workbook_Activate() Application.MoveAfterReturnDirection = xlToRight End Sub Private Sub Workbook_Open() Application.MoveAfterReturnDirection = xlToRight End Sub Private Sub Workbook_BeforeClose(Cancel As Boolean) Application.MoveAfterReturnDirection = xlDown End Sub Private Sub Workbook_Deactivate() Application.MoveAfterReturnDirection = xlDown End Sub