أكواد + برامج + وصلات + كتب وغيرها

موافع عربية

http://www.vb4arab.com/vb/index.php

http://vb-art.virtualave.net/

http://www.cadmagazine.com/learn_vba.html

http://www.khayma.com/ism77/cgi/vb.htm

http://www.aljoher.com/prog.htm

http://www.absoft2000.com/les1.htm

http://www.khayma.com/learnvb/

http://www.geocities.com/actionscript4arab...ming/basic.html

http://alajeeb.com/ajeeb1/alajeeb22/koktail/VB.htm

هذه الاكواد مجمعه من المنتدى وهناك الكثير منها

+++++++++++++++++++++++++++

هذا الكود يقوم باختبار إذا كان البرنامج لا يشتغل من القرص المدمج فإنه يقوم بإنهائه

Private Declare Function GetDriveType Lib "kernel32.dll" Alias "GetDriveTypeA" _
    (ByVal nDrive As String) As Long

Private Sub Form_Load()
Dim driveType As Long
driveType = GetDriveType(Mid(App.Path, 1, 3))
If driveType <> 5 Then
       End
End If
End Sub

هذا الكود لمعرفة ما إذا كانت سواقة الأقرص المدمجة المحددة تحتوي على قرص أم لا

Private Declare Function GetVolumeInformation Lib "kernel32" Alias _
    "GetVolumeInformationA" (ByVal lpRootPathName As String, _
    ByVal lpVolumeNameBuffer As String, ByVal nVolumeNameSize As Long, _
    lpVolumeSerialNumber As Long, lpMaximumComponentLength As Long, _
    lpFileSystemFlags As Long, ByVal lpFileSystemNameBuffer As String, _
    ByVal nFileSystemNameSize As Long) As Long
Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" _
    (ByVal nDrive As String) As Long
Private Const DRIVE_CDROM = 5

Private Sub Command1_Click()
Dim VolName As String, FSys As String, erg As Long
Dim VolNumber As Long, MCM As Long, FSF As Long
Dim Drive As String, DriveType As Long
VolName = Space(127)
FSys = Space(127)
Drive = "D:" 'Enter the driverletter you want
DriveType& = GetDriveType(Drive$)
erg& = GetVolumeInformation(Drive$, VolName$, 127&, VolNumber&, MCM&, FSF&, FSys$, 127&)
If DriveType& = DRIVE_CDROM Then
  If erg& = 0 Then
    Print "no CD in the drive)"
  Else
    Print "CD in the drive)"
  End If
End If
End Sub

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

Public Function Wait(ByVal TimeToWait As Long) 'Time In seconds
    Dim EndTime As Long
    EndTime = GetTickCount + TimeToWait * 1000 '* 1000 Cause u give seconds and GetTickCount uses Milliseconds
    Do Until GetTickCount > EndTime
        DoEvents
        Loop
    End Function

Private Const FILE_ATTRIBUTE_HIDDEN = &H2
Private Const FILE_ATTRIBUTE_NORMAL = &H80
Private Const FILE_ATTRIBUTE_READONLY = &H1
Private Const FILE_ATTRIBUTE_SYSTEM = &H4
Private Const FILE_ATTRIBUTE_TEMPORARY = &H100


Code

'بعد علامة الاستفهام يمكنك وضع  أي شيء تريده من الاسفل مباشره 
'Archive, Compressed, Directory,Hidden,Normal,Read-Only, System, Or Temporary

Dim File
File = "هني خل اسم الملف"
SetFileAttributes File, File_Atrributes_?

وهذا هو البرنامج

استخدم خاصية حفظ باسم

والله ولي التوفيق

;)

Private Sub Command1_Click()
  ' Set CancelError is True
  CommonDialog1.CancelError = True
  On Error GoTo ErrHandler
  ' Set flags
  CommonDialog1.Flags = cdlOFNHideReadOnly
  ' Set filters
  CommonDialog1.Filter = "All Files (*.*)|*.*|Text Files" & _
  "(*.txt)|*.txt|Batch Files (*.bat)|*.bat"
  ' Specify default filter
  CommonDialog1.FilterIndex = 2
  ' Display the Open dialog box
  CommonDialog1.ShowOpen
  ' Display name of selected file
  MsgBox CommonDialog1.filename
  Exit Sub

ErrHandler:
  'User pressed the Cancel button
  Exit Sub
End Sub

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

لذلك أبدأ المشاركة في هذا الموضوع.

كود لتشغيل ملفات AVI دون الحاجة إلى أداة

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

Private Sub Form_Click()

Dim Ret As Long, A$, x As Integer, y As Integer

x = 10

y = 10

A$ = "c:top6.avi"

Ret = mciSendString("stop movie", 0&, 128, 0)

Ret = mciSendString("close movie", 0&, 128, 0)

Ret = mciSendString("open AVIvideo!" & A$ & " alias movie parent " & Form1.hWnd & " style child", 0&, 128, 0)

Ret = mciSendString("put movie window client at " & x & " " & y & " 0 0", 0&, 128, 0)

Ret = mciSendString("play movie", 0&, 128, 0)

End Sub

Private Sub Form_DblClick()

End

End Sub

Private Sub Form_Terminate()

Dim Ret As Long

Ret = mciSendString("close all", 0&, 128, 0)

End Sub

قم بوضع أداة Picture1 وزر Command1 وأداة مربع الحوار CommonDialog1

ثم انسخ الكود التالي إلى نافذة الكود لتحصل على برنامج يقوم بلقط صورة لسطح المكتب ومن ثم حفظها في ملف.

مثل زر Print Screen

الكود :

Option Base 0

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

End Type

Private Type GUID

Data1 As Long

Data2 As Integer

Data3 As Integer

Data4(7) As Byte

End Type

Private Const RASTERCAPS As Long = 38

Private Const RC_PALETTE As Long = &H100

Private Const SIZEPALETTE As Long = 104

Private Type RECT

Left As Long

Top As Long

Right As Long

Bottom As Long

End Type

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 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 SelectObject Lib "GDI32" (ByVal hDC As Long, ByVal hObject As Long) As Long

Private Declare Function BitBlt Lib "GDI32" (ByVal hDCDest As Long, ByVal XDest As Long, ByVal YDest As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hDCSrc 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 GetForegroundWindow Lib "USER32" () 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 GetWindowDC Lib "USER32" (ByVal hWnd As Long) As Long

Private Declare Function GetDC Lib "USER32" (ByVal hWnd As Long) As Long

Private Declare Function GetWindowRect Lib "USER32" (ByVal hWnd As Long, lpRect As RECT) As Long

Private Declare Function ReleaseDC Lib "USER32" (ByVal hWnd As Long, ByVal hDC As Long) As Long

Private Declare Function GetDesktopWindow Lib "USER32" () As Long

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

Public Function CreateBitmapPicture(ByVal hBmp As Long, ByVal hPal As Long) As Picture

Dim r As Long

Dim Pic As PicBmp

Dim IPic As IPicture

Dim IID_IDispatch As GUID

With IID_IDispatch

.Data1 = &H20400

.Data4(0) = &HC0

.Data4(7) = &H46

End With

With Pic

.Size = Len(Pic)

.Type = vbPicTypeBitmap

.hBmp = hBmp

.hPal = hPal

End With

r = OleCreatePictureIndirect(Pic, IID_IDispatch, 1, IPic)

Set CreateBitmapPicture = IPic

End Function

Public Function CaptureWindow(ByVal hWndSrc As Long, ByVal Client As Boolean, ByVal LeftSrc As Long, ByVal TopSrc As Long, ByVal WidthSrc As Long, ByVal HeightSrc As Long) As Picture

Dim hDCMemory As Long

Dim hBmp As Long

Dim hBmpPrev As Long

Dim r As Long

Dim hDCSrc As Long

Dim hPal As Long

Dim hPalPrev As Long

Dim RasterCapsScrn As Long

Dim HasPaletteScrn As Long

Dim PaletteSizeScrn As Long

Dim LogPal As LOGPALETTE

If Client Then

hDCSrc = GetDC(hWndSrc)

Else

hDCSrc = GetWindowDC(hWndSrc)

End If

hDCMemory = CreateCompatibleDC(hDCSrc)

hBmp = CreateCompatibleBitmap(hDCSrc, WidthSrc, HeightSrc)

hBmpPrev = SelectObject(hDCMemory, hBmp)

RasterCapsScrn = GetDeviceCaps(hDCSrc, RASTERCAPS)

HasPaletteScrn = RasterCapsScrn And RC_PALETTE

PaletteSizeScrn = GetDeviceCaps(hDCSrc, SIZEPALETTE)

If HasPaletteScrn And (PaletteSizeScrn = 256) Then

LogPal.palVersion = &H300

LogPal.palNumEntries = 256

r = GetSystemPaletteEntries(hDCSrc, 0, 256, LogPal.palPalEntry(0))

hPal = CreatePalette(LogPal)

hPalPrev = SelectPalette(hDCMemory, hPal, 0)

r = RealizePalette(hDCMemory)

End If

r = BitBlt(hDCMemory, 0, 0, WidthSrc, HeightSrc, hDCSrc, LeftSrc, TopSrc, vbSrcCopy)

hBmp = SelectObject(hDCMemory, hBmpPrev)

If HasPaletteScrn And (PaletteSizeScrn = 256) Then

hPal = SelectPalette(hDCMemory, hPalPrev, 0)

End If

r = DeleteDC(hDCMemory)

r = ReleaseDC(hWndSrc, hDCSrc)

Set CaptureWindow = CreateBitmapPicture(hBmp, hPal)

End Function

Public Function CaptureScreen() As Picture

Dim hWndScreen As Long

hWndScreen = GetDesktopWindow()

Set CaptureScreen = CaptureWindow(hWndScreen, False, 0, 0, Screen.Width Screen.TwipsPerPixelX, Screen.Height Screen.TwipsPerPixelY)

End Function

Public Function CaptureForm(frmSrc As Form) As Picture

Set CaptureForm = CaptureWindow(frmSrc.hWnd, False, 0, 0, frmSrc.ScaleX(frmSrc.Width, vbTwips, vbPixels), frmSrc.ScaleY(frmSrc.Height, vbTwips, vbPixels))

End Function

Public Function CaptureClient(frmSrc As Form) As Picture

Set CaptureClient = CaptureWindow(frmSrc.hWnd, True, 0, 0, frmSrc.ScaleX(frmSrc.ScaleWidth, frmSrc.ScaleMode, vbPixels), frmSrc.ScaleY(frmSrc.ScaleHeight, frmSrc.ScaleMode, vbPixels))

End Function

Public Function CaptureActiveWindow() As Picture

Dim hWndActive As Long

Dim r As Long

Dim RectActive As RECT

hWndActive = GetForegroundWindow()

r = GetWindowRect(hWndActive, RectActive)

Set CaptureActiveWindow = CaptureWindow(hWndActive, False, 0, 0, RectActive.Right - RectActive.Left, RectActive.Bottom - RectActive.Top)

End Function

Public Sub PrintPictureToFitPage(Prn As Printer, Pic As Picture)

Const vbHiMetric As Integer = 8

Dim PicRatio As Double

Dim PrnWidth As Double

Dim PrnHeight As Double

Dim PrnRatio As Double

Dim PrnPicWidth As Double

Dim PrnPicHeight As Double

If Pic.Height >= Pic.Width Then

Prn.Orientation = vbPRORPortrait

Else

Prn.Orientation = vbPRORLandscape

End If

PicRatio = Pic.Width / Pic.Height

PrnWidth = Prn.ScaleX(Prn.ScaleWidth, Prn.ScaleMode, vbHiMetric)

PrnHeight = Prn.ScaleY(Prn.ScaleHeight, Prn.ScaleMode, vbHiMetric)

PrnRatio = PrnWidth / PrnHeight

If PicRatio >= PrnRatio Then

PrnPicWidth = Prn.ScaleX(PrnWidth, vbHiMetric, Prn.ScaleMode)

PrnPicHeight = Prn.ScaleY(PrnWidth / PicRatio, vbHiMetric, Prn.ScaleMode)

Else

PrnPicHeight = Prn.ScaleY(PrnHeight, vbHiMetric, Prn.ScaleMode)

PrnPicWidth = Prn.ScaleX(PrnHeight * PicRatio, vbHiMetric, Prn.ScaleMode)

End If

Prn.PaintPicture Pic, 0, 0, PrnPicWidth, PrnPicHeight

End Sub

'-------------------------------------------------------------------

Private Sub Command1_Click()

CommonDialog1.DefaultExt = ".BMP"

CommonDialog1.Filter = "Bitmap Image (*.bmp)|*.bmp"

CommonDialog1.ShowSave

If CommonDialog1.FileName <> "" Then

SavePicture Picture1.Picture, CommonDialog1.FileName

End If

End Sub

Private Sub Form_Load()

Set Picture1.Picture = CaptureScreen()

Form1.WindowState = 1

End Sub

ضع زري أمر command1 , command2

ثم انسخ الكود التالي

يستخدم لتغيير خلفية سطح المكتب.

Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" _

(ByVal uAction As Long, ByVal uParam As Long, _

ByVal lpvParam As String, ByVal fuWinIni As Long) As Long

Const SPIF_UPDATEINIFILE = &H1

Const SPI_SETDESKWALLPAPER = 20

Const SPIF_SENDWININICHANGE = &H2

Private Sub Command1_Click()

Dim X As Long

X = SystemParametersInfo(SPI_SETDESKWALLPAPER, 0&, "(None)", _

SPIF_UPDATEINIFILE Or SPIF_SENDWININICHANGE)

MsgBox "Wallpaper was removed"

End Sub

Private Sub Command2_Click()

Dim FileName As String

Dim X As Long

FileName = "C:WINDOWSA.bmp"

X = SystemParametersInfo(SPI_SETDESKWALLPAPER, 0&, FileName, _

SPIF_UPDATEINIFILE Or SPIF_SENDWININICHANGE)

MsgBox "Wallpaper was changed"

End Sub

لرسم دوائر متداخله عجيب جربه

Private Sub Command1_Click()
Dim x, y, xx, yy, hu As Integer
For hu = 1 To 10000 Step 50
x = 6000 + 1400 * Cos(hu)
y = 2500 + 500 * Sin(hu)
Circle (x, y), 555, 44

Circle (y + 3000, x), 555, 44
Circle (x, y + 3000), 555, 44

Circle (y + 3500, x - 3500), 555, 44
Next hu
End Sub

والله ولى التوفيق

;)

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

Private Sub Command1_Click()
Dim str As String
Dim wd() As String

str = "الفريق * العربي * 2000"
wd() = Split(str, "*")

For Each y In wd()
   MsgBox y
Next

End Sub

Dim winPath As String
winPath = Environ$("windir")

أيضاً للحصول على باث الويندوز بطريقة الا بي آي.

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

Public Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long

Public Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long

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

وهذا في زر الأمر:

Dim path As String

Dim lonstatus As Long

path = Space$(255)

lonstatus = GetWindowsDirectory(path, 255)

Label1.Caption = path

وللحصول على باث السيستم :

Dim path As String

Dim lonstatus As Long

path = Space$(255)

lonstatus = GetSystemDirectory(path, 255)

Label2.Caption = path

وللحصول على مسار الملفات المؤقتة :

Dim path As String

Dim lonstatus As Long

path = Space$(255)

lonstatus = GetTempPath(255, path)

Label3.Caption = path

على فكرة أخي حسين هذا الموضوع سيكون من أروع الموضوعات.

;)

أخي عبد الغني كيف حالك وشكرا لك على المشاركات الفعالة

لتغير BackGround

لعمل ذلك .. قم بفتح شاشة الكود واكتب الشفرة التالية في البداية (كأول سطر):

Private Declare Function SystemParametersInfo Lib "user32" Alias _
    "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam _
    As Long, ByVal lpvParam As String, ByVal fuWinIni As Long) As Long
    Const SPI_SETDESKWALLPAPER = 20
    Const SPIF_UPDATEINIFILE = &H1
    Const SPIF_SENDWININICHANGE = &H2
‘=========================================================================

ولتغيير خلفية سطح المكتب قم باستخدام الكود التالي باعتبار ان
 المتغير File_Name يحمل اسم ومسار الصورة المراد وضعها كخلفية لسطح المكتب : 

‘=========================================================================
Dim File_Name As String
Dim X As Long
File_Name = "c:windowssetup.bmp"
X = SystemParametersInfo(SPI_SETDESKWALLPAPER, 0&, File_Name, _
        SPIF_UPDATEINIFILE Or SPIF_SENDWININICHANGE)
+++++=====================================================================’

أما اذا اردت ان تجعل سطح المكتب بدون خلفية .. استخدم الكود التالي: 
‘=========================================================================

Dim X As Long
X = SystemParametersInfo(SPI_SETDESKWALLPAPER, 0&, "(None)", _
        SPIF_UPDATEINIFILE Or SPIF_SENDWININICHANGE

Dim Response As String, Reply As Integer, DateNow As String
Dim first As String, Second As String, Third As String
Dim Fourth As String, Fifth As String, Sixth As String
Dim Seventh As String, Eighth As String
Dim Start As Single, Tmr As Single



Sub SendEmail(MailServerName As String, FromName As String, FromEmailAddress As String, ToName As String, ToEmailAddress As String, EmailSubject As String, EmailBodyOfMessage As String)

    Winsock1.LocalPort = 0 ' Must set local port to 0 (Zero) or you can only send 1 e-mail pre program start

If Winsock1.State = sckClosed Then ' Check to see if socet is closed
    DateNow = Format(Date, "Ddd") & ", " & Format(Date, "dd Mmm YYYY") & " " & Format(Time, "hh:mm:ss") & "" & " -0600"
    first = "mail from:" + Chr(32) + FromEmailAddress + vbCrLf ' Get who's sending E-Mail address
    Second = "rcpt to:" + Chr(32) + ToEmailAddress + vbCrLf ' Get who mail is going to
    Third = "Date:" + Chr(32) + DateNow + vbCrLf ' Date when being sent
    Fourth = "From:" + Chr(32) + FromName + vbCrLf ' Who's Sending
    Fifth = "To:" + Chr(32) + ToNametxt + vbCrLf ' Who it going to
    Sixth = "Subject:" + Chr(32) + EmailSubject + vbCrLf ' Subject of E-Mail
    Seventh = EmailBodyOfMessage + vbCrLf ' E-mail message body
    Ninth = "mouse mailer" + vbCrLf ' What program sent the e-mail, customize this
    Eighth = Fourth + Third + Ninth + Fifth + Sixth  ' Combine for proper SMTP sending

    Winsock1.Protocol = sckTCPProtocol ' Set protocol for sending
    Winsock1.RemoteHost = MailServerName ' Set the server address
    Winsock1.RemotePort = 25 ' Set the SMTP Port
    Winsock1.Connect ' Start connection

    WaitFor ("220")

    StatusTxt.Caption = "Connecting...."
    StatusTxt.Refresh

    Winsock1.SendData ("HELO worldcomputers.com" + vbCrLf)

    WaitFor ("250")

    StatusTxt.Caption = "Connected"
    StatusTxt.Refresh

    Winsock1.SendData (first)

    StatusTxt.Caption = "Sending Message"
    StatusTxt.Refresh

    WaitFor ("250")

    Winsock1.SendData (Second)

    WaitFor ("250")

    Winsock1.SendData ("data" + vbCrLf)

    WaitFor ("354")


    Winsock1.SendData (Eighth + vbCrLf)
    Winsock1.SendData (Seventh + vbCrLf)
    Winsock1.SendData ("." + vbCrLf)

    WaitFor ("250")

    Winsock1.SendData ("quit" + vbCrLf)

    StatusTxt.Caption = "Disconnecting"
    StatusTxt.Refresh

    WaitFor ("221")

    Winsock1.Close
Else
    MsgBox (Str(Winsock1.State))
End If

End Sub
Sub WaitFor(ResponseCode As String)
    Start = Timer ' Time event so won't get stuck in loop
    While Len(Response) = 0
        Tmr = Start - Timer
        DoEvents ' Let System keep checking for incoming response **IMPORTANT**
        If Tmr > 50 Then ' Time in seconds to wait
            MsgBox "SMTP service error, timed out while waiting for response", 64, MsgTitle
            Exit Sub
        End If
    Wend
    While Left(Response, 3) <> ResponseCode
        DoEvents
        If Tmr > 50 Then
            MsgBox "SMTP service error, impromper response code. Code should have been: " + ResponseCode + " Code recieved: " + Response, 64, MsgTitle
            Exit Sub
        End If
    Wend
Response = "" ' Sent response code to blank **IMPORTANT**
End Sub


Private Sub Command1_Click()
    SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtEmailBodyOfMessage.Text
    MsgBox ("Mail Sent")
    StatusTxt.Caption = "Mail Sent"
    StatusTxt.Refresh
    Beep

    Close
End Sub

Private Sub Command2_Click()

    End

End Sub

Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)

    Winsock1.GetData Response ' Check for incoming response *IMPORTANT*

End Sub

لمعرفة دقة عرض الشاشة :

Dim intWidth As Integer

Dim intHeight As Integer

intWidth = Screen.Width Screen.TwipsPerPixelX

intHeight = Screen.Height Screen.TwipsPerPixelY

MsgBox "Screen Resolution:" + Str$(intWidth) + " x" + Str$(intHeight)

لجعل صورة ملونة متدرجة بلون فضي :

Picture1.ScaleMode = vbPixels

x = Picture1.ScaleWidth

y = Picture1.ScaleHeight

For i = 0 To y - 1

For j = 0 To x - 1

pixel = Picture1.Point(j, i)

red = pixel Mod 256

green = ((pixel And &HFF00) / 256) Mod 256

blue = (pixel And &HFF0000) / 65536

g = ((red * 30) + (green * 60) + (blue * 20)) / 100

Picture1.PSet (j, i), RGB(g, g, g)

Next

Next

Picture1.ScaleMode = vbTwips

ضع أداة (Picture) وسمها pic3d

ثم أضف Class Module

ضع الكود التالي في Class Module :

Option Explicit



Const PI = 3.141593

Const PS_SOLID = 0

Dim HALF_SCREEN_WIDTH As Long

Dim HALF_SCREEN_HEIGHT As Long

Dim HPC As Long

Dim VPC As Long

Dim ASPECT_COMP As Long

Private obj3dObject As Object3D

Private Render As PictureBox

Private Declare Function PolyDraw Lib "gdi32" (ByVal hdc As Long, lppt As POINTAPI, lpbTypes As Byte, ByVal cCount As Long) As Long

Private Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long

Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor 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 Polygon Lib "gdi32" (ByVal hdc As Long, lpPoint As POINTAPI, ByVal nCount As Long) As Long

Private Type Triplet

    First As Long

    Second As Long

    Third As Long

End Type

Private Type Point3d

    X As Double

    Y As Double

    Z As Double

End Type

Private Type Point2d

    X As Double

    Y As Double

End Type

Private Type Object3D

    Name As String

    Version As String

    NumVertices As Long

    NumTriangles As Long

    Xangle As Long

    Yangle As Long

    Zangle As Long

    ScaleFactor As Double

    CenterofWorld As Point3d

    LocalCoord() As Point3d

    RotatedLocalCoord() As Point3d

    WorldCoord() As Point3d

    CameraCoord() As Point3d

    Triangle() As Triplet

    ScreenCoord() As Point2d

    Isvisible() As Boolean

    Color() As Long

End Type

Private Type Face

    Y As Double

    X As Double

End Type

Private Type POINTAPI

        X As Long

        Y As Long

End Type

Private Sub CalculateNormals()

    Dim lngIncr As Long

    Dim ObjectFace(0 To 2) As Face

    

        For lngIncr = 0 To obj3dObject.NumTriangles - 1

            

            ObjectFace(0).X = obj3dObject.ScreenCoord(obj3dObject.Triangle(lngIncr).First).X

            ObjectFace(0).Y = obj3dObject.ScreenCoord(obj3dObject.Triangle(lngIncr).First).Y

            ObjectFace(1).X = obj3dObject.ScreenCoord(obj3dObject.Triangle(lngIncr).Second).X

            ObjectFace(1).Y = obj3dObject.ScreenCoord(obj3dObject.Triangle(lngIncr).Second).Y

            ObjectFace(2).X = obj3dObject.ScreenCoord(obj3dObject.Triangle(lngIncr).Third).X

            ObjectFace(2).Y = obj3dObject.ScreenCoord(obj3dObject.Triangle(lngIncr).Third).Y

            

            If ((ObjectFace(0).Y - ObjectFace(2).Y) * (ObjectFace(1).X - ObjectFace(0).X)) - _

               ((ObjectFace(0).X - ObjectFace(2).X) * (ObjectFace(1).Y - ObjectFace(0).Y)) > 0 Then

                obj3dObject.Isvisible(lngIncr) = True

            Else

                obj3dObject.Isvisible(lngIncr) = False

            End If

            

        Next



End Sub





Public Sub SetRotations(Optional X As Double, Optional Y As Double, Optional Z As Double)



    If Not (IsMissing(X)) Then

        obj3dObject.Xangle = X

    End If

    

    If Not (IsMissing(Y)) Then

        obj3dObject.Yangle = Y

    End If

    

    If Not (IsMissing(Z)) Then

        obj3dObject.Zangle = Z

    End If



End Sub





Public Sub SetTranslations(Optional XPos As Variant, Optional YPos As Variant, Optional ZPos As Variant)



    If Not (IsMissing(XPos)) Then

        obj3dObject.CenterofWorld.X = XPos

    End If

    

    If Not (IsMissing(YPos)) Then

        obj3dObject.CenterofWorld.Y = YPos

    End If

    

    If Not (IsMissing(ZPos)) Then

        obj3dObject.CenterofWorld.Z = ZPos

    End If



End Sub





Public Sub LoadObject(strFileName As String, DeviceContext As PictureBox, lngCenterofWorldX As Double, lngCenterofWorldY As Double, lngCenterofWorldZ As Double, dblScaleFactor As Double, lngSetXRotation As Long, lngSetYRotation As Long, lngSetZRotation As Long)



    Dim strTemp As String

    Dim lngNumTemp As Long

    Dim lngNumVertices As Long

    Dim lngNumTriangles As Long

    Set Render = DeviceContext

    HALF_SCREEN_HEIGHT = Render.ScaleHeight / 2

    HALF_SCREEN_WIDTH = Render.ScaleWidth / 2

    ASPECT_COMP = (Render.ScaleHeight) / ((Render.ScaleWidth * 3) / 4)

    HPC = HALF_SCREEN_WIDTH / (Tan((60 / 2) * (PI / 180)))

    VPC = HALF_SCREEN_HEIGHT / (Tan((60 / 2) * (PI / 180)))

    obj3dObject.CenterofWorld.X = lngCenterofWorldX

    obj3dObject.CenterofWorld.Y = lngCenterofWorldY

    obj3dObject.CenterofWorld.Z = lngCenterofWorldZ

    obj3dObject.ScaleFactor = dblScaleFactor

    obj3dObject.Xangle = lngSetXRotation

    obj3dObject.Yangle = lngSetYRotation

    obj3dObject.Zangle = lngSetZRotation

    Open strFileName For Input As 1

    Line Input #1, strTemp

    If strTemp <> "3D OBJECT DEFINITION FILE" Then

        MsgBox "Not a valid object file!", vbOKOnly + vbCritical, "Open"

        Exit Sub

    End If

    Line Input #1, strTemp

    obj3dObject.Version = Trim(strTemp)

    Line Input #1, strTemp

    obj3dObject.Name = Trim(strTemp)



    Line Input #1, strTemp

    Line Input #1, strTemp

    Do While strTemp <> ""



        lngNumVertices = lngNumVertices + 1

        ReDim Preserve obj3dObject.LocalCoord(0 To lngNumVertices - 1)

        

        obj3dObject.LocalCoord(lngNumVertices - 1).X = CDbl(Left(strTemp, InStr(1, strTemp, ",", vbTextCompare) - 1))

        lngNumTemp = InStr(1, strTemp, ",", vbTextCompare)

        obj3dObject.LocalCoord(lngNumVertices - 1).Y = CDbl(Mid(strTemp, lngNumTemp + 1, InStr(lngNumTemp + 1, strTemp, ",", vbTextCompare) - lngNumTemp - 1))

        lngNumTemp = InStr(lngNumTemp + 1, strTemp, ",", vbTextCompare)

        obj3dObject.LocalCoord(lngNumVertices - 1).Z = CDbl(Right(strTemp, Len(strTemp) - lngNumTemp))

            

        Line Input #1, strTemp

    Loop

    obj3dObject.NumVertices = lngNumVertices

    Line Input #1, strTemp

    Do While strTemp <> "END"



        lngNumTriangles = lngNumTriangles + 1

        ReDim Preserve obj3dObject.Triangle(0 To lngNumTriangles - 1)

        ReDim Preserve obj3dObject.Color(0 To lngNumTriangles - 1)

        

        obj3dObject.Triangle(lngNumTriangles - 1).First = CDbl(Left(strTemp, InStr(1, strTemp, ",", vbTextCompare) - 1))

        lngNumTemp = InStr(1, strTemp, ",", vbTextCompare)

        obj3dObject.Triangle(lngNumTriangles - 1).Second = CDbl(Mid(strTemp, lngNumTemp + 1, InStr(lngNumTemp + 1, strTemp, ",", vbTextCompare) - lngNumTemp - 1))

        lngNumTemp = InStr(lngNumTemp + 1, strTemp, ",", vbTextCompare)

        obj3dObject.Triangle(lngNumTriangles - 1).Third = CDbl(Mid(strTemp, lngNumTemp + 1, InStr(lngNumTemp + 1, strTemp, ",", vbTextCompare) - lngNumTemp - 1))

        lngNumTemp = InStr(lngNumTemp + 1, strTemp, ",", vbTextCompare)

        obj3dObject.Color(lngNumTriangles - 1) = CLng(Right(strTemp, Len(strTemp) - lngNumTemp))

            

        Line Input #1, strTemp

    Loop

    obj3dObject.NumTriangles = lngNumTriangles



    Close #1

    ReDim Preserve obj3dObject.RotatedLocalCoord(0 To obj3dObject.NumVertices - 1)

    ReDim Preserve obj3dObject.WorldCoord(0 To obj3dObject.NumVertices - 1)

    ReDim Preserve obj3dObject.CameraCoord(0 To obj3dObject.NumVertices - 1)

    ReDim Preserve obj3dObject.ScreenCoord(0 To obj3dObject.NumVertices - 1)

    ReDim Preserve obj3dObject.Isvisible(0 To obj3dObject.NumTriangles - 1)



End Sub

Private Sub LocaltoWorld()



    Dim lngIncr As Long

    For lngIncr = 0 To obj3dObject.NumVertices - 1

        obj3dObject.WorldCoord(lngIncr).X = obj3dObject.RotatedLocalCoord(lngIncr).X + obj3dObject.CenterofWorld.X

        obj3dObject.WorldCoord(lngIncr).Y = obj3dObject.RotatedLocalCoord(lngIncr).Y + obj3dObject.CenterofWorld.Y

        obj3dObject.WorldCoord(lngIncr).Z = obj3dObject.RotatedLocalCoord(lngIncr).Z + obj3dObject.CenterofWorld.Z

    Next



End Sub

Private Sub Project3dto2d()

    

    Dim lngIncr As Long

    For lngIncr = 0 To obj3dObject.NumVertices - 1

        obj3dObject.ScreenCoord(lngIncr).X = (obj3dObject.WorldCoord(lngIncr).X * HPC / obj3dObject.WorldCoord(lngIncr).Z) + HALF_SCREEN_WIDTH

        obj3dObject.ScreenCoord(lngIncr).Y = (-obj3dObject.WorldCoord(lngIncr).Y * VPC * ASPECT_COMP / obj3dObject.WorldCoord(lngIncr).Z) + HALF_SCREEN_HEIGHT

    Next



End Sub

Public Sub RenderObject()



    Dim lngIncr As Long

    Dim ScreenBuffer(0 To 2) As POINTAPI

    Dim Brush As Long

    Dim Pen As Long

    Dim OldBrush As Long

    Dim OldPen As Long

    DoRotations

    LocaltoWorld

    Project3dto2d

    CalculateNormals



    For lngIncr = 0 To obj3dObject.NumTriangles - 1

        If obj3dObject.Isvisible(lngIncr) = True Then

            With obj3dObject.ScreenCoord(obj3dObject.Triangle(lngIncr).First)

                ScreenBuffer(0).X = .X

                ScreenBuffer(0).Y = .Y

            End With

            With obj3dObject.ScreenCoord(obj3dObject.Triangle(lngIncr).Second)

                ScreenBuffer(1).X = .X

                ScreenBuffer(1).Y = .Y

            End With

            With obj3dObject.ScreenCoord(obj3dObject.Triangle(lngIncr).Third)

                ScreenBuffer(2).X = .X

                ScreenBuffer(2).Y = .Y

            End With

            Brush = CreateSolidBrush(obj3dObject.Color(lngIncr))

            Pen = CreatePen(PS_SOLID, 1, obj3dObject.Color(lngIncr))

            OldPen = SelectObject(Render.hdc, Pen)

            OldBrush = SelectObject(Render.hdc, Brush)

            Polygon Render.hdc, ScreenBuffer(0), 3

            SelectObject Render.hdc, OldPen

            SelectObject Render.hdc, OldBrush

            DeleteObject Pen

            DeleteObject Brush

        End If

        

    Next



End Sub





Property Get RotateX() As Long



    RotateX = obj3dObject.Xangle



End Property



Property Get RotateY() As Long



    RotateY = obj3dObject.Yangle



End Property



Property Get RotateZ() As Long



    RotateZ = obj3dObject.Zangle



End Property







Property Get TranslateX() As Double



    TranslateX = obj3dObject.CenterofWorld.X



End Property



Property Get TranslateY() As Double



    TranslateY = obj3dObject.CenterofWorld.Y



End Property



Property Get TranslateZ() As Double



    TranslateZ = obj3dObject.CenterofWorld.Z



End Property



Private Sub DoRotations()



    Dim lngIncr As Long

    Dim RotationBuffer As Point3d

    If obj3dObject.Xangle > 360 Then

        obj3dObject.Xangle = obj3dObject.Xangle - 360

    ElseIf obj3dObject.Xangle < 0 Then

        obj3dObject.Xangle = obj3dObject.Xangle + 360

    End If

    If obj3dObject.Yangle > 360 Then

        obj3dObject.Yangle = obj3dObject.Yangle - 360

    ElseIf obj3dObject.Yangle < 0 Then

        obj3dObject.Yangle = obj3dObject.Yangle + 360

    End If

    If obj3dObject.Zangle > 360 Then

        obj3dObject.Zangle = obj3dObject.Zangle - 360

    ElseIf obj3dObject.Zangle < 0 Then

        obj3dObject.Zangle = obj3dObject.Zangle + 360

    End If

    For lngIncr = 0 To obj3dObject.NumVertices - 1

        RotationBuffer = obj3dObject.LocalCoord(lngIncr)

        obj3dObject.RotatedLocalCoord(lngIncr).X = obj3dObject.ScaleFactor * (RotationBuffer.X)

        obj3dObject.RotatedLocalCoord(lngIncr).Y = obj3dObject.ScaleFactor * (RotationBuffer.Y * Cos(DegtoRad(obj3dObject.Xangle)) - RotationBuffer.Z * Sin(DegtoRad(obj3dObject.Xangle)))

        obj3dObject.RotatedLocalCoord(lngIncr).Z = obj3dObject.ScaleFactor * (RotationBuffer.Z * Cos(DegtoRad(obj3dObject.Xangle)) + RotationBuffer.Y * Sin(DegtoRad(obj3dObject.Xangle)))

        

        RotationBuffer = obj3dObject.RotatedLocalCoord(lngIncr)

        obj3dObject.RotatedLocalCoord(lngIncr).X = obj3dObject.ScaleFactor * (RotationBuffer.X * Cos(DegtoRad(obj3dObject.Yangle)) + RotationBuffer.Z * Sin(DegtoRad(obj3dObject.Yangle)))

        obj3dObject.RotatedLocalCoord(lngIncr).Y = obj3dObject.ScaleFactor * (RotationBuffer.Y)

        obj3dObject.RotatedLocalCoord(lngIncr).Z = obj3dObject.ScaleFactor * (RotationBuffer.Z * Cos(DegtoRad(obj3dObject.Yangle)) - RotationBuffer.X * Sin(DegtoRad(obj3dObject.Yangle)))

        

        RotationBuffer = obj3dObject.RotatedLocalCoord(lngIncr)

        obj3dObject.RotatedLocalCoord(lngIncr).X = obj3dObject.ScaleFactor * (RotationBuffer.X * Cos(DegtoRad(obj3dObject.Zangle)) - RotationBuffer.Y * Sin(DegtoRad(obj3dObject.Zangle)))

        obj3dObject.RotatedLocalCoord(lngIncr).Y = obj3dObject.ScaleFactor * (RotationBuffer.Y * Cos(DegtoRad(obj3dObject.Zangle)) + RotationBuffer.X * Sin(DegtoRad(obj3dObject.Zangle)))

        obj3dObject.RotatedLocalCoord(lngIncr).Z = obj3dObject.ScaleFactor * (RotationBuffer.Z)

    Next



End Sub





Private Function DegtoRad(lngDeg As Long) As Double

    DegtoRad = (lngDeg * PI) / 180



End Function







وضع هذا الكود في نافذة الكود العادية:



Option Explicit

Dim obj1 As New cls3dObject

Dim obj2 As New cls3dObject

Dim obj3 As New cls3dObject

Dim obj4 As New cls3dObject

Sub RunDemo()



    Do

        obj1.SetRotations obj1.RotateX - 3, obj1.RotateY + 3, obj1.RotateZ + 3

        obj2.SetRotations obj2.RotateX + 2, obj2.RotateY - 2, obj2.RotateZ + 1

        obj3.SetRotations obj3.RotateX + 1, obj3.RotateY + 1, obj3.RotateZ - 1

        obj4.SetRotations obj4.RotateX + 3, obj4.RotateY - 2, obj4.RotateZ + 1

        pic3d.Cls

        obj1.RenderObject

        obj2.RenderObject

        obj3.RenderObject

        obj4.RenderObject

        DoEvents

    Loop



End Sub

Private Sub Form_Load()



    Me.Show

    obj1.LoadObject App.Path & "cube.odf", pic3d, -20, 0, -75, 2, 0, 0, 0

    obj2.LoadObject App.Path & "cube.odf", pic3d, 20, 0, -70, 2, 0, 0, 0

    obj3.LoadObject App.Path & "cube.odf", pic3d, 0, -20, -65, 2, 0, 0, 0

    obj4.LoadObject App.Path & "cube.odf", pic3d, 0, 20, -60, 2, 0, 0, 0

    RunDemo

    

End Sub



Private Sub Form_Unload(Cancel As Integer)



    End



End Sub



Private Sub pic3d_Click()



End Sub

لتحصل على أشكال ثلاثية الأبعاد متحركة بألوان مختلفة.

هل لديك صورة ونريد أن تجعلها تغمق ألوانها حتى تصبح سوداء ( بطريقة جميلة )

إليكم الكود :

Option Explicit

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 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 DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long

Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long

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



Private Const SRCAND = &H8800C6

Private Const SRCCOPY = &HCC0020



Private Sub Command1_Click()

    Dim lDC As Long

    Dim lBMP As Long

    Dim W As Integer

    Dim H As Integer

    Dim lColor As Long

    

    Screen.MousePointer = vbHourglass

    

    W = ScaleX(Picture1.Picture.Width, vbHimetric, vbPixels)

    H = ScaleY(Picture1.Picture.Height, vbHimetric, vbPixels)

    lBMP = CreateCompatibleBitmap(Picture1.hdc, W, H)

    lDC = CreateCompatibleDC(Picture1.hdc)

    Call SelectObject(lDC, lBMP)

    BitBlt lDC, 0, 0, W, H, Picture1.hdc, 0, 0, SRCCOPY

    Picture1 = LoadPicture("")

    

    For lColor = 255 To 0 Step -3

        Picture1.BackColor = RGB(lColor, lColor, lColor)

        BitBlt Picture1.hdc, 0, 0, W, H, lDC, 0, 0, SRCAND

        Sleep 15

    Next

    Call DeleteDC(lDC)

    Call DeleteObject(lBMP)

    Screen.MousePointer = vbDefault

    

End Sub

لمعرفة إحداثيات اللون الذي يقع تحت مؤشر الفأرة.

ضع Timer1 و Label2

Option Explicit

Private Type POINTAPI

x As Long

y As Long

End Type

Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long

Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long

Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long

Private Sub Form_Load()

Timer1.Interval = 100

End Sub

Private Sub Timer1_Timer()

Dim tPOS As POINTAPI

Dim sTmp As String

Dim lColor As Long

Dim lDC As Long

lDC = GetWindowDC(0)

Call GetCursorPos(tPOS)

lColor = GetPixel(lDC, tPOS.x, tPOS.y)

Label2.BackColor = lColor

sTmp = Right$("000000" & Hex(lColor), 6)

Caption = "R:" & Right$(sTmp, 2) & " G:" & Mid$(sTmp, 3, 2) & " B:" & Left$(sTmp, 2)

End Sub

وأنا من عندي أقدم لكم هذا الموقع الأكثر من رائع

وبه تجد مكتبة متكاملة لكل ما يتعلق بلغات البرمجة بما فيها الفجوال بيسك

تحياتي

www.planet-source-code.com

أستخدم حفظ باسم

والله الموفق

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 
'--------------- 
Private Sub Timer1_Timer() 
Timer1.Interval = Timer1.Interval + "1000" 
If Timer1.Interval = "2000" Then 
Call mciSendString("Set CDAudio Door Open", 0&, 0&, 0&) 
End If 
If Timer1.Interval = "5000" Then 
Call mciSendString("Set CDAudio Door Closed", 0&, 0&, 0&) 
End If 
End Sub

Private Sub Command1_Click() 
Dim LonStatus As Long 
Dim flag As Long 
Dim result As Integer 
Dim prompt As String 
Dim Title As String 
prompt = "هل تريد بالتأكيد إيقاف تشغيل Windows ؟" 
Title = "برنامج إيقاف تشغيل Windows" 
result = MsgBox(prompt, _ 
4 + 32 + 524288 + 1048576, Title) 
If result = 6 Then 
flag = 1 
LonStatus = ExitWindowsEx(flag, 0) 
End If 
End Sub 

نفس العمليه بس مع استخدام API
1.لإعادة تشغيل الكمبيوتر 
shell "RUNDLL.EXE user.exe,exitwindowsexec" 

2.لإطفاء الكمبيوتر نهائياً 
shell "RUNDLL.EXE user.exe,exitwindows" 

3. لتغيير المستخدم (لوغ اوف) 
shell "RUNDLL.EXE shell32.dll,SHExitWindowsEx 0"

‘لمعرفة مجلد الويندوز
Private Declare Function GetSystemDirectory Lib "kernel32" Alias _
"GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
‘الدالة الثانية هي GetWindowsDirectory تستخدم للحصول على نص مسار مجلد الويندوز 
Private Declare Function GetWindowsDirectory Lib "kernel32" Alias _ 
"GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long 
‘الدالة الثالثة هي GetTempPath تستخدم للحصول على نص مسار مجلد ملفات المؤقته
Private Declare Function GetTempPath Lib "kernel32" Alias _
"GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
‘وهذا مثال على أستخدام أحداها وباقي الدوال تستخدم 
Sub Command1_Click()
Dim winpath As String
'تعبة النص بالحرف نل كرتر والذي الآسكي له صفر 260 مره
winpath = String(260, 0)
'أستدعاء الداله
GetWindowsDirectory winpath, 260
''إنشاء رساله فيها نص بمسار مجلد الويندو
MsgBox winpath
End Sub