Option Compare Database
Option Explicit
'Visualizar todas las imágenes de una carpeta y subcarpetas en un formulario
'
'Construimos un formulario con
'encabezado formulario:
'1 botón de comando
'
'detalles formulario:
'1 control imagen y origen del control llamado Img
'3 textbox con origen del control FName, PathFName y Order
'
'configurar el formulario en formularios continuos
Private Enum MsoFileDialogType
msoFileDialogOpen = 1 'Permite al usuario abrir un archivo.
msoFileDialogSaveAs = 2 'Permite al usuario guardar un archivo.
msoFileDialogFilePicker = 3 'Permite al usuario seleccionar un archivo.
msoFileDialogFolderPicker = 4 'Permite al usuario seleccionar una carpeta.
End Enum
Private Function SelectItem(ByVal tipo As MsoFileDialogType) As String
On Error GoTo error
Dim fDialog As Object
Dim intResult As Integer
Dim strPath As String
strPath = ""
Set fDialog = Application.FileDialog(tipo)
intResult = Application.FileDialog(tipo).Show
If intResult <> 0 Then
strPath = Application.FileDialog(tipo).SelectedItems(1)
End If
SelectItem = strPath
Exit Function
error:
SelectItem = ""
MsgBox Err.Description
End Function
Private Sub cmdLoadFolderImageToPictures_Click()
Dim res As Boolean
Dim sFPathFolder As String
sFPathFolder = SelectItem(msoFileDialogFolderPicker)
If sFPathFolder = "" Then Exit Sub
Dim oFileList As New clsFileList
res = oFileList.GetFileList(sFPathFolder)
If Not res Then Exit Sub
Dim rs As New ADODB.Recordset
With rs
.Fields.Append "PathFName", adVarChar, 255, adFldKeyColumn
.Fields.Append "FName", adVarChar, 255, adFldIsNullable
.Fields.Append "Img", adVarChar, 255, adFldIsNullable
.Fields.Append "Order", adInteger, , adFldIsNullable
.CursorType = adOpenKeyset
.CursorLocation = adUseClient
.LockType = adLockPessimistic
.Open
End With
Dim fso As New FileSystemObject
Dim i As Long
For i = 1 To oFileList.FilesCount
rs.AddNew
rs!FName = fso.GetFileName(oFileList.Files(i))
rs!PathFName = oFileList.Files(i)
rs!Img = oFileList.Files(i)
rs!Order = i
rs.Update
Next i
Set fso = Nothing
'rs.Sort = "PathFname,FName"
rs.Sort = "FName"
Set Me.Recordset = rs
rs.Close
Set rs = Nothing
End Sub
Suscribirse a:
Enviar comentarios (Atom)
VBA Access. Redondeo de números decimales con el método medio redondeo. Alternativa a la función Round (bankers round)
Private Function Redondeo(ByVal Numero As Variant, ByVal Decimales As Integer) As Double 'Aplica método medio redondeo (half round ...
-
Option Compare Database Option Explicit '***************************** ' 'Ejemplo de uso ' 'selecciona 1 ficher...
-
Option Compare Database Option Explicit 'Zip / UnZip file or folder 'http://www.codekabinett.com/rdumps.php?Lang=2&targetDoc...
No hay comentarios:
Publicar un comentario