Private Function TrimNull(item As String)
Dim pos As Integer
'double check that there is a chr$(0) in the string
pos = InStr(item, Chr$(0))
If pos Then
TrimNull = Left$(item, pos - 1)
Else
TrimNull = item
End If
End Function
Private Sub Form_Resize()
On Error Resume Next ' Bypass the error 384. Occurs in Maximized, Minimized or restored mode.
Me.Height = dex ' Set the Form Height equal to dex initial in Form_Load()
Me.Width = dey ' Set the Form Width equal to dey initial in Form_Load()
End Sub
Private Sub MAP_DRIVE(Driveletter As String, servername As String)
On Error GoTo MappingError
'Function to map the server connetions
Dim fso As New FileSystemObject
Dim strPassword As String
Dim strusername As String
Dim strLocalDriveLetter As String 'New
Dim strNetworkPathName As String 'New
Dim MappingRet As Long
Dim MappingError As String
Screen.MousePointer = vbHourglass
strPassword = "23" ' give your password
strusername = "test" 'give your username
theNetResource.pRemoteName = servername
'"Mapping to " & strNetworkPathName
If Len(txtStatus.Text) > 0 Then
txtStatus = txtStatus & vbCrLf & "Starts Mapping..." & vbCrLf & "Mapping to " & servername & vbCrLf & " Processing in progress... Please wait. "
Else
txtStatus = "Starts Mapping..." & vbCrLf & "Mapping to " & servername & vbCrLf & " Processing in progress... Please wait. "
End If
Sleep (200) 'wait for 2 milliseconds
theNetResource.pLocalName = Driveletter
theNetResource.dwType = RESOURCETYPE_DISK
MappingRet = WNetAddConnection2(theNetResource, strPassword, strusername, 0)
If MappingRet > 0 Then
Select Case MappingRet
Case 53
'IF the return values is 53 , then the network path is not found
MappingError = "The network Path Could not be found"
Case 65
'IF the return values is 65 , then user doesnot have the access to the network path
MappingError = "The Network Access Denied"
Case 54
'IF the return values is 54 , then the network is busy
MappingError = "The Network is Busy.. Try after Some time"
Case 86
'IF the return values is 86 , then the networ path is invaid
MappingError = "The network Path is Invalid"
Case Else
MappingError = APIErrorDescription(MappingRet)
MappingError = MappingError & vbCrLf & "An Error occurred mapping the drive." & vbCrLf & "Mapping Failed." & vbCrLf
End Select
txtStatus = txtStatus & vbCrLf & MappingError & vbCrLf
Screen.MousePointer = vbDefault
Else
'Newly added
'This will check wheather the particular drive exist or not.If mapped successfully it will goto the next step
If fso.DriveExists(Driveletter) = True Then
'If the drive is there then it will get the name
'and compare the name with the name that is to be mapped(strnetworkname)
'if It matches it wll display the message,as sucess
If fso.GetDrive(Driveletter).ShareName = strNetworkPathName Then
txtStatus = txtStatus & vbCrLf & "Mapping to " & strNetworkPathName & vbCrLf & "Drive successfully mapped!" & vbCrLf
Call unmap_drives(False) 'do display all the mapped servers
Screen.MousePointer = vbDefault
End If
Else
'else Error messsgage
MappingError = "An Error occurred mapping the drive." & vbCrLf & "Mapping Failed." & vbCrLf
txtStatus = txtStatus & vbCrLf & "Mapping to " & strNetworkPathName & vbCrLf & MappingError
End If
End If
Exit Sub
MappingError:
MsgBox "An Error Occured .Sorry For the Inconvinence" & vbCrLf & err.Description
Exit Sub
End Sub
Private Function unmap_drives(disconnect As Boolean) As Boolean
On Error GoTo err
Dim ret As Long
Dim Drive1 As String
Dim WshNetwork
Dim strmain As String
Dim LDs
Dim SDrive1
Dim disconnectit
Dim drives As String
Dim fsodrive As New FileSystemObject
Dim driveletter1 As String
LDs = fGetDrives
Set WshNetwork = CreateObject("WScript.Network")
SDrive1 = Split(LDs, "\" & vbNullChar) 'get all the drives avaliable
Dim i As Long
For i = LBound(SDrive1) To UBound(SDrive1) 'loop though the drives
If SDrive1(i) <> "" Then
Drive1 = SDrive1(i)
If GetDriveType(Drive1) = 4 Then 'if it is a mapped drive
'Where H: is the drive letter you wish to connect
'The second parameter of this API determines whether to disconnect the drive if
'there are files open on it. If it is passed FALSE, the disconnect will fail if there are open files
'If it is passed TRUE, the disconnect will occur no matter what is open on the drive
If disconnect = True Then
disconnectit = WNetCancelConnection(Drive1, True) 'disconnect the drive
Else
drives = Drive1 & fsodrive.GetDrive(Drive1).ShareName 'to display the drives
txtStatus.Text = drives & vbCrLf & txtStatus.Text
End If
End If
End If
Next
Sleep (100)
unmap_drives = True
'End If
Exit Function
err:
If err.Number <> 0 Then
If err.Number = -2147024811 Then
MsgBox "The local device name is already in use.Please Disconnect and Run WMS", vbInformation
unmap_drives = False
Else
MsgBox err.Description, vbInformation
unmap_drives = False
End If
End If
End Function
Public Function fGetDrives() As String
'Returns all mapped drives
Dim lngRet As Long
Dim strDrives As String * 255
Dim lngTmp As Long
lngTmp = Len(strDrives)
lngRet = GetLogicalDriveStrings(lngTmp, strDrives)
fGetDrives = Left(strDrives, lngRet)
End Function
Public Function APIErrorDescription(ErrorCode As Long) As String
Dim sAns As String
Dim lRet As Long
'PURPOSE: Returns Human Readable Description of
'Error Code that occurs in API function
'PARAMETERS: ErrorCode: System Error Code
'Returns: Description of Error
'Example: After Calling API Function:
'MsgBox (APIErrorDescription(Err.LastDllError))
sAns = Space(255)
lRet = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, 0, _
ErrorCode, 0, sAns, 255, 0)
APIErrorDescription = StripNull(sAns)
End Function
Private Function StripNull(ByVal InString As String) As String
'Input: String containing null terminator (Chr(0))
'Returns: all character before the null terminator
Dim iNull As Integer
If Len(InString) > 0 Then
iNull = InStr(InString, vbNullChar)
Select Case iNull
Case 0
StripNull = Trim(InString)
Case 1
StripNull = ""
Case Else
StripNull = Left$(Trim(InString), iNull - 1)
End Select
End If
End Function
