softsoft
22-08-10, 18:12
من یه کد ویبی 6 دارم که باهاش میشه اطلاعات درمورد کانکشن های ویندوز به دست آورد . مثل UserName . میخوام تبدیلش کنم به
ویبی دات نت و ازش توی پروژه دات نتم استفاده کنم ولی نمیدونم چه جوری .کمکم کنید .
کد ویبی 6 به صورت زیر هستش :
ابتدا یه لیست ویو توی فرم بزارید .
بعد کد زیر رو به فرمتون اضافه کنید :
Private Sub Form_Load()
'set the listview
ListView1.ColumnHeaders.Add , , "Connection Name", ListView1.Width / 3
ListView1.ColumnHeaders.Add , , "Username", ListView1.Width / 3
ListView1.ColumnHeaders.Add , , "Password", ListView1.Width / 3
'declarations for the use of the api
Dim rdp As VBRasDialParams
Dim b() As Byte
Dim rtn As Long
Dim sArray() As String
Dim iCtr As Integer
DUN_Services sArray 'here the connections names are stored in the sArray
For iCtr = 0 To UBound(sArray) 'here we take every connection name and use it to get
'get more infos about this connection by calling the
'VBRasGetEntryDialParams function
rtn = VBRasGetEntryDialParams(b, vbNullString, sArray(iCtr))
Call BytesToVBRasDialParams(b, rdp)
'store the infos in the listview
Set llist = ListView1.ListItems.Add(, , rdp.EntryName)
llist.ListSubItems.Add , , rdp.UserName
llist.ListSubItems.Add , , rdp.Password
Next
End Sub
حالا یه ماژولبا نام Ras.bas ایجاد و کد زیر رو توش کپی کنید :
'here are all the declarations of the api and the types are used from the apis
Private Declare Function RasGetCredentials Lib "rasapi32.dll" Alias "RasGetCredentialsA" _
(ByVal lpcstr As String, ByVal lpcstr As String, ByRef TLPRASCREDENTIALSA As RASCREDENTIALS) _
As Long
Private Type RASCREDENTIALS
dwSize As Long
dwMask As Long
szUserName As String
szPassword As String
szDomain As String
End Type
Public Type RASENTRYNAME95
dwSize As Long
szEntryname(256) As Byte
End Type
Public Declare Function RasEnumEntriesA Lib "rasapi32.dll" _
(ByVal reserved As String, ByVal lpszPhonebook As String, _
lprasentryname As Any, lpcb As Long, lpcEntries As Long) _
As Long
Public Declare Function RasGetEntryDialParams _
Lib "rasapi32.dll" Alias "RasGetEntryDialParamsA" _
(ByVal lpszPhonebook As String, _
lpRasDialParams As Any, _
blnPasswordRetrieved As Long) As Long
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(Destination As Any, Source As Any, ByVal Length As Long)
Public Type VBRasDialParams
EntryName As String
PhoneNumber As String
CallbackNumber As String
UserName As String
Password As String
Domain As String
SubEntryIndex As Long
RasDialFunc2CallbackId As Long
End Type
'VB "friendly" RasDialParams Structure
Function VBRasSetEntryDialParams _
(strPhonebook As String, bytesIn() As Byte, _
blnRemovePassword As Boolean) As Long
' VBRasSetEntryDialParams = RasSetEntryDialParams _
' (strPhonebook, bytesIn(0), blnRemovePassword)
End Function
Sub CopyByteToTrimmedString(strToCopyTo As String, _
bPos As Byte, lngMaxLen As Long)
Dim strTemp As String, lngLen As Long
strTemp = String(lngMaxLen + 1, 0)
CopyMemory ByVal strTemp, bPos, lngMaxLen
lngLen = InStr(strTemp, Chr$(0)) - 1
strToCopyTo = Left$(strTemp, lngLen)
End Sub
Sub CopyStringToByte(bPos As Byte, _
strToCopy As String, lngMaxLen As Long)
Dim lngLen As Long
lngLen = Len(strToCopy)
If lngLen = 0 Then
Exit Sub
ElseIf lngLen > lngMaxLen Then
lngLen = lngMaxLen
End If
CopyMemory bPos, ByVal strToCopy, lngLen
End Sub
Function BytesToVBRasDialParams(bytesIn() As Byte, _
udtVBRasDialParamsOUT As VBRasDialParams) As Boolean
Dim iPos As Long, lngLen As Long
Dim dwSize As Long
On Error GoTo badBytes
CopyMemory dwSize, bytesIn(0), 4
If dwSize = 816& Then
lngLen = 21&
ElseIf dwSize = 1060& Or dwSize = 1052& Then
lngLen = 257&
Else
'unkown size
Exit Function
End If
iPos = 4
With udtVBRasDialParamsOUT
CopyByteToTrimmedString .EntryName, bytesIn(iPos), lngLen
iPos = iPos + lngLen: lngLen = 129
CopyByteToTrimmedString .PhoneNumber, bytesIn(iPos), lngLen
iPos = iPos + lngLen: lngLen = 129
CopyByteToTrimmedString .CallbackNumber, bytesIn(iPos), lngLen
iPos = iPos + lngLen: lngLen = 257
CopyByteToTrimmedString .UserName, bytesIn(iPos), lngLen
iPos = iPos + lngLen: lngLen = 257
CopyByteToTrimmedString .Password, bytesIn(iPos), lngLen
iPos = iPos + lngLen: lngLen = 16
CopyByteToTrimmedString .Domain, bytesIn(iPos), lngLen
If dwSize > 1052& Then
CopyMemory .SubEntryIndex, bytesIn(1052), 4&
CopyMemory .RasDialFunc2CallbackId, bytesIn(1056), 4&
End If
End With
BytesToVBRasDialParams = True
Exit Function
badBytes:
'error handling goes here ??
BytesToVBRasDialParams = False
End Function
Public Sub DUN_Services(DUN_Array() As String)
'Pass in Empty array for DUN_Array
Dim s As Long, ln As Long, conname As String, i As Long
Dim r(255) As RASENTRYNAME95
r(0).dwSize = 264
s = 256 * r(0).dwSize
Call RasEnumEntriesA(vbNullString, vbNullString, r(0), s, ln)
ln = ln - 1
ReDim DUN_Array(ln)
For i = 0 To ln
conname = StrConv(r(i).szEntryname(), vbUnicode)
DUN_Array(i) = Left$(conname, InStr(conname, _
vbNullChar) - 1)
'RasGetEntryDialParams
Next i
End Sub
Function VBRasGetEntryDialParams _
(bytesOut() As Byte, _
strPhonebook As String, strEntryName As String, _
Optional blnPasswordRetrieved As Boolean) As Long
Dim rtn As Long
Dim blnPsswrd As Long
Dim bLens As Variant
Dim lngLen As Long, i As Long
bLens = Array(1060&, 1052&, 816&)
'try our three different sizes for RasDialParams
'eatch OS version has is own structure size
For i = 0 To 2
lngLen = bLens(i)
ReDim bytesOut(lngLen - 1)
CopyMemory bytesOut(0), lngLen, 4
If lngLen = 816& Then
CopyStringToByte bytesOut(4), strEntryName, 20
Else
CopyStringToByte bytesOut(4), strEntryName, 256
End If
rtn = RasGetEntryDialParams(strPhonebook, bytesOut(0), blnPsswrd)
If rtn = 0 Then Exit For
Next i
blnPasswordRetrieved = blnPsswrd
VBRasGetEntryDialParams = rtn
End Function
یه سوال دیگه هم دارم.
ما یه پیکچر باکس رو فرم داریم که یه عکس توشه . چه طور میشه فقط یه قسمت از عکس توش رو به داخل یه پیکچر باکس دیگه فرستاد .
ویبی دات نت و ازش توی پروژه دات نتم استفاده کنم ولی نمیدونم چه جوری .کمکم کنید .
کد ویبی 6 به صورت زیر هستش :
ابتدا یه لیست ویو توی فرم بزارید .
بعد کد زیر رو به فرمتون اضافه کنید :
Private Sub Form_Load()
'set the listview
ListView1.ColumnHeaders.Add , , "Connection Name", ListView1.Width / 3
ListView1.ColumnHeaders.Add , , "Username", ListView1.Width / 3
ListView1.ColumnHeaders.Add , , "Password", ListView1.Width / 3
'declarations for the use of the api
Dim rdp As VBRasDialParams
Dim b() As Byte
Dim rtn As Long
Dim sArray() As String
Dim iCtr As Integer
DUN_Services sArray 'here the connections names are stored in the sArray
For iCtr = 0 To UBound(sArray) 'here we take every connection name and use it to get
'get more infos about this connection by calling the
'VBRasGetEntryDialParams function
rtn = VBRasGetEntryDialParams(b, vbNullString, sArray(iCtr))
Call BytesToVBRasDialParams(b, rdp)
'store the infos in the listview
Set llist = ListView1.ListItems.Add(, , rdp.EntryName)
llist.ListSubItems.Add , , rdp.UserName
llist.ListSubItems.Add , , rdp.Password
Next
End Sub
حالا یه ماژولبا نام Ras.bas ایجاد و کد زیر رو توش کپی کنید :
'here are all the declarations of the api and the types are used from the apis
Private Declare Function RasGetCredentials Lib "rasapi32.dll" Alias "RasGetCredentialsA" _
(ByVal lpcstr As String, ByVal lpcstr As String, ByRef TLPRASCREDENTIALSA As RASCREDENTIALS) _
As Long
Private Type RASCREDENTIALS
dwSize As Long
dwMask As Long
szUserName As String
szPassword As String
szDomain As String
End Type
Public Type RASENTRYNAME95
dwSize As Long
szEntryname(256) As Byte
End Type
Public Declare Function RasEnumEntriesA Lib "rasapi32.dll" _
(ByVal reserved As String, ByVal lpszPhonebook As String, _
lprasentryname As Any, lpcb As Long, lpcEntries As Long) _
As Long
Public Declare Function RasGetEntryDialParams _
Lib "rasapi32.dll" Alias "RasGetEntryDialParamsA" _
(ByVal lpszPhonebook As String, _
lpRasDialParams As Any, _
blnPasswordRetrieved As Long) As Long
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(Destination As Any, Source As Any, ByVal Length As Long)
Public Type VBRasDialParams
EntryName As String
PhoneNumber As String
CallbackNumber As String
UserName As String
Password As String
Domain As String
SubEntryIndex As Long
RasDialFunc2CallbackId As Long
End Type
'VB "friendly" RasDialParams Structure
Function VBRasSetEntryDialParams _
(strPhonebook As String, bytesIn() As Byte, _
blnRemovePassword As Boolean) As Long
' VBRasSetEntryDialParams = RasSetEntryDialParams _
' (strPhonebook, bytesIn(0), blnRemovePassword)
End Function
Sub CopyByteToTrimmedString(strToCopyTo As String, _
bPos As Byte, lngMaxLen As Long)
Dim strTemp As String, lngLen As Long
strTemp = String(lngMaxLen + 1, 0)
CopyMemory ByVal strTemp, bPos, lngMaxLen
lngLen = InStr(strTemp, Chr$(0)) - 1
strToCopyTo = Left$(strTemp, lngLen)
End Sub
Sub CopyStringToByte(bPos As Byte, _
strToCopy As String, lngMaxLen As Long)
Dim lngLen As Long
lngLen = Len(strToCopy)
If lngLen = 0 Then
Exit Sub
ElseIf lngLen > lngMaxLen Then
lngLen = lngMaxLen
End If
CopyMemory bPos, ByVal strToCopy, lngLen
End Sub
Function BytesToVBRasDialParams(bytesIn() As Byte, _
udtVBRasDialParamsOUT As VBRasDialParams) As Boolean
Dim iPos As Long, lngLen As Long
Dim dwSize As Long
On Error GoTo badBytes
CopyMemory dwSize, bytesIn(0), 4
If dwSize = 816& Then
lngLen = 21&
ElseIf dwSize = 1060& Or dwSize = 1052& Then
lngLen = 257&
Else
'unkown size
Exit Function
End If
iPos = 4
With udtVBRasDialParamsOUT
CopyByteToTrimmedString .EntryName, bytesIn(iPos), lngLen
iPos = iPos + lngLen: lngLen = 129
CopyByteToTrimmedString .PhoneNumber, bytesIn(iPos), lngLen
iPos = iPos + lngLen: lngLen = 129
CopyByteToTrimmedString .CallbackNumber, bytesIn(iPos), lngLen
iPos = iPos + lngLen: lngLen = 257
CopyByteToTrimmedString .UserName, bytesIn(iPos), lngLen
iPos = iPos + lngLen: lngLen = 257
CopyByteToTrimmedString .Password, bytesIn(iPos), lngLen
iPos = iPos + lngLen: lngLen = 16
CopyByteToTrimmedString .Domain, bytesIn(iPos), lngLen
If dwSize > 1052& Then
CopyMemory .SubEntryIndex, bytesIn(1052), 4&
CopyMemory .RasDialFunc2CallbackId, bytesIn(1056), 4&
End If
End With
BytesToVBRasDialParams = True
Exit Function
badBytes:
'error handling goes here ??
BytesToVBRasDialParams = False
End Function
Public Sub DUN_Services(DUN_Array() As String)
'Pass in Empty array for DUN_Array
Dim s As Long, ln As Long, conname As String, i As Long
Dim r(255) As RASENTRYNAME95
r(0).dwSize = 264
s = 256 * r(0).dwSize
Call RasEnumEntriesA(vbNullString, vbNullString, r(0), s, ln)
ln = ln - 1
ReDim DUN_Array(ln)
For i = 0 To ln
conname = StrConv(r(i).szEntryname(), vbUnicode)
DUN_Array(i) = Left$(conname, InStr(conname, _
vbNullChar) - 1)
'RasGetEntryDialParams
Next i
End Sub
Function VBRasGetEntryDialParams _
(bytesOut() As Byte, _
strPhonebook As String, strEntryName As String, _
Optional blnPasswordRetrieved As Boolean) As Long
Dim rtn As Long
Dim blnPsswrd As Long
Dim bLens As Variant
Dim lngLen As Long, i As Long
bLens = Array(1060&, 1052&, 816&)
'try our three different sizes for RasDialParams
'eatch OS version has is own structure size
For i = 0 To 2
lngLen = bLens(i)
ReDim bytesOut(lngLen - 1)
CopyMemory bytesOut(0), lngLen, 4
If lngLen = 816& Then
CopyStringToByte bytesOut(4), strEntryName, 20
Else
CopyStringToByte bytesOut(4), strEntryName, 256
End If
rtn = RasGetEntryDialParams(strPhonebook, bytesOut(0), blnPsswrd)
If rtn = 0 Then Exit For
Next i
blnPasswordRetrieved = blnPsswrd
VBRasGetEntryDialParams = rtn
End Function
یه سوال دیگه هم دارم.
ما یه پیکچر باکس رو فرم داریم که یه عکس توشه . چه طور میشه فقط یه قسمت از عکس توش رو به داخل یه پیکچر باکس دیگه فرستاد .