Option Compare Database
Option Explicit
'Visualizar todas las imágenes de una carpeta y subcarpetas en un formulario simulando 5 registros por fila
'
'Construimos un formulario con
'encabezado formulario:
'1 botón de comando para seleccionar la carpeta con las imagenes
'
'detalles formulario:
'5 controles imagen1,imagen2,imagen3,imagen4,imagen5 y origen del control llamados Img_1,Img_2,Img_3,Img_4,Img_5 en cada uno de ellos
'5 botones transparentes encima de cada imagen
'Por cada imagen, debajo añadimos, 3 textbox con origen del control FName,PathFName,Order, para la segunda imagen FName_2,PathFName_2,Order_2, ...
'
'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 cmbButton1_Click()
MsgBox Me.PathFName
End Sub
Private Sub cmbButton2_Click()
MsgBox Me.PathFName_2
End Sub
Private Sub cmbButton3_Click()
MsgBox Me.PathFName_3
End Sub
Private Sub cmbButton4_Click()
MsgBox Me.PathFName_4
End Sub
Private Sub cmbButton5_Click()
MsgBox Me.PathFName_5
End Sub
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 "FName", adVarChar, 255, adFldIsNullable
.Fields.Append "PathFName", adVarChar, 255, adFldKeyColumn
.Fields.Append "Img", adVarChar, 255, adFldIsNullable
.Fields.Append "Order", adInteger, , adFldIsNullable
.Fields.Append "FName_2", adVarChar, 255, adFldIsNullable
.Fields.Append "PathFName_2", adVarChar, 255, adFldKeyColumn
.Fields.Append "Img_2", adVarChar, 255, adFldIsNullable
.Fields.Append "Order_2", adInteger, , adFldIsNullable
.Fields.Append "FName_3", adVarChar, 255, adFldIsNullable
.Fields.Append "PathFName_3", adVarChar, 255, adFldKeyColumn
.Fields.Append "Img_3", adVarChar, 255, adFldIsNullable
.Fields.Append "Order_3", adInteger, , adFldIsNullable
.Fields.Append "FName_4", adVarChar, 255, adFldIsNullable
.Fields.Append "PathFName_4", adVarChar, 255, adFldKeyColumn
.Fields.Append "Img_4", adVarChar, 255, adFldIsNullable
.Fields.Append "Order_4", adInteger, , adFldIsNullable
.Fields.Append "FName_5", adVarChar, 255, adFldIsNullable
.Fields.Append "PathFName_5", adVarChar, 255, adFldKeyColumn
.Fields.Append "Img_5", adVarChar, 255, adFldIsNullable
.Fields.Append "Order_5", adInteger, , adFldIsNullable
.CursorType = adOpenKeyset
.CursorLocation = adUseClient
.LockType = adLockPessimistic
.Open
End With
Dim nRecords As Long
nRecords = oFileList.FilesCount
Dim fso As New FileSystemObject
Dim i As Long
Dim j As Integer
For i = 1 To nRecords
rs.AddNew
rs!FName = fso.GetFileName(oFileList.Files(i))
rs!PathFName = oFileList.Files(i)
rs!Img = oFileList.Files(i)
rs!Order = i
j = 0
j = i + 1
If j <= nRecords Then
rs!FName_2 = fso.GetFileName(oFileList.Files(j))
rs!PathFName_2 = oFileList.Files(j)
rs!Img_2 = oFileList.Files(j)
rs!Order_2 = j
End If
j = j + 1
If j <= nRecords Then
rs!FName_3 = fso.GetFileName(oFileList.Files(j))
rs!PathFName_3 = oFileList.Files(j)
rs!Img_3 = oFileList.Files(j)
rs!Order_3 = j
End If
j = j + 1
If j <= nRecords Then
rs!FName_4 = fso.GetFileName(oFileList.Files(j))
rs!PathFName_4 = oFileList.Files(j)
rs!Img_4 = oFileList.Files(j)
rs!Order_4 = j
End If
j = j + 1
If j <= nRecords Then
rs!FName_5 = fso.GetFileName(oFileList.Files(j))
rs!PathFName_5 = oFileList.Files(j)
rs!Img_5 = oFileList.Files(j)
rs!Order_5 = j
End If
rs.Update
i = j
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