أكواد للمبتدئين

(f)الكود الثالث والثلاثون(f)

لإنشاء Command Button و Text Box بواسطة الكود.

Option Explicit

Private WithEvents btnObj As CommandButton

Private WithEvents txtObj As TextBox





Private Sub btnObj_Click()

On Error Resume Next

Set txtObj = Controls.Add("VB.textbox", "txtObj")

With txtObj

.Visible = True

.RightToLeft = True

.Alignment = 2

.Width = 2000

.Text = "السلام عليكم"

.Top = 2000

.Left = 1000

End With

End Sub



Private Sub Form_Load()

Set btnObj = Controls.Add("VB.CommandButton", "btnObj")

With btnObj

.Visible = True

.Width = 2000

.Caption = "Click"

.Top = 1000

.Left = 1000

End With

End Sub

(f)الكود الرابع والثلاثون(f)

لمعرفة مسار مجلد الويندوز

ولمعرفة مسار مجلد النظام

ولمعرفة اسم المستخدم

Option Explicit

Private Declare Function GetWindowsDirectory Lib "kernel32" Alias 



"GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As 



Long) As Long



Private Declare Function GetSystemDirectory Lib "kernel32" Alias 



"GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As 



Long) As Long



Private Declare Function GetUserName Lib "advapi32.dll" Alias 



"GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long







Private Sub Form_Load()

Dim W

Dim WindowsD As String

WindowsD = Space(144)

W = GetWindowsDirectory(WindowsD, 144)

Text1.Text = WindowsD



Dim S

Dim SystemD As String

SystemD = Space(144)

S = GetSystemDirectory(SystemD, 144)

Text2.Text = SystemD



Dim N

Dim UserN As String

UserN = Space(144)

N = GetUserName(UserN, 144)

Text3.Text = UserN



End Sub

(f)الكود الخامس والثلاثون(f)

لفتح الـ 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

الشكر قليل جدا اخوي بالفعل كل يوم بلاقي حل لمشكلة كود الف شكر (gift)(f)

شكرا لك على هزه المعلاومات الهامه

يا حضره الخ عبدله فتحي

واتمن لك التوفيق

معكم سمير بعلبكي من لبنان

(gift)(gift)

(f)(f)

اقتباس

كاتب الرسالة الأصلية : عبد الله فتحي

(f)الكود الثالث والعشرون(f)

إنشاء مجلد جديد

السلام عليكم ورحمة الله

شكرا لك اخى عبدالله على مجهوداتك هذة

ولكن هناك طريقة اخرى وانا افضلها فى كيفية انشاء مجلد جديد

Private Sub Command1_Click()

'On Error Resume Next



MkDir Text1.Text



End Sub



Private Sub Form_Load()

Text1.Text = "c:arafa"



End Sub

شكراً أخوي arafa (f)فعلاً طريقة أسهل وأجمل.

أشكرك كثيراً.

أخوك عبد الله.

(f)الكود السادس والثلاثون(f)

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

Option Explicit



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

(f)الكود السابع والثلاثون(f)

لتنفيذ أوامر عند الضغط على زري F9 أو F10

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)

    If KeyCode = 120 Then

    Email = InputBox("Enter Your Name :", "تحياتي")

    End If

     

    If KeyCode = 121 Then

    Email = InputBox("Enter Your E-mail :", "تحياتي")

    End If

End Sub

(f)الكود الثامن والثلاثون(f)

لتغيير دقة عرض الشاشة

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

Public Const EWX_LOGOFF = 0

Public Const EWX_SHUTDOWN = 1

Public Const EWX_REBOOT = 2

Public Const EWX_FORCE = 4

Public Const CCDEVICENAME = 32

Public Const CCFORMNAME = 32

Public Const DM_BITSPERPEL = &H40000

Public Const DM_PELSWIDTH = &H80000

Public Const DM_PELSHEIGHT = &H100000

Public Const CDS_UPDATEREGISTRY = &H1

Public Const CDS_TEST = &H4

Public Const DISP_CHANGE_SUCCESSFUL = 0

Public Const DISP_CHANGE_RESTART = 1



Type typDevMODE

    dmDeviceName       As String * CCDEVICENAME

    dmSpecVersion      As Integer

    dmDriverVersion    As Integer

    dmSize             As Integer

    dmDriverExtra      As Integer

    dmFields           As Long

    dmOrientation      As Integer

    dmPaperSize        As Integer

    dmPaperLength      As Integer

    dmPaperWidth       As Integer

    dmScale            As Integer

    dmCopies           As Integer

    dmDefaultSource    As Integer

    dmPrintQuality     As Integer

    dmColor            As Integer

    dmDuplex           As Integer

    dmYResolution      As Integer

    dmTTOption         As Integer

    dmCollate          As Integer

    dmFormName         As String * CCFORMNAME

    dmUnusedPadding    As Integer

    dmBitsPerPel       As Integer

    dmPelsWidth        As Long

    dmPelsHeight       As Long

    dmDisplayFlags     As Long

    dmDisplayFrequency As Long

End Type



Declare Function EnumDisplaySettings Lib "user32" Alias "EnumDisplaySettingsA" (ByVal lpszDeviceName As Long, ByVal iModeNum As Long, lptypDevMode As Any) As Boolean

Declare Function ChangeDisplaySettings Lib "user32" Alias "ChangeDisplaySettingsA" (lptypDevMode As Any, ByVal dwFlags As Long) As Long

Declare Function ExitWindowsEx Lib "user32" (ByVal uFlags As Long, ByVal dwReserved As Long) As Long

وهذا الكود في الفورم

Private Sub Command1_Click()

Dim typDevM As typDevMODE

Dim lngResult As Long

Dim intAns    As Integer



lngResult = EnumDisplaySettings(0, 0, typDevM)



With typDevM

    .dmFields = DM_PELSWIDTH Or DM_PELSHEIGHT

    .dmPelsWidth = 640  'اختر العرض (640,800,1024, etc)

    .dmPelsHeight = 480 'اختر الطول (480,600,768, etc)

End With



lngResult = ChangeDisplaySettings(typDevM, CDS_TEST)

Select Case lngResult

    Case DISP_CHANGE_RESTART

        intAns = MsgBox("You must restart your computer to apply these changes." & _

            vbCrLf & vbCrLf & "Do you want to restart now?", _

            vbYesNo + vbSystemModal, "Screen Resolution")

        If intAns = vbYes Then Call ExitWindowsEx(EWX_REBOOT, 0)

    Case DISP_CHANGE_SUCCESSFUL

        Call ChangeDisplaySettings(typDevM, CDS_UPDATEREGISTRY)

        MsgBox "Screen resolution changed", vbInformation, "Resolution Changed"

    Case Else

        MsgBox "Mode not supported", vbSystemModal, "Error"

End Select



End Sub

(f)الكود التاسع والثلاثون(f)

لصهر الشاشة:

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

(f)الكود الأربعون(f)

لعمل فورم شفاف

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

(gift)(gift)(gift) شكرررررررررررررررراً (gift)(gift)(gift)

رائع رائع :D

(f)الكود الحادي والأربعون(f)

لتشغيل شاشة افتتاحية لفترة معينة، ثم تختفي ويشتغل البرنامج

يتطلب البرنامج Form وليكن اسمها frmshow

ويتطلب أيضا Form ثانية وليكن اسمها frmstart

ضع الكود التالي في حدث الـ Form_Load للفورم frmshow:

Dim Start,Finsh

FrmShow.Show

Start=Timer

Finsh=Start+3 

Do Until Finsh<= Timer

DoEvents

Loop

Unload Frmshow

FrmStart.Show

(f)الكود الثاني والأربعون(f)

لإيقاف الماوس ولوحة المفاتيح عن العمل لمدة معينة

Private Declare Function BlockInput Lib "user32" (ByVal fBlock As 



Long) As Long

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As 



Long)

Private Sub Form_Activate()

    DoEvents

    BlockInput True

    Sleep 1000

    BlockInput False

End Sub

(f)الكود الثالث والأربعون(f)

لنقل ملف من مكان إلى مكان

Private Sub Command1_Click()

Name "c:Autoexec.bat" As "D:Autoexec.bat"

End Sub

الكود الرابع والأربعون

(f)لجعل الفورم في المقدمة(f)

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 Const SWP_NOMOVE = 2

Private Const SWP_NOSIZE = 1

Private Const HWND_TOPMOST = -1

Private Const HWND_NOTOPMOST = -2



Public Sub SetOnTop(ByVal hwnd As Long, ByVal bSetOnTop As Boolean)

Dim lR As Long

If bSetOnTop Then

    lR = SetWindowPos(hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE)

Else

    lR = SetWindowPos(hwnd, HWND_NOTOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE)

End If

End Sub



Private Sub Form_Load()

    SetOnTop Form1.hwnd, True

End Sub

(f)الكود الخامس والأربعون(f)

لتحريك Label بطريقة مسلية;)

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

:rolleyes:

اخوي اولا يعطيك العافية كل يوم 5 اكواد من الروائع

سؤالي عن الفورم الشفاف

اخوي بالنسبة لكود جعل الفورم شفافة استخدمته لكن يظهر خطا نصه هو التالي فما المشكلة وكيف الحل ؟

'Run-time error 453'

'cant find DLL entry point SetLayeredWindowAttributes in user32.dll'

علما ان الخطا عند النقر على تنقيح 'debugg' يقوم بتحديد السطر

SetLayeredWindowAttributes hwnd, 0, 128, LWA_ALPHA

باللون الاصفر

ارجو ان توضح لي المشكلة

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

الف شكر مرة اخرى على هذه الاكواد الرائعة

اخوك NOP (gift)

أخي وصديقي العزيز NOP أود أن أعلمك بأنني لا أقوم بوضع أي كود في هذه الصفحة بالذات قبل أن أجربها، وبالنسبة للخطأ الذي وقع لديك:

'cant find DLL entry point SetLayeredWindowAttributes in user32.dll'

فهو يعني أنه لم يجد تابع SetLayeredWindowAttributes في ملف user32.dll .

وأنا أعتقد أنك لا تستخدم النظام Windows XP، لأنني قمت بتجريب الكود مرة ثانية واشتغل.

إليك تحياتي

فعلاً أخي NOP لقد قمت بتجريب الكود على ويندوز Millineum وأعطاني نفس رسالة الخطأ.

أرجو أن تقوم بتجربته على الإكس بي.

للاسف هذا يعني انه لا يعمل على ويندوز 9x

سارى ان بامكاني ايجاد ما يعمل على 9x لكن ان وجدته ساحتاج مساعدتك فلربما لن يعمل على اكس بي عندها يجب عمل كود يحدد النظام ووفقه يطبق كود ال transparent اللي بيمشي للنظام شو رايك ؟

تحياتي

شكراً جزيلاً لك أخي عبدالله

(f) (f)