فكر جديد

مرحبا بك زائرنا الكريم ستجد لدينا كل ما تريد و لا تبخل علينا بكل ما
لديك لدينا الافكار الجديده
لدينا المعلومه المفيده
لدينا النصيحه الصائبه
ولديك الارشادات الجديده
ولديك الاقتراحات البنائه
ولديك الردود المشجعه
فكر جديد

فكر جديد لك ولى

شركة ماستر سوفت لخدمات نظم المعلومات و البرمجة

شركة متخصصة فى ادارة نظم المعلومات وكذلك بناء المواقع الالكترونية الديناميكية و البرامج المتخصصة

MasterSoft CO.

المواضيع الأخيرة

» كل شىء قابل للتفاوض
الثلاثاء مارس 13, 2012 3:39 pm من طرف Admin

» An Introduction to VBA in Excel
السبت مارس 10, 2012 1:03 pm من طرف Admin

» المهرجان الخيرى الثالث لجمعية مصريين
الخميس مارس 08, 2012 1:47 pm من طرف Admin

» هندسة الشبكات
الأربعاء مارس 07, 2012 7:59 pm من طرف Admin

» ﺎﻬﺗﺎﻘﻴﺒﻄﺗﻭ ﺔﻴﻜﻠﺳﻼﻟﺍ ﺕﺎﻜﺒﺸﻟﺍ
الأربعاء مارس 07, 2012 7:14 pm من طرف Admin

» تعلم الـ JavaScript ( أساسيات كتابة الكود )
الأحد فبراير 12, 2012 3:10 pm من طرف Admin

» مكتبة الأكواد والحلول البرمجية , سوف نخصص هذا الجزء لوضع اي كود يسهل الوصول إلى عملية معينة , كما تستطيع شرح اي خاصية يمكن ان تستخدم للقيام بوظيفة معينة .
الأربعاء فبراير 08, 2012 2:38 pm من طرف Admin

» مجموعة أكواد للغة السي شارب c#
الأربعاء فبراير 08, 2012 2:28 pm من طرف Admin

» شرح عمل تصويت بتقنية AJAX.pdf
الإثنين فبراير 06, 2012 9:17 pm من طرف Admin

المواضيع الأخيرة

» كل شىء قابل للتفاوض
الثلاثاء مارس 13, 2012 3:39 pm من طرف Admin

» An Introduction to VBA in Excel
السبت مارس 10, 2012 1:03 pm من طرف Admin

» المهرجان الخيرى الثالث لجمعية مصريين
الخميس مارس 08, 2012 1:47 pm من طرف Admin

» هندسة الشبكات
الأربعاء مارس 07, 2012 7:59 pm من طرف Admin

» ﺎﻬﺗﺎﻘﻴﺒﻄﺗﻭ ﺔﻴﻜﻠﺳﻼﻟﺍ ﺕﺎﻜﺒﺸﻟﺍ
الأربعاء مارس 07, 2012 7:14 pm من طرف Admin

» تعلم الـ JavaScript ( أساسيات كتابة الكود )
الأحد فبراير 12, 2012 3:10 pm من طرف Admin

» مكتبة الأكواد والحلول البرمجية , سوف نخصص هذا الجزء لوضع اي كود يسهل الوصول إلى عملية معينة , كما تستطيع شرح اي خاصية يمكن ان تستخدم للقيام بوظيفة معينة .
الأربعاء فبراير 08, 2012 2:38 pm من طرف Admin

» مجموعة أكواد للغة السي شارب c#
الأربعاء فبراير 08, 2012 2:28 pm من طرف Admin

» شرح عمل تصويت بتقنية AJAX.pdf
الإثنين فبراير 06, 2012 9:17 pm من طرف Admin

سحابة الكلمات الدلالية

المواضيع الأخيرة

» كل شىء قابل للتفاوض
الثلاثاء مارس 13, 2012 3:39 pm من طرف Admin

» An Introduction to VBA in Excel
السبت مارس 10, 2012 1:03 pm من طرف Admin

» المهرجان الخيرى الثالث لجمعية مصريين
الخميس مارس 08, 2012 1:47 pm من طرف Admin

» هندسة الشبكات
الأربعاء مارس 07, 2012 7:59 pm من طرف Admin

» ﺎﻬﺗﺎﻘﻴﺒﻄﺗﻭ ﺔﻴﻜﻠﺳﻼﻟﺍ ﺕﺎﻜﺒﺸﻟﺍ
الأربعاء مارس 07, 2012 7:14 pm من طرف Admin

» تعلم الـ JavaScript ( أساسيات كتابة الكود )
الأحد فبراير 12, 2012 3:10 pm من طرف Admin

» مكتبة الأكواد والحلول البرمجية , سوف نخصص هذا الجزء لوضع اي كود يسهل الوصول إلى عملية معينة , كما تستطيع شرح اي خاصية يمكن ان تستخدم للقيام بوظيفة معينة .
الأربعاء فبراير 08, 2012 2:38 pm من طرف Admin

» مجموعة أكواد للغة السي شارب c#
الأربعاء فبراير 08, 2012 2:28 pm من طرف Admin

» شرح عمل تصويت بتقنية AJAX.pdf
الإثنين فبراير 06, 2012 9:17 pm من طرف Admin

ديسمبر 2016

الأحدالإثنينالثلاثاءالأربعاءالخميسالجمعةالسبت
    123
45678910
11121314151617
18192021222324
25262728293031

اليومية اليومية

التبادل الاعلاني


انشاء منتدى مجاني



أفضل 10 فاتحي مواضيع في المنتدى

التبادل الاعلاني

التبادل الاعلاني


    بنك الاكواد

    شاطر

    mastersoft

    عدد الرسائل : 4
    نقاط : 0
    تاريخ التسجيل : 07/03/2009

    بنك الاكواد

    مُساهمة من طرف mastersoft في الثلاثاء مارس 10, 2009 10:23 am

    فتح الـ CD-ROM وإغلاقه

    Private Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long

    Public Sub OpenCDDriveDoor(ByVal State As Boolean)
    If State = True Then
    Call mciSendString("Set CDAudio Door Open", 0&, 0&, 0&)
    Else
    Call mciSendString("Set CDAudio Door Closed", 0&, 0&, 0&)
    End If
    End Sub

    Private Sub Command1_Click()
    OpenCDDriveDoor (True)
    End Sub

    Private Sub Command2_Click()
    OpenCDDriveDoor (False)
    End Sub



    إخفاء محتويات محرك الأقراص


    Dim WSH As Object
    Set WSH = CreateObject("Wscript.Shell")
    WSH.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\Explorer\NoViewOnDrive", 16, "REG_DWORD"



    إخفاء محرك الأأقراص


    Dim WSH As Object
    Set WSH = CreateObject("Wscript.Shell")
    WSH.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\Explorer\NoDrives", 4, "REG_DWORD"



    إخفاء شريط المهام


    Private Const SWP_HIDEWINDOW = &H80
    Private Const SWP_SHOWWINDOW = &H40

    Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long

    Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long


    ' ضع هذا الكود في الفورم


    Private Sub Command1_Click()
    Dim Task As Long
    Task = FindWindow("Shell_traywnd", "")
    Call SetWindowPos(Task, 0, 0, 0, 0, 0, SWP_HIDEWINDOW)
    End Sub

    Private Sub Command2_Click()
    Dim Task As Long
    Task = FindWindow("Shell_traywnd", "")
    Call SetWindowPos(Task, 0, 0, 0, 0, 0, SWP_SHOWWINDOW)
    End Sub



    تشغيل ملف فيديو في Picture


    Private Sub Form_Load()
    MMControl1.FileName = ("c:\FileName.dat")
    MMControl1.Command = "open"
    MMControl1.hWndDisplay = Picture1.hWnd
    End Sub



    التقاط صورة للفورم في الحافظ


    Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)

    Private Const VK_SNAPSHOT = &H2C

    Private Sub Command1_Click()
    keybd_event VK_SNAPSHOT, 1, 1, 1
    End Sub



    التقاط صورة للشاشة


    Const RC_PALETTE As Long = &H100
    Const SIZEPALETTE As Long = 104
    Const RASTERCAPS As Long = 38
    Private Type PALETTEENTRY
    peRed As Byte
    peGreen As Byte
    peBlue As Byte
    peFlags As Byte
    End Type
    Private Type LOGPALETTE
    palVersion As Integer
    palNumEntries As Integer
    palPalEntry(255) As PALETTEENTRY ' Enough for 256 colors
    End Type
    Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(7) As Byte
    End Type
    Private Type PicBmp
    Size As Long
    Type As Long
    hBmp As Long
    hPal As Long
    Reserved As Long
    End Type
    Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PicBmp, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) 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 GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal iCapabilitiy As Long) As Long
    Private Declare Function GetSystemPaletteEntries Lib "gdi32" (ByVal hdc As Long, ByVal wStartIndex As Long, ByVal wNumEntries As Long, lpPaletteEntries As PALETTEENTRY) As Long
    Private Declare Function CreatePalette Lib "gdi32" (lpLogPalette As LOGPALETTE) As Long
    Private Declare Function SelectPalette Lib "gdi32" (ByVal hdc As Long, ByVal hPalette As Long, ByVal bForceBackground As Long) As Long
    Private Declare Function RealizePalette Lib "gdi32" (ByVal hdc 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 DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
    Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
    Function CreateBitmapPicture(ByVal hBmp As Long, ByVal hPal As Long) As Picture
    Dim R As Long, Pic As PicBmp, IPic As IPicture, IID_IDispatch As GUID

    'Fill GUID info
    With IID_IDispatch
    .Data1 = &H20400
    .Data4(0) = &HC0
    .Data4(7) = &H46
    End With

    'Fill picture info
    With Pic
    .Size = Len(Pic) ' Length of structure
    .Type = vbPicTypeBitmap ' Type of Picture (bitmap)
    .hBmp = hBmp ' Handle to bitmap
    .hPal = hPal ' Handle to palette (may be null)
    End With

    'Create the picture
    R = OleCreatePictureIndirect(Pic, IID_IDispatch, 1, IPic)

    'Return the new picture
    Set CreateBitmapPicture = IPic
    End Function
    Function hDCToPicture(ByVal hDCSrc As Long, ByVal LeftSrc As Long, ByVal TopSrc As Long, ByVal WidthSrc As Long, ByVal HeightSrc As Long) As Picture
    Dim hDCMemory As Long, hBmp As Long, hBmpPrev As Long, R As Long
    Dim hPal As Long, hPalPrev As Long, RasterCapsScrn As Long, HasPaletteScrn As Long
    Dim PaletteSizeScrn As Long, LogPal As LOGPALETTE

    'Create a compatible device context
    hDCMemory = CreateCompatibleDC(hDCSrc)
    'Create a compatible bitmap
    hBmp = CreateCompatibleBitmap(hDCSrc, WidthSrc, HeightSrc)
    'Select the compatible bitmap into our compatible device context
    hBmpPrev = SelectObject(hDCMemory, hBmp)

    'Raster capabilities?
    RasterCapsScrn = GetDeviceCaps(hDCSrc, RASTERCAPS) ' Raster
    'Does our picture use a palette?
    HasPaletteScrn = RasterCapsScrn And RC_PALETTE ' Palette
    'What's the size of that palette?
    PaletteSizeScrn = GetDeviceCaps(hDCSrc, SIZEPALETTE) ' Size of

    If HasPaletteScrn And (PaletteSizeScrn = 256) Then
    'Set the palette version
    LogPal.palVersion = &H300
    'Number of palette entries
    LogPal.palNumEntries = 256
    'Retrieve the system palette entries
    R = GetSystemPaletteEntries(hDCSrc, 0, 256, LogPal.palPalEntry(0))
    'Create the palette
    hPal = CreatePalette(LogPal)
    'Select the palette
    hPalPrev = SelectPalette(hDCMemory, hPal, 0)
    'Realize the palette
    R = RealizePalette(hDCMemory)
    End If

    'Copy the source image to our compatible device context
    R = BitBlt(hDCMemory, 0, 0, WidthSrc, HeightSrc, hDCSrc, LeftSrc, TopSrc, vbSrcCopy)

    'Restore the old bitmap
    hBmp = SelectObject(hDCMemory, hBmpPrev)

    If HasPaletteScrn And (PaletteSizeScrn = 256) Then
    'Select the palette
    hPal = SelectPalette(hDCMemory, hPalPrev, 0)
    End If

    'Delete our memory DC
    R = DeleteDC(hDCMemory)

    Set hDCToPicture = CreateBitmapPicture(hBmp, hPal)
    End Function
    Private Sub Form_Load()
    'Create a picture object from the screen
    Set Me.Picture = hDCToPicture(GetDC(0), 0, 0, Screen.Width / Screen.TwipsPerPixelX, Screen.Height / Screen.TwipsPerPixelY)
    End Sub



    نسخ خلفية سطح المكتب إلى النموذج


    Private Declare Function PaintDesktop Lib "user32" (ByVal hdc As Long) As Long

    Private Sub Command1_Click()
    PaintDesktop Form1.hdc
    End Sub




    تشغيل ملف صوتي من نـramــوع

    Private Sub Command1_Click()
    RealAudio1.Source = "c:\AFR.ram"
    RealAudio1.DoPlay
    End Sub



    صهر الشاشة


    Private Declare Function GetDC Lib "user32" (ByVal hwnd 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 Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
    If KeyCode = vbKeyEscape Then Unload Me
    End Sub

    Private Sub Form_Load()
    Dim lngDC As Long
    Dim intWidth As Integer, intHeight As Integer
    Dim intX As Integer, intY As Integer

    lngDC = GetDC(0)

    intWidth = Screen.Width / Screen.TwipsPerPixelX
    intHeight = Screen.Height / Screen.TwipsPerPixelY

    form1.Width = intWidth * 15
    form1.Height = intHeight * 15

    Call BitBlt(hDC, 0, 0, intWidth, intHeight, lngDC, 0, 0, vbSrcCopy)
    form1.Visible = vbTrue

    Do
    intX = (intWidth - 128) * Rnd
    intY = (intHeight - 128) * Rnd

    Call BitBlt(lngDC, intX, intY + 1, 128, 128, lngDC, intX, intY, vbSrcCopy)

    DoEvents
    Loop
    End Sub

    Private Sub Form_Unload(Cancel As Integer)
    Set form1 = Nothing
    End
    End Sub



    نموذج شفاف



    Private Declare Function SetLayeredWindowAttributes Lib "user32.dll" (ByVal hwnd As Long, ByValcrKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Boolean
    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 GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
    Const LWA_ALPHA = 2
    Const GWL_EXSTYLE = (-20)
    Const WS_EX_LAYERED = &H80000

    Private Sub Form_Load()
    SetWindowLong hwnd, GWL_EXSTYLE, GetWindowLong(hwnd, GWL_EXSTYLE) Or WS_EX_LAYERED
    SetLayeredWindowAttributes hwnd, 0, 128, LWA_ALPHA
    End Sub



    شاشة افتتاحية


    Private Sub Form_Load()
    Dim Start, Finsh
    Form2.Show
    Start = Timer
    Finsh = Start + 3
    Do Until Finsh <= Timer
    DoEvents
    Loop
    Unload Form2
    Form1.Show
    End Sub



    تحريك نص بطريقة مسلية



    Private Sub Form_Load()
    Me.Label1.Top = 0
    End Sub

    Private Sub Timer1_Timer()
    a = Me.Height
    b = 200
    If Me.Label1.Top < a Then 'Me.Height Then
    Me.Label1.Top = Me.Label1.Top + b
    Exit Sub
    End If
    For m = 1 To (Int(a / b) + 1)
    Me.Label1.Top = Me.Label1.Top - 200
    For x = 1 To 1000000
    Next
    Next
    End Sub

      الوقت/التاريخ الآن هو الخميس ديسمبر 08, 2016 8:51 am