Private Type OPENFILENAME
lStructSize As Long
hWnd As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
Flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type

Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
Private Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Long

Private Const OFN_FILEMUSTEXIST = &H1000
Private Const OFN_HIDEREADONLY = &H4
Private Const OFN_OVERWRITEPROMPT = &H2
Private Const OFN_PATHMUSTEXIST = &H800
Private Const OFN_SAVE = 0
Private Const OFN_OPEN = 1

Private lngHwnd As Long
Private wMode As Integer
Private szDialogTitle As String
Private szFileName As String
Private szFilter As String
Private szDefDir As String
Private szDefExt As String
Private szFileTitle As String
Private szFileDir As String
Private intFilterIndex As Integer
Public Function Action() As String
Dim x As Long, OFN As OPENFILENAME
Call SetDefs
With OFN
.lStructSize = Len(OFN)
.hWnd = lngHwnd
.lpstrTitle = szDialogTitle
.lpstrFile = szFileName & String$(250 - Len(szFileName), 0)
.nMaxFile = 255
.lpstrFileTitle = String$(255, 0)
.nMaxFileTitle = 255
.lpstrFilter = szFilter
.nFilterIndex = intFilterIndex
.lpstrInitialDir = szDefDir
.lpstrDefExt = szDefExt
If wMode = 1 Then
OFN.Flags = OFN_HIDEREADONLY Or OFN_PATHMUSTEXIST Or OFN_FILEMUSTEXIST
x = GetOpenFileName(OFN)
Else
OFN.Flags = OFN_HIDEREADONLY Or OFN_OVERWRITEPROMPT Or OFN_PATHMUSTEXIST
x = GetSaveFileName(OFN)
End If
If x <> 0 Then
If InStr(.lpstrFile, Chr$(0)) > 0 Then
szFileName = Left$(.lpstrFile, InStr(.lpstrFile, Chr$(0)) - 1)
szFileTitle = Left$(.lpstrFileTitle, InStr(.lpstrFileTitle, Chr$(0)) - 1)
Call getFile_Dir
End If
Else
szFileName = ""
End If
End With
Action = szFileName
End Function
'Pass a bar separated string and returns a Null separated string
Private Function NullSepString(ByVal BarString As String) As String
Dim intInstr As Integer
Const vbBar = "|"
Do
intInstr = InStr(BarString, vbBar)
If intInstr > 0 Then Mid$(BarString, intInstr, 1) = vbNullChar
Loop While intInstr > 0
NullSepString = BarString
End Function
Private Sub getFile_Dir()
Dim intInstr As Integer
intInstr = InStr(szFileName, szFileTitle) - 1
szFileDir = Left(szFileName, intInstr)
End Sub

Property Let hWnd(SourceHwnd As Long)
lngHwnd = SourceHwnd
End Property

Property Let ModeOpen(DialogMode As Boolean)
wMode = DialogMode * -1
End Property
Property Let Title(DialogTitle As String)
szDialogTitle = DialogTitle
End Property
Property Let FileName(DefaultFile As String)
szFileName = DefaultFile
End Property
Property Get FileName() As String
FileName = szFileName
End Property
Property Let Filter(FilterList As String)
szFilter = NullSepString(FilterList)
End Property
Property Let StartDir(InitialDir As String)
szDefDir = InitialDir
End Property
Property Let DefaultExtension(DefExt As String)
szDefExt = DefExt
End Property
Property Get FileTitle()
FileTitle = szFileTitle
End Property
Property Get FileDir() As String
FileDir = szFileDir
End Property
Private Sub SetDefs()
If lngHwnd = 0 Then lngHwnd = hWndAccessApp
If szDialogTitle = "" Then szDialogTitle = CurrentDb.Name
If szFilter = "" Then szFilter = NullSepString("All Files|*.*")
If szDefDir = "" Then szDefDir = "C:\"
If intFilterIndex = 0 Then intFilterIndex = 1
End Sub

Dim loDlg As CommDlg
Set loDlg = New CommDlg
With loDlg
.hWnd = Me.hWnd
.Filter = "GIF|*.gif|JPG|*.jpg|BMP|*.bmp|All|*.*"
.Title = "اختيار ملف الصورة :"
.StartDir = "d:\my documents"
.ModeOpen = True
.Action
Me!المسار = .FileName
End With

If IsNull(Me![المسار]) Then
MsgBox "اختر ملف الصور أولا .", vbCritical
Exit Sub
End If

Dim bytBLOB() As Byte
Dim intNum As Integer
Dim rst As New ADODB.Recordset

rst.Open "جدول1", CurrentProject.Connection, adOpenStatic, adLockOptimistic

'Open the picture file
intNum = FreeFile
Open المسار For Binary As #intNum
ReDim bytBLOB(FileLen(المسار))

'Read the data and close the file
Get #intNum, , bytBLOB
Close #1
rst.AddNew
rst.Fields("صورة").AppendChunk bytBLOB
rst.Fields("نوع الصورة") = Right(المسار, 3)
rst.Update
Me.Requery
DoCmd.GoToRecord , , acLast

If Me.NewRecord = True Then
الصورة.Picture = ""
Exit Sub
End If
Dim lngImageSize As Long
Dim lngOffset As Long
Dim bytChunk() As Byte
Dim intFile As Integer
Dim strTempPic As String
Const conChunkSize = 100
Dim rst As New ADODB.Recordset

rst.Open "جدول1", CurrentProject.Connection, adOpenStatic, adLockOptimistic

Dim fs
Set fs = CreateObject("Scripting.FileSystemObject")
If fs.FolderExists("C:\temp1") = False Then MkDir "C:\temp1"

strTempPic = "C:\temp1\TempPic." & [نوع الصورة]

'Open the temporary file to save the BLOB to
intFile = FreeFile
Open strTempPic For Binary As #intFile
rst.Find "[ترقيم]=" & Me![ترقيم]
lngImageSize = rst("صورة").ActualSize

Do While lngOffset < lngImageSize
bytChunk() = rst("صورة").GetChunk(conChunkSize)
Put #intFile, , bytChunk()
lngOffset = lngOffset + conChunkSize
Loop
Close #intFile
الصورة.Picture = strTempPic
Kill "C:\temp1\*.*"
rst.Close

Option Compare Database
Option Explicit

' هذه الوحدة مختصة بعرض الصور من نوع GIF
Public مسار_الوثيقة As String

Private Type POINTAPI
X As Long
Y As Long
End Type

Private Type RECTL
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 RGBQUAD
rgbBlue As Byte
rgbGreen As Byte
rgbRed As Byte
rgbReserved As Byte
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 BITMAPINFOHEADER '40 bytes
biSize As Long
biWidth As Long
biHeight As Long
biPlanes As Integer
biBitCount As Integer
biCompression As Long
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 ' No COlors 24 bit RGB
End Type


Private Declare Function apiCloseEnhMetaFile Lib "gdi32" _
Alias "CloseEnhMetaFile" (ByVal hdc As Long) As Long
' lprect as RECT changed to as BYVAL as Any to allow for NULL

Private Declare Function apiCreateEnhMetaFile Lib "gdi32" _
Alias "CreateEnhMetaFileA" (ByVal hDCref As Long, _
ByVal lpFileName As String, ByVal lpRect As Any, ByVal lpDescription As String) As Long

Private Declare Function apiDeleteEnhMetaFile Lib "gdi32" _
Alias "DeleteEnhMetaFile" (ByVal hemf As Long) As Long

Private Declare Function GetEnhMetaFileBits Lib "gdi32" _
(ByVal hemf As Long, ByVal cbBuffer As Long, lpbBuffer As Byte) As Long

Private Declare Sub apiCopyMemory Lib "KERNEL32" Alias "RtlMoveMemory" _
(Destination As Any, Source As Any, ByVal Length As Long)

Private Declare Function apiSelectObject Lib "gdi32" _
Alias "SelectObject" (ByVal hdc As Long, ByVal hObject As Long) As Long

Private Declare Function apiGetDC Lib "user32" _
Alias "GetDC" (ByVal hwnd As Long) As Long

Private Declare Function apiReleaseDC Lib "user32" _
Alias "ReleaseDC" (ByVal hwnd As Long, _
ByVal hdc As Long) As Long

Private Declare Function apiCreateCompatibleDC Lib "gdi32" _
Alias "CreateCompatibleDC" (ByVal hdc As Long) As Long

Private Declare Function apiDeleteDC Lib "gdi32" _
Alias "DeleteDC" (ByVal hdc As Long) As Long

Private Declare Function apiBitBlt Lib "gdi32" _
Alias "BitBlt" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, _
ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, _
ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long

Private Declare Function apiDeleteObject Lib "gdi32" _
Alias "DeleteObject" (ByVal hObject As Long) As Long

Private Declare Function apiGetObject Lib "gdi32" Alias "GetObjectA" _
(ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hwnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, lParam As Any) As Long

' CONSTANTS

Private Const WM_HSCROLL = &H114
Private Const WM_VSCROLL = &H115
' Scroll Bar Commands
Private Const SB_LINEUP = 0
Private Const SB_LINELEFT = 0
Private Const SB_LINEDOWN = 1
Private Const SB_LINERIGHT = 1
Private Const SB_PAGEUP = 2
Private Const SB_PAGELEFT = 2
Private Const SB_PAGEDOWN = 3
Private Const SB_PAGERIGHT = 3
Private Const SB_THUMBPOSITION = 4
Private Const SB_THUMBTRACK = 5
Private Const SB_TOP = 6
Private Const SB_LEFT = 6
Private Const SB_BOTTOM = 7
Private Const SB_RIGHT = 7
Private Const SB_ENDSCROLL = 8

' Ternary raster operations
Private Const SRCCOPY = &HCC0020 ' (DWORD) dest = source

' 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


Function fStdPicToImageData(hStdPic As Object, ctl As Access.Image, _
Optional FileNamePath As String = "") As Boolean

'On Error GoTo ERR_SHOWPIC

' Temp Device Context handles
Dim hDCref As Long, hdc As Long

' Temp GDI Bitmap handles
Dim hBmap As Long
Dim hBmapOrig As Long

' Temp var to hold API returns
Dim lngRet As Long

' Bitmap structure to hold Image props
Dim Bm As BITMAP

' handle to EMF
Dim hMetafile As Long

' handle to Metafile DC
Dim hDCMeta As Long

' Array to hold binary copy of Enhanced Metafile
' we will create.
Dim arrayMeta() As Byte

' Temp DC to select StdPicture object into
hdc = apiCreateCompatibleDC(0)

' It must be GetDC not CreateCompatibleDC!!!
hDCref = apiGetDC(0)

' Make sure user hasn't tricked us by renaming
' a graphic file mistakenly to JPG OR GIF.

If hStdPic.Type <> 1 Then
Err.Raise vbObjectError + 523, "CreateBitmapFromImageCtl.modStdPic", _
"الكود يعرض صور من نوع GIF أو JPG فقط ." & vbCrLf & "اختر أحد هذين النوعين فقط"
End If

' Get the Original Images Width and Height props
lngRet = apiGetObject(hStdPic, Len(Bm), Bm)

' Can we read the picture dimensions
If Bm.bmWidth <= 0 Then
Err.Raise vbObjectError + 524, "CreateBitmapFromImageCtl.modStdPic", _
"Sorry...cannot read Image Dimensions. Please Select a Valid JPEG or GIF File"
End If

hBmapOrig = apiSelectObject(hdc, hStdPic)

' Create our Enhanced Metafile - Memory Based
hDCMeta = apiCreateEnhMetaFile(hDCref, vbNullString, 0&, vbNullString)

If hDCMeta = 0 Then
Err.Raise vbObjectError + 525, "CreateBitmapFromImageCtl.modStdPic", _
"Sorry...cannot Create Enhanced Metafile"
End If

' Copy the contents of our StdPicture object over
' into the Enhanced Metafile we created.
lngRet = apiBitBlt(hDCMeta, 0&, 0&, Bm.bmWidth, _
Bm.bmHeight, hdc, 0, 0, SRCCOPY)

' Cleanup our Bitmaps
If hBmapOrig <> 0 Then
lngRet = apiSelectObject(hdc, hBmapOrig)
Call apiDeleteObject(hBmap)
End If

' Delete our Memory DC
Call apiDeleteDC(hdc)

' Close EnhMetafile
If hDCMeta <> 0 Then
hMetafile = apiCloseEnhMetaFile(hDCMeta)
End If

' Grab the contents of the Metafile
lngRet = GetEnhMetaFileBits(hMetafile, 0, ByVal 0&)
ReDim arrayMeta((lngRet - 1) + 8)
lngRet = GetEnhMetaFileBits(hMetafile, lngRet, arrayMeta(8))

' Delete EMF memory footprint.
lngRet = apiDeleteEnhMetaFile(hMetafile)


arrayMeta(0) = CF_ENHMETAFILE
ctl.PictureData = arrayMeta

EXIT_SHOWPIC:
Call apiDeleteDC(hdc)
lngRet = apiReleaseDC(0&, hDCref)
Exit Function

ERR_SHOWPIC:
MsgBox Err.Description, vbOKOnly, Err.Source & ":" & Err.Number
Resume EXIT_SHOWPIC

End Function


Public Function fLoadPicture(ctl As Access.Image, Optional strfName As String = "") As Boolean

'On Error GoTo Err_fLoadPicture

' Temp Vars
Dim lngRet As Long
Dim blRet As Boolean

' Our StdPicture object returned by LoadPicture
Dim hPic As Object

' Were we passed the Optional FileName and Path
If Len(strfName & vbNullString) = 0 Then
' Call the File Common Dialog Window
Dim clsDialog As Object
Dim StrTemp As String

strfName = strfName
'clsDialog.FileName
If Len(strfName & vbNullString) = 0 Then
' Raise the exception
Err.Raise vbObjectError + 513, "CreateBitmapFromImageCtl.modStdPic", _
"الكود يعرض صور من نوع GIF أو JPG فقط ."
End If

End If

Application.Screen.MousePointer = 11

' Load the Picture as a StandardPicture object
Set hPic = LoadPicture(strfName)
If hPic = 0 Then
Err.Raise vbObjectError + 514, "CreateBitmapFromImageCtl.modStdPic", _
"الكود يعرض صور من نوع GIF أو JPG فقط ."
End If

blRet = fStdPicToImageData(hPic, ctl)

' Scroll the Form back to X:0,Y:0
ScrollToHome ctl

' Cleanup
fLoadPicture = True

Exit_LoadPic:

' Set the MousePointer back to Default
Application.Echo True
Application.Screen.MousePointer = 0
Err.Clear
Set hPic = Nothing
Set clsDialog = Nothing
Exit Function

Err_fLoadPicture:
fLoadPicture = False
MsgBox Err.Description, vbOKOnly, Err.Source & ":" & Err.Number
Resume Exit_LoadPic

End Function


Public Sub ScrollToHome(ctl As Control)
Dim lngRet As Long

' Temp counter
Dim lngTemp As Long

' Be careful because of Echo Off
On Error Resume Next

' Stop Screen Redraws
Application.Echo False

For lngTemp = 1 To 9
lngRet = SendMessage(ctl.Parent.hwnd, WM_VSCROLL, SB_PAGEUP, 0&)
lngRet = SendMessage(ctl.Parent.hwnd, WM_HSCROLL, SB_PAGELEFT, 0&)
Next lngTemp

' Start Screen Redraws
Application.Echo True

End Sub

If Me.NewRecord = True Then
الصورة.Picture = ""
Exit Sub
End If
Dim lngImageSize As Long
Dim lngOffset As Long
Dim bytChunk() As Byte
Dim intFile As Integer
Dim strTempPic As String
Const conChunkSize = 100
Dim rst As New ADODB.Recordset

rst.Open "جدول1", CurrentProject.Connection, adOpenStatic, adLockOptimistic

Dim fs
Set fs = CreateObject("Scripting.FileSystemObject")
If fs.FolderExists("C:\temp1") = False Then MkDir "C:\temp1"

strTempPic = "C:\temp1\TempPic." & [نوع الصورة]

'Open the temporary file to save the BLOB to
intFile = FreeFile
Open strTempPic For Binary As #intFile
rst.Find "[ترقيم]=" & Me![ترقيم]
lngImageSize = rst("صورة").ActualSize

Do While lngOffset < lngImageSize
bytChunk() = rst("صورة").GetChunk(conChunkSize)
Put #intFile, , bytChunk()
lngOffset = lngOffset + conChunkSize
Loop
Close #intFile
If [نوع الصورة] = "gif" Or [نوع الصورة] = "jpg" Then
fLoadPicture الصورة, strTempPic
Else
الصورة.Picture = strTempPic
End If
Kill "C:\temp1\*.*"
rst.Close