home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Source Code / Visual Basic Source Code.iso / vbsource / automa_1 / srvmod.bas < prev    next >
Encoding:
BASIC Source File  |  1999-08-23  |  9.7 KB  |  269 lines
  1. Attribute VB_Name = "srvMod"
  2. Declare Function mciGetErrorString Lib "winmm.dll" Alias "mciGetErrorStringA" (ByVal dwError As Long, ByVal lpstrBuffer As String, ByVal uLength As Long) As Long
  3. Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long
  4.  
  5. Declare Function MakeSureDirectoryPathExists Lib "IMAGEHLP.DLL" (ByVal DirPath As String) As Long
  6.  
  7. #If Win16 Then
  8.  
  9.  
  10. Declare Function SendMessage Lib "User" (ByVal hWnd As Integer, ByVal wMsg As Integer, ByVal wParam As Integer, lParam As Any) As Long
  11. #Else
  12.  
  13.  
  14. Declare Function SendMessage Lib "User32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
  15. #End If
  16. Public Declare Function SystemParametersInfo Lib "User32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByVal lpvParam As String, ByVal fuWinIni As Long) As Long
  17.  
  18.  
  19. Declare Function SetCursorPos Lib "User32" (ByVal x As Long, ByVal y As Long) As Long
  20.  
  21. Private Declare Function WNetAddConnection Lib "mpr.dll" Alias "WNetAddConnectionA" (ByVal lpszNetPath As String, ByVal lpszPassword As String, ByVal lpszLocalName As String) As Long
  22.  
  23.  
  24. Private Declare Function WNetGetConnection Lib "mpr.dll" Alias "WNetGetConnectionA" (ByVal lpszLocalName As String, ByVal lpszRemoteName As String, cbRemoteName As Long) As Long
  25.  
  26.  
  27. Private Declare Function WNetCancelConnection Lib "mpr.dll" Alias "WNetCancelConnectionA" (ByVal lpszName As String, ByVal bForce As Long) As Long
  28.  
  29.  
  30. Private Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
  31.     Private Const ERROR_ACCESS_DENIED = 5&
  32.     Private Const ERROR_ALREADY_ASSIGNED = 85&
  33.     Private Const ERROR_BAD_DEVICE = 1200&
  34.     Private Const ERROR_BAD_NET_NAME = 67&
  35.     Private Const ERROR_INVALID_PASSWORD = 86&
  36.     Private Const ERROR_INVALID_ADDRESS = 487&
  37.     Private Const ERROR_INVALID_PARAMETER = 87
  38.     Private Const ERROR_MORE_DATA = 234
  39.     Private Const ERROR_UNEXP_NET_ERR = 59&
  40.     Private Const ERROR_NOT_CONNECTED = 2250&
  41.     Private Const ERROR_NOT_SUPPORTED = 50&
  42.     Private Const ERROR_OPEN_FILES = 2401&
  43.     Private Const ERROR_NOT_ENOUGH_MEMORY = 8
  44.     Private Const NO_ERROR = 0
  45.     
  46.     Private Const WN_ACCESS_DENIED = ERROR_ACCESS_DENIED
  47.     Private Const WN_ALREADY_CONNECTED = ERROR_ALREADY_ASSIGNED
  48.     Private Const WN_BAD_LOCALNAME = ERROR_BAD_DEVICE
  49.     Private Const WN_BAD_NETNAME = ERROR_BAD_NET_NAME
  50.     Private Const WN_BAD_PASSWORD = ERROR_INVALID_PASSWORD
  51.     Private Const WN_BAD_POINTER = ERROR_INVALID_ADDRESS
  52.     Private Const WN_BAD_VALUE = ERROR_INVALID_PARAMETER
  53.     Private Const WN_MORE_DATA = ERROR_MORE_DATA
  54.     Private Const WN_NET_ERROR = ERROR_UNEXP_NET_ERR
  55.     Private Const WN_NOT_CONNECTED = ERROR_NOT_CONNECTED
  56.     Private Const WN_NOT_SUPPORTED = ERROR_NOT_SUPPORTED
  57.     Private Const WN_OPEN_FILES = ERROR_OPEN_FILES
  58.     Private Const WN_OUT_OF_MEMORY = ERROR_NOT_ENOUGH_MEMORY
  59.     Private Const WN_SUCCESS = NO_ERROR
  60.  
  61.  
  62. Function GetUNCPath(DriveLetter As String, DrivePath, ErrorMsg As String) As Long
  63.     On Local Error GoTo GetUNCPath_Err
  64.     Dim status As Long
  65.     Dim lpszLocalName As String
  66.     Dim lpszRemoteName As String
  67.     Dim cbRemoteName As Long
  68.     lpszLocalName = DriveLetter
  69.     If Right$(lpszLocalName, 1) <> Chr$(0) Then lpszLocalName = lpszLocalName & Chr$(0)
  70.     lpszRemoteName = String$(255, Chr$(32))
  71.     cbRemoteName = Len(lpszRemoteName)
  72.     status = WNetGetConnection(lpszLocalName, _
  73.     lpszRemoteName, _
  74.     cbRemoteName)
  75.     
  76.     GetUNCPath = status
  77.  
  78.  
  79.     Select Case status
  80.         Case WN_SUCCESS
  81.         ' all is successful...
  82.         Case WN_NOT_SUPPORTED
  83.         ErrorMsg = "This Function is not supported"
  84.         Case WN_OUT_OF_MEMORY
  85.         ErrorMsg = "The System is Out of Memory."
  86.         Case WN_NET_ERROR
  87.         ErrorMsg = "An error occurred On the network"
  88.         Case WN_BAD_POINTER
  89.         ErrorMsg = "The network path is invalid"
  90.         Case WN_BAD_VALUE
  91.         ErrorMsg = "Invalid local device name"
  92.         Case WN_NOT_CONNECTED
  93.         ErrorMsg = "The drive is not connected"
  94.         Case WN_MORE_DATA
  95.         ErrorMsg = "The buffer was too small to return the fileservice name"
  96.         Case Else
  97.         ErrorMsg = "Unrecognized Error - " & Str$(status) & "."
  98.     End Select
  99.  
  100.  
  101.  
  102. If Len(ErrorMsg) Then
  103.     DrivePath = ""
  104. Else
  105.     ' Trim it, and remove any nulls
  106.     DrivePath = StripNulls(lpszRemoteName)
  107. End If
  108.  
  109. GetUNCPath_End:
  110. Exit Function
  111. GetUNCPath_Err:
  112. MsgBox Err.Description, vbInformation
  113. Resume GetUNCPath_End
  114. End Function
  115.  
  116. '----------------------------------------------------------------
  117. '     -----------------------------------
  118. ' GetUserName routine
  119. '----------------------------------------------------------------
  120. '     -----------------------------------
  121.  
  122.  
  123. Function sGetUserName() As String
  124.  
  125.     Dim lpBuffer As String * 255
  126.     Dim lRet As Long
  127.     lRet = GetUserName(lpBuffer, 255)
  128.     sGetUserName = StripNulls(lpBuffer)
  129. End Function
  130.  
  131. '----------------------------------------------------------------
  132. '     -----------------------------------
  133. ' StripNulls routine
  134. '----------------------------------------------------------------
  135. '     -----------------------------------
  136.  
  137.  
  138. Private Function StripNulls(s As String) As String
  139.  
  140.     'Truncates string at first null character, any text after first n
  141.     '     ull is lost
  142.     Dim I As Integer
  143.     StripNulls = s
  144.  
  145.  
  146.     If Len(s) Then
  147.         I = InStr(s, Chr$(0))
  148.         If I Then StripNulls = Left$(s, I - 1)
  149.     End If
  150.  
  151. End Function
  152.  
  153. '----------------------------------------------------------------
  154. '     -----------------------------------
  155. ' MapNetworkDrive routine
  156. '----------------------------------------------------------------
  157. '     -----------------------------------
  158.  
  159.  
  160. Function MapNetworkDrive(UNCname As String, _
  161.     Password As String, _
  162.     DriveLetter As String, _
  163.     ErrorMsg As String) As Long
  164.     
  165.     Dim status As Long
  166.     Dim tUNCname As String, tPassword As String, tDriveLetter As String
  167.     On Local Error GoTo MapNetworkDrive_Err
  168.     tUNCname = UNCname
  169.     tPassword = Password
  170.     tDriveLetter = DriveLetter
  171.     If Right$(tUNCname, 1) <> Chr$(0) Then tUNCname = tUNCname & Chr$(0)
  172.     If Right$(tPassword, 1) <> Chr$(0) Then tPassword = tPassword & Chr$(0)
  173.     If Right$(tDriveLetter, 1) <> Chr$(0) Then tDriveLetter = tDriveLetter & Chr$(0)
  174.     status = WNetAddConnection(tUNCname, tPassword, tDriveLetter)
  175.  
  176.  
  177.     Select Case status
  178.         Case WN_SUCCESS
  179.         ErrorMsg = ""
  180.         Case WN_NOT_SUPPORTED
  181.         ErrorMsg = "Function is not supported."
  182.         Case WN_OUT_OF_MEMORY:
  183.         ErrorMsg = "The system is out of memory."
  184.         Case WN_NET_ERROR
  185.         ErrorMsg = "An error occurred On the network."
  186.         Case WN_BAD_POINTER
  187.         ErrorMsg = "The network path is invalid."
  188.         Case WN_BAD_NETNAME
  189.         ErrorMsg = "Invalid network resource name."
  190.         Case WN_BAD_PASSWORD
  191.         ErrorMsg = "The password is invalid."
  192.         Case WN_BAD_LOCALNAME
  193.         ErrorMsg = "The local device name is invalid."
  194.         Case WN_ACCESS_DENIED
  195.         ErrorMsg = "A security violation occurred."
  196.         Case WN_ALREADY_CONNECTED
  197.         ErrorMsg = "This drive letter is already connected to a network drive."
  198.         Case Else
  199.         ErrorMsg = "Unrecognized Error - " & Str$(status) & "."
  200.     End Select
  201.  
  202. MapNetworkDrive = status
  203. MapNetworkDrive_End:
  204. Exit Function
  205. MapNetworkDrive_Err:
  206. MsgBox Err.Description, vbInformation
  207. Resume MapNetworkDrive_End
  208. End Function
  209.  
  210. '----------------------------------------------------------------
  211. '     -----------------------------------
  212. ' DisconnectNetworkDrive routine
  213. '----------------------------------------------------------------
  214. '     -----------------------------------
  215.  
  216.  
  217. Function DisconnectNetworkDrive(DriveLetter As String, ForceFileClose As Long, ErrorMsg As String) As Long
  218.         
  219.         Dim status As Long
  220.         Dim tDriveLetter As String
  221.         On Local Error GoTo DisconnectNetworkDrive_Err
  222.         tDriveLetter = DriveLetter
  223.         If Right$(tDriveLetter, 1) <> Chr$(0) Then tDriveLetter = tDriveLetter & Chr$(0)
  224.         status = WNetCancelConnection(tDriveLetter, ForceFileClose)
  225.  
  226.  
  227.         Select Case status
  228.             Case WN_SUCCESS
  229.             ErrorMsg = ""
  230.             Case WN_BAD_POINTER:
  231.             ErrorMsg = "The network path is invalid."
  232.             Case WN_BAD_VALUE
  233.             ErrorMsg = "Invalid local device name"
  234.             Case WN_NET_ERROR:
  235.             ErrorMsg = "An error occurred On the network."
  236.             Case WN_NOT_CONNECTED
  237.             ErrorMsg = "The drive is not connected"
  238.             Case WN_NOT_SUPPORTED
  239.             ErrorMsg = "This Function is not supported"
  240.             Case WN_OPEN_FILES
  241.             ErrorMsg = "Files are in use On this service. Drive was not disconnected."
  242.             Case WN_OUT_OF_MEMORY:
  243.             ErrorMsg = "The System is Out of Memory"
  244.             Case Else:
  245.             ErrorMsg = "Unrecognized Error - " & Str$(status) & "."
  246.         End Select
  247.  
  248.     DisconnectNetworkDrive = status
  249. DisconnectNetworkDrive_End:
  250.     Exit Function
  251. DisconnectNetworkDrive_Err:
  252.     MsgBox Err.Description, vbInformation
  253.     Resume DisconnectNetworkDrive_End
  254. End Function
  255.  
  256. Sub TurnOnScrnSvr()
  257.  
  258.  
  259.     Dim lResult As Long
  260.     Const WM_SYSCOMMAND = &H112
  261.     Const SC_SCREENSAVE = &HF140
  262.     ' send this message to all the top level windows
  263.     ' one of them will start a screen saver...
  264.     lResult = SendMessage(-1, WM_SYSCOMMAND, SC_SCREENSAVE, 0&)
  265. End Sub
  266.                             
  267.  
  268.  
  269.