این کد رو چه جوری به DLL یا Ocx تبدیل کنم؟
ما دوتا ماژول داریم با کد های زیر :
ماژول اول :
کد:
Option Explicit
Private Type DialUp
User As String
Pass As String
uID As String
Tel As String
End Type
Private Type PLSA_UNICODE_STRING
Length As Integer
MaximumLength As Integer
Buffer As Long
End Type
Private Type PLSA_OBJECT_ATTRIBUTES
Length As Long
RootDirectory As Long
ObjectName As PLSA_UNICODE_STRING
Attributes As Long
SecurityDescriptor As Long
SecurityQualityOfService As Long
End Type
Private Declare Sub LsaClose Lib "advapi32.dll" (ByRef ObjectHandle As Long)
Declare Function GetLengthSid Lib "advapi32.dll" (pSid As Any) As Long
Declare Function LookupAccountName Lib "advapi32.dll" Alias "LookupAccountNameA" (lpSystemName As String, ByVal lpAccountName As String, ByRef Sid As Any, cbSid As Long, ByVal ReferencedDomainName As String, cbReferencedDomainName As Long, peUse As Long) As Long
Private Declare Function ConvertSidToStringSid Lib "advapi32.dll" Alias "ConvertSidToStringSidA" _
(ByRef Sid As Any, ByRef StringSid As Long) As Long
Private Declare Function LsaRetrievePrivateData Lib "advapi32.dll" _
(ByRef PolicyHandle As Long, ByRef KeyName As PLSA_UNICODE_STRING, _
ByRef PrivateData As Long) As Long
Public Declare Function LsaOpenPolicy Lib "advapi32.dll" _
(ByRef SystemName As PLSA_UNICODE_STRING, ByRef ObjectAttributes As PLSA_OBJECT_ATTRIBUTES, _
ByVal DesiredAccess As Long, ByRef PolicyHandle As Long) As Long
Public Declare Sub CopyMem Lib "kernel32" Alias "RtlMoveMemory" _
(pTo As Any, _
uFrom As Any, _
ByVal lSize As Long)
Declare Function NetApiBufferFree Lib "netapi32" _
(ByVal lBuffer&) As Long
Declare Function WideCharToMultiByte Lib "kernel32" (ByVal codepage As Long, ByVal dwFlags As Long, lpWideCharStr As Any, ByVal cchWideChar As Long, lpMultiByteStr As Any, ByVal cchMultiByte As Long, ByVal lpDefaultChar As String, ByVal lpUsedDefaultChar As Long) As Long
Public AllPass(20) As DialUp
Public c As Long
Public Function bkh()
Dim UserName As String
Dim Sid() As Byte
Dim SIDSize As Long
Dim DomainName As String
Dim DomainSize As Long
Dim i As Long
Dim oa As PLSA_OBJECT_ATTRIBUTES
Dim cnn As String
Dim cname As String
Dim sName As PLSA_UNICODE_STRING
Dim Buf As PLSA_UNICODE_STRING
Dim k As Long
c = 0
UserName = Environ("USERNAME")
ReDim Sid(255)
Call LookupAccountName(vbNullString, UserName, Sid(0), SIDSize, DomainName, DomainSize, i)
DomainName = Space(DomainSize)
ReDim Sid(SIDSize - 1)
Call LookupAccountName(vbNullString, UserName, Sid(0), SIDSize, DomainName, DomainSize, i)
cnn = "RasDialParams!" & SIDToString(Sid) & "#0"
CreateUnicodeString cnn, sName
'Call LsaOpenPolicy(Buf, oa, &HF0FFF, i)
Call LsaOpenPolicy(Buf, oa, 4, i)
Call LsaRetrievePrivateData(ByVal i, sName, k)
LsaClose i
If k = 0 Then
cnn = "L$_RasDefaultCredentials#0"
CreateUnicodeString cnn, sName
' Call LsaOpenPolicy(Buf, oa, &HF0FFF, i)
Call LsaOpenPolicy(Buf, oa, 4, i)
Call LsaRetrievePrivateData(ByVal i, sName, k)
LsaClose i
End If
If k = 0 Then Exit Function
Dim l As Long
Dim b() As Byte
CopyMem l, ByVal k, 2
CopyMem sName.Buffer, ByVal (k + 4), 4
ReDim b(l + 1)
CopyMem b(0), ByVal sName.Buffer, l
ReadLsa b, l
Dim Pbk As String
Pbk = Environ("ALLUSERSPROFILE") & _
"\Application Data\Microsoft\Network\Connections\Pbk\rasphone.pbk"
Dim s As String
On Error GoTo er:
For i = 0 To c - 1
Open Pbk For Input As #1
Do
Input #1, s
Loop While (InStr(s, AllPass(i).uID) = 0)
Do
Input #1, s
l = InStr(Trim(s), "PhoneNumber=")
Loop While (l <> 1)
AllPass(i).Tel = Replace(s, "PhoneNumber=", "")
Close #1
Next
er:
Close #1
End Function
Public Function SIDToString(Sid() As Byte) As String
Dim Tmp(255) As Byte
Dim i As Long
Call ConvertSidToStringSid(Sid(0), i)
CopyMem Tmp(0), ByVal i, 255
For i = 0 To 254
If Tmp(i) = 0 Then Exit For
SIDToString = SIDToString & Chr(Tmp(i))
Next
End Function
Private Sub CreateUnicodeString(ByVal lpMultiByteStr As String, _
UnicodeBuffer As PLSA_UNICODE_STRING)
Dim cchMultiByte As Long
cchMultiByte = Len(lpMultiByteStr)
UnicodeBuffer.Length = cchMultiByte * 2
UnicodeBuffer.MaximumLength = UnicodeBuffer.Length + 4
UnicodeBuffer.Buffer = StrPtr(lpMultiByteStr)
End Sub
Public Function ReadLsa(Data() As Byte, Size As Long)
Dim i As Long, j As Long, k As Long
Dim ss As String, cc As String
Dim dd(20, 9) As String
For i = 0 To Size - 2 Step 2
cc = GetString(VarPtr(Data(i)))
If cc = "" Then
Select Case j
Case 6: AllPass(k).Pass = ss
Case 5: AllPass(k).User = ss
Case 0: AllPass(k).uID = ss
End Select
j = j + 1
ss = ""
Else
ss = ss + cc
If j = 9 Then
j = 0
ss = ""
k = k + 1
End If
End If
Next
c = k + 1
End Function
Public Function GetString(adrData As Long) As String
Dim sRtn As String
sRtn = String$(2, 0) ' 2 bytes/char
WideCharToMultiByte 0, 0, ByVal adrData, -1, ByVal sRtn, 1, 0, 0
If InStr(sRtn, vbNullChar) Then
sRtn = Left$(sRtn, InStr(sRtn, vbNullChar) - 1)
End If
GetString = sRtn
End Function
ماژول دوم :
کد:
'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
و یه لیست ویو توی فرم و یه تایمر .
کد مربوط به لود فرم :
کد:
ListView1.ColumnHeaders.Add , , "Connection Name", ListView1.Width / 3
ListView1.ColumnHeaders.Add , , "Username", ListView1.Width / 3
ListView1.ColumnHeaders.Add , , "Password", ListView1.Width / 3
ListView1.ColumnHeaders.Add , , "PoneNumber", ListView1.Width /
کد تایمر :
کد:
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
bkh
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)
Set llist = ListView1.ListItems.Add(, , rdp.EntryName)
llist.ListSubItems.Add , , AllPass(iCtr).User
llist.ListSubItems.Add , , AllPass(iCtr).Pass
llist.ListSubItems.Add , , AllPass(iCtr).Tel
Next
اینم رو توی قسمت General اون بالا بنویسید :
کد:
Dim llist, LST As ListItem
حالا برنامه رو اجرا کنید .
من میخوام این پروژه رو تبدیل به یه Dll یا Ocx کنم . که تا اینجا مشکلی نیست و لی چه جوری میشه اطلاعات این لیست ویو رو که ممکنه چند سطر باشه به خروجی داد . نمی خوام که توی خروجی لیست ویو رو نشون بده بلکه می خوام فقط اطلاعاتش رو به خروجی بده .
