تعلم معى بالتمرين خطوة خطوة -3

كود للأتصال من خلال البرنامج باستعمال اداة mscomm
*كود برمجي*


--------------------------------------------------------------------------------


'اضف 12 command و 2 text و اداة mscomm و ضع الكود التالي
Option Explicit

Private Sub Command1_Click(Index As Integer)

Text1.Text = Text1.Text & Command1(Index).Caption

End Sub


Private Sub Command2_Click()

On Error GoTo er:

Dim DialString$, FromModem$, dummy
Dim Result As Long

If MSComm1.PortOpen = True Then: MsgBox "منفذ الاتصال قيد الاستخدام حاليا", vbInformation, "": Exit Sub

If Text1.Text <> "" Then
With MSComm1
'تحديد منفذ الاتصال الخاص بالمودم
.CommPort = Text2.Text
'اعدادات خاصة بالمودم وسرعته
.Settings = "9600,N,8,1"
'فتح المنفذ للحصول على الخط
.PortOpen = True
'بعض الثوابت لتعريف الاتصال
.Output = "ATDT" & MSComm1.Tag & Chr$(13)
End With
Else
MsgBox "لايوجد رقم للأتصال به ؟", vbCritical, "خطاء"
End If

MSComm1.InBufferCount = 0

'حلقة للحصول على نتائج الاتصال
Do
dummy = DoEvents()
'تم اقفال منفذ الاتصال
If MSComm1.PortOpen = False Then Exit Sub

If MSComm1.InBufferCount Then
FromModem$ = FromModem$ + MSComm1.Input

If InStr(FromModem$, "NO DIALTONE") Then
MsgBox "لايوجد صوت طنين تاكد من الخط غير مشغول او باتصاله بالمودم بشكل صحيح", vbInformation, ""
Exit Do
End If

If InStr(FromModem$, "BUSY") Then
MsgBox "الخط مشغول اعد الاتصال مرة اخرى", vbInformation, ""
Exit Do
End If

If InStr(FromModem$, "OK") Then
Result = MsgBox("ارفع السماعة واضغط موافق للمكالمة ان اردت انهاء المكالمة اضغط موافق بدون رفع السماعة", vbInformation, "")
Exit Do
End If
End If
Loop
MSComm1.PortOpen = False

Exit Sub
er:
If Err.Number = 8002 Then
MsgBox "لا يوجد مودم في المنفذ المحدد فضلا تأكد من المنفذ الصحيح أو تأكد من وصل المودم بجهازك بشكل جيد", vbCritical, "خطاء"
Else
MsgBox Err.Number & " " & Err.Description, vbCritical, "خطاء"
End If

End Sub


Private Sub Command3_Click()

If MSComm1.PortOpen = False Then Exit Sub
MSComm1.PortOpen = False

End Sub


--------------------------------------------------------------------------------


تشغيل الصوت
*كود برمجي*


--------------------------------------------------------------------------------


'فقط *.wav إظهار الملفات من النوع
commonDialog1.Filter = "Wave Files|*.wav|"
'لإضهار مربع حوار فتح
CommonDialog1.ShowOpen
'لو لم يختار أي ملف فإنه يتم الخروج من هذا الإجراء
'دون فتح الملف
' FileName حيث أن اسم الملف يتواجد في الخاصية
If CommonDialog1.FileName = "" Then Exit Sub

'تحديد نوع الملف المطلوب تشغيله
MMControl1.DeviceType = "waveaudio"
'تحديد اسم ملف الصوت
MMControl1.FileName = CommonDialog1.FileName
'فتح ملف الصوت
MMControl1.Command = "open


--------------------------------------------------------------------------------


امر بحث عن الملفات
*كود برمجي*


--------------------------------------------------------------------------------


'ضع هذا الكود في ملف باس bas
Declare Function SearchTreeForFile Lib "IMAGEHLP.DLL" _
(ByVal lpRootPath As String, _
ByVal lpInputName As String, _
ByVal lpOutputName As String) As Long

Public Const MAX_PATH = 260
Public Function FindFile(RootPath As String, _
FileName As String) As String

Dim lNullPos As Long
Dim lResult As Long
Dim sBuffer As String

On Error GoTo FileFind_Error

'Allocate buffer
sBuffer = Space(MAX_PATH * 2)

'Find the file
lResult = SearchTreeForFile(RootPath, FileName, sBuffer)

'Trim null, if exists
If lResult Then
lNullPos = InStr(sBuffer, vbNullChar)
If Not lNullPos Then
sBuffer = Left(sBuffer, lNullPos - 1)
End If
'Return filename
FindFile = sBuffer
Else
'Nothing found
FindFile = vbNullString
End If

Exit Function

FileFind_Error:
FindFile = vbNullString

End Function



'البحث عن ملف
'هذا الكود ضعه في الحدث الضغط على زر كوماند او غيره
MsgBox FindFile("c:", "win.com")



--------------------------------------------------------------------------------


هل الملف موجود أم لا؟
*كود برمجي*


--------------------------------------------------------------------------------


If Dir("c:\test.txt", vbNormal or vbReadOnly or vbHidden or vbSystem or vbArchive) = "" then
Msgbox "الملف غير موجود"
Else
Msgbox "الملف موجود"
End If


--------------------------------------------------------------------------------


عكس اتجاه جمله
*كود برمجي*


--------------------------------------------------------------------------------


Public Function reversestring(revstr As String) As String
Dim doreverse As Long
reversestring = ""
For doreverse = Len(revstr) To 1 Step -1
reversestring = reversestring & Mid$(revstr, doreverse, 1)
Next
End Function

Private Sub Form_DblClick()
Dim strResult As String
'الكلمه المراد عكسها
strResult = reversestring("String")
MsgBox strResult
End Sub


--------------------------------------------------------------------------------


نعطيل النوافذ الدعائية في متصفحكDisble Popup Window
*كود برمجي*


--------------------------------------------------------------------------------


Private Sub Form_Load()
WebBrowser1.Navigate "http://www.aol.com"
End Sub


Private Sub WebBrowser1_NewWindow2(ppDisp As Object, Cancel As Boolean)
'this sets the popup window to another b
' rowser control
'in which webbrowser2.visible = false
Set ppDisp = WebBrowser2.Object
End Sub


--------------------------------------------------------------------------------


تكملة تلقائية للكومبوبكس Auto complete Combobox
*كود برمجي*


--------------------------------------------------------------------------------


'قسم التصاريح
Public Const CB_FINDSTRING = &H14C
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

'الكود
Sub AutoComplete(cbCombo As ComboBox, strKeyHit As String)
' To use this code, put the following co
' de in the combo box's KeyPress event
'
' AutoComplete , Key
' Ascii
'
' change to the nam
' e of the combobox


If KeyAscii = 13 Then
cbCombo.AddItem cbCombo.Text
KeyAscii = 0
Exit Sub
End If
Dim lngFind As Long, intPos As Integer, intLength As Integer


With cbCombo


If KeyAscii = 8 Then
If .SelStart = 0 Then Exit Sub
.SelStart = .SelStart - 1
.SelLength = 32000
.SelText = ""
Else
.SelText = chr(KeyAscii)
End If
KeyAscii = 0
lngFind = SendMessage(.hWnd, CB_FINDSTRING, 0, ByVal .Text)
If lngFind = -1 Then Exit Sub
intPos = .SelStart
intLength = Len(.List(lngFind)) - Len(.Text)
.SelText = .SelText & Right(.List(lngFind), intLength)
.SelStart = intPos
.SelLength = intLength
End With
End Sub


--------------------------------------------------------------------------------


حفظ ملف في قاعدة بياناتStore Binary files in a database
*كود برمجي*


--------------------------------------------------------------------------------


Public Function BLOBToFile(ByVal strFullPath As String, ByRef objField As ADODB.Field, Optional ByVal bUseStream As Boolean = True, Optional ByVal lngChunkSize As Long = 8192) As Boolean
On Error Resume Next
Dim objStream As ADODB.Stream
Dim intFreeFile As Integer
Dim lngBytesLeft As Long
Dim lngReadBytes As Long
Dim byBuffer() As Byte


If bUseStream Then
Set objStream = New ADODB.Stream


With objStream
.Type = adTypeBinary
.Open
.Write objField.Value
.SaveToFile strFullPath, adSaveCreateOverWrite
End With


DoEvents
Else


If Dir(strFullPath) <> "" Then
Kill strFullPath
End If
lngBytesLeft = objField.ActualSize
intFreeFile = FreeFile
Open strFullPath For Binary As #intFreeFile


Do Until lngBytesLeft <= 0
lngReadBytes = lngBytesLeft


If lngReadBytes > lngChunkSize Then
lngReadBytes = lngChunkSize
End If
byBuffer = objField.GetChunk(lngReadBytes)
Put #intFreeFile, , byBuffer
lngBytesLeft = lngBytesLeft - lngReadBytes


DoEvents
Loop
Close #intFreeFile
End If


If Err.Number <> 0 Or Err.LastDllError <> 0 Then
BLOBToFile = False
Else
BLOBToFile = True
End If
End Function
'***************************************
' ************************
' Abstract: Writes a binary file to a BL
' OB datafield. If the file
'is big I would recommend that you set b
' UseStream = False.
'
' Input: strFullPath: Full path to the s
' ource file
'objField: Field object that will contai
' n the BLOB data.
'bUseStream: (Optional) True = Use Strea
' m methode, False = Use GetChunk
'lngChunkSize: (Optional) Specifies the
' Chunk size to fetch with each GetChunk
'
' Output: True on success, False on fail
' ure
'***************************************
' ************************


Public Function FileToBLOB(ByVal strFullPath As String, ByRef objField As ADODB.Field, Optional ByVal bUseStream As Boolean = True, Optional ByVal lngChunkSize As Long = 8192) As Boolean
On Error Resume Next
Dim objStream As ADODB.Stream
Dim intFreeFile As Integer
Dim lngBytesLeft As Long
Dim lngReadBytes As Long
Dim byBuffer() As Byte
Dim varChunk As Variant


If bUseStream Then
Set objStream = New ADODB.Stream


With objStream
.Type = adTypeBinary
.Open
.LoadFromFile strFullPath
objField.Value = .Read(adReadAll)
End With
Else


With objField
'<<--If the field does not support
' Long Binary data'-->>
'<<--then we cannot load the data
' into the field.-->>


If (.Attributes And adFldLong) <> 0 Then
intFreeFile = FreeFile
Open strFullPath For Binary Access Read As #intFreeFile
lngBytesLeft = LOF(intFreeFile)


Do Until lngBytesLeft <= 0


If lngBytesLeft > lngChunkSize Then
lngReadBytes = lngChunkSize
Else
lngReadBytes = lngBytesLeft
End If
ReDim byBuffer(lngReadBytes)
Get #intFreeFile, , byBuffer()
objField.AppendChunk byBuffer()
lngBytesLeft = lngBytesLeft - lngReadBytes


DoEvents
Loop
Close #intFreeFile
Else
Err.Raise -10000, "FileToBLOB", "The Database Field does Not support Long Binary Data."
End If
End With
End If



If Err.Number <> 0 Or Err.LastDllError <> 0 Then
FileToBLOB = False
Else
FileToBLOB = True
End If
End Function


--------------------------------------------------------------------------------