|
Mostrar Temas
|
Páginas: [1]
|
1
|
Programación / Programación Visual Basic / formularios MDI
|
en: 4 Febrero 2006, 17:56 pm
|
alguien sabe como agregar muchos formularios MDI en un solo proyecto? trate de agregarlos en tiempo real pero no funciona con el clasico> set m = new mdiform1
alguna idea? se los agradecere de alguna manera.
Salu2.
|
|
|
2
|
Programación / Programación Visual Basic / File System Object Class (Con Apis) open source
|
en: 1 Octubre 2005, 01:09 am
|
Crea una clase nueva y ponle de nombre FsoClass. Pega el siguiente codigo en ella: '****File System Object Class***** ' Coded by Nemlim (I return!) '********************************* ' Please not remove this header ' Contribute with the Open Source ' www.gedzac.com ' www.hispavirus.com.ar ' 21 September 2005 = Spring
Option Explicit Private Type SECURITY_ATTRIBUTES nLength As Long lpSecurityDescriptor As Long bInheritHandle As Long End Type Private Type SHFILEOPSTRUCT hWnd As Long wFunc As Long pFrom As String pTo As String fFlags As Integer fAborted As Boolean hNameMaps As Long sProgress As String End Type Public Enum Method WriteMethod = &H40000000 ReadMethod = &H80000000 End Enum Public Enum DiskEnum [Removable] = 1 [Drive Fixed] = 2 [Remote] = 3 [Cd-Rom] = 4 [Ram disk] = 5 [Unrecognized] = 6 End Enum Public Enum SpecialFolderConst SystemFolder = 1 TemporaryFolder = 2 WindowsFolder = 0 End Enum Private Type FILETIME dwLowDateTime As Long dwHighDateTime As Long End Type Private Type WIN32_FIND_DATA dwFileAttributes As Long ftCreationTime As FILETIME ftLastAccessTime As FILETIME ftLastWriteTime As FILETIME nFileSizeHigh As Long nFileSizeLow As Long dwReserved0 As Long dwReserved1 As Long cFileName As String * 260 cAlternate As String * 14 End Type Const FILE_BEGIN = 0 Const FILE_SHARE_READ = &H1 Const FILE_SHARE_WRITE = &H2 Const FO_DELETE = &H3 Const OF_READ = &H0& Const ERROR_NO_MORE_FILES = 18& Const INVALID_HANDLE_VALUE = -1 Const DDL_DIRECTORY = &H10 Const OPEN_ALWAYS = 4 Const OPEN_EXISTING = 3
Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long Private Declare Function GetLastError Lib "kernel32" () As Long Private Declare Function PathAppend Lib "shlwapi.dll" Alias "PathAppendA" (ByVal pszPath As String, ByVal pMore As String) As Long Private Declare Function WriteFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, ByVal lpOverlapped As Any) As Long Private Declare Function ReadFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, ByVal lpOverlapped As Any) As Long Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, ByVal lpSecurityAttributes As Any, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long Private Declare Function SetFilePointer Lib "kernel32" (ByVal hFile As Long, ByVal lDistanceToMove As Long, lpDistanceToMoveHigh As Long, ByVal dwMoveMethod As Long) As Long Private Declare Function APICopyFile Lib "kernel32" Alias "CopyFileA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String, ByVal bFailIfExists As Long) As Long Private Declare Function APICreateDirectory Lib "kernel32" Alias "CreateDirectoryA" (ByVal lpPathName As String, lpSecurityAttributes As SECURITY_ATTRIBUTES) As Long Private Declare Function APIDeleteFile Lib "kernel32" Alias "DeleteFileA" (ByVal lpFileName As String) As Long Private Declare Function APISHFileOperation Lib "shell32.dll" Alias "SHFileOperationA" (lpFileOp As SHFILEOPSTRUCT) As Long Private Declare Function APIPathFileExists Lib "shlwapi.dll" Alias "PathFileExistsA" (ByVal pszPath As String) As Long Private Declare Function APIPathIsDirectory Lib "shlwapi.dll" Alias "PathIsDirectoryA" (ByVal pszPath As String) As Long Private Declare Function APIlOpen Lib "kernel32" Alias "_lopen" (ByVal lpPathName As String, ByVal iReadWrite As Long) As Long Private Declare Function APIlclose Lib "kernel32" Alias "_lclose" (ByVal hFile As Long) As Long Private Declare Function APIGetFileSize Lib "kernel32" Alias "GetFileSize" (ByVal hFile As Long, lpFileSizeHigh As Long) As Long Private Declare Function APIGetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long Private Declare Function APIGetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long Private Declare Function APIGetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long Private Declare Function APIPathStripToRoot Lib "shlwapi.dll" Alias "PathStripToRootA" (ByVal pszPath As String) As Long Private Declare Function APIPathAddBackslash Lib "shlwapi.dll" Alias "PathAddBackslashA" (ByVal pszPath As String) As Long Private Declare Function APIGetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long Private Declare Function APIGetLogicalDrives Lib "kernel32" Alias "GetLogicalDrives" () As Long Private Declare Sub APIPathStripPath Lib "shlwapi.dll" Alias "PathStripPathA" (ByVal pszPath As String)
Public Function BuildPath(Path As String, name As String) Dim b As String b = Path & String(Len(name), 0) PathAppend b, name BuildPath = b End Function
Public Sub CopyFile(Source As String, Destination As String, Optional OverWriteFiles As Boolean = True) APICopyFile Source, Destination, OverWriteFiles End Sub
Public Sub CopyFolders(ByVal Source As String, ByVal Destination As String, Optional OverWriteFiles As Boolean = True) Dim ret As Long If GetAttr(Source) And vbDirectory Then Source = GetAbsolutePathName(Source) Destination = GetAbsolutePathName(Destination) Dim s As SECURITY_ATTRIBUTES ret = APICreateDirectory(Destination, s) SUBCopyFiles Source, Destination Else CopyFile Source, Destination End If End Sub
Public Function DriveExists(ByVal DriveSpec As String) As Boolean Select Case APIGetDriveType(DriveSpec) Case 2 DriveExists = True Case 3 DriveExists = True Case Is = 4 DriveExists = True Case Is = 5 DriveExists = True Case Is = 6 DriveExists = True Case Else DriveExists = False End Select End Function
Public Function DriverType(ByVal DriveSpec As String) As DiskEnum DriverType = APIGetDriveType(DriveSpec) - 1 End Function
Public Function GetAbsolutePathName(ByVal Path As String) As String Path = Path + String(100, 0) APIPathAddBackslash Path GetAbsolutePathName = StripTerminator(Path) End Function
Public Function GetExtensionName(ByVal Path As String) As String APIPathStripPath Path Path = StripTerminator(Path) If InStr(Path, ".") <> 0 Then Path = Mid(Path, CLng(InStrRev(Path, ".")) + 1) Else Path = "" End If GetExtensionName = Path End Function
Public Function CreateFolder(Path As String) Dim Security As SECURITY_ATTRIBUTES Dim ret As Long ret = APICreateDirectory(Path, Security) If ret = 0 Then MsgBox "Error : Couldn't create directory !", vbCritical + vbOKOnly End Function
Public Sub DeleteFile(FileSpec As String) APIDeleteFile FileSpec End Sub
Public Sub DeleteFolder(FileSpec As String) Dim SHDirOp As SHFILEOPSTRUCT With SHDirOp .wFunc = FO_DELETE .pFrom = FileSpec End With APISHFileOperation SHDirOp End Sub
Public Function FileExists(FileSpec As String) As Boolean FileExists = CBool(APIPathFileExists(FileSpec)) End Function
Public Function FolderExists(FolderSpec As String) As Boolean FolderExists = CBool(APIPathIsDirectory(FolderSpec)) End Function
Public Function GetBaseName(ByVal Path As String) As String APIPathStripPath Path Path = StripTerminator(Path) If InStr(Path, ".") <> 0 Then Path = Mid(Path, 1, CLng(InStrRev(Path, ".")) - 1) Else Path = "" End If GetBaseName = Path End Function
Public Function GetDriveName(ByVal Path As String) As String APIPathStripToRoot Path GetDriveName = StripTerminator(Path) End Function
Function GetFileName(ByVal Path As String) As String APIPathStripPath Path GetFileName = StripTerminator(Path) End Function
Public Function GetFileSize(Path As String) As Long Dim Pointer As Long, sizeofthefile As Long Pointer = APIlOpen(Path, OF_READ) sizeofthefile = APIGetFileSize(Pointer, 0) APIlclose Pointer GetFileSize = sizeofthefile End Function
Function GetSpecialFolder(SpecialFolder As SpecialFolderConst) As String Dim sSave As String, ret As Long sSave = Space(255) If SpecialFolder = SystemFolder Then ret = APIGetSystemDirectory(sSave, 255) sSave = Left$(sSave, ret) ElseIf SpecialFolder = WindowsFolder Then ret = APIGetWindowsDirectory(sSave, 255) sSave = Left$(sSave, ret) ElseIf SpecialFolder = TemporaryFolder Then ret = APIGetTempPath(255, sSave) sSave = Left$(sSave, ret) End If GetSpecialFolder = sSave End Function
Public Function OpenFileFor(FileName As String, forWhat As Method, Optional Create As Boolean = False) As Long Dim hNewFile As Long If Create Then OpenFileFor = CreateFile(FileName, forWhat, FILE_SHARE_READ Or FILE_SHARE_WRITE, ByVal 0&, 4, 0, 0) Else OpenFileFor = CreateFile(FileName, forWhat, FILE_SHARE_READ Or FILE_SHARE_WRITE, ByVal 0&, 3, 0, 0) End If SetFilePointer OpenFileFor, 0, 0, FILE_BEGIN If OpenFileFor <= 0 Then MsgBox "Error : Couldn't open file !", vbCritical + vbOKOnly Err.Raise 0, 0, "Couldn't open file !" End If End Function
Public Function WriteInFile(Handle As Long, data As String) Dim bBytes() As Byte Dim ret As Long If Handle > 0 Then bBytes = StrConv(data, vbFromUnicode) WriteFile Handle, bBytes(0), Len(data), ret, ByVal 0& 'If Ret <> UBound(bBytes) Then MsgBox "Error writing file ..." End If End Function
Public Function ReadInFile(Handle As Long) As String Dim bBytes() As Byte Dim ret As Long Dim nSize As Long If Handle > 0 Then nSize = APIGetFileSize(Handle, 0) ReDim bBytes(nSize) ReadFile Handle, bBytes(0), UBound(bBytes), ret, ByVal 0& ReadInFile = StrConv(bBytes, vbUnicode) End If End Function
Public Function CloseFile(Handle As Long) CloseHandle Handle End Function
'Example To Use: 'For Each strFile In ListFiles("C:\") ' MsgBox strFile 'Next Public Function ListFiles(ByVal Path As String, Optional WithSubDirectories As Boolean = True) As Collection Dim Dirs As Collection Dim Fils As Collection Dim Buff As Collection Dim fName As String Dim sHNL As Long Dim W32FD As WIN32_FIND_DATA Dim i As Integer Dim ii As Integer
Set Dirs = New Collection Set Fils = New Collection Path = GetAbsolutePathName(Path) sHNL = FindFirstFile(Path & "*.*", W32FD) If sHNL <> INVALID_HANDLE_VALUE Then Do fName = W32FD.cFileName fName = StripTerminator(fName) If fName <> "." And fName <> ".." Then If W32FD.dwFileAttributes And DDL_DIRECTORY Then Dirs.Add fName Else Fils.Add Path & fName End If End If If FindNextFile(sHNL, W32FD) = 0 Then Exit Do Loop FindClose sHNL End If
If WithSubDirectories Then For i = 1 To Dirs.Count fName = Dirs(i) Set Buff = ListFiles(Path & fName) For ii = 1 To Buff.Count Fils.Add Buff(ii) Next ii Next i End If Set ListFiles = Fils End Function
Public Function ListFolders(ByVal Path As String, Optional WithSubDirectories As Boolean = True) As Collection Dim Dirs As Collection Dim Buff As Collection Dim fName As String Dim sHNL As Long Dim W32FD As WIN32_FIND_DATA Dim i As Integer Dim u As Integer Dim ii As Integer
Set Dirs = New Collection Path = GetAbsolutePathName(Path) sHNL = FindFirstFile(Path & "*.*", W32FD) If sHNL <> INVALID_HANDLE_VALUE Then Do fName = W32FD.cFileName fName = StripTerminator(fName) If fName <> "." And fName <> ".." Then If W32FD.dwFileAttributes And DDL_DIRECTORY Then Dirs.Add fName End If End If If FindNextFile(sHNL, W32FD) = 0 Then Exit Do Loop FindClose sHNL End If
If WithSubDirectories Then u = Dirs.Count For i = 1 To u fName = Dirs(i) Set Buff = ListFolders(Path & fName) For ii = 1 To Buff.Count Dirs.Add Buff(ii) Next ii Next i End If Set ListFolders = Dirs End Function
Public Function ListDisks() As Collection Dim LDs As Long Dim Cnt As Integer Dim buf As New Collection LDs = APIGetLogicalDrives For Cnt = 0 To 25 If (LDs And 2 ^ Cnt) <> 0 Then buf.Add Chr$(65 + Cnt) & ":\" End If Next Cnt Set ListDisks = buf End Function
Private Function SUBCopyFiles(ByVal from_dir As String, ByVal to_dir As String) As Long Dim Dirs As Collection Dim fName As String Dim sHNL As Long Dim W32FD As WIN32_FIND_DATA Dim i As Integer
Set Dirs = New Collection sHNL = FindFirstFile(from_dir & "*.*", W32FD) If sHNL <> INVALID_HANDLE_VALUE Then Do fName = W32FD.cFileName fName = StripTerminator(fName) If fName <> "." And fName <> ".." Then If W32FD.dwFileAttributes And DDL_DIRECTORY Then Dim s As SECURITY_ATTRIBUTES Call APICreateDirectory(to_dir & fName, s) Dirs.Add fName Else CopyFile from_dir & fName, to_dir & fName End If End If If FindNextFile(sHNL, W32FD) = 0 Then Exit Do Loop FindClose sHNL End If
For i = 1 To Dirs.Count fName = Dirs(i) SUBCopyFiles from_dir & fName & "\", to_dir & fName & "\" Next i End Function
Private Function StripTerminator(sInput As String) As String Dim ZeroPos As Long ZeroPos = InStr(1, sInput, Chr$(0)) If ZeroPos > 0 Then StripTerminator = Left$(sInput, ZeroPos - 1) Else StripTerminator = sInput End If End Function
Modo de uso, y diferencias con el fso original: Para acceder a la clase hay que declararla como variable antes: Dim f As New FsoClass 'Antes de abrir un archivo, deberá comprobar que exista primero:If f.FileExists("C:\file.txt") Then handle = f.OpenFileFor("C:\file.txt", ReadMethod, False) datos = f.ReadInFile(handle) f.CloseFile handle End If 'Para listar los archivos de un directorio determinado:For Each strFile In f.ListFiles("C:\", False) MsgBox strFile Next 'Para listar las carpetas de un directorio determinado:For Each strFolder In f.ListFolders("C:\", False) MsgBox strFolder Next 'Para listar los discos y mostrar un msg del tipo de disco presente:For Each strDisk In f.ListDisks h = f.DriverType(Cstr(strDisk)) Select Case h Case 1 msgbox "Removable" Case 2 msgbox "Drive Fixed" Case 3 msgbox "Remote" Case 4 msgbox "Cd-Rom" Case 5 msgbox "RamDisk" End Select Next Las demás funciones se usan igual. Salu2 y espero les sirva.
|
|
|
4
|
Programación / Programación Visual Basic / Code: Listar los archivos de un directorio (subdirectorios incluidos)
|
en: 25 Agosto 2005, 01:31 am
|
2 Moneda) Muchas veces y por diversas razones que no vienen al tema, queremos listar todos los archivos de un directorio. Podemos utilizar el FSO, pero... ¿por que hacerlo si podemos hacerlo directamente desde el visual basic? Declaramos un array en la cabezera del formulario:Private direcs() As StringEn ese array se guardaran los archivos listados. Luego, la funcion: Function ListFiles(Path) 'On Error Resume Next Dim x() As String Dim a As Integer Dim sf As String Dim u As Integer If Right(Path, 1) <> "\" Then Path = Path & "\" ReDim x(a) sf = Dir(Path, vbHidden + vbArchive + vbReadOnly + vbSystem + vbNormal + vbDirectory) Do While Len(sf) <> 0 If sf <> "." And sf <> ".." Then sf = Path & sf If GetAttr(sf) And vbDirectory Then x(a) = sf ReDim Preserve x(a + 1) a = a + 1 Else u = UBound(direcs) ReDim Preserve direcs(u + 1) direcs(u) = sf End If End If sf = Dir() Loop
For a = 0 To UBound(x) If Len(x(a)) Then ListFiles x(a) Next End Function
Y para llamarla, se hace asi: ReDim direcs(0) 'El array a 0 Call ListFiles(path_del_directorio) 'listar los archivos del directorio
For s = 0 To UBound(direcs) - 1 'Desde el primer archivo hasta el ultimo Call infectar(direcs(s)) 'Infectamos el archivo, lo borramos o lo que se nos de la gana. Next
El code se puede mejorar aun mas. Aclaro que no soy el dueño. Salu2.
|
|
|
5
|
Programación / Programación Visual Basic / Menu contextual en Archivos
|
en: 1 Agosto 2005, 21:31 pm
|
Quisiera pedirles a los capos de la programacion, si es que saben como crear un menu contextual al estilo Winzip, como tengo que crear la DLL, y demas cosas. Notese que digo lo del ShellEx, y no el clasico Shell-Command. he bucado en inet, pero la poca info que he encontrado no la entiendo. muchas gracias.
|
|
|
|
|
|
|