07. april 2004 - 16:29Der er
7 kommentarer og 4 løsninger
Hente filer ind i et array
Hej
Jeg skal læse en mappe, og finde alle filer af typen .jpg i mappen, disse filers fuldstændige URL skal så gemmes i et array, så jeg senere kan gennemgå dem og så flytte filerne ( Det skal gøres på denne måde, jeg kan sagtens flytte filerne ) men jeg skal have dem i et array, så jeg kan flytte dem en af gangen.
Samtidig ønsker jeg om det er muligt at få info om filerne, så som fil størrelse og lign.
Private Sub Form_Load() With ImgInfo If .ReadInfo("D:\System\Dokumenter\Billeder\Eksempel.jpg") Then MsgBox "Type: " & .ImageType MsgBox "Depth: " & .Depth MsgBox "Width/Height: " & .Width & " x " & .Height MsgBox "Size: " & .Size & " byte" End If End With End Sub '--------------------- Form1 ---------------------
Private Const MAX_PATH As Long = 260 Private Const INVALID_HANDLE_VALUE As Long = -1 Private Const FILE_ATTRIBUTE_DIRECTORY As Long = &H10
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 * MAX_PATH cAlternate As String * 14 End Type
Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
Private Const BUFFERSIZE As Long = 65535
Private m_Size As Long Private m_Width As Long Private m_Height As Long Private m_Depth As Byte Private m_ImageType As String
Public Property Get Width() As Long Width = m_Width End Property
Public Property Get Height() As Long Height = m_Height End Property
Public Property Get Depth() As Byte Depth = m_Depth End Property
Public Property Get ImageType() As String ImageType = m_ImageType End Property
Public Property Get Size() As Long Size = m_Size End Property
Public Function ReadInfo(ByVal strPath As String) As Boolean Dim bytBuffer() As Byte Dim intFile As Integer
If FileExists(strPath) Then intFile = FreeFile Open strPath For Binary Access Read As #intFile m_Size = LOF(intFile) ReDim bytBuffer(BUFFERSIZE) As Byte Get #intFile, 1, bytBuffer() Close #intFile Else Exit Function End If
'PNG file If bytBuffer(0) = 137 And bytBuffer(1) = 80 And bytBuffer(2) = 78 Then m_ImageType = "PNG" Select Case bytBuffer(25) Case 0 m_Depth = bytBuffer(24) Case 2 m_Depth = bytBuffer(24) * 3 Case 3 m_Depth = CByte(8) Case 4 m_Depth = bytBuffer(24) * 2 Case 6 m_Depth = bytBuffer(24) * 4 Case Else m_ImageType = "Unknown" End Select If m_ImageType = "PNG" Then m_Width = Mult(bytBuffer(19), bytBuffer(18)) m_Height = Mult(bytBuffer(23), bytBuffer(22)) ReadInfo = True Exit Function End If End If
'GIF file If bytBuffer(0) = 71 And bytBuffer(1) = 73 And bytBuffer(2) = 70 Then m_ImageType = "GIF" m_Width = Mult(bytBuffer(6), bytBuffer(7)) m_Height = Mult(bytBuffer(8), bytBuffer(9)) m_Depth = (bytBuffer(10) And 7) + 1 ReadInfo = True Exit Function End If
'BMP file If bytBuffer(0) = 66 And bytBuffer(1) = 77 Then m_ImageType = "BMP" m_Width = Mult(bytBuffer(18), bytBuffer(19)) m_Height = Mult(bytBuffer(22), bytBuffer(23)) m_Depth = bytBuffer(28) ReadInfo = True Exit Function End If
'WBMP file If bytBuffer(0) = 0 And bytBuffer(1) = 0 Then m_Width = WMult(bytBuffer(2), bytBuffer(3)) m_Height = WMult(bytBuffer(4), bytBuffer(5)) If m_Width > 0 And m_Height > 0 Then m_ImageType = "WBMP" m_Depth = CByte(1) ReadInfo = True Exit Function Else m_Width = 0 m_Height = 0 End If End If
'JPEG file If m_ImageType = "Unknown" Then Dim lngPos As Long Do If (bytBuffer(lngPos) = &HFF And _ bytBuffer(lngPos + 1) = &HD8 And _ bytBuffer(lngPos + 2) = &HFF) Or (lngPos >= BUFFERSIZE - 10) Then Exit Do lngPos = lngPos + 1 Loop lngPos = lngPos + 2 If lngPos >= BUFFERSIZE - 10 Then Exit Function Do Do If bytBuffer(lngPos) = &HFF And bytBuffer(lngPos + 1) <> &HFF Then Exit Do lngPos = lngPos + 1 If lngPos >= BUFFERSIZE - 10 Then Exit Function Loop lngPos = lngPos + 1 Select Case bytBuffer(lngPos) Case &HC0 To &HC3, &HC5 To &HC7, &HC9 To &HCB, &HCD To &HCF Exit Do End Select lngPos = lngPos + Mult(bytBuffer(lngPos + 2), bytBuffer(lngPos + 1)) If lngPos >= BUFFERSIZE - 10 Then Exit Function Loop m_ImageType = "JPG" m_Height = Mult(bytBuffer(lngPos + 5), bytBuffer(lngPos + 4)) m_Width = Mult(bytBuffer(lngPos + 7), bytBuffer(lngPos + 6)) m_Depth = bytBuffer(lngPos + 8) * 8 ReadInfo = True End If End Function
Private Function WMult(ByVal byt1 As Byte, ByVal byt2 As Byte) As Long If byt1 < 128 Then WMult = CLng(byt1) Else WMult = CLng((byt1 Mod 128) * 128 + byt2) End If End Function
Private Function Mult(ByVal byt1 As Byte, ByVal byt2 As Byte) As Long Mult = CLng(byt1 + (byt2 * CLng(256))) End Function
Private Function FileExists(ByVal strFile As String) As Boolean Dim hFile As Long Dim WFD As WIN32_FIND_DATA hFile = FindFirstFile(strFile, WFD) FileExists = CBool(hFile <> INVALID_HANDLE_VALUE) Call FindClose(hFile) End Function '--------------------- Class1 --------------------
Opret en form, og sæt en filelistbox på den. Copy-paste følgende kode:
Private Sub Form_Load()
Dim FileArray() As String 'Arrayet har dimensionen NUL til at starte med Dim i As Long 'En tæller-variabel
'Alle JPG ind i din filelist File1.Path = "C:\billeder" '<- Ret stien File1.Pattern = "*.jpg" File1.Visible = False 'Drop dette hvis FileList skal være synlig på formen
'Indlæs fra file1 fil array For i = 0 To File1.ListCount - 1 ReDim Preserve FileArray(i) 'Giver arrayet ny dimension, gemmer oprindeligt indhold (PRESERVE) FileArray(i) = File1.List(i) 'Indlæser i array Next i
'Skriv f.eks. arrayet ud i en msgbox, for test For i = 0 To UBound(FileArray) MsgBox "Fil i array på plads " & i & ": " & FileArray(i) Next i End Sub
Funktionen dir() virkede, og er langt den nemmeste måde.. se kildekode i et svar længere oppe..
Først hentes alle filerne ved dir(strSti, VbNormal) dernæst bruges filen dir() til at gå videre til næste fil.
Virker perfekt :) Takker for jeres svar :) og martin får 50% for hans store indsats ;)
Synes godt om
Ny brugerNybegynder
Din løsning...
Tilladte BB-code-tags: [b]fed[/b] [i]kursiv[/i] [u]understreget[/u] Web- og emailadresser omdannes automatisk til links. Der sættes "nofollow" på alle links.