نجوم المشاركات

السلام عليكم ورحمة الله وبركاته هي لعبة معروفه لديكم ولكن هذا العمل لم ينجز من اجل عيون اللعبة وانما لنتعلم وهو نفس عمل آلية الحروف المعمولة في ملف شرح دوال الاكسل ستجدون الكثير من الاسئلة التي تحتاج الى اجابة في هذا العمل ضعوها هنا لنرد عليها ساعطيكم انا اول سؤال فان لم اجد اجاية ساجيب لاحقا لدينا 24 ليبل لاظهار ما تروه امامكم من صور ولا يوجد اي امر يستخدم من احداث هذه الليبلات لا عبر الفورم ولا عبر موديل كلاسس ولكن عند الضغط على الليبل يتحقق حدث معين كيف ذلك ؟ ودمتم في حفظ الله ================================== تعديل بسيط افي المرفق ملف اكسل 2003و2007 لعبة التركيز1.rar لعبة التركيز.xls

أخي الكريم الجزيرة كود activeprinter هو الخاص بتنشيط طابعة معينة للطباعة عليها ولا يوجد غيره لعمل ذلك فإما أن يكون الخطأ في اسم الطابعة أو في اتصال الطابعة بالجهاز وتأكد أنه تظهر أسفل رمز الطابعة كلمة ready (جاهز) قبل الطباعة ولمعرفة اسماء الطابعات الموصلة بالجهاز يمكنك استعمال هذا الكود Private Const PRINTER_ENUM_LOCAL = &H2 Private Const PRINTER_ENUM_CONNECTIONS = &H4 Private Declare Function EnumPrinters Lib "winspool.drv" _ Alias "EnumPrintersA" _ (ByVal flags As Long, _ ByVal name As String, _ ByVal Level As Long, _ pPrinterEnum As Any, _ ByVal cdBuf As Long, _ pcbNeeded As Long, _ pcReturned As Long) _ As Long Private Declare Function StrLen Lib "kernel32" _ Alias "lstrlenA" _ (ByVal Ptr As Long) _ As Long Private Declare Function StrCopy Lib "kernel32" _ Alias "lstrcpyA" _ (ByVal RetVal As String, _ ByVal Ptr As Long) _ As Long Private Function CopyStringFromPtr(ByVal pSource As Long) As String CopyStringFromPtr = Space$(StrLen(pSource)) StrCopy CopyStringFromPtr, pSource End Function Public Function GetPrinterNames() As Variant Dim fSuccess As Boolean, lBuflen As Long, lFlags As Long Dim aBuffer() As Long, lEntries As Long Dim iCount As Integer, aPrinters() As String lFlags = PRINTER_ENUM_LOCAL Or PRINTER_ENUM_CONNECTIONS Call EnumPrinters(lFlags, vbNullString, 1, 0, 0, lBuflen, lEntries) ReDim aBuffer(lBuflen \ 4) fSuccess = EnumPrinters( _ lFlags, _ vbNullString, _ 1, _ aBuffer(0), _ lBuflen, _ lBuflen, _ lEntries) <> 0 If fSuccess And lEntries > 0 Then ReDim aPrinters(lEntries - 1) For iCount = 0 To lEntries - 1 aPrinters(iCount) = CopyStringFromPtr(aBuffer(iCount * 4 + 2)) Next GetPrinterNames = aPrinters End If End Function Public Sub GetPrinterList() Dim aPrinters As Variant, i As Integer aPrinters = GetPrinterNames If IsArray(aPrinters) Then For i = 0 To UBound(aPrinters) Debug.Print aPrinters(i) Next End If End Sub لذلك يجب أولا التأكد من توصيل الطابعة وجاهزيتها وثانيا اسمها الصحيح ثم تستعمل activeprinter وفقنا الله وإياكم لكل خير

السلام عليكم جرب هذا الكود Sub ALIDROOS_JC_F() Dim S_ALI$ Dim SAV_ALI As String SAV_ALI = Range("F7") & ":\" & Range("B7") & "\" S_ALI = Range("D7") & ".xls" If [B7].Value = "" Or [D7].Value = "" Or [F7].Value = "" Then MsgBox "قم أولاً بتسجيل إسم الملف وقرص الحفظ في الخلية المعنية", vbCritical, "_" Exit Sub Else: If MsgBox(" هل تريد حفظ البيانات في " & SAV_ALI & " بإسم " & S_ALI, vbQuestion + vbYesNo) = vbYes Then On Error Resume Next Application.DisplayAlerts = False GetAttr (SAV_ALI) Select Case Err.Number Case Is = 0 Application.DisplayAlerts = False ThisWorkbook.SaveCopyAs SAV_ALI & S_ALI Application.DisplayAlerts = True Case Else MkDir SAV_ALI ThisWorkbook.SaveCopyAs SAV_ALI & S_ALI End Select On Error GoTo 0 MsgBox "تم حفظ قاعدة بيانات بالأسم التالي..." & S_ALI & ALI_JC End If End If End Sub وهذا المرفق ALIDROOS_F.rar

السلام عليكم تم التعديل على كود ابو انصار حفظه الله Sub COPY_ALIDROOS() Dim W_ALI As Workbook, WB_ALI As Workbook Dim N_ALI$, CH_ALI$ Dim SH_ALI As Worksheet Dim T%, R%, co% Application.ScreenUpdating = False '============================================ ' هنا تحط مسار مجلد الملفات التي تريد جلب بياناتها CH_ALI = "C:\Mine\" 'CH_ALI = ThisWorkbook.Path & "\Mine\" '============================================ N_ALI = Dir(CH_ALI & "\*.xlsx") Set W_ALI = ThisWorkbook Do While N_ALI <> "" Set WB_ALI = Workbooks.Open(CH_ALI & "\" & N_ALI) Set SH_ALI = WB_ALI.Worksheets(1) R = SH_ALI.Cells(Rows.Count, 1).End(xlUp).Row If R = 2 Then GoTo 1 '============================================ '(A-E-F)هنا الاعمدة المراد جلب بياناتها هيا حسب طلبك هيا ' إبتداء من السطر الثالث Union(SH_ALI.Range("A3:A" & R), SH_ALI.Range("E3:E" & R), SH_ALI.Range("F3:F" & R)).Copy '============================================ W_ALI.Activate With W_ALI.Worksheets(1) T = .Cells(.Rows.Count, 1).End(xlUp).Row + 1 .Range("A" & T).PasteSpecial xlPasteValues kh_Delete Selection End With 1: WB_ALI.Close 0 N_ALI = Dir Loop Application.ScreenUpdating = True Set W_ALI = Nothing: Set WB_ALI = Nothing: Set SH_ALI = Nothing End Sub Sub kh_Delete(Rng As Range) Dim Col As Range, Rw% With Rng For Rw = 1 To .Rows.Count If Val(.Cells(Rw, 2)) + Val(.Cells(Rw, 3)) = 0 Then If Col Is Nothing Then Set Col = .Rows(Rw) Else _ Set Col = Union(Col, .Rows(Rw)) End If Next End With If Not Col Is Nothing Then Col.Delete Shift:=xlUp End If End Sub شاهد المرفق2007 MAIN.rar

السلام عليكم تحايلنا بحذف الصفوف ذات القيمة صفر Sub COPY_ALIDROOS() On Error Resume Next Dim W_ALI As Workbook, WB_ALI As Workbook, N_ALI$, CH_ALI$, SH_ALI As Worksheet Dim T%, R% Dim X As Range ' Dim S_A ' S_A = Union(SH_ALI.Range("A3:A" & R), SH_ALI.Range("E3:E" & R), SH_ALI.Range("F3:F" & R)) Application.ScreenUpdating = 0 '============================================ ' هنا تحط مسار مجلد الملفات التي تريد جلب بياناتها CH_ALI = "C:\Mine\" '============================================ N_ALI = Dir(CH_ALI & "\*.xlsx") Set W_ALI = ThisWorkbook Do While N_ALI <> "" Set WB_ALI = Workbooks.Open(CH_ALI & "\" & N_ALI) For Each SH_ALI In WB_ALI.Worksheets R = SH_ALI.Cells(Rows.Count, 1).End(xlUp).Row W_ALI.Activate '============================================ '(A-E-F)هنا الاعمدة المراد جلب بياناتها هيا حسب طلبك هيا ' إبتداء من السطر الثالث If SH_ALI.Range("C3:C" & R).Value <> 0 Then Union(SH_ALI.Range("A3:A" & R), SH_ALI.Range("E3:E" & R), SH_ALI.Range("F3:F" & R)).Copy '============================================ T = Cells(Rows.Count, 1).End(xlUp).Row + 1 ThisWorkbook.Worksheets(1).Range("A" & T).PasteSpecial xlPasteValues End If Next SH_ALI N_ALI = Dir WB_ALI.Close 0 Loop With ورقة1 For Each X In .Range("C3:C5000") If X.Value = 0 Then X.EntireRow.Delete End If Next X End With Application.ScreenUpdating = 1 End Sub

السلام عليكم ورحمة الله وبركاته اخواني الاحباء ابو انس habibdar نزاهة الشهابي نادر jazea يحياوي الحسامي احمد زمان طاهر احمد حمور حفظكم الله ورعاكم ====================== اعذروني لم استطع التعبير عرفانا لما اورتموه من الكلام الطيب اكرمكم الله وجزاكم خيرا في الدنيا والآخرة ====================== ودمتم في حفظ الله

السلام عليكم ورحمة الله وبركاته جمعة مباركة على الجميع اخي الحبيب / عبدالله -حفظك الله و جزاك الله خيرا ----------------------------------------------- اخي الحبيب / طارق -حفظك الله و جزاك الله خيرا الجواب: كما قاله ابو انصار جعلنا الليبل LabelEvent هو اساس التحكم و عن طريقه يتم التعامل مع 24 ليبل و لو جعلت خلفيته غير شفافة ستلاحظ انه في الامام ولن ترى 24 ليبل لانها خلفه عن طريق الضغط على الماوس على الليبل LabelEvent يتم تحديد عنوان الليبل اللي خلفه بالدالة MyIndex ويتم التعامل معه بالكود kh_Test وقد عملت فورم للتاريخ الميلادي بنفس هذه الالية --------------------------------------------- اخي الحبيب / مجدي يونس -حفظك الله و جزاك الله خيرا اخي الحبيب / aboalaa-حفظك الله و جزاك الله خيرا اخي الحبيب / انيس -حفظك الله و جزاك الله خيرا اخي الحبيب / ابو انصار-حفظك الله و جزاك الله خيرا لقد اصبت الهدف عندك حب شغوف للتعلم مع ذكاء ملحوظ اخي الحبيب / ابو الحسن -حفظك الله و جزاك الله خيرا تقبلوا جميعا شكري وتقديري ودمتم في حفظ الله اضفت حركة بسيطة لتبسيط اللعبة تفضلوا المرفق ملف 2003/2007 لعبة التركيز1.rar