Salve a tutti. Ho questo problema: devo estrarre una matrice dei dati relativi ai livelli di colore di immagini di tipo bitmap al fine di effettuare su questi analisi successive. Ho preparato le macro per l'estrazione dati da matrice e per l'analisi degli stessi perchè ho esperienza di programmazione Fortran. Purtroppo, sulla gestione delle immagini e sul VBA sono neofita. Dopo aver studiato il problema (Loadimage con LR-CreateDIBSection+GetObject dal DIBSection) anche su questo sito ed altrove, senza riuscire, ho trovato il cosice allegato che funziona ma non riesce a gestire le mie immagini BMP che hanno più di 100 livelli di grigio: qualcuno può aiutarmi?
Grazie
Gaetano
codice:Option Explicit '################################################################### ' Full Credit to Gary Simmons for this BMP loader code ' Demonstration/tutorial of reading and manually drawing an ' uncompressed (most) bitmap Free for any use: ' see included file (BMP.TXT) for Bitmap file info reference. ' ' Please email me at gary.simmons@optushome.com.au if you find this ' useful ' ' 21st December 2001 Gary Simmons '################################################################### Private Type BitMapFile 'bitmap file header structure bfType As String * 2 bfSize As String * 4 bfReserved1 As String * 2 bfreserved2 As String * 2 bfOffset As String * 4 End Type Private Type BitMapInfo 'bitmap info header structure biSize As String * 4 biWidth As String * 4 biHeight As String * 4 biPlanes As String * 2 biBitCount As String * 2 biCompression As String * 4 biSizeImage As String * 4 biXPelsPerMeter As String * 4 biYPelsPerMeter As String * 4 biClrUsed As String * 4 biClrImportant As String * 4 End Type Private Type RGBQuads 'RGBQuad structure (temporary) cBlue As String * 1 cGreen As String * 1 cRed As String * 1 cReserved As String * 1 End Type Private Type RGBQuad 'RGBQuad (used in index) Blue As Byte Green As Byte Red As Byte End Type Public Sub GetBmpValues(Filename As String, BMPData() As Long, Progress As MSForms.Label) ' show information about the bitmap and ' manually draw it in another Picturebox Dim bmf As BitMapFile Dim bmi As BitMapInfo Dim rgbqs As RGBQuads Dim rgbq(255) As RGBQuad Dim s1 As String * 1 Dim Dword As String * 4 Dim lngCol As Long Dim lngRow As Long Dim IWidth As Long Dim IBitCount As Integer Dim Pointer As Long Dim i As Integer Dim ClrInd As Integer Dim aMask As Long Dim z As Integer Dim ByteNum As Integer Dim ThisByte As Byte Dim ColoursFound As Integer Dim ThisRed As Byte Dim ThisGreen As Byte Dim ThisBlue As Byte Const MAX_WIDTH = 256 Const MAX_HEIGHT = 65536 Progress.Caption = "Reading BMP " & Filename DoEvents Open Filename For Binary As #1 Get #1, , bmf 'load the file header Get #1, , bmi 'info header follows If lVal(bmi.biSize) <> 40 Or bmf.bfType <> "BM" Then MsgBox "Not a compatible bitmap." Close #1 Exit Sub End If 'load the relevant colour tables If lVal(bmi.biBitCount) = 1 Then For i = 0 To 1 Get #1, , rgbqs rgbq(i).Red = lVal(rgbqs.cRed) rgbq(i).Green = lVal(rgbqs.cGreen) rgbq(i).Blue = lVal(rgbqs.cBlue) Next i ElseIf lVal(bmi.biBitCount) = 4 Then For i = 0 To 15 Get #1, , rgbqs rgbq(i).Red = lVal(rgbqs.cRed) rgbq(i).Green = lVal(rgbqs.cGreen) rgbq(i).Blue = lVal(rgbqs.cBlue) Next i ElseIf lVal(bmi.biBitCount) = 8 Then For i = 0 To 255 Get #1, , rgbqs rgbq(i).Red = lVal(rgbqs.cRed) rgbq(i).Green = lVal(rgbqs.cGreen) rgbq(i).Blue = lVal(rgbqs.cBlue) Next i End If ' show the properties of the bitmap ' some don't seem to be used ' MsgBox "Actual File Size:" & (Str(LOF(1))) & " bytes" & vbCrLf & _ ' "Bitmap File Size: " & lVal(bmf.bfSize) & " bytes" & vbCrLf & _ ' "Bitmap Width: " & lVal(bmi.biWidth) & " pixels" & vbCrLf & _ ' "Bitmap Height: " & lVal(bmi.biHeight) & " pixels" & vbCrLf & _ ' "Bitmap Offset: " & lVal(bmf.bfOffset) & vbCrLf & _ ' "Bitmap BitPlanes: " & lVal(bmi.biPlanes) & vbCrLf & _ ' "Bitmap BitCount: " & lVal(bmi.biBitCount) & " bit/pixel" & vbCrLf & _ ' "Bitmap Size: " & lVal(bmi.biSizeImage) & " bytes" & vbCrLf & _ ' "Bitmap ClrUsed: " & lVal(bmi.biClrUsed) & vbCrLf & _ ' "Bitmap ClrsImportant: " & lVal(bmi.biClrImportant) & vbCrLf & _ ' "Bitmap Compression: " & lVal(bmi.biCompression) If lVal(bmi.biCompression) <> 0 Then MsgBox "Its a compressed bitmap." Close #1 Exit Sub End If Close #1 If lVal(bmi.biBitCount) <= 8 Then ' the file is either: ' mono (1-bit/pixel) ' 16-color (4-bit/pixel) ' 256-color (8-bit/pixel) Open Filename For Binary As #1 lngCol = 0 'holds X position of pixel to draw lngRow = lVal(bmi.biHeight) '- 1 'holds Y position (Note: bitmap stored from lowest line to highest) IWidth = lVal(bmi.biWidth) 'width of bitmap ReDim BMPData(lngRow, IWidth) As Long IBitCount = lVal(bmi.biBitCount) ' bits/pixel (1,4,8) Get #1, lVal(bmf.bfOffset), s1 'move binary pointer to start of bitmap Do While Not EOF(1) Get #1, , Dword ' read 4-bytes at a time ByteNum = 1 ' start with first byte in double word Do While lngCol < IWidth And ByteNum < 5 'stop drawing if edge of bitmap encountered or processed every byte in dword ThisByte = lVal(Mid(Dword, ByteNum, 1)) 'get relevant byte Pointer = 8 ' start bit pointer Do If lngCol < IWidth Then 'only bother if edge of bitmap not reached aMask = 0 'reset bit-mask For z = Pointer To Pointer - IBitCount + 1 Step -1 'the best algorithm aMask = aMask + 2 ^ (z - 1) 'I could come up with to build a bit-mask Next z ClrInd = (ThisByte And (aMask)) / (2 ^ (Pointer - IBitCount)) ' mask of relevant bits and reduce to an appropriate index BMPData(lngRow, lngCol + 1) = RGB(rgbq(ClrInd).Red, rgbq(ClrInd).Green, rgbq(ClrInd).Blue) 'set the pixel the colour End If Pointer = Pointer - IBitCount 'move to the next appropriate bits lngCol = lngCol + 1 'move the X-position Loop Until Pointer = 0 'not more bits to process - exit ByteNum = ByteNum + 1 'point to the next byte in the dword Loop If lngCol >= IWidth Then 'if, after processing this dword, we have Progress.Caption = "Lines remaining " & lngRow DoEvents lngRow = lngRow - 1 'reached the end of a line then If lngRow = 0 Then Exit Do lngCol = 0 'get the next line and reset the X-position End If Loop Close #1 ElseIf lVal(bmi.biBitCount) = 24 Then ' 16Million-color (24-bit/pixel) Open Filename For Binary As #1 lngCol = 0 lngRow = lVal(bmi.biHeight) ' - 1 IWidth = lVal(bmi.biWidth) ReDim BMPData(lngRow, IWidth) As Long IBitCount = lVal(bmi.biBitCount) Get #1, lVal(bmf.bfOffset), s1 ColoursFound = 0 'need 3-colours to form a pixel Do While Not EOF(1) Get #1, , Dword 'get 4-bytes ByteNum = 1 Do While lngCol < IWidth And ByteNum < 5 ThisByte = lVal(Mid(Dword, ByteNum, 1)) If lngCol < IWidth Then ColoursFound = ColoursFound + 1 Select Case ColoursFound Case Is = 1 'first byte in three is blue (contradicts BMP.TXT) ThisBlue = ThisByte Case Is = 2 'second byte is green ThisGreen = ThisByte Case Is = 3 'third byte is red ThisRed = ThisByte 'got the colours we need 'draw the pixel and move on to next pixel BMPData(lngRow, lngCol + 1) = RGB(ThisRed, ThisGreen, ThisBlue) ColoursFound = 0 lngCol = lngCol + 1 End Select End If ByteNum = ByteNum + 1 Loop If lngCol >= IWidth Then Progress.Caption = "Lines remaining " & lngRow DoEvents lngRow = lngRow - 1 If lngRow = 0 Then Exit Do lngCol = 0 End If Loop Close #1 End If End Sub Function lVal(vStr As String) As Long 'convert little-endian string to long integer Dim i As Integer Dim t As Long t = 0 For i = 1 To Len(vStr) t = t + Asc(Mid(vStr, i, 1)) * (256 ^ (i - 1)) Next i lVal = t End Function Sub BMPToChart() frmBMPLoader.Show Unload frmBMPLoader End Sub
Rispondi quotando