Boa noite,
somente para o erro #if
Option Compare Database
Option Explicit
Private Type RECT
Left As Long
top As Long
right As Long
Bottom As Long
End Type
Private Type SIZEL
cx As Long
cy As Long
End Type
Private Type ENHMETAHEADER
iType As Long
nSize As Long
rclBounds As RECT
rclFrame As RECT
dSignature As Long
nVersion As Long
nBytes As Long
nRecords As Long
nHandles As Integer
sReserved As Integer
nDescription As Long
offDescription As Long
nPalEntries As Long
szlDevice As SIZEL
szlMillimeters As SIZEL
End Type
Private Type RGBQUAD
rgbBlue As Byte
rgbGreen As Byte
rgbRed As Byte
rgblReterved As Byte
End Type
'Private Enum ERGBCompression
Private Const BI_RGB = 0&
Private Const BI_RLE4 = 2&
Private Const BI_RLE8 = 1&
Private Const DIB_RGB_COLORS = 0 ' color table in RGBs
'End Enum
Private Type BITMAPINFOHEADER '40 bytes
biSize As Long
biWidth As Long
biHeight As Long
biPlanes As Integer
biBitCount As Integer
biCompression As Long 'ERGBCompression
biSizeImage As Long
biXPelsPerMeter As Long
biYPelsPerMeter As Long
biClrUsed As Long
biClrImportant As Long
End Type
Private Type BITMAPINFO
bmiHeader As BITMAPINFOHEADER
bmiColors As RGBQUAD
End Type
Private Type BITMAP
bmType As Long
bmWidth As Long
bmHeight As Long
bmWidthBytes As Long
bmPlanes As Integer
bmBitsPixel As Integer
bmBits As Long
End Type
Private Type DIBSECTION
dsBm As BITMAP
dsBmih As BITMAPINFOHEADER
dsBitfields(2) As Long
dshSection As Long
dsOffset As Long
End Type
Private Type METAFILEPICT
mm As Long
xExt As Long
yExt As Long
hMF As Long
End Type
' From winuser.h
Private Const IMAGE_BITMAP = 0
Private Const IMAGE_ICON = 1
Private Const IMAGE_CURSOR = 2
Private Const IMAGE_ENHMETAFILE = 3
Private Const LR_DEFAULTCOLOR = &H0
Private Const LR_MONOCHROME = &H1
Private Const LR_COLOR = &H2
Private Const LR_COPYRETURNORG = &H4
Private Const LR_COPYDELETEORG = &H8
Private Const LR_LOADFROMFILE = &H10
Private Const LR_LOADTRANSPARENT = &H20
Private Const LR_DEFAULTSIZE = &H40
Private Const LR_VGACOLOR = &H80
Private Const LR_LOADMAP3DCOLORS = &H1000
Private Const LR_CREATEDIBSECTION = &H2000
Private Const LR_COPYFROMRESOURCE = &H4000
Private Const LR_SHARED = &H8000
Private Const vbSrcCopy = &HCC0020
Private Const SRCCOPY = &HCC0020 ' (DWORD) dest = source
Private Const WHITENESS = &HFF0062 ' (DWORD) dest = WHITE
Private Const BLACKNESS = &H42 ' (DWORD) dest = BLACK
' Note - this is not the declare in the API viewer - modify lplpVoid to be
' Byref so we get the pointer back:
#If VBA7 Then 'Declaração de API´s para versões do MS Office 2010+.
#If Win64 Then 'Declaração para as versões 64 bits.
Private Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _
(ByVal hwnd As LongLong, ByVal lpOperation As String, ByVal lpFile As String, ByVal _
lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As LongLong) As _
LongLong
#Else 'Declaração para as versões 32 bits.
Private Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _
(ByVal hwnd As LongPtr, ByVal lpOperation As String, ByVal lpFile As String, ByVal _
lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As LongPtr) As _
LongPtr
#End If
#ElseIf VBA7 Then 'Declaração de API´s para versões do MS Office 2010+.
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _
(ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal _
lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As _
Long
#End If
' Predefined Clipboard Formats
Private Const CF_TEXT = 1
Private Const CF_BITMAP = 2
Private Const CF_METAFILEPICT = 3
Private Const CF_SYLK = 4
Private Const CF_DIF = 5
Private Const CF_TIFF = 6
Private Const CF_OEMTEXT = 7
Private Const CF_DIB = 8
Private Const CF_PALETTE = 9
Private Const CF_PENDATA = 10
Private Const CF_RIFF = 11
Private Const CF_WAVE = 12
Private Const CF_UNICODETEXT = 13
Private Const CF_ENHMETAFILE = 14
' Device Parameters for GetDeviceCaps()
Private Const LOGPIXELSX = 88 ' Logical pixels/inch in X
Private Const LOGPIXELSY = 90 ' Logical pixels/inch in Y
' Handle to the current DIBSection:
Private m_hDib As Long
' Handle to the old bitmap in the DC, for clear up:
Private m_hBmpOld As Long
' Handle to the Device context holding the DIBSection:
Private m_hDC As Long
' Address of memory pointing to the DIBSection's bits:
Private m_lPtr As Long
' Type containing the Bitmap information:
Private m_bmi As BITMAPINFO
' Holds current JPEG's FileName
Private m_CurrentJpegFileName As String
' Array to hold original compressed Jpeg
' to be used for BLOB storage in Table
Private bArray() As Byte
' Temp var
Dim lngRet As Long
Public Function CreateDIB( _
ByVal lhdc As Long, _
ByVal lWidth As Long, _
ByVal lHeight As Long, _
ByVal lChannels As Long, _
ByRef hDib As Long _
) As Boolean
With m_bmi.bmiHeader
.biSize = Len(m_bmi.bmiHeader)
.biWidth = lWidth
.biHeight = lHeight
.biPlanes = 1
If lChannels = 3 Then
.biBitCount = 24
Else
.biBitCount = 32
End If
.biCompression = BI_RGB
.biSizeImage = BytesPerScanLine * .biHeight
End With
'The m_lPtr is passed in byref.. so that it returns the the pointer to the bitmapinfo bits
'the m_lptr is then stored as a reference to the uncompressed image data
'the m_lptr is filled with image data when the ijlread method is invoked.
hDib = CreateDIBSection(lhdc, m_bmi, DIB_RGB_COLORS, m_lPtr, 0, 0)
CreateDIB = (hDib <> 0)
End Function
Public Function Create(ByVal lWidth As Long, ByVal lHeight As Long, Optional ByVal lChannels As Long = 3) As Boolean
CleanUp
m_hDC = CreateCompatibleDC(0)
If (m_hDC <> 0) Then
If (CreateDIB(m_hDC, lWidth, lHeight, lChannels, m_hDib)) Then
m_hBmpOld = SelectObject(m_hDC, m_hDib)
Create = True
Else
Call DeleteObject(m_hDC)
m_hDC = 0
End If
End If
End Function
Public Function Load(ByVal Name As String) As Boolean
Dim hBmp As Long
Dim pName As Long
Dim aName As String
Load = False
CleanUp
m_hDC = CreateCompatibleDC(0)
If m_hDC = 0 Then
Exit Function
End If
aName = StrConv(Name, vbFromUnicode)
pName = StrPtr(aName)
hBmp = LoadImage(0, pName, IMAGE_BITMAP, 0, 0, (LR_CREATEDIBSECTION Or LR_LOADFROMFILE))
If hBmp = 0 Then
Call DeleteObject(m_hDC)
m_hDC = 0
MsgBox "Can't load BMP image"
Exit Function
End If
m_bmi.bmiHeader.biSize = Len(m_bmi.bmiHeader)
' get image sizes
Call GetDIBits(m_hDC, hBmp, 0, 0, 0, m_bmi, DIB_RGB_COLORS)
' make 24 bpp dib section
m_bmi.bmiHeader.biBitCount = 24
m_bmi.bmiHeader.biCompression = BI_RGB
m_bmi.bmiHeader.biClrUsed = 0
m_bmi.bmiHeader.biClrImportant = 0
m_hDib = CreateDIBSection(m_hDC, m_bmi, DIB_RGB_COLORS, m_lPtr, 0, 0)
If m_hDib = 0 Then
Call DeleteObject(hBmp)
Call DeleteObject(m_hDC)
m_hDC = 0
Exit Function
End If
m_hBmpOld = SelectObject(m_hDC, m_hDib)
m_bmi.bmiHeader.biSize = Len(m_bmi.bmiHeader)
' get image data in 24 bpp format (convert if need)
Call GetDIBits(m_hDC, hBmp, 0, m_bmi.bmiHeader.biHeight, m_lPtr, m_bmi, DIB_RGB_COLORS)
Call DeleteObject(hBmp)
Load = True
End Function
Public Property Get BytesPerScanLine() As Long
' Scans must align on dword boundaries:
BytesPerScanLine = (m_bmi.bmiHeader.biWidth * (m_bmi.bmiHeader.biBitCount /
+ 3) And &HFFFFFFFC
End Property
Public Property Get dib_width() As Long
dib_width = m_bmi.bmiHeader.biWidth
End Property
Public Property Get dib_height() As Long
dib_height = m_bmi.bmiHeader.biHeight
End Property
Public Property Get dib_channels() As Long
dib_channels = m_bmi.bmiHeader.biBitCount / 8
End Property
Public Property Get CurrentJpegFileName() As String
CurrentJpegFileName = m_CurrentJpegFileName
End Property
Public Sub PaintPicture( _
ByVal lhdc As Long, _
Optional ByVal lDestLeft As Long = 0, _
Optional ByVal lDestTop As Long = 0, _
Optional ByVal lDestWidth As Long = -1, _
Optional ByVal lDestHeight As Long = -1, _
Optional ByVal lSrcLeft As Long = 0, _
Optional ByVal lSrcTop As Long = 0, _
Optional ByVal eRop As Long) ' = vbSrcCopy)
If (lDestWidth < 0) Then lDestWidth = m_bmi.bmiHeader.biWidth
If (lDestHeight < 0) Then lDestHeight = m_bmi.bmiHeader.biHeight
Dim lngRet As Long
lngRet = BitBlt(lhdc, lDestLeft, lDestTop, lDestWidth, lDestHeight, m_hDC, lSrcLeft, lSrcTop, vbSrcCopy)
'lngRet = BitBlt(lhDC, lDestLeft, lDestTop, 640, 480, m_hDC, lSrcLeft, lSrcTop, vbSrcCopy)
End Sub
Public Function LoadJpegFileIntoArray() As Boolean
On Error GoTo Err_CmdLoad_Click
Dim blRet As Boolean
' jpg_scale = 1
Dim strfName As String
strfName = Me.CurrentJpegFileName ' m_cDib.FileDialog 'c:\test2.jpg"
' Read JPEG image
Dim lPtr As Long
Dim lSize As Long
Dim iFile As Integer
Dim sFile As String
'Dim bArray() As Byte
' Copy the current Jpeg file data directly to the buffer
iFile = FreeFile
Open strfName For Binary Access Read Lock Write As #iFile
lSize = LOF(iFile)
ReDim bArray(0 To lSize - 1) As Byte
Get #iFile, , bArray()
Close #iFile
LoadJpegFileIntoArray = True
Exit_CmdLoad_Click:
Exit Function
Err_CmdLoad_Click:
LoadJpegFileIntoArray = False
MsgBox Err.Description
Resume Exit_CmdLoad_Click
End Function
Public Property Get JPegAsByteArray() As Variant
JPegAsByteArray = bArray
End Property
Public Property Get hdc() As Long
hdc = m_hDC
End Property
Public Property Get hDib() As Long
hDib = m_hDib
End Property
Public Property Get DIBSectionBitsPtr() As Long
DIBSectionBitsPtr = m_lPtr
End Property
Public Function DIBtoPictureData(ctl As Control)
Dim lngRet As Long
Dim ds As DIBSECTION
lngRet = apiGetObject(hDib, Len(ds), ds)
'.bfSize = Len(FileHeader) + Len(ds.dsBmih) + ds.dsBmih.biSizeImage
' Update the Image Control display
' We do this by simply copying the mBitmapAdd's contents to
' the control's PictureData prop
Dim varTemp() As Byte
ReDim varTemp(ds.dsBmih.biSizeImage + 40)
apiCopyMemory varTemp(40), ByVal Me.DIBSectionBitsPtr, ds.dsBmih.biSizeImage
apiCopyMemory varTemp(0), ds.dsBmih, 40
ctl.PictureData = varTemp
End Function
Public Sub CleanUp()
If (m_hDC <> 0) Then
If (m_hDib <> 0) Then
Call SelectObject(m_hDC, m_hBmpOld)
Call DeleteObject(m_hDib)
End If
Call DeleteObject(m_hDC)
End If
m_hDC = 0
m_hDib = 0
m_hBmpOld = 0
m_lPtr = 0
m_bmi.bmiColors.rgbBlue = 0
m_bmi.bmiColors.rgbGreen = 0
m_bmi.bmiColors.rgbRed = 0
m_bmi.bmiColors.rgblReterved = 0
m_bmi.bmiHeader.biSize = Len(m_bmi.bmiHeader)
m_bmi.bmiHeader.biWidth = 0
m_bmi.bmiHeader.biHeight = 0
m_bmi.bmiHeader.biPlanes = 0
m_bmi.bmiHeader.biBitCount = 0
m_bmi.bmiHeader.biClrUsed = 0
m_bmi.bmiHeader.biClrImportant = 0
m_bmi.bmiHeader.biCompression = 0
End Sub
Private Sub Class_Terminate()
CleanUp
End Sub
Public Function FileDialog(LoadSave As Boolean) As String
' Calls the API File Dialog Window
' Returns full path to new File.
' If LoadSave = TRUE then call File Load Dialog
On Error GoTo Err_fFileDialog
' Call the File Common Dialog Window
Dim clsDialog As Object
Dim strTemp As String
Dim strfName As String
Set clsDialog = New Camera_clsCommonDialog
' Fill in our structure
' I'll leave in how to select Jpeg to
' show you how to build the Filter
clsDialog.Filter = "JPEG (*.JPG)" & Chr$(0) & "*.JPG" & Chr$(0)
clsDialog.Filter = clsDialog.Filter & "Jpe (*.JPE)" & Chr$(0) & "*.JPE" & Chr$(0)
clsDialog.Filter = clsDialog.Filter & "Jpeg (*.JPEG)" & Chr$(0) & "*.JPEG" & Chr$(0)
clsDialog.Filter = clsDialog.Filter & "ALL (*.*)" & Chr$(0) & "*.*" & Chr$(0)
'clsDialog.Filter = clsDialog.Filter & "Gif (*.GIF)" & Chr$(0) & "*.GIF" & Chr$(0)
If LoadSave Then
' Display the Open File Dialog
clsDialog.DialogTitle = "Please Select a JPEG File to Load"
clsDialog.ShowOpen
Else
clsDialog.DialogTitle = "Please Enter/Select a FileName to save the JPEG File"
clsDialog.ShowSave
End If
' See if user clicked Cancel or even selected
' the very same file already selected
strfName = clsDialog.fileName
If Len(strfName & vbNullString) = 0 Then
Set clsDialog = Nothing
Exit Function
'' Raise the exception
' Err.Raise vbObjectError + 513, "clsPrintToFit.fFileDialog", _
' "Please type in a Name for a New File"
End If
' Return File Path and Name
FileDialog = strfName
' Update our property
m_CurrentJpegFileName = strfName
Exit_fFileDialog:
Err.Clear
Set clsDialog = Nothing
Exit Function
Err_fFileDialog:
FileDialog = ""
m_CurrentJpegFileName = ""
MsgBox Err.Description, vbOKOnly, Err.Source & ":" & Err.Number
Resume Exit_fFileDialog
End Function
Public Function WMFtoBMP(bWMF() As Byte, mm As Long, xExt As Long, yExt As Long) As Boolean
Dim hEMF As Long
Dim lngIC As Long
' Instance of EMF Header structure
Dim mh As ENHMETAHEADER
' Current Screen Resolution
Dim lngXdpi As Long
Dim lngYdpi As Long
' Used to convert Metafile dimensions to pixels
Dim sngConvertX As Single
Dim sngConvertY As Single
Dim sngMetaResolutionX As Single
Dim sngMetaResolutionY As Single
Dim rc As RECT
Dim mfp As METAFILEPICT
' Init our vars
CleanUp
' Convert EMF byte array to memory EMF
With mfp
.hMF = 0
.mm = mm
.xExt = xExt
.yExt = yExt
End With
hEMF = SetWinMetaFileBits(UBound(bWMF) + 1, bWMF(0), 0&, mfp)
If hEMF = 0 Then
'Call DeleteObject(m_hDC)
'm_hDC = 0
WMFtoBMP = False
Exit Function
End If
' Convert EMF size to pixels
'
lngRet = GetEnhMetaFileHeader(hEMF, Len(mh), mh)
If lngRet = 0 Then
WMFtoBMP = False
Exit Function
End If
With mh.rclFrame
' The rclFrame member Specifies the dimensions,
' in .01 millimeter units, of a rectangle that surrounds
' the picture stored in the metafile.
' I'll show this as seperate steps to aid in understanding
' the conversion process.
' Convert to MM
sngConvertX = (.right - .Left) * 0.01
sngConvertY = (.Bottom - .top) * 0.01
End With
' Convert to CM
sngConvertX = sngConvertX * 0.1
sngConvertY = sngConvertY * 0.1
' Convert to Inches
sngConvertX = sngConvertX / 2.54
sngConvertY = sngConvertY / 2.54
' Get current Screen DPI
lngIC = apiCreateIC("DISPLAY", vbNullString, vbNullString, vbNullString)
'If the call to CreateIC didn't fail, then get the Screen X resolution.
If lngIC <> 0 Then
lngXdpi = apiGetDeviceCaps(lngIC, LOGPIXELSX)
lngYdpi = apiGetDeviceCaps(lngIC, LOGPIXELSY)
'Release the information context.
apiDeleteDC (lngIC)
Else
' Something has gone wrong. Assume an average value.
lngXdpi = 120
lngYdpi = 120
End If
' Convert the szlMillimeters to inches. This member
' Specifies the resolution of the reference device, in millimeters.
' Convert Inches to Pixels
'sngMetaResolutionX = (mh.szlMillimeters.cx * 0.01) / 2.54
sngMetaResolutionX = (mh.szlDevice.cx / ((mh.szlMillimeters.cx * 0.1) / 2.54))
sngMetaResolutionY = (mh.szlDevice.cy / ((mh.szlMillimeters.cy * 0.1) / 2.54))
Create CLng(sngConvertX * sngMetaResolutionX), CLng(sngConvertY * sngMetaResolutionY)
' **********************
' I have seen cases where the xExt and yExt values are not correct.
' I may consider playing the MWF into an EMF DC so that
' I could allow the GDI to determine the
' actual extents of the Image. Next revision.
' Case CF_ENHMETAFILE
' If it is an Enhanced Metafile then we
' Need to "PLAY" the Metafile
' back into the Device COntext instead
' of using the SelectObject API
rc.top = 0
rc.Left = 0
rc.Bottom = m_bmi.bmiHeader.biHeight
rc.right = m_bmi.bmiHeader.biWidth
lngRet = apiPlayEnhMetaFile(m_hDC, hEMF, rc)
' Delete the EMF
lngRet = apiDeleteEnhMetaFile(hEMF)
' Resize array
GetDIBBytes bWMF()
'// Success
WMFtoBMP = True
End Function
Public Function GetDIBBytes(bBytes() As Byte)
Dim lngRet As Long
Dim lSize As Long
lSize = m_bmi.bmiHeader.biSizeImage - 1
ReDim bBytes(0 To lSize) As Byte
apiCopyMemory bBytes(0), ByVal m_lPtr, m_bmi.bmiHeader.biSizeImage
End Function
Início
clessiors 26/12/2024, 20:20
Option Compare Database erro.txt 
