تعلم معى بالتمرين خطوة خطوة -3
صفحة 1 من اصل 1
تعلم معى بالتمرين خطوة خطوة -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
--------------------------------------------------------------------------------
*كود برمجي*
--------------------------------------------------------------------------------
'اضف 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
--------------------------------------------------------------------------------
مواضيع مماثلة
» تعلم معى بالتمرين خطوة خطوة -1
» تعلم معى بالتمرين خطوة خطوة -2
» تعلم معى بالتمرين خطوة خطوة -4
» اول خطوة -وبعدها نشوف هنعمل ايه
» تعلم ويندوز 7 بالصوت والصورة
» تعلم معى بالتمرين خطوة خطوة -2
» تعلم معى بالتمرين خطوة خطوة -4
» اول خطوة -وبعدها نشوف هنعمل ايه
» تعلم ويندوز 7 بالصوت والصورة
صفحة 1 من اصل 1
صلاحيات هذا المنتدى:
لاتستطيع الرد على المواضيع في هذا المنتدى