Интересные функции

[MMX//ALEX]

Первой фишкой пусть будет эта:

Private Sub LightOrDark(ByVal fraction As Single)
Dim r As Integer, g As Integer, b As Integer
Dim X As Integer, Y As Integer, clr As Long
MyPic.ScaleMode = vbPixels
For Y = 0 To MyPic.ScaleHeight
For X = 0 To MyPic.ScaleWidth
' Получить цвет
clr = MyPic.Point(X, Y)
r = clr Mod 256
g = (clr \ 256) Mod 256
b = clr \ 256 \ 256
' Уменьшить/увеличить яркость
r = r * fraction
g = g * fraction
b = b * fraction
' Иногда бывает < 0
If r < 0 Then r = 0
If g < 0 Then g = 0
If b < 0 Then b = 0
' Hарисовать пиксель
MyPic.PSet (X, Y), RGB(r, g, b)
Next X
DoEvents
Next Y
End Sub

это еще не все.
Я буду дописывать дальше...

[Лёха_Virus]

клёва! давай ещё!

[MMX//ALEX]

Без проблем.
Вот этот код будет отключать и подключать сетевые диски.

Это в модуль:

Option Explicit
Public Declare Function WNetAddConnection2 Lib "mpr.dll" Alias "WNetAddConnection2A" (lpNetResource As NETRESOURCE, ByVal lpPassword As String, ByVal lpUsername As String, ByVal dwFlags As Long) As Long
Public Declare Function WNetCancelConnection2 Lib "mpr.dll" Alias "WNetCancelConnection2A" (ByVal lpName As String, ByVal dwFlags As Long, ByVal fForce As Long) As Long

Public ErrorNum As Long
Public ErrorMsg As String
Public rc As Long
Public RemoteName As String

Public Const ERROR_BAD_DEV_TYPE = 66&
Public Const ERROR_ALREADY_ASSIGNED = 85&
Public Const ERROR_ACCESS_DENIED = 5&
Public Const ERROR_BAD_NET_NAME = 67&
Public Const ERROR_BAD_PROFILE = 1206&
Public Const ERROR_BAD_PROVIDER = 1204&
Public Const ERROR_BUSY = 170&
Public Const ERROR_CANCEL_VIOLATION = 173&
Public Const ERROR_CANNOT_OPEN_PROFILE = 1205&
Public Const ERROR_DEVICE_ALREADY_REMEMBERED = 1202&
Public Const ERROR_EXTENDED_ERROR = 1208&
Public Const ERROR_INVALID_PASSWORD = 86&
Public Const ERROR_NO_NET_OR_BAD_PATH = 1203&
Public Const ERROR_NO_NETWORK = 1222&
Public Const ERROR_NO_CONNECTION = 8
Public Const ERROR_NO_DISCONNECT = 9
Public Const ERROR_DEVICE_IN_USE = 2404&
Public Const ERROR_NOT_CONNECTED = 2250&
Public Const ERROR_OPEN_FILES = 2401&
Public Const ERROR_MORE_DATA = 234

Public Const CONNECT_UPDATE_PROFILE = &H1
Public Const RESOURCETYPE_DISK = &H1

Public Type NETRESOURCE
dwScope As Long
dwType As Long
dwDisplayType As Long
dwUsage As Long
lpLocalName As String
lpRemoteName As String
lpComment As String
lpProvider As String
End Type

Public lpNetResourse As NETRESOURCE

Public Sub Connect(ByVal HostName As String, ByVal RemoteName As String, ByVal Username As String, ByVal Password As String)
Dim lpUsername As String
Dim lpPassword As String
On Error GoTo Err_Connect
ErrorNum = 0
ErrorMsg = ""
lpNetResourse.dwType = RESOURCETYPE_DISK
lpNetResourse.lpLocalName = RemoteName & Chr(0)
'Drive Letter to use
lpNetResourse.lpRemoteName = "\\" & HostName & Chr(0)
'Network Path to share
lpNetResourse.lpProvider = Chr(0)
lpPassword = Password & Chr(0)
'password on share pass "" if none
lpUsername = Username & Chr(0)
'username to connect as if applicable
rc = WNetAddConnection2(lpNetResourse, lpPassword, lpUsername, CONNECT_UPDATE_PROFILE)
If rc <> 0 Then GoTo Err_Connect
Exit Sub
Err_Connect:
ErrorNum = rc
ErrorMsg = WnetError(rc)
End Sub

Public Sub DisConnect(ByVal Name As String, ByVal ForceOff As Boolean)
On Error GoTo Err_DisConnect
ErrorNum = 0
ErrorMsg = ""
rc = WNetCancelConnection2(Name & Chr(0), CONNECT_UPDATE_PROFILE, ForceOff)
If rc <> 0 Then GoTo Err_DisConnect
Exit Sub
Err_DisConnect:
ErrorNum = rc
ErrorMsg = WnetError(rc)
End Sub

Private Function WnetError(Errcode As Long) As String
Select Case Errcode
Case ERROR_BAD_DEV_TYPE
WnetError = "Bad device."
Case ERROR_ALREADY_ASSIGNED
WnetError = "Already Assigned."
Case ERROR_ACCESS_DENIED
WnetError = "Access Denied."
Case ERROR_BAD_NET_NAME
WnetError = "Bad net name"
Case ERROR_BAD_PROFILE
WnetError = "Bad Profile"
Case ERROR_BAD_PROVIDER
WnetError = "Bad Provider"
Case ERROR_BUSY
WnetError = "Busy"
Case ERROR_CANCEL_VIOLATION
WnetError = "Cancel Violation"
Case ERROR_CANNOT_OPEN_PROFILE
WnetError = "Cannot Open Profile"
Case ERROR_DEVICE_ALREADY_REMEMBERED
WnetError = "Device already remembered"
Case ERROR_EXTENDED_ERROR
WnetError = "Device already remembered"
Case ERROR_INVALID_PASSWORD
WnetError = "Invalid Password"
Case ERROR_NO_NET_OR_BAD_PATH
WnetError = "Could not find the specified device"
Case ERROR_NO_NETWORK
WnetError = "No Network Present"
Case ERROR_DEVICE_IN_USE
WnetError = "Connection Currently in use "
Case ERROR_NOT_CONNECTED
WnetError = "No Connection Present"
Case ERROR_OPEN_FILES
WnetError = "Files open and the force parameter is false"
Case ERROR_MORE_DATA
WnetError = "Buffer to small to hold network name, make lpnLength bigger"
Case Else:
WnetError = "Unrecognized Error " + Str(Errcode) + "."
End Select
End Function

А вот это на форму:

Private Sub Command1_Click()
Call Module1.Connect("Oksana\c$", "K:", "defaultsharename", "garik")
If (Module1.rc <> 0) And (Module1.rc <> 85) Then
MsgBox Module1.ErrorMsg
End If
End Sub

Private Sub Command2_Click()
Call Module1.DisConnect("K:", True)
If (Module1.rc <> 0) And (Module1.rc <> 85) Then
MsgBox Module1.ErrorMsg
End If
End Sub

Ну вот и все.

[MMX//ALEX]

Если у вас в опциях корзины Windows не стоит галочка "Уничтожать файлы сразу после удаления", то данный пример удалит созданные вами файлы в корзину.

Private Type SHFILEOPSTRUCT
hwnd As Long
wFunc As Long
pFrom As String
pTo As String
fFlags As Integer
fAnyOperationsAborted As Long
hNameMappings As Long
lpszProgressTitle As Long
End Type
Private Declare Function SHFileOperation Lib "shell32.dll" Alias "SHFileOperationA" (lpFileOp As SHFILEOPSTRUCT) As Long
Private Const FO_DELETE = &H3
Private Const FOF_ALLOWUNDO = &H40
Private Const FOF_NOCONFIRMATION = &H10
Private Const FOF_SILENT = &H4

Sub SendFileToRecycleBin(FileName As String, Optional Confirm As Boolean = True, Optional Silent As Boolean = False)
Dim FileOp As SHFILEOPSTRUCT
With FileOp
.wFunc = FO_DELETE
.pFrom = FileName
.fFlags = FOF_ALLOWUNDO
If Not Confirm Then .fFlags = .fFlags + FOF_NOCONFIRMATION
If Silent Then .fFlags = .fFlags + FOF_SILENT
End With
SHFileOperation FileOp
End Sub

Private Sub Command1_Click()
SendFileToRecycleBin "C:\1.txt", False
SendFileToRecycleBin "C:\11.txt", True
End Sub

Private Sub Form_Load()
Dim FN As Integer
FN = FreeFile
Dim FName As String
FName = "C:\1.txt"
Open FName For Output As #FN
Print #FN, ""
Close #FN
FName = "C:\11.txt"
Open FName For Output As #FN
Print #FN, ""
Close #FN
End Sub

Ну вот и все.