مكتبة أكواد بها أكثر من 200 كود فيجول بيسك من عضو غائب عن الأضواء

[ahmed ksnv]

وأريد منكم عدم وضع ردود أو تشجيع حتى أنتهي من أكواد الفيجوال بيسك
بسم الله نبدأ



المجموعة الأولى : أكواد الاتصالات

اتصال تليفوني

Private Sub Command1_Click()
On Error GoTo eror_non
Dim Number$, Temp$
Call_n.Caption = "الإتصال بـ / " & Trim(Text1)

Number$ = Trim(Text1.Text)
If Number$ = "" Then Exit Sub
Command1.Enabled = False
Command2.Enabled = True
Status = "جاري الإتصال بـ " + Number$

Dial Number$
eror_non:
End Sub
Private Sub Dial(Number$)
On Error GoTo error_1
Dim DialString$, FromModem$, dummy
Dim msg1 As String
Dim msg2 As String
Dim response As Integer
Dim mod_com As Integer

mod_com = 2

DialString$ = "ATDT" + Number$ + ";" + vbCr
MSComm1.CommPort = mod_com
MSComm1.Settings = "9600,N,8,1"

On Error Resume Next
MSComm1.PortOpen = True
If Err Then
Beep
Screen.MousePointer = 0
msg1 = " COM تعذر الوصول إلى جهاز المودم أو مخرج الإتصال " & mod_com
msg2 = "للمساعدة أنظر دليل رسائل الأخطاء "
MsgBox msg1, 16, msg2
Status = ""
DialButton.Enabled = True
CancelButton.Enabled = False
Exit Sub
End If

MSComm1.InBufferCount = 0

MSComm1.Output = DialString$

Do
dummy = DoEvents()
If MSComm1.InBufferCount Then
FromModem$ = FromModem$ + MSComm1.Input
If InStr(FromModem$, "OK") Then

CancelButton.Enabled = False
Status = "تم الإتصال بـ " + Number$
Beep
response = MsgBox("اختر موافق لتحويل المكالمة للهاتف(ارفع السماعة أولا) أو الغاء الامر لإنهاء المكالمة", 1)
If response = 1 Then '== موافق
DialButton.Enabled = True
CancelButton.Enabled = False
Status = ""
Exit Do
Else
CancelFlag = False
Status = ""
DialButton.Enabled = True
CancelButton.Enabled = False
Exit Do
End If
Exit Do
End If
End If

If CancelFlag Then
CancelFlag = False
Exit Do
End If
Loop

MSComm1.Output = "ATH" + vbCr

MSComm1.PortOpen = False
Exit Sub
'---------------------------------------
error_1:
Beep
Screen.MousePointer = 0
msg1 = " تعذر الوصول إلى جهاز المودم، المودم تحت استخدام برنامج آخر!،أعد تشغيل البرنامج و كرر المحاولة"
msg2 = "للمساعدة أنظر دليل رسائل الأخطاء "
MsgBox msg1, 16, msg2
Status = ""
DialButton.Enabled = True
CancelButton.Enabled = False
Exit Sub
End Sub

إجراء اتصال تليفوني

Private Declare Function tapiRequestMakeCall& Lib "TAPI32.DLL" (ByVal DestAddress$, ByVal AppName$, ByVal CalledParty$, ByVal Comment$)
Private Const TAPIERR_NOREQUESTRECIPIENT = -2&
Private Const TAPIERR_REQUESTQUEUEFULL = -3&
Private Const TAPIERR_INVALDESTADDRESS = -4&


Private Sub cmdDial_Click()
    Dim buff As String
    Dim nResult As Long

    'Invoke tapiRequestMakeCall. If tapiRequestMakeCall returns 0, the
    'request has been accepted. It is up to the call manager application
    'to do any further work. The second-to-last argument should be
    'changed to be the name of the person you are dialing.
    nResult = tapiRequestMakeCall&(Trim$(txtNumber), CStr(Caption), "Test Dial", "")
    'Display message if error
    If nResult <> 0 Then
        buff = "Error dialing number : "
        Select Case nResult
            Case TAPIERR_NOREQUESTRECIPIENT
                buff = buff & "No Windows Telephony dialing application is running and none could be started."
            Case TAPIERR_REQUESTQUEUEFULL
                buff = buff & "The queue of pending Windows Telephony dialing requests is full."
            Case TAPIERR_INVALDESTADDRESS
                buff = buff & "The phone number is not valid."
            Case Else
                buff = buff & "Unknown error."
        End Select
        MsgBox buff
    End If
End Sub

Private Sub cmdExit_Click()
    Unload Me
End Sub

Private Sub Form_Load()
    Move (Screen.Width - Width) \ 2, (Screen.Height - Height) \ 2
    EnableDial
End Sub

Private Sub txtNumber_Change()
    EnableDial
End Sub

Private Sub EnableDial()
    cmdDial.Enabled = Len(Trim$(txtNumber)) > 0
End Sub

أرسل رسالة للجوالSMS

Dim SMS As Simplewire.SMS 
Dim carrier As Simplewire.SMSCarrier 
Dim Index As Integer 
' instantiate the the request 
Set SMS = New Simplewire.SMS 
' send off a carrier list request 
SMS.CarrierListSend 
' first off, we need to check if the req
'     uest was a success 
If SMS.Success = False Then 
' display the error de******ion 
MsgBox SMS.ErrorDesc & " " & SMS.ErrorCode, vbCritical, "Carrier List Error" 
' kill the pager interfaces 
Set SMS = Nothing 
' stop the program 
End 
' otherwise, we have a valid response 
Else 
' resize PagerService array to make a pe
'     rfect fit 
ReDim SMSCarrierID(SMS.CarrierList.Count) 
ReDim SMSCarrierTextMaxLength(SMS.CarrierList.Count) 
' init the integer 
Index = 0 
' loop until the next service doesnt exi
'     st 


For Each carrier In SMS.CarrierList 
    ' set the new item on the combo box and 
    '     set the subtitle in the 
    .CarrierList.AddItem carrier.Title & " " & carrier.Subtitle 
    ' set the service id for the global serv
    '     ice id array 
    SMSCarrierID(Index) = carrier.ID 
    SMSCarrierTextMaxLength(Index) = carrier.TextMaxLength 
    ' increment the index 
    Index = Index + 1 
Next 
' init the list 
.CarrierList.ListIndex = 0 
End If 
' kill the sms object 
Set SMS = Nothing

استقبال مكالمة هاتفية

Private Sub Form_Load() 
MSComm1.Settings = "9600,N,8,1" 
' لوب للتشييك على عشرة منافذ وإستخراج رقم منفذ المودوم الصحيح 

For i = 1 To 10 
MSComm1.CommPort = i 

On Error GoTo N 
MSComm1.PortOpen = True 

N: 
If MSComm1.PortOpen = True Then 
Exit For 
End If 

Next 

End Sub 

Private Sub MSComm1_OnComm() 

If MSComm1.CommEvent Then 

MsgBox " وصول إتصال لك " 

End If 


End Sub

المجموعة الثانية :أجهزة

مراقبة أحد منافذ الجهاز

Private Sub Command1_Click()
'لجعل البرنامج في إنتظار المتصل
Winsock1.LocalPort = Text1.Text
Winsock1.Listen
Command1.Enabled = False
Label1.Caption = "البرنامج في إنتظار متصل"
End Sub
Private Sub Command2_Click()
'لتوقف البرنامج عن الإنتظار
Winsock1.Close
Command1.Enabled = True
Label1.Caption = "توقف عن الإنتظار"
End Sub
Private Sub Winsock1_ConnectionRequest(ByVal requestID As Long)
'عندما يتم اٌتصال من قبل أي برنامج إتصال خارجي
'العداد الذي يحسب عدد مرات الدخول
Label4.Caption = Label2.Caption + 1 'ليضيف في القوائم بيانات المخترقList1.AddItem Winsock1.LocalHostNameList2.AddItem Winsock1.LocalIPList3.AddItem Label2.CaptionLabel1.Caption = "تم الإتصال بالبرنامج"
Beep
End Sub

معرفة رقم المنفذ الخاص بالمودم

Private Sub Form_Load()
    MSComm1.Settings = "9600,N,8,1"
    ' لوب للتشييك على عشرة منافذ وإستخراج رقم منفذ المودوم الصحيح
    
    For i = 1 To 10
    MSComm1.CommPort = i
    
    On Error GoTo N
    MSComm1.PortOpen = True
    
N:
    If MSComm1.PortOpen = True Then
    Exit For
    End If
    Next
End Sub

Private Sub MSComm1_OnComm()
    If MSComm1.CommEvent Then
    MsgBox " وصول إتصال لك "
    End If
End Sub

الرقم التسلسلي للوحة الام

Option Explicit

'نكتب في الموديول
Private Declare Sub GetMem1 Lib "msvbvm50.dll" (ByVal MemAddress As Long, var As Byte)
Private Function GetBIOSDate() As String
    Dim p As Byte, MemAddr As Long, sBios As String
    Dim i As Integer
    MemAddr = &HFEC71
    For i = 0 To 25
        Call GetMem1(MemAddr + i, p)
        sBios = sBios & Chr$(p)
    Next i
    GetBIOSDate = sBios
End Function

'وفي الأمر
Private Sub Command1_Click()
MsgBox GetBIOSDate
End Sub

لإطفاء وتشغيل الشاشة

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) _
As Long
Const WM_SYSCOMMAND = &H112
Const SC_MONITORPOWER = &HF170

ثم اكتب هذا الكود لإطفاء الشاشة :

SendMessage Me.hwnd, WM_SYSCOMMAND, SC_MONITORPOWER, 2&

أما لتشغيل الشاشة فاكتب الكود التالي :

SendMessage Me.hwnd, WM_SYSCOMMAND, SC_MONITORPOWER, -1

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

معرفة بعض المعلومات عن المعالج

Private Type SYSTEM_INFO
    dwOemID As Long
    dwPageSize As Long
    lpMinimumApplicationAddress As Long
    lpMaximumApplicationAddress As Long
    dwActiveProcessorMask As Long
    dwNumberOfProcessors As Long
    dwProcessorType As Long
    dwAllocationGranularity As Long
    wProcessorLevel As Integer
    wProcessorRevision As Integer
    End Type

Private Type OSVERSIONINFO
    dwOSVersionInze As Long
    dwMajorVersion As Long
    dwMinorVersion As Long
    dwBuildNumber As Long
    dwPlatformId As Long
    szCSDVersion As String * 128 ' Maintenance string For PSS usage
    End Type

Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As Long
Private Declare Sub GetSystemInfo Lib "kernel32" (lpSystemInfo As SYSTEM_INFO)
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long
    
    Private Const HKEY_LOCAL_MACHINE As Long = &H80000002
    Private Const PROCESSOR_INTEL_386 = 386
    Private Const PROCESSOR_INTEL_486 = 486
    Private Const PROCESSOR_INTEL_PENTIUM = 586
    Private Const PROCESSOR_LEVEL_80386 As Long = 3
    Private Const PROCESSOR_LEVEL_80486 As Long = 4
    Private Const PROCESSOR_LEVEL_PENTIUM As Long = 5
    Private Const PROCESSOR_LEVEL_PENTIUMII As Long = 6
    Private Const VER_PLATFORM_WIN32_NT = 2
    Private Const VER_PLATFORM_WIN32_WINDOWS = 1


Private Type udtCPU
    lClockSpeed As Variant
    lProcType As Integer
    strProcLevel As String
    strProcRevision As String
    lNumberOfProcessors As Long
    End Type


Private Enum eVersion
    eWindowsNT = 1
    eWindows95_98 = 2
    eUnknown = 3
End Enum


Private Function GetCPUInfo(ptCPUInfo As udtCPU)
    Dim tSYS As SYSTEM_INFO
    Dim intProcType As Integer
    Dim strProcLevel As String
    Dim strProcRevision As String
    Call GetSystemInfo(tSYS)


    Select Case tSYS.dwProcessorType
        Case PROCESSOR_INTEL_386: intProcType = 386
        Case PROCESSOR_INTEL_486: intProcType = 486
        Case PROCESSOR_INTEL_PENTIUM: intProcType = 586
    End Select


Select Case tSYS.wProcessorLevel
    Case PROCESSOR_LEVEL_80386: strProcLevel = "Intel 80386"
    Case PROCESSOR_LEVEL_80486: strProcLevel = "Intel 80486"
    Case PROCESSOR_LEVEL_PENTIUM: strProcLevel = "Intel Pentium"
    Case PROCESSOR_LEVEL_PENTIUMII: strProcLevel = "Intel Pentium Pro or Pentium II"
End Select
strProcRevision = "Model " & HiByte(tSYS.wProcessorRevision) & ", Stepping " & LoByte(tSYS.wProcessorRevision)


With ptCPUInfo
.lClockSpeed = GetCPUSpeed
.lNumberOfProcessors = tSYS.dwNumberOfProcessors
.lProcType = intProcType
.strProcLevel = IIf(strProcLevel = "", "None", strProcLevel)
.strProcRevision = IIf(strProcRevision = "", "None", strProcRevision)
End With
End Function


Private Function GetVersion() As eVersion
    Dim os As OSVERSIONINFO
    os.dwOSVersionInze = Len(os)


    If GetVersionEx(os) Then


        If os.dwPlatformId = VER_PLATFORM_WIN32_NT Then
            GetVersion = eWindowsNT
        Else
            GetVersion = eWindows95_98
        End If
    Else
        GetVersion = eUnknown
    End If
End Function


Private Function HiByte(ByVal wParam As Integer) As Byte
    HiByte = (wParam And &HFF00&) \ (&H100)
End Function


Private Function LoByte(ByVal wParam As Integer) As Byte
    LoByte = wParam And &HFF&
End Function


Private Function GetCPUSpeed() As Variant
    Dim hKey As Long
    Dim lClockSpeed As Long
    Dim strKey As String


    If GetVersion = eWindowsNT Then
        strKey = "HARDWARE\DE******ION\System\CentralProcessor\0"
        Call RegOpenKey(HKEY_LOCAL_MACHINE, strKey, hKey)
        Call RegQueryValueEx(hKey, "~MHz", 0, 0, lClockSpeed, 4)
        Call RegCloseKey(hKey)
        GetCPUSpeed = lClockSpeed
    Else
        GetCPUSpeed = "Could Not be determined"
    End If
End Function

'وفي زر الأمر نكتب

Private Sub Command1_Click()
    Dim tCPU As udtCPU
    Call GetCPUInfo(tCPU)
    List1.AddItem "CPU Type: " & tCPU.lProcType
    List1.AddItem "Number ofCPUs:" & tCPU.lNumberOfProcessors
    List1.AddItem "CPU Level: " & tCPU.strProcLevel
    List1.AddItem "CPU Revision:" & tCPU.strProcRevision
    List1.AddItem "CPU Speed (Approx): " & tCPU.lClockSpeed
End Sub

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

Private Declare Sub GetMem1 Lib "msvbvm50.dll" (ByVal MemAddress As Long, var As Byte)

Private Function GetBIOSDate() As String
  Dim p As Byte, MemAddr As Long, sBios As String
  Dim i As Integer
  
  MemAddr = &HFFFF5
  For i = 0 To 7
      Call GetMem1(MemAddr + i, p)
      sBios = sBios & Chr$(p)
  Next i
  GetBIOSDate = sBios
End Function

Private Sub Form_Load()
    MsgBox "The Bios date: " & GetBIOSDate
End Sub

المجموعة الثالثة : الأخطاء


إظهار نافذة الخطأ البيضاء

Private Declare Sub FatalAppExit Lib "kernel32" Alias "FatalAppExitA" (ByVal uAction As Long, ByVal lpMessageText As String) 

Private Sub Form_Load() 
FatalAppExit 0, "Contactez le revendeur de ce programme" & vbLf & vbLf & "(Cette source provient de http:// www.bramjnet.com/vb3/)" 
End Sub

عرض جميع أخطاء الويندوز من خلال رقم الخطأ

Private Const FORMAT_MESSAGE_ARGUMENT_ARRAY = &H2000
Private Const FORMAT_MESSAGE_FROM_HMODULE = &H800
Private Const FORMAT_MESSAGE_FROM_STRING = &H400
Private Const FORMAT_MESSAGE_FROM_SYSTEM = &H1000
Private Const FORMAT_MESSAGE_IGNORE_INSERTS = &H200
Private Const FORMAT_MESSAGE_MAX_WIDTH_MASK = &HFF
Private Const LANG_USER_DEFAULT = &H400&

Private Function GetLastErrorStr(dwErrCode As Long) As String
  Static sMsgBuf As String * 257, dwLen As Long
  dwLen = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM _
  Or FORMAT_MESSAGE_IGNORE_INSERTS Or FORMAT_MESSAGE_MAX_WIDTH_MASK, ByVal 0&, _
  dwErrCode, LANG_USER_DEFAULT, ByVal sMsgBuf, 256&, 0&)
  If dwLen Then GetLastErrorStr = Left$(sMsgBuf, dwLen)
End Function


Private Sub Command1_Click()
'Place the following code in under a command button or in a menu, etc...
'Sub needs a textbox and label
Dim x
x = GetLastErrorStr(Val(Text1.Text))
Label1.Caption = x

End Sub

قائمة أخطاء فيجوال بيسك

3  Return without GoSub.
5  Illegal function call.
6  Overflow.
7  Out of memory.
9  Sub****** out of range.
10  Duplicate definition.
11  Division by zero.
13  Type mismatch.
14  Out of string space.
16  String formula too complex.
17  Can't continue.
19  No Resume.
20  Resume without error.
28  Out of stack space.
35  Sub or Function not defined.
48  Error in loading DLL.
49  Bad DLL calling convention.
51  Internal error.
52  Bad file name or number.
53  File not found.
54  Bad file mode.
55  File already open.
57  Device I/O error.
58  File already exists.
59  Bad record length.
61  Disk full.
62  Input past end of file.
63  Bad record number.
64  Bad file name.
67  Too many files.
68  Device unavailable.
70  Permission denied.
71  Disk not ready.
74  Can't rename with different drive.
75  Path/File access error.
76  Path not found.
91  Object variable not Set.
92  For loop not initialized.
93  Invalid pattern string.
94  Invalid use of Null.
95  Cannot destroy active form instance.
260  No timer available.
280  DDE channel not fully closed; awaiting response from foreign application.
281  No More DDE channels.
282  No foreign application responded to a DDE initiate.
283  Multiple applications responded to a DDE initiate.
284  DDE channel locked.
285  Foreign application won't perform DDE method or operation.
286  Timeout while waiting for DDE response.
287  User pressed Escape key during DDE operation.
288  Destination is busy.
289  Data not provided in DDE operation.
290  Data in wrong format.
291  Foreign application quit.
292  DDE conversation closed or changed.
293  DDE Method invoked with no channel open.
294  Invalid DDE Link format.
295  Message queue filled; DDE message lost.
296  PasteLink already performed on this control.
297  Can't set LinkMode; invalid LinkTopic.
298  DDE requires ddeml.dll.
320  Can't use character device names in file names.
321  Invalid file format.
340  Control array element doesn't exist.
341  Invalid control array index.
342  Not enough room to allocate control array.
343  Object not an array.
344  Must specify index for object array.
345  Reached limit: cannot create any more controls for this form.
360  Object already loaded.
361  Can't load or unload this object.
362  Can't unload controls created at design time.
363  Custom control not found.
364  Object was unloaded.
365  Unable to unload within this context.
366  No MDI Form available to load.
380  Invalid property value.
381  Invalid property array index.
382  property cannot be set at run time.
383  property is read-only.
384  A form can't be moved or sized while minimized or maximized.
385  Must specify index when using property array.
386  property not available at run time.
387  property can't be set on this control.
388  Can't set Visible property from a parent menu.
389  Invalid key.
390  No Defined Value.
391  Name not available.
392  MDI child forms cannot be hidden.
393  property cannot be read at run time.
394  property is write-only.
395  Can't use separator bar as menu name.
400  Form already displayed; can't show modally.
401  Can't show non-modal form when modal form is displayed.
402  Must close or hide topmost modal form first.
403  MDI forms cannot be shown modally.
404  MDI child forms cannot be shown modally.
420  Invalid object reference.
421  Method not applicable for this object.
422  Property not found.
423  Property or control not found.
424  Object required.
425  Invalid object use.
426  Only one MDI Form allowed.
427  Invalid object type; Menu control required.
428  Popup menu must have at least one submenu.
429  OLE Automation server cannot create object.
430  Class does not support OLE Automation.
431  OLE Automation server cannot load file.
432  OLE Automation file or object name syntax error.
433  OLE Automation object does not exist.
434  Access to OLE Automation object denied.
435  OLE initialization error.
436  OLE Automation method returned unsupported type.
437  OLE Automation method did not return a value.
438  OLE Automation no such property or method.
439  OLE Automation argument type mismatch.
440  OLE Automation error.
441  Error loading VBOA300.DLL.
442  OLE Automation Lbound or Ubound on non Array value.
443  OLE Automation Object does not have a default value.
444  Method not applicable in this context.
460  Invalid Clipboard format.
461  Specified format doesn't match format of data.
480  Can't create AutoRedraw image.
481  Invalid picture.
482  Printer error.
520  Can't empty Clipboard.
521  Can't open Clipboard.
600  Set value not allowed on collections.
601  Get value not allowed on collections.
602  General ODBC error.
603  ODBC - SQLAllocEnv failure.
604  ODBC - SQLAllocConnect failure.
605  OpenDatabase - invalid connect string.
606  ODBC - SQLConnect failure.
607  Access attempted on unopened DataBase.
608  ODBC - SQLFreeConnect error.
609  ODBC - GetDriverFunctions failure.
610  ODBC - SQLAllocStmt failure.
611  ODBC - SQLTables (TableDefs.Refresh) failure.
612  ODBC - SQLBindCol failure.
613  ODBC - SQLFetch failure.
614  ODBC - SQLColumns (Fields.Refresh) failure.
615  ODBC - SQLStatistics (Indexes.Refresh) failure.
616  Table exists - append not allowed.
617  No fields defined - cannot append table.
618  ODBC - SQLNumResultCols (CreateDynaset) failure.
619  ODBC - SQLDescibeCol (CreateDynaset) failure.
620  Dynaset is open - CreateDynaset method not allowed.
621  Row-returning SQL is illegal in ExecuteSQL method.
622  CommitTrans/Rollback illegal - Transactions not support.
623  Name not found in this collection.
624  Unable to Build Data Type Table.
625  Data type of field not supported by target database.
626  Attempt to Move past EOF.
627  Dynaset is not updatable or Edit method has not been invoked.
628  Dynaset method illegal - no scrollable cursor support.
629  Warning:   (ODBC - SQLSetConnectOption failure).
630  Property is read-only.
631  Zero rows affected by Update method.
632  Update illegal without previous Edit or AddNew method.
633  Append illegal - Field is part of a TableDefs collection.
634  Property value only valid when Field is part of a Dynaset.
635  Cannot set the property of an object which is part of a Database.
636  Set field value illegal without previous Edit or AddNew method.
637  Append illegal - Index is part of a TableDefs collection.
638  Access attempted on unopened Dynaset.
639  Field type is illegal.
640  Field size illegal for specified Field Type.
641  illegal - no current record.
642  Reserved parameter must be FALSE.
643  Property Not Found.
644  ODBC - SQLConfigDataSource error.
645  ODBC Driver does not support exclusive access to Dynasets.
646  GetChunk: Offset/Size argument combination illegal.
647  Delete method requires a name argument.
648  Data access objects require VBDB300.DLL.
2420  Syntax error in number.
2421  Syntax error in date.
2422  Syntax error in string.
2423  Invalid use of '.', '!', or '()'.
2424  Unknown name.
2425  Unknown function name.
2426  Function isn't available in expressions.
2427  Object has no value.
2428  Invalid arguments used with domain function.
2429  In operator without ().
2430  Between operator without And.
2431  Syntax error.
2432  Syntax error.
2433  Syntax error.
2434  Syntax error.
2435  Extra ).
2436  Missing ), ], or ".
2437  Invalid use of vertical bars.
2438  Syntax error.
2439  Wrong number of arguments used with function.
2440  IIF function without ().
2442  Invalid use of parentheses.
2443  Invalid use of Is operator.
2445  Expression too complex.
2446  Out of memory during calculation.
2447  Invalid use of '.', '!', or '()'.
2448  Can't set value.
2449  Invalid method in expression.
2450  Invalid reference to form.
2451  Invalid reference to report.
2452  Invalid reference to Parent property.
2453  Invalid reference to control.
2454  Invalid reference to '! '.
2455  Invalid reference to property.
2456  Invalid form number reference.
2457  Invalid report number reference.
2458  Invalid control number reference.
2459  Can't refer to Parent property in Design view.
2460  Can't refer to Dynaset property in Design view.
2461  Invalid section reference.
2462  Invalid section number reference.
2463  Invalid group level reference.
2464  Invalid group level number reference.
2465  Invalid reference to field.
2466  Invalid reference to Dynaset property.
2467  Object referred to in expression no longer exists.
2468  Invalid argument used with DatePart, DateAdd or DateDiff function.
2469  1 in validation rule: '|2'.
2470  Syntax Error in validation rule.
2471  Syntax Error in query.
2472  Syntax Error in linked master field.
2473  1 in '|2' expression.
2474  No control is active.
2475  No form is active.
2476  No report is active.
2477  Invalid subclass referred to in TypeOf function.

3000  Reserved error ( ); there is no message for this error.
3001  Invalid argument.
3002  Couldn't start session.
3003  Couldn't start transaction; too many transactions already nested.
3004  Couldn't find database
3005  This isn't a valid database name.
3006  Database is exclusively locked.
3007  Couldn't open database
3008  Table is exclusively locked.
3009  Couldn't lock table ; currently in use.
3010  Table already exists.
3011  Couldn't find object
3012  Object already exists.
3013  Couldn't rename installable ISAM file.
3014  Can't open any more tables.
3015  This isn't an index in this table.
3016  Field won't fit in record.
3017  Field length is too long.
3018  Couldn't find field.
3019  Operation invalid without a current index.
3020  Update without AddNew or Edit.
3021  No current record.
3022  Can't have duplicate key; index changes were unsuccessful.
3023  AddNew or Edit already used.
3024  Couldn't find file.
3025  Can't open any more files.
3026  Not enough space on disk.
3027  Couldn't update; database is read-only.
3028  Couldn't initialize data access because file 'SYSTEM.MDA' couldn't be opened.
3029  Not a valid account name or password.
3030  This isn't a valid account name.
3031  Not a valid password.
3032  Can't delete account.
3033  No permission for that
3034  Commit or Rollback without BeginTrans.
3035  Out of memory.
3036  Database has reached maximum size.
3037  Can't open any more tables or queries.
3038  Out of memory.
3039  Couldn't create index; too many indexes already defined.
3040  Disk I/O error during read.
3041  Incompatible database version.
3042  Out of MS-DOS file handles.
3043  Disk or network error.
3044  This isn't a valid path.
3045  Couldn't use ; file already in use.
3046  Couldn't save; currently locked by another user.
3047  Record is too large.
3048  Can't open any more databases.
3049  This is corrupted or isn't a Microsoft Access database.
3050  Couldn't lock file; SHARE.EXE hasn't been loaded.
3051  Couldn't open file.
3052  MS-DOS file sharing lock count exceeded.  You need to increase the number of locks installed with SHARE.EXE.
3053  Too many client tasks.
3054  Too many Memo or Long Binary fields.
3055  Not a valid file name.
3056  Couldn't repair this database.
3057  Operation not supported on attached tables.
3058  Can't have Null value in index.
3059  Operation canceled by user.
3060  Wrong data type for parameter.
3061  1 parameters were expected, but only |2 were supplied.
3062  Duplicate output alias.
3063  Duplicate output destination.
3064  Can't open action query.
3065  Can't execute a non-action query.
3066  Query must have at least one output field.
3067  Query input must contain at least one table or query.
3068  Not a valid alias name.
3069  Can't have action query as an input.
3070  Can't bind name.
3071  Can't evaluate expression.
3073  Operation must use an updatable query.
3074  Can't repeat table name in FROM clause.
3075  1 in query expression '|2'.
3076  Syntax Error in criteria expression.
3077  Syntax Error in expression.
3078  Couldn't find input table or query.
3079  Ambiguous field reference.
3080  Joined table not listed in FROM clause.
3081  Can't join more than one table with the same name ( ).
3082  JOIN operation refers to a non-joined table.
3083  Can't use internal report query.
3084  Can't insert into action query.
3085  Undefined function in expression.
3086  Couldn't delete from specified tables.
3087  Too many expressions in GROUP BY clause.
3088  Too many expressions in ORDER BY clause.
3089  Too many expressions in DISTINCT output.
3090  Resultant table may not have more than one Counter field.
3091  HAVING clause ( ) without grouping or aggregation.
3092  Can't use HAVING clause in TRANSFORM statement.
3093  ORDER BY clause ( ) conflicts with DISTINCT.
3094  ORDER BY clause ( ) conflicts with GROUP BY clause.
3095  Can't have aggregate function in expression ( ).
3096  Can't have aggregate function in WHERE clause ( ).
3097  Can't have aggregate function in ORDER BY clause ( ).
3098  Can't have aggregate function in GROUP BY clause ( ).
3099  Can't have aggregate function in JOIN operation ( ).
3100  Can't set field in join key to Null.
3101  Join is broken by value(s) in fields
3102  Circular reference caused by statement.
3103  Circular reference caused by alias in query definition's SELECT list.
3104  Can't specify Fixed Column Heading in a crosstab query more than once.
3105  Missing destination field name in SELECT INTO statement ( ).
3106  Missing destination field name in UPDATE statement ( ).
3107  Couldn't insert; no insert permission for table or query.
3108  Couldn't replace; no replace permission for table or query.
3109  Couldn't delete; no delete permission for table or query.
3110  Couldn't read definitions; no read definitions permission for table or query.
3111  Couldn't create; no create permission for table or query.
3112  Couldn't read; no read permission for table or query.
3113  Can't update ; field not updatable.
3114  Can't include Memo or Long Binary when you select unique values
3115  Can't have Memo or Long Binary in aggregate argument ( ).
3116  Can't have Memo or Long Binary in criteria ( ) for aggregate function.
3117  Can't sort on Memo or Long Binary ( ).
3118  Can't join on Memo or Long Binary ( ).
3119  Can't group on Memo or Long Binary ( ).
3120  Can't group on fields selected with '*' ( ).
3121  Can't group on fields selected with '*'.
3122  not part of aggregate function or grouping.
3123  Can't use '*' in crosstab query.
3124  Can't input from internal report query ( ).
3125  This isn't a valid name.
3126  Invalid bracketing of name.
3127  INSERT INTO statement contains unknown field name
3128  Must specify tables to delete from.
3129  Invalid SQL statement; expected 'DELETE', 'INSERT', 'PROCEDURE','SELECT', or 'UPDATE'.
3130  Syntax error in DELETE statement.
3131  Syntax error in FROM clause.
3132  Syntax error in GROUP BY clause.
3133  Syntax error in HAVING clause.
3134  Syntax error in INSERT statement.
3135  Syntax error in JOIN operation.
3136  Syntax error in LEVEL clause.
3137  Missing semicolon (  at end of SQL statement.
3138  Syntax error in ORDER BY clause.
3139  Syntax error in PARAMETER clause.
3140  Syntax error in PROCEDURE clause.
3141  Syntax error in SELECT statement.
3142  Characters found after end of SQL statement.
3143  Syntax error in TRANSFORM statement.
3144  Syntax error in UPDATE statement.
3145  Syntax error in WHERE clause.
3146  ODBC--call failed.
3147  ODBC--data buffer overflow.
3148  ODBC--connection failed.
3149  ODBC--incorrect DLL.
3150  ODBC--missing DLL.
3151  ODBC--connection is failed.
3152  ODBC--incorrect driver version ' 1'; expected version '|2'.
3153  ODBC--incorrect server version ' 1'; expected version '|2'.
3154  ODBC--couldn't find DLL.
3155  ODBC--insert failed.
3156  ODBC--delete failed.
3157  ODBC--update failed.
3158  Couldn't save record; currently locked by another user.
3159  Not a valid bookmark.
3160  Table isn't open.
3161  Couldn't decrypt file.
3162  Null is invalid.
3163  Couldn't insert or paste; data too long for field.
3164  Couldn't update field.
3165  Couldn't open .INF file.
3166  Missing memo file.
3167  Record is deleted.
3168  Invalid .INF file.
3169  Illegal type in expression.
3170  Couldn't find installable ISAM.
3171  Couldn't find net path or user name.
3172  Couldn't open PARADOX.NET.
3173  Couldn't open table 'MSysAccounts' in SYSTEM.MDA.
3174  Couldn't open table 'MSysGroups' in SYSTEM.MDA.
3175  Date is out of range or is in an invalid format.
3176  Couldn't open file.
3177  Not a valid table name.
3178  Out of memory.
3179  Encountered unexpected end of file.
3180  Couldn't write to file.
3181  Invalid range.
3182  Invalid file format.
3183  Not enough space on temporary disk.
3184  Couldn't execute query; couldn't find linked table.
3185  SELECT INTO remote database tried to produce too many fields.
3186  Couldn't save; currently locked by user ' 2' on machine '|1'.
3187  Couldn't read; currently locked by user ' 2' on machine '|1'.
3188  Couldn't update; currently locked by another session on this machine.
3189  Table ' 1' is exclusively locked by user '|3' on machine '|2'.
3190  Too many fields defined.
3191  Can't define field more than once.
3192  Couldn't find output table
3193  (unknown)
3194  (unknown)
3195  (expression)
3196  Couldn't use ; database already in use.
3197  Data has changed; operation stopped.
3198  Couldn't start session. Too many sessions already active.
3199  Couldn't find reference.
3200  Can't delete or change record. Since related records exist in table referential integrity rules would be violated.
3201  Can't add or change record. Referential integrity rules require a related record in table.
3202  Couldn't save; currently locked by another user.
3203  Can't specify subquery in expression ( ).
3204  Database already exists.
3205  Too many crosstab column headers ( ).
3206  Can't create a relationship between a field and itself.
3207  Operation not supported on Paradox table with no primary key.
3208  Invalid Deleted entry in [dBASE ISAM] section in INI file.
3209  Invalid Stats entry in [dBASE ISAM] section in INI file.
3210  Connect string too long.
3211  Couldn't lock table ; currently in use.
3212  Couldn't lock table ' 1'; currently in use by user '|3' on machine '|2'.
3213  Invalid Date entry in [dBASE ISAM] section in INI file.
3214  Invalid Mark entry in [dBASE ISAM] section in INI file.
3215  Too many Btrieve tasks.
3216  Parameter specified where a table name is required.
3217  Parameter specified where a database name is required.
3218  Couldn't update; currently locked.
3219  Can't perform operation; it is illegal.
3220  Wrong Paradox sort sequence.
3221  Invalid entries in [Btrieve ISAM] section in WIN.INI.
3222  Query can't contain a Database parameter.
3223  This isn't a valid parameter name.
3224  Btrieve--data dictionary is corrupted.
3225  Encountered record locking deadlock while performing Btrieve operation.
3226  Errors encountered while using the Btrieve DLL.
3227  Invalid Century entry in [dBASE ISAM] section in INI file.
3228  Invalid CollatingSequence entry in [Paradox ISAM] section in INI file.
3229  Btrieve--can't change field.
3230  Out-of-date Paradox lock file.
3231  ODBC--field would be too long; data truncated.
3232  ODBC--couldn't create table.
3233  ODBC--incorrect driver version.
3234  ODBC--remote query timeout expired.
3235  ODBC--data type not supported on server.
3236  ODBC--encountered unexpected Null value.
3237  ODBC--unexpected type.
3238  ODBC--data out of range.
3239  Too many active users.
3240  Btrieve--missing WBTRCALL.DLL.
3241  Btrieve--out of resources.
3242  Invalid reference in SELECT statement.
3243  None of the import field names match fields in the appended table.
3244  Can't import password-protected spreadsheet.
3245  Couldn't parse field names from first row of import table.
3246  Operation not supported in transactions.
3247  ODBC--linked table definition has changed.
3248  Invalid NetworkAccess entry in INI file.
3249  Invalid PageTimeout entry in INI file.
3250  Couldn't build key.
3251  Feature not available.
3252  Illegal reentrancy during query execution.
3254  ODBC--Can't lock all records.
3255  ODBC--Can't change connect string parameter.
3256  Index file not found.
3257  Syntax error in WITH OWNERACCESS OPTION declaration.
3258  Query contains ambiguous (outer) joins.
3259  Invalid field data type.
3260  Couldn't update; currently locked by user ' 2' on machine '|1'.
3261
3262
3263  Invalid database object.
3264  No fields defined - cannot append table.
3265  Name not found in this collection.
3266  Append illegal - Field is part of a TableDefs collection.
3267  Property value only valid when Field is part of a recordset.
3268  Cannot set the property of an object which is part of a Database object.
3269  Append illegal - Index is part of a TableDefs collection.
3270  Property not found.
3271  Invalid property value.
3272  Object is not an array.
3273  Method not applicable for this object.
3274  External table isn't in the expected format.
3275  Unexpected error from external database driver ( ).
3276  Invalid database ID.
3277  Can't have more than 10 fields in an index.
3278  Database engine has not been initialized.
3279  Database engine has already been initialized.
3280  Can't delete a field that is part of an index.
3281  Can't delete an index that is used in a relationship.
3282  Can't perform operation on a nontable.
3283  Primary key already exists.
3284  Index already exists.
3285  Invalid index definition.
3286  Invalid type for Memo field.
3287  Can't create index on Memo field or Long Binary field.
3288  Invalid ODBC driver.
3289  Paradox: No primary index.
3290  Syntax error.
3291  Syntax error in CREATE TABLE statement.
3292  Syntax error in CREATE INDEX statement.
3293  Syntax error in column definition.
3294  Syntax error in ALTER TABLE statement.
3295  Syntax error in DROP INDEX statement.
3296  Syntax error in DROP statement.
3297  Operation not supported in version 1.1
3298  Couldn't import. No records found or all records contained errors.
3299  Several tables exist with that name; please specify owner, as in 'owner.table'.

كود تتبع الخطأ في أي إجراء

'بداية معالج الخطأ
On Error GoTo ErrHandler

'هنا يوضع الكود

'إنهاء تتبع الأخطاء والخروج من الإجراء
  On Error GoTo 0
  Exit Function

ErrHandler:
  Dim strErr As String
  strErr = "Error " & Err.Number & " " & Err.De******ion 
  MsgBox strErr, vbCritical + vbOK, "Error message"
يوضع هذا الكود بداخل أي كود أو وظيفة ويقوم بتفحص الكود وفي حالة حدوث خطأ فإنه يظهر رسالة توضيحية ثم ينهي الإجراء ويفيد في تتبع الأخطاء البرمجية

المجموعة الرابعة : الخطوط


استعراض الخطوط المثبتة علي الجهاز

'Add 1 List Box to your form. The List Box will be populated with all installed fonts.
'When you click on one of the fonts, the List Box will change its font to the clicked font.
'Insert this code to your form:

Private Sub Form_Load()
Dim counter As Integer
For counter = 0 To Screen.FontCount - 1
List1.AddItem Screen.Fonts(counter)
Next
End Sub

Private Sub List1_Click()
Static tempheight As Single
If tempheight = 0 Then tempheight = List1.Height
List1.Font.Name = List1.List(List1.ListIndex)
List1.Height = tempheight
End Sub

تثبيت خط جديد

'Add a module to your project (In the menu choose Project -> Add Module, Then click Open)
'Add 1 Command Button to your form.
'Insert this code to the module :

Declare Function AddFontResource& Lib "gdi32" Alias "AddFontResourceA" _
(ByVal lpFileName As String)
Declare Function RemoveFontResource& Lib "gdi32" Alias "RemoveFontResourceA" _
(ByVal lpFileName As String)

'Insert this code to your form:

Private Sub Command1_Click()
Dim retvalue As Long
'Replace all 'MyFont' below with your font file.
retvalue = RemoveFontResource("c:\MyFont.ttf")
Command1.Caption = "uninstall"
End Sub

Private Sub Form_Load()
Dim retvalue As Long
Command1.Caption = "uninstall"
retvalue = AddFontResource("c:\MyFont.ttf")
Command1.FontName = "MyFont"
End Sub

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

Private Sub Form_Load()
Dim i As Integer
For i = 0 To Screen.FontCount - 1
Combo1.AddItem Screen.Fonts(i)
Next i
Combo1.Text = Combo1.List(0)
End Sub

وضع جميع الفونتات (Fonts) فى الأداة TreeView

Private Sub Form_Load()

Dim root As Node
Dim i As Integer

With TreeView1.Nodes
Set root = .Add(, , , "Fonts")

.Add root.Index, tvwChild, , Screen.Fonts(i)

For i = 1 To Screen.FontCount - 1
.Add root.Index, tvwChild, , Screen.Fonts(i)
Next

End With

End Sub

المجموعة الخامسة : دوال الفيجوال بيسك


الدوال الرياضية

الدالة Abs : ترجع القيمة المطلقة لآي عدد وترجعه من نفس نوع البيانات المعطى للدالة والمقصود بالقيمة المطلقة هي قيمة العدد بدون إشارة فالقيمة المطلقة ل (-13) مثلا هي (13) وهكذا, فمثلا لو كتبنا الكود التالي 


code: MyNumber=Abs(-45.6) 
Text1.Text=MyNumber
 
 
فإن نتيجة تنفيذ الدالة هي MyNumber=45.6
ولاحظ أن القيمة المدخلة للدالة لابد أن تكون عدد أو تعبير عددي فإذا كانت القيمة المدخلة للدالة Null ستكون النتيجة Null وإذا كانت القيمة المدخلة للدالة متغير فارغ أو لم يتم تعيين قيمة له ستكون النتيجة (0).

الدالة Sqr : تستخدم هذه الدالة في تحديد الجذر التربيعي لرقم معين وتأخذ الصورة العامة التالية .

code: MyNumber=Sqr(10)
Text1.Text=MyNumber
 
فإن نتيجة تنفيذ الدالة هي MyNumber=3.1622776

الدالة Log : تستخدم هذه الدالة في تحديد قيمة اللوغاريتم العشري لرقم وتأخذ الصورة العامة التالية : 

code: MyNumber=Log (20)
Text1.Text=MyNumber
 
فإن نتيجة تنفيذ الدالة هي MyNumber=2.9957327

الدالة Exp : تستخدم هذه الدالة في تحديد القيمة (e) وهي قاعدة اللوغاريتم الطبيعي مرفوعة بقوة الرقم الذي تتضمنه حيث (e) تساوي تقريبا 2.7182818 وتأخذ الصورة العامة التالية :

code: MyNumber=Exp (رقم)
 

الدالة Rnd : وتستخدم هذا الدالة في توليد أرقام عشوائية تقع ما بين الصفر و واحد بحد أقصي 15 رقما عشريا وتأخذ الصورة العامة التالية :

code: MyNumber=Rnd (عدد)
 

فمثلا الدالة Rnd(10) قد تعطي رقما مثل 0.7055475 وعند تشغيل الدالة مرة أخري ينتج رقما آخر مثل 0.533424 وهكذا .

الدالة Int : وتستخدم هذه الدالة لحساب الجزء الصحيح فقط من رقم يشتمل علي أرقام صحيحة وعشرية أو بعبارة أخر لحذف الأرقام العشرية الموجودة بعد العلامة العشرية بدون تقريب وتأخذ الصورة التالية :

code: MyNumber=Int (332.54)
 
فإن نتيجة تنفيذ الدالة هي MyNumber=332

الدالة Atn : تستخدم هذه الدالة في حساب مقلوب ظل الزاوية "ظتا" للرقم الذي تشتمل علية مقدار بالتقدير الدائري وتأخذ الصورة العامة التالية :

code: MyNumber=Atn (رقم)
 
الدالة Tan : تستخدم هذه الدالة في تحديد قيمة ظل زاوية معينة وتأخذ الصورة العامة التالية : 

code: MyNumber=Tan (رقم)
 

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

code: MyNumber=Cos (رقم)
 
 
الدالة Sin : : تستخدم هذه الدالة في تحديد قيمة جيب زاوية معينة وتأخذ الصورة العامة التالية :

code: MyNumber=Sin (رقم)

دوال رياضية 2

الدالة Round : وهي دالة التقريب التي من خلالها يمكنك تحديد عدد الأرقام العشرية وتأخذ الصورة التالية :


code: MyNumber= Round(4.52696,2)
 
حيث 4.52696 الرقم المراد تقريبه أما الرقم 2 فهو عدد التي ستقرب بعد العلامة العشرية وسيكون الناتج 4.53

الدالة CInt : وهي تشبه الدالة Round مع اختلاف بسيط وهو لا يمكنك تحديد عدد الأرقام التي ستقرب إليه بعد العلامة العشرية وتأخذ الصورة التالية : 

code: MyNumber= CInt(4.52696)
 
 

حيث 4.52696 الرقم المراد تقريبه وسيكون الناتج عدد صحيح مقرب 5 

الدالة Fix : وهي تشبه الدالة Int تماما أي أنها تستخدم لحساب الجزء الصحيح فقط وتأخذ الصورة التالية : 

code: MyNumber= Fix(4.52696)
 
 
فإن نتيجة تنفيذ الدالة هي MyNumber=4

الدوال المثلثية

Private Sub Command1_Click()
Dim A As Integer, X As Integer
A = Sin(90)  ' X دالة الجيب للزاوية
Debug.Print "جيب الزاوية=", A
A = Cos(90)  ' x دالة جيب التمام للزاوية
Debug.Print "جيب تمام الزاوية=", A
A = Tan(90)  ' X دالة الظل للزاوية
Debug.Print "ظل الزاوية=", A
'A = ATAN(45) ' X مقلوب دالة الظل للزاوية
'Debug.Print A

End Sub

دوال أخري

الدالة InStrRev : وهي شبيهه بدالة InStr ( وقد سبق شرحها من قبل ) ولكن تكون عملية البحث عن الحرف عكسية أي تبدأ من نهاية القيمة . وهي حساسة لحالة الأحرف وتأخذ الصورة التالية :

code: Print InStrRev("Mostafa", "a")
Print InStr("Mostafa", "a")
 
 
بالنسبة للحالة الأولى سيكون الناتج رقم 7 لأنها تبدأ من نهاية القيمة .
أما في الحالة الثانية فسيكون الناتج 5 لأنها تبدأ من بداية القيمة .


الدالة Val : وهي تحول السلاسل النصية إلى قيمة رقمية وهي عكس الدالة Str() التي تحول الأرقام إلى سلاسل نصية وتأخذ الصورة التالية :

code: myNumber = Val (Text1.text)
 
 


وهنا تعمل الدالة علي تحويل القيمة الموجودة في Text1 إلى قيمة رقمية .


الدالة Button : إيجاد الرقم المقابل لضغط علي كل جهة من الماوس .
الزر الأيسر = 1
الزر الأيمن = 2
الزر الأوسط =4 

code: Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y 
As Single)
If Button = 1 Then
txtResult.Text = "زر الفأرة اليسرى مضغوط الآن"
End If
If Button = 2 Then
txtResult.Text = "زر الفأرة اليمني مضغوط الآن"
End If
If Button = 4 Then
txtResult.Text = "زر الفأرة الوسطي مضغوط الآن"
End If
End Sub

دوال التحويلات Conversion Functions

الدالة Ccur : وتعمل هذه الدالة بتحويل التعبير الموجود بين القوسين إلى قيمة محولة عملة Currency . وتأخذ الصورة التالية :


code: MyNumber= Ccur(32465)
 

وتقوم هذه الدالة بتخزين نوع الرقم 32465 في المتغير MyNumber بعد تحويلة إلى نوع عملة .

الدالة CInt : وهي تشبه الدالة Round مع اختلاف بسيط وهو لا يمكنك تحديد عدد الأرقام التي ستقرب إليه بعد العلامة العشرية وتأخذ الصورة التالية : 

code: MyNumber= CInt(4.52696)
 
 
حيث 4.52696 الرقم المراد تقريبه وسيكون الناتج عدد صحيح مقرب 5

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

الدالة CDbl : : وتعمل هذه الدالة علي تحويل نوع بيانات متغيرها إلى عدد مضاعف الدقة Double وتأخذ الصورة التالية :

code: MyNumber= CDbl(678)
 
 
الدالة CLng : تعمل هذه الدالة علي تحويل نوع بيانات متغيرها إلى عدد طويل Long وتأخذ الصورة التالية :

code: MyNumber= CLng(25427.45)
MyNumber= CLng(25427.55)
 
 
الدالة CLng تحول القيمة من عدد أحادي Single إلي عدد طويل Long لاحظ أن الرقم 25427.45 تم تقريبه إلي أقرب رقم صحيح ولذلك حصلنا علي الناتج 25427 أما الرقم 25427.55 فقد تم تقريبه إلي 25428 .

الدالة CSng : وتحول هذه الدالة نوع بيانات متغيرها إلي عدد أحادي الدقة Single لاحظ في هذا المثال الدالة CSng تحول القيمة Double إلي Single .

code: MyNumber= CSng(75.3421115)
 
ليكون الناتج 75.34211

الدالة CStr : وتقوم هذه الدالة علي تحويل نوع بيانات متغيرها إلى سلسلة من الحروف ثابتة الطول وتأخذ الشكل التالي :

code: MyStr= CStr(1254)
 
الدالة CVar : وتعمل هذه الدالة علي تحويل بيانات متغيرها إلي النوع Variant ( الوقت / التاريخ أو عدد ذو علامة عشرية عائمة أو سلسلة حروف )

code: MyVar= CVar(1254)

الدالة CBool : تعمل هذه الدالة علي تحويل بيانات متغيرها إلى قيمة منطقية وتأخذ الصورة التالية :


code: MyBool= CBool ("22")
 

الدالة CByte : تعمل هذه الدالة علي تحويل بيانات متغيرها إلي عدد صحيح بطول 1 بايت وتأخذ الصورة التالية :

code: MyByte= CByte ("22")
 
 
الدالة CDate : تعمل هذه الدالة علي تحويل بيانات متغيرها إلى وقت أو تاريخ وتأخذ الصورة التالية :

code: ss = Now
Print Int(ss)
Print CDate(ss - Int(ss))
 
 الدالة CDec : تعمل هذه الدالة علي تحويل متغيرها إلي قيمة بفاصلة عشرية وهي تسمح لك بثمانية وعشرون رقما ولا يمكنك التصريح عن المتغيرات من النوع Decimal مباشرا وانما تستخدم النوع Variant للتصريح عنه وتأخذ الصورة التالية : ( أرجو توضيح اكثر لهذه الدالة ) 

code: 
Dim d As Variant
d = 1E+28
Dim i As Variant
i = CDec(d)

دوال التعامل مع الفهارس

الدالة Dir : وتعمل هذه الدالة علي عرض الملفات أو المجلدات كما هو الواضح من أسم الدالة وتأخذ الصورة التالية :

code:  MyDir = Dir(("c:\"), vbDirectory)
Do Until MyDir =""
List1.AddItem MyDir
MyDir = Dir
Loop
 
 و مثال ثاني : هنا تعمل علي التأكد من وجود ملف TafTaf موجود في الدليل C:\ أم لا ويأخذ الصورة التالية :

code: If Dir("c:\TafTaf.Txt") <> "" Then
MsgBox "الملف موجود"
Else
MsgBox "الملف غير موجود"
End If
 
 الدالة MkDir : تعمل هذه الدالة علي إنشاء ( فهرس جديد ) مجلد جديد في نفس الدليل الذي تحدده ويأخذ الصورة التالية : 

code: MkDir "c:\TafTaf"
 
 حيث TafTaf اسم المجلد الجديد .

الدالة RmDir : وهذه الدالة هي عكس الدالة MkDir في تعمل علي حذف (الفهرس) المجلد وتأخذ الصورة التالية :

code: RmDir "c:\TafTaf"
 
 الدالة Kill : تعمل هذه الدالة علي حذف الملف الذي تحدد مساره وامتداده وتأخذ الصورة التالية :

code: Kill "c:\TafTaf.txt"
 
الدالة FileCopy : تعمل هذه الدالة علي نسخ الملفات وتأخذ الصورة التالية :

code: FileCopy "C:\TafTaf.txt", "D:\Mostafa.txt"
 
 


حيث TafTaf الملف المراد نسخه من مساره القديم C:\ إلى مسار جديد D:\ مع تغير اسم الملف باسم Mostafa .

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

code: Print CurDir
 
 كما يمكن أن يأخذ هذا الشكل 

code: PathName = Shell(CurDir & "\" & "TafTaf.exe", 1)
 
و المثال السابق يوضح لنا كيفه استخدام الدالة CurDir في تحديد مسار البرنامج TafTaf.exe المراد تشغيله في نفس المسار الحالي للبرنامج الأصلي . وهذا يذكرنا بالكائن وخاصيته App.path . 

code: PathName = Shell(App.Path& "\" & "TafTaf.exe", 1)
 
 الدالة ChDrive : وتعمل هذه الدالة علي تغير مشغل القرص الحالي بمشغل قرص آخر وتأخذ الصورة التالية :

code: NewDrive = InputBox("أدخل أسم المشغل المطلوب")
ChDrive NewDrive
 
 



الدالة ChDir : تعمل هذه الدالة علي تغير الدليل الحالي ( الافتراضي ) إلي دليل آخر علي نفس مشغل القرص وتأخذ الصورة التالية :

code: ChDir "C:\TafTaf Folder"

دوال التعامل مع الملفات

الدالة FileLen : تعود هذه الدالة بقيمه تمثل حجم الملف بالبايت وتأخذ الصورة التالية 
code: ss = FileLen("c:\TafTaf.txt")
MsgBox ss & "  Byte"
 
 الدالة FileDateTime : وتعطي لك هذه الدالة معلومات عن وقت وتاريخ إنشاء الملف وتأخذ الصورة التالية :

code: ss = FileDateTime("c:\TafTaf.txt")
MsgBox ss
 
الدالة LOF : وهذه الدالة قريبة الشبه بالدالة FileLen ولكن الاختلاف بينهم أن هذه الدالة تعود بقيمه تمثل حجم الملفات المفتوحة بتمرير رقم للملف المفتوح وتأخذ الصورة التالية :

code: Open "C:\TafTaf.txt" For Binary As #1
MsgBox LOF(1) & "  Byte"
Close 1
 
 الدالة LOC : تعيد هذه الدالة موقع مؤشر القراءة والكتابة في الملف المفتوح وتأخذ الصورة التالية :

code: Dim ss
Open "c:\TafTaf.txt" For Input As #1
Loc (1)
Line Input #1, ss
MsgBox ss
Close #1
 
 الدالة EOF : تعود هذه الدالة بقيمة منطقية تبين ما إذا قد تم الوصول لنهاية الملف أم لا (False - True ) وتأخذ الصورة التالية : 

code: Dim ss
Open "c:\TafTaf.txt" For Input As #1
Do While Not EOF(1(
Line Input #1, ss
Text1.Text = Text1.Text & vbNewLine & ss
Loop
Close #1
 
الدالة GetAttr : : تمكنك هذه الدالة من معرفة خصائص الملف File Attributes وتأخذ الصورة التالية : 

code: If GetAttr("c:\TafTaf.txt") = vbNormal Then
MsgBox "الملف غير مخفي"
Else
MsgBox "الملف مخفي"
End If
 
 
الدالة SetAttr : وهذه الدالة تمكنك من تغير خصائص الملفات شرط أساسي أن يكون الملف غير مفتوح وتأخذ الصورة التالية : 

code: SetAttr ("c:\TafTaf.txt"), vbHidden
 
 
الدالة FreeFile : تعود هذه الدالة برقم غير محجوز ( رقم حر غير مستخدم ) لفتح الملف وتأخذ الصورة التالية : 

code: MyFree = FreeFile
Open "c:\TafTaf.txt" For Input As #MyFree
MsgBox MyFree
Close #MyFree
 
 
الدالة Seek : تعمل هذه الدالة علي تغير موقع مؤشر القراءة والكتابة في الملف وتأخذ الصورة التالية :

code: Dim ss
Open "c:\TafTaf.txt" For Input As #1
Seek #1, 20
Line Input #1, ss
MsgBox ss
Close #1
 
 
الدالة SavePicture : تعمل هذه الدالة علي حفظ الصورة إلى ملف خارجي بأي امتداد تريده ومن أي أداة يمكنها احتواء صورة بداخلها وتأخذ الشكل التالي :

code: SavePicture Picture1.Picture,  "C:\TafTaf.bmp"
 
 
الدالة LoadPicture : تعمل هذه الدالة علي ( تحميل ) الصورة من مكان تحدده أنت أو من الممكن ( تحميل ) الصورة تابعة لكائن وتأخذ الصورة التالية :

code: Picture1.Picture = LoadPicture("c:\TafTaf.bmp")

دوال جديدة

الدالة SendKeys : وتعمل هذه الدالة علي إرسال أمر معين إلى لوحة المفاتيح لاستدعائه في تنفيذ هذا الأمر وتأخذ الصورة التالية :


code: SendKeys "(TAB)" 
 
إرسال أمر إلى زرار TAB في لوحة المفاتيح لاستخدام وظيفته .

code: SendKeys "^+" 
 
 الدالة StrConv : وهي دالة تحويل وتعمل هذه الدالة علي تحويل متغيرها علي حسب الثابت التي تستخدمه معها وـاخذ الصورة التالية :

code: aa = "welcome to 4arab"
MsgBox StrConv(aa, vbProperCase)
 
 وهنا استخدمنا الثابت vbProperCase ويعمل علي تكبير الحرف الأول من كل كلمة .
والثابت vbLowerCase يعمل علي تصغير النص والثابت vbUpperCase تكبير النص
والثابت vbUncode تحويل النص من ASCII إلى Unicode والثابت vbFromUnicode العكس

الدالة Ascw : وهي عكس الدالة Asc فالدالة Ascw ترجع كود الرمز المدخل إلى الترميز Unicode وتأخذ الصورة التالية :

code: MsgBox Ascw("ت")
 
 
الدالة Chrw : وهي عكس الدالة Chr تعيد الحرف الممثل لهذه القيمة في الترميز Unicode وتأخذ الصورة التالية :

code: MsgBox ChrW(1578(
 

توضيح اكثر للدوال الأربع : 

code: Private Sub Command1_Click()
MsgBox Asc("ت")
MsgBox AscW("ت")
MsgBox Chr(202(
MsgBox ChrW(1578)
End Sub
 
الدالة Hex : وتعمل هذه الدالة علي تحويل الرقم العشري إلى ما يقابله في النظام السادس عشر Hexadecimal وتأخذ الصورة التالية :

code: Dim HexNO, Character As String
Character = "A 'أو أي قيمة أخرى  "
HexNO = Hex(Asc(Character))
MsgBox "Character " & Character & " = " & HexNO
 
 
الدالة OCT : وهذه الدالة تعمل علي تحويل نظام الرقم العشري إلى ما يقابله في النظام الثمانية Octal وتأخذ الصورة التالية :

code: MsgBox Oct(100)

دوال سلاسل البيانات

الدالة Array : تحول عدة بيانات مدخلة كنصوص تفصلها فاصلة إلى مصفوفة يكون رقم أول عنصر فيها (Lower Bound) هو (0) فمثلا لو أدخلنا النص التالي إلى الدالة . 

code: "Frist","Second","Third","Forth"
MyNumber= Array("First" , "Second" , "Third" , "Forth" )
Print MyNumber(0)
Print MyNumber(1)
Print MyNumber(2)
Print MyNumber(3)
 
نرى أن النتيجة هي

code: First
Second
Third
Forth
 

أي أن المتغير MyNumber يحمل مصفوفة ممتلئة بالنصوص المدخلة بعد أن تحولت إلى عناصر للمصفوفة
لاحظ أن المتغير MyNumber كان من نوع Variant لأننا لم نعلن عنه ويمكن للمتغير من هذا النوع أن يحمل مصفوفة وكذلك يمكن أن تكون المصفوفة من أي نوع آخر فالمصفوفة المستعملة في المثال هي مصفوفة نصية بينما لو كانت العناصر المدخلة أرقما (لاستعملنا علامات التنصيص مع الأرقام حتى لا تعتبر نصوصا) لكانت مصفوفة من نوع Integer مثلا . 


الدالة Asc : ترجع كود الرمز المدخل (ASCII Code) فمثلا الحرف A له الكود 65 فعند إدخال حرف A مثلا ستكون النتيجة 65 وهكذا ( لاحظ أن حرف A يختلف عن حرف a في الكود) . 

code: MyNumber = Asc("a")
 
 
تجد أن المتغير MyNumber أصبح يحمل القيمة 97 . وهكذا .. انتبه فيما لو غيرة الحرف من صغير إلى كبير ستتغير القيمة إلى 65 

الدالة IsNumeric : تستخدم لمعرفة ما إذا كان تعبير معين يدل على عدد أم لا فنحن ندخل للدالة تعبير من نوع Variant أو String فتختبر الدالة هذا التعبير هل يمكن التعامل مع هذا التعبير كعدد أم لا فإذا كان يمكن التعامل معه كعدد فإن الدالة IsNumeric ترجع بالقيمة True وإذا كان التعبير لا فإن الدالة ترجع بالقيمة False , فمثلا في المثال التالي كان المتغير ric من نوع String ويحمل عدد معين و نريد أن نختبر هذا العدد هل يمكن التعامل معه كعدد أم لا وفي حالتنا هذه سوف تكون قيمة المتغير True لان المتغير ric يصلح لأن يكون عدد

code: Dim ric as string
ric="7.1342"
TafTaf=IsNumeric(ric)
 
 
ستكون النتيجة هنا True لأن المتغير ric يحمل عددا بالفعل .

code: Dim ric as string
ric="LM7.1342"
TafTaf=IsNumeric(ric)
 
ستكون النتيجة هنا False لأن المتغير ric لا يحمل عددا فقط بل عدد مع أحرف وهذا غير صالح للتعامل معه كعدد .


الدالة UCase : وظيفتها بسيطة جدا فهي ببساطة تحول حالة النص المدخل من حالة الأحرف الصغيرة (Small Letters) إلى حالة الأحرف الكبيرة (Capital Letters)
فالمثال التالي يحول "taftaf1267" إلى "TAFTAF1267"

code: Ucase("taftaf1267")
 

الدالة LCase : : تعيد الدالة LCase نسخة من النص string تكون فيه جميع الحروف صغيرة Lowercase المتغيرة myText في المثال التالي ستحتوي على عبارة it works 

code: myText = "It Works"
myText = LCase(myText)

الدالة chr : تقوم الدالة chr بأخذ قيمة بين 0 و 255 وتعيد الحرف الممثل لهذه القيمة في جدول رموز ASCII، على سبيل المثال العبارة التالية : 


code: Hi,
I'm "TafTaf"
 
 

ستجد أنك لا تستطيع كتابتها بهذا الشكل :

code: myText = "Hi," & vbCrLf & "I'm "TafTaf"" 
 

لأن البرنامج سيعتقد بأن نهاية السلسة النصية السابقة هي عند علامات الاقتباس التي تقع مباشرة قبل كلمة TafTaf وستظهر لك رسالة خطأ، لذلك فإننا نلجأ لاستخدام الدالة chr حيث أن رمز علامة الاقتباس المزدوجة في جدول ASCII هو 34، فتكون الصياغة الصحيحة للعبارة البرمجية السابقة كالتالي :
myText = "Hi," & vbCrLf & "I'm " & chr(34) & "TafTaf" & chr(34) 

الدالة Len : ستجد فيما بعد حاجة في كثير من الأحيان لمعرفة طول السلسلة النصية ( عدد الأحرف )، ولعمل ذلك استخدم الدالة Len، مرر إليها النص وستعيد لك عدد الحروف.

code: myLength = Len("TafTaf") 
 
 
الدالة InStr : : يمكنك بواسطة هذه الدالة معرفة أول مكان يظهر فيه نص ما ضمن نص آخر أكبر منه. الوسيطة الأولى هي وسيطة اختيارية تحدد مكان بدء البحث، أما الوسيطة الثانية string1 فتحدد السلسلة النصية التي سيتم البحث فيها، والوسيطة الثالثة string2 تحدد السلسلة النصية التي سيتم البحث عنها في السلسلة الأولى، أما الوسيطة الأخيرة فهي اختيارية أيضا وتحدد نوع المقارنة التي يجب إجرائها وهي تأخذ أحد الثوابت التالية : 
0 - vbBinaryCompare 
1 - vbTextCompare 
والفرق بينهما هو أن الأولى تراعي حالة الأحرف والثاني لا تراعي حالة الأحرف. 
في المثال التالي الدالة i ستحتوي على القيمة 1 :

code: i = InStr("TafTaf","T") 
 
وأما المثال التالي فستحتوي i فيه على القيمة 3 :

code:  i = InStr("aafTaf","T") 
 
 حيث أن الدالة في المثال السابق ستبحث عن الحرف T بادئه من الحرف الثاني ولذلك فهي لن تجد الحرف الأول. 

الدالة Str : قد تبدو الدالة Str متشابهة مع الدالة chr، إلا أنها تؤدي وظيفة مختلف تماما، فهي تحول الأرقام إلى سلاسل نصية، وهي تفيد مثلا في حال أردت أن تقوم بالتحام بين رقمين فتقوم بتحويل كل منهما إلى سلسلة نصية وتطبق بينهما جمع السلاسل ( & ) الذي يختلف عن جمع الأرقام وبالتالي تحصل على سلسلة جديدة يمكنك أن تحولها إلى رقم من جديد، على سبيل المثال الدالة myNumber تحتوي على القيمة 123456.

code: myNumber = Str(123) & Str(456) 
 
 
ستواجهك مشكلة في الشفرة السابقة حيث يقوم فبجوال بيسيك بإضافة مسافة قبل كل سلسلة نصية تنتج من الدالة السابقة. 

الدالة Left : حيث تقوم بوضع سلسلة نصية string وتحدد الجزء الذي تريد اقتطاعه من بداية السلسلة length، والتعبير بكلمة من بداية السلسلة أدق من يسار السلسلة لأن هذا قد يحدث اشتباها في السلاسل النصية للغات التي تكتب من اليمين إلى اليسار مثل العربية، هنا تعيد السلسلة العدد المحدد من الحروف من اليمين أي أنها لا تهتم لاتجاه ظهور أحرف السلسة وإنما اتجاه تخزينها، وللتخلص من هذه المشكلة سنقول بداية السلسلة .

الدالة Right : مطابقة للدالة Left في كل شيء، إلا أنها تأخذ العدد المحدد من الحروف من نهاية السلسلة. 

الدالة Mid : تعيد الدالة Mid عددا من الأحرف قدره length بدءا من حرف معين هو start، في سلسلة نصية string لاحظ أيضا أن الوسيطة length اختيارية وإذا لم تمرر بها أي قيمة فإن الدالة ستعيد الأحرف إلى نهاية السلسلة . 
في المثال التالي ستحتوي المتغيرة myText على العبارة I'm Taf :

code: myText = Mid("I'm TafTaf", 1, 7) 
 
 
أما في المثال التالي فستحتوي على الكلمة TafTaf :

code: myText = Mid("I'm TafTaf", 5) 
 
 
التصريح Mid : يقوم التصريح Mid باستبدال مقطع محدد من النص بنص آخر، وهو يكتب في صورة مشابهة جدا لطريقة كتابة دالة Mid ولكن توضع بعده علامة مساواة وبعدها العبارة الجديدة، في المثال التالي ستحتوي المتغيرة myText على القيمة I'm TafTaf : 
code: name = "TafTaf"
myText = "I'm name"
Mid(myText, 5) = name
 
 
حيث سيتم حذف الجزء المحدد بالخاصية Mid ويوضع الجزء الذي بعد علامة المساواة في مكان الجزء المحذوف

المجموعة السادسة :رسم ثلاثي الأبعاد

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

ضع أداة (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

مكعب ثلاثي الأبعاد يدورحول نفسه

'Add 1 Picture Box and 1 Timer Control to your form.
'At Run-Time, Move the mouse to change the rotation speed and direction..
'Insert the following code to your form:

Private X(8) As Integer
Private y(8) As Integer
'Integer arrays that hold the actual 2D coordinates of the
'8 corners of the cube.These are the values used to plot
'the cube on the form after the X,Y,Z coordinates of each cube
'corner have been converted to 2 dimensinal X and Y coordinates.
Private Const Pi = 3.14159265358979
'Constant used to convert degrees to radians
Private CenterX As Integer
Private CenterY As Integer
'The center of the 3 dimensional plane,where it's
'X=0 , Y=0 , Z=0
Private Const SIZE = 250
'The length of the cube achmes,therefore also adjusts the overall size.
Private Radius As Integer
'The radius of the rotation.Each one of the 8 corners of the cube
'rotates around the vertical Y axis with the same angular speed and radius
'of rotation.
Private Angle As Integer
'The value of this variable loops from 0 to 360 and it is passed
'as an argument to the COS and SIN functions (sine and cosine)
'that return the changing Z and X coordinates of each corner
'as the cube rotates around the Y axis
Private CurX As Integer
Private CurY As Integer
'Variables that hold the current mouse position on the form.
Private CubeCorners(1 To 8, 1 To 3) As Integer
'The array that holds the X,Y and Z coordinates of the 8 corners
'The center of the 3D plane is right on the center of the cube.
'So ,if SIZE the length of one achmes,it's:
'CenterCube(1,1) = SIZE/2 ' X coordinate of 1st corner
'CenterCube(1,2) = SIZE/2 ' Y coordinate
'CenterCube(1,3) = SIZE/2 ' Z coordinate
'Actually,we only need to give a value for the Y coordinates
'of each corner since that will never change during the rotation
'as all corners rotate around the Y axis ,with only their Z and X
'coordinates changing periodically.
Private Sub Form_Load()
Me.ScaleMode = 3
Picture1.ScaleMode = 3
Timer1.Interval = 1
'Set here the cube Width and color.
Me.ForeColor = vbBlue
Me.DrawWidth = 3
Picture1.AutoRedraw = True
Show
Picture1.Height = Picture1.Width
Picture1.Move ScaleWidth / 2 - Picture1.ScaleWidth / 2, Picture1.Height
CenterX = ScaleWidth / 2
CenterY = ScaleHeight / 2
'Set the center of the 3D plane to reflect the center of the form.
Angle = 0
Radius = Sqr(2 * (SIZE / 2) ^ 2)
'Give a value to the radius of the rotation.This is
'the Pythagorean theorem that returns the length of the
'hypotenuse of a right triangle as the square root
'of the sum of the other two sides raised to the 2nd power.
CubeCorners(1, 2) = SIZE / 2
CubeCorners(2, 2) = SIZE / 2
CubeCorners(3, 2) = -SIZE / 2
CubeCorners(4, 2) = -SIZE / 2
CubeCorners(5, 2) = SIZE / 2
CubeCorners(6, 2) = SIZE / 2
CubeCorners(7, 2) = -SIZE / 2
CubeCorners(8, 2) = -SIZE / 2
'Assign a value to the Y coordinates of each cube.This
'will never change through out the rotation since the cube
'rotates around the Y axis.Play around with these if you like
'but the 3D prism will no longer resemble a cube...
End Sub

Private Sub DrawCube()
Cls
For i = 1 To 8
X(i) = CenterX + CubeCorners(i, 1) + CubeCorners(i, 3) / 8
y(i) = CenterY + CubeCorners(i, 2) + Sgn(CubeCorners(i, 2)) * CubeCorners(i, 3) / 8
'These two lines contain the algorith that converts the
'coordinates of a point on the 3D plane (x,y,z) ,into 2
'dimensional X and Y coordinates that can be used to plot
'a point on the form.Play around with the 8's and see what happens...
Next
Line (X(3), y(3))-(X(4), y(4))
Line (X(4), y(4))-(X(8), y(8))
Line (X(3), y(3))-(X(7), y(7))
Line (X(7), y(7))-(X(8), y(8))
Line (X(1), y(1))-(X(3), y(3))
Line (X(1), y(1))-(X(2), y(2))
Line (X(5), y(5))-(X(6), y(6))
Line (X(5), y(5))-(X(1), y(1))
Line (X(5), y(5))-(X(7), y(7))
Line (X(6), y(6))-(X(8), y(8))
Line (X(2), y(2))-(X(4), y(4))
Line (X(2), y(2))-(X(6), y(6))
Line (X(1), y(1))-(X(4), y(4))
Line (X(2), y(2))-(X(3), y(3))
Line (X(4), y(4))-(X(8), y(8))
Line (X(3), y(3))-(X(7), y(7))
'The plotting of the cube onto the form.
'We have to draw each achmes seperately and then
' "connect" the bottom square with the top square.
DoEvents
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, y As Single)
CurX = X
CurY = y
'Store the current position of the mouse cursor into
'the variable CurX,CurY.
End Sub

Private Sub Timer1_Timer()
Select Case CurX
Case Is > ScaleWidth / 2
Angle = Angle + Abs(CurX - ScaleWidth / 2) / 20
If Angle = 360 Then Angle = 0
Case Else
Angle = Angle - Abs(CurX - ScaleWidth / 2) / 20
If Angle = 0 Then Angle = 360
End Select
'Change the direction and the angular speed of the rotation
'according to the position of the mouse cursor.If it's near
'the left edge of the form then the rotation will be
'anti-clockwise ,it's near the right edge it will be
'clockwise. The closer to the center of the form the
'cursor is,the slower the cube rotates.
'The angular speed of the rotation is controlled by the
'pace at which 'Angle' (the value that we pass to the
'(COS and SIN functions) increases or decreases (increases
'for anti-clockwise rotation and decreases for clockwise rotation).
For i = 1 To 3 Step 2
CubeCorners(i, 3) = Radius * Cos((Angle) * Pi / 180)
CubeCorners(i, 1) = Radius * Sin((Angle) * Pi / 180)
Next
For i = 2 To 4 Step 2
CubeCorners(i, 3) = Radius * Cos((Angle + 2 * 45) * Pi / 180)
CubeCorners(i, 1) = Radius * Sin((Angle + 2 * 45) * Pi / 180)
Next
For i = 5 To 7 Step 2
CubeCorners(i, 3) = Radius * Cos((Angle + 6 * 45) * Pi / 180)
CubeCorners(i, 1) = Radius * Sin((Angle + 6 * 45) * Pi / 180)
Next
For i = 6 To 8 Step 2
CubeCorners(i, 3) = Radius * Cos((Angle + 4 * 45) * Pi / 180)
CubeCorners(i, 1) = Radius * Sin((Angle + 4 * 45) * Pi / 180)
Next
'Give the new values to the X and Z coordinates of each one
'of the 8 cube corners by using the COS and SIN mathematical
'functions.Notice that corners 1 and 3 always have the same
'X and Z coordinates, as well as 2 and 4, 5 and 7,6 & 8.
'Take a look at the little scetch on the top of the form
'to see how this is explained (imagine the cube rotating
'around the Y axis)
DrawCube
End Sub

أرجو منكم التمهل في الرد حتى الغد

[veto_44]

الاخ احمد ممكن توضح لنا ما الذي يجري بهذا الموضوع
ولمن هي هذه العضوية mohamed47 هل هي لك ام
لاحد اقاربك وخصوصا الرد الاخير لها ومقدمة الموضوع

لي أخ مشترك في منتدى برامج نت أزعجكم بمواضيعه القصير المحتمل أن تكون مهمة بالنسبة لبعض الأعضاءالهدف من هذا الموضوع :1-تشجيع هذا العضو المجهول على تكملة الاكواد
وكما عودكم سأتبع سبيله في عرض موضوعاته

واعتقد انه يوجد موضوع لك انت والاخ حماده لغرض
وضع الاكواد به ننتظر ردك حتى نعرف كيف نتصرف
دمت بخير وعافية .

[veto_44]

واتمنى ان تلاحظ مدى التشاة الكبير بالاكواد بين الموضوعين
فمعظم الاكواد متشابهة

[ahmed ksnv]

1-وقال هذا أيضًا

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

2- mohamed47 هو أخي "جاري "

3- هذه الأكواد من محصلة أكوادي ،كنت قد أعددتها من أجل نشرها في برامج نت
ووضعتها في ملف ورد في مجلد له خاصية المشاركة بين أجهزة الشبكة فرآها mohamed47 في ملف بعنوان أكواد الوداع ففتحه فوجد أنه معد للنشر وأيضًا موقت بتواقيت النشر فمثلًا يوم 22/1 الساعة الـ 6:30 مساءً سيتم نشر المجموعة السابعة
فأراد تشجيعي على الاكمال في المنتدى
فقام بنشر بعض الأكواد منه على أن أكمله أنا فرأيت بعض الأعضاء قد تفاعلوا مع الموضوع وقاموا بالرد والتشجيع وكنت أريد أن أقوم بتكملة الأكواد في أول رد على موضوع أخي "جاري"

كما أنك ستجد IP الشبكة واحد لأنك مشرف ومن الكؤكد السماح لك بمعرفة رقم IP


موضوعي أنا والأخ حمادا قد تم إلغاء تثبيته وكنا أنتهينا من الأكواد المتفق على نشرها
و الأخ حمادا قد قل تواجده ي المنتدى

[على كريم الدين]

مش فاهم اى حاجه