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

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

لمعرفة ما هو الشهر الحالي

Private Sub Command1_Click()
Mmonth = Mid(Date, 4, 2)
Label1 = MonthName(Mmonth)
End Sub

:D

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

لإضافة نص متحرك

Dim Llabel As Integer

Private Sub Form_Load()

Form1.ScaleMode = 3

Timer1.Interval = 100

End Sub

Private Sub Timer1_Timer()

Llabel = Llabel + 10

Label1.Left = Llabel

If Llabel > 300 Then

Timer1.Interval = 0

Timer2.Interval = 100

End If

End Sub

Private Sub Timer2_Timer()

Llabel = Llabel - 10

Label1.Left = Llabel

If Llabel :D:D

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

لمعرفة هل الجهاز متصل بالإنترنت أم لا

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

Public Declare Function RasEnumConnections Lib "RasApi32.dll" Alias "RasEnumConnectionsA" (lpRasCon As Any, lpcb As Long, lpcConnections As Long) As Long
Public Declare Function RasGetConnectStatus Lib "RasApi32.dll" Alias "RasGetConnectStatusA" (ByVal hRasCon As Long, lpStatus As Any) As Long
Public Const RAS95_MaxEntryName = 256
Public Const RAS95_MaxDeviceType = 16
Public Const RAS95_MaxDeviceName = 32

Public Type RASCONN95
    dwSize As Long
    hRasCon As Long
    szEntryName(RAS95_MaxEntryName) As Byte
    szDeviceType(RAS95_MaxDeviceType) As Byte
    szDeviceName(RAS95_MaxDeviceName) As Byte
End Type

Public Type RASCONNSTATUS95
    dwSize As Long
    RasConnState As Long
    dwError As Long
    szDeviceType(RAS95_MaxDeviceType) As Byte
    szDeviceName(RAS95_MaxDeviceName) As Byte
End Type

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

Public Function IsConnected() As Boolean

Dim TRasCon(255) As RASCONN95
Dim lg As Long
Dim lpcon As Long
Dim RetVal As Long
Dim Tstatus As RASCONNSTATUS95

TRasCon(0).dwSize = 412
lg = 256 * TRasCon(0).dwSize

RetVal = RasEnumConnections(TRasCon(0), lg, lpcon)

If RetVal <> 0 Then
    MsgBox "ERROR"
    Exit Function
End If

Tstatus.dwSize = 160
RetVal = RasGetConnectStatus(TRasCon(0).hRasCon, Tstatus)

If Tstatus.RasConnState = &H2000 Then
    IsConnected = True
    Else
    IsConnected = False
End If

End Function

Private Sub Command1_Click()
If IsConnected() = True Then
    MsgBox ("الجهاز متصل بالانترنت")
    Else
    MsgBox ("الجهاز غير متصل بالانترنت")
End If
End Sub

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

للتأكد من وجود الملف

Private Sub Command1_Click()
On Error GoTo Error:
Open "ضع مسار الملف الذي تريد التأكد من وجوده هنا" For Input As #1
Close
MsgBox ("الملف موجود")
Exit Sub
Error:
MsgBox ("الملف غير موجود")

End Sub

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

لمعرفة حجم الملف بالبايت

Private Sub Command1_Click()
Print FileLen("c:Autoexec.bat")
End Sub

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

لمعرفة الوقت الذي مضى على تشغيل الويندوز بالدقيقة

Private Declare Function GetTickCount Lib "Kernel32" () As Long

Private Sub Command1_Click()
Print Format(GetTickCount / 10000 / 6, "0")
End Sub

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

لتشغيل ملف من نوع mdi

قم بوضع اداة mmcontrol

ثم قم بكتابة هذا الكود:

Private Sub Form_Load()
MMControl1.Visible = False
MMControl1.DeviceType = "sequencer"
MMControl1.FileName = ("c:FileName.mid")
MMControl1.Command = "open"
MMControl1.Command = "play"
End Sub

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

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

قم بوضع اداة mmcontrol

ثم قم بكتابة هذا الكود:

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

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

لوضع صورة في الحافظة:

Private Sub Command1_Click()
    Clipboard.Clear
    Clipboard.SetData Image1.Picture
End Sub

ولوضع نص في الحافظة:

Private Sub Command1_Click()
    Clipboard.Clear
    Clipboard.SetText (Text1.Text)
End Sub

هذه مشاركات متواضعة أرجو أن تحوز على رضاكم

سأضيف كل يوم (5) مشاركات

إذا أعجبتك هذه الفكرة ورغبت في استمرارها، أو حى لم تعجبك، أرجو أن تضيف صوتك

وإليكم خالص تحياتي

عبد الله فتحي

(f)الكود الحادي عشر(f)

لحذف أي ملف:

Private Sub Command1_Click()
Kill ("C:FileName.fnm")
End Sub

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

لعمل ملف جديد من خلال برنامجك:

open "c:FileName.txt" for append as #1
Print #1,"Willkommen auf die Erde"
Close #1

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

لمعرفة الفرق ما بين تاريخين باليوم

Private Sub Command1_Click()
On Error GoTo 1
Dim Form1Date As Date
Dim Form2Date As Date
Form1Date = Text1.Text
Form2Date = Text2.Text
Text3.Text = DateDiff("d", Text1.Text, Text2.Text) & " يوم"
Exit Sub
1 MsgBox ("من فضلك أدخل التاريخ بشكل صحيح")
End Sub

(f)الكود الرابع عشر(f)

لمعرفة مسار مجلد الـ Temp

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

Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long

وهذا الكود في الـ Form

Public Function TheTempDir() As String
Dim lpBuffer As String
Dim TempPath As Long
lpBuffer = Space(255)
TempPath = GetTempPath(255, lpBuffer)
TheTempDir = Left(lpBuffer, TempPath)
End Function
Private Sub Command1_Click()
Text1.Text = TheTempDir
End Sub

(f)الكود الخامس عشر(f)

برنامج لتحميل الملفات من الإنترنت إلى جهازك

لتحميل ملف من على الإنترنت

متطلبات البرنامج

Class Module وليكن اسمه clsDownload

Form وليكن اسمها frmMain

CommandButton وليكن اسمه cmdDownload

CommandButton وليكن اسمه cmdexit

Textbox وليكن اسمه txtFrom

Textbox وليكن اسمه txtTo

ضع الكود التالي في clsDownload

Option Explicit

Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long

Private Declare Function InternetOpen Lib "wininet" Alias "InternetOpenA" (ByVal sAgent As String, ByVal lAccessType As Long, ByVal sProxyName As String, ByVal sProxyBypass As String, ByVal lFlags As Long) As Long

Private Declare Function InternetCloseHandle Lib "wininet" (ByVal hInet As Long) As Integer

Const INTERNET_OPEN_TYPE_PRECONFIG = 0
Const INTERNET_FLAG_EXISTING_CONNECT = &H20000000
Const INTERNET_OPEN_TYPE_DIRECT = 1
Const INTERNET_OPEN_TYPE_PROXY = 3
Const INTERNET_FLAG_RELOAD = &H80000000

Public Function Get_File(sURLFileName As String, sSaveFileName As String) As Boolean

    Dim lRet As Long
    On Error GoTo err_Fix

    lRet = InternetOpen("", INTERNET_OPEN_TYPE_DIRECT, vbNullString, vbNullString, 0)
    lRet = URLDownloadToFile(0, sURLFileName, sSaveFileName, 0, 0)
    Get_File = True
    Exit Function
err_Fix:
    Debug.Print Err.LastDllError, lRet
    Err.Clear
    Get_File = False
End Function

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

Option Explicit

Private Sub Form_Load()
txtFrom.Text = "http://www.vb4arab.com/pix/book.zip"
txtTo.Text = "c:VBbook.zip"
End Sub

Private Sub cmdDownload_Click()
  Dim obj As clsDownload
  Set obj = New clsDownload
  Dim bRet As Boolean

     Screen.MousePointer = vbHourglass
       bRet = obj.Get_File(Trim(Me.txtFrom.Text), Trim(Me.txtTo.Text))
        If bRet = False Then Me.txtTo.Text = "Error downloading!"
          Screen.MousePointer = vbDefault
     Set obj = Nothing
     MsgBox "Done", vbInformation
End Sub

Private Sub cmdExit_Click()
   Unload Me
End Sub

الاخ عبدالله

اشكرك جزيل الشكر.

شكرا على الاكواد ويعطيك العافيه.

الف يعطيك العافية ارجو منك الاستمرار وتحياتي الحارة

الأخ العزيز :D عبد الله فتحي :D شكرا لك على هذه الأكواد الجميلة و أرجو منك الاستمرار في وضع الأكواد .

أخوك : سعد (f)

أشكركم أخوتي الأعزاء على تشجيعكم ... وأرجو أن لا أخيب ظنكم

بارك الله فيك اخى عبدالله

(f)الكود السادس عشر(f)

label يعرض الزمن والتاريخ:

Private Sub Form_Load()

Timer1.Interval = 1000

End Sub



Private Sub Timer1_Timer()

Label1 = Time & Date

End Sub

(f)الكود السابع عشر(f)

لنسخ الملفات من وإلى أي مكان في الهارديسك:

Private Sub Command1_Click()

FileCopy "c:Autoexec.bat", "d:Autoexec.bat"

End Sub

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

طريقتين لفتح صفحة إنترنت:

Private Sub Command1_Click()

Shell "RUNDLL32.EXE URL.DLL,FileProtocolHandler http://www.arabteam2000.com", vbNormalFocus

End Sub



Private Sub Command2_Click()

Dim X As Object

     Set X = CreateObject("InternetExplorer.Application")

         X.Navigate "www.noisrael.com"

     X.Visible = True

End Sub