Is Null
جمعه 11 بهمن 1392, 22:12 عصر
یه چیزایی اضافی بود دیگه حذف نکردم.
موفق باشی.
Form
Private Sub mnuSaveDB_Click()
Dim rsImage As Recordset
Dim lOffset As Long
Dim lSize As Long
Dim sPath As String
Dim nHandle As Integer
Dim lSubChunks As Long
Dim Chunk() As Byte
Dim nFragmentOffset As Integer
Dim i As Integer
Dim lChunks As Long
Dim lKey As Long
Dim sSQL As String
On Error GoTo mnuSaveDB_Click_Error
'================================================= ================
'========================== To Open New Picture =========================
'================================================= ================
Dim MyPic As StdPicture
Dim FileName As String
FileName = FileDialog1(Me, False, "ÇäÊÎÇÈ ÝÇíá ÌåÊ ÐÎíÑå ÏÑ ÇíÇå ÏÇÏå", "ÝÇíá ÚßÓ|*.jpg;*.jpeg;*.gif;*.bmp;*.wmp;*.rle;*.cur; *.ico;*.emf|All Files [*.*]|*.*")
If Len(FileName) > 0 Then
On Error Resume Next
Set MyPic = LoadPicture(FileName)
If Err.Number = 0 Then
Set m_Image = New cImage
m_Image.CopyStdPicture MyPic
If mnuAutosize.Checked Then SetFormSize m_Image
AdjustScrollBars m_Image
Me.Caption = App.Title & " - " & FileTitleOnly(FileName)
mnuSave(0).Enabled = True
name1_ = FileTitleOnly(FileName)
Else
MsgBox "ÇãßÇä ÈÇÒ ÔÏä äãíÈÇÔÏ" & vbCrLf & """" & FileName & """", vbExclamation, "ãÔßá ÏÑ ÈÇÒ ÔÏä ÝÇíá"
End If
Set MyPic = Nothing
End If
If FileName <> "" Then
lKey = InputBox("áØÝÇð ßÏ ÔäÇÓÇíí ÌåÊ ËÈÊ æÇÑÏ äãÇííÏ", "ÏÑÎæÇÓÊ ßÏ ÌåÊ ÔäÇÓÇíí")
If lKey > 0 Then
sSQL = "select * from images"
sSQL = sSQL & " where myKey=" & lKey
Set rsImage = objDB.OpenRecordset(sSQL, dbOpenDynaset)
If Not rsImage.EOF Then
MsgBox "Çíä ßÏ æÌæÏ ÏÇÑÏ" & vbCrLf & """" & lKey & """", vbExclamation + vbMsgBoxRight + vbOKOnly, "ãÔßá ÏÑ ÈÇÒ ÔÏä ÝÇíá"
GoTo Exit_mnusavedb_Click
End If
Set rsImage = objDB.OpenRecordset("Images", dbOpenDynaset)
nHandle = FreeFile
Open FileName For Binary Access Read As nHandle
lSize = LOF(nHandle)
If nHandle = 0 Then
Close nHandle
End If
lChunks = lSize \ conChunkSize
nFragmentOffset = lSize Mod conChunkSize
rsImage.AddNew
rsImage("Description") = FileName
rsImage("MyKey") = lKey
ReDim Chunk(nFragmentOffset)
Get nHandle, , Chunk()
rsImage("A_Image").AppendChunk Chunk()
ReDim Chunk(conChunkSize)
lOffset = nFragmentOffset
For i = 1 To lChunks
Get nHandle, , Chunk()
rsImage("A_Image").AppendChunk Chunk()
lOffset = lOffset + conChunkSize
DoEvents
Next
rsImage.Update
MsgBox "ÚßÓ ÈÇ ßÏ ÒíÑ ËÈÊ ÔÏ" & vbCrLf & """" & lKey & """", vbInformation + vbMsgBoxRight + vbOKOnly, "ËÈÊ ÚßÓ ÏÑ ÇíÇå ÏÇÏå"
End If
End If
Exit_mnusavedb_Click:
Exit Sub
mnuSaveDB_Click_Error:
#If gnDebug Then
Stop
Resume
#End If
HandleError "mnuSaveDB_Click", Err.Description, Err.Number, gErrFormName
Resume Exit_mnusavedb_Click
End Sub
'================================================= ===============================
' AUTOSIZE WINDOW TO PICTURE
'================================================= ===============================
Public Sub SetFormSize(TheImage As cImage)
Dim NewLeft As Long
Dim NewTop As Long
Dim NewWidth As Long
Dim NewHeight As Long
If ObjPtr(TheImage) <> 0 Then
If Me.WindowState = 0 Then
If TheImage.Width > 0 And TheImage.Height > 0 Then
NewWidth = (TheImage.Width + 4) * TwipsPerPixel + 120 + PictureBoxLeft + PictureBoxRight
NewHeight = (TheImage.Height + 4) * TwipsPerPixel + 420 + PictureBoxTop + PictureBoxBottom
NewLeft = Me.Left + (Me.Width - NewWidth) \ 2
NewTop = Me.Top + (Me.Height - NewHeight) \ 2
If NewHeight > Screen.Height Then
NewTop = 0
NewHeight = Screen.Height
NewWidth = NewWidth + VScroll1.Width
Else
If NewTop < 0 Then
NewTop = 0
Else
If NewTop + NewHeight > Screen.Height Then
NewTop = Screen.Height - NewHeight
End If
End If
End If
If NewWidth > Screen.Width Then
NewLeft = 0
NewWidth = Screen.Width
Else
If NewLeft < 0 Then
NewLeft = 0
Else
If NewLeft + NewWidth > Screen.Width Then
NewLeft = Screen.Width - NewWidth
End If
End If
End If
Me.Move NewLeft, NewTop, NewWidth, NewHeight
End If
End If
End If
End Sub
'================================================= ===============================
' LINKING PICTURE TO SCROLLBARS
'================================================= ===============================
Private Sub AdjustScrollBars(TheImage As cImage)
Dim X As Long
Dim Y As Long
If ObjPtr(TheImage) = 0 Then
HScroll1.Min = 0
HScroll1.Max = 0
HScroll1.Visible = False
VScroll1.Min = 0
VScroll1.Max = 0
VScroll1.Visible = False
Else
If Picture1.Width >= VScroll1.Width + 4 * TwipsPerPixel And Picture1.Height >= HScroll1.Height + 4 * TwipsPerPixel Then
X = Picture1.Width \ TwipsPerPixel - 4
Y = Picture1.Height \ TwipsPerPixel - 4
If TheImage.Width > X Then
Y = Y - HScroll1.Height \ TwipsPerPixel
If TheImage.Height > Y Then X = X - VScroll1.Width \ TwipsPerPixel
Else
If TheImage.Height > Y Then
X = X - VScroll1.Width \ TwipsPerPixel
If TheImage.Width > X Then Y = Y - HScroll1.Height \ TwipsPerPixel
End If
End If
If TheImage.Width > X Then
HScroll1.Min = 0
HScroll1.Max = TheImage.Width - X
HScroll1.Move 0, Picture1.Height - HScroll1.Height - 4 * TwipsPerPixel, Picture1.Width - IIf(TheImage.Height > Y, VScroll1.Width, 0) - 4 * TwipsPerPixel
HScroll1.Visible = True
Else
HScroll1.Visible = False
HScroll1.Min = (TheImage.Width - Picture1.Width \ TwipsPerPixel + 4 + IIf(TheImage.Height > Y, VScroll1.Width \ TwipsPerPixel, 0)) \ 2
HScroll1.Max = HScroll1.Min
End If
If TheImage.Height > Y Then
VScroll1.Min = 0
VScroll1.Max = TheImage.Height - Y
VScroll1.Move Picture1.Width - VScroll1.Width - 4 * TwipsPerPixel, 0, VScroll1.Width, Picture1.Height - 4 * TwipsPerPixel
VScroll1.Visible = True
Else
VScroll1.Visible = False
VScroll1.Min = (TheImage.Height - Picture1.Height \ TwipsPerPixel + 4 + IIf(HScroll1.Visible, HScroll1.Height \ TwipsPerPixel, 0)) \ 2
VScroll1.Max = VScroll1.Min
End If
End If
End If
PaintImage m_Image
End Sub
Private Sub HScroll1_Change()
PaintImage m_Image
End Sub
Private Sub VScroll1_Change()
PaintImage m_Image
End Sub
Private Sub PaintImage(TheImage As cImage)
If ObjPtr(TheImage) = 0 Then
Picture1.Cls
Else
If HScroll1.Value < 0 Or VScroll1.Value < 0 Then Picture1.Cls
TheImage.PaintHDC Picture1.hDC, -HScroll1.Value, -VScroll1.Value
Picture1.Refresh
End If
End Sub
Class:
cImage.cls
Option Explicit
Option Base 0
Private Type SAFEARRAYBOUND
cElements As Long
lLbound As Long
End Type
Private Type SAFEARRAY2D
cDims As Integer
fFeatures As Integer
cbElements As Long
cLocks As Long
pvData As Long
Bounds(0 To 1) As SAFEARRAYBOUND
End Type
Private Type RGBQUAD
rgbBlue As Byte
rgbGreen As Byte
rgbRed As Byte
rgbReserved As Byte
End Type
Private Type BITMAPINFOHEADER
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 BITMAPFILEHEADER
bfType As Integer
bfSize As Long
bfReserved1 As Integer
bfReserved2 As Integer
bfOffBits As Long
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 BITMAPINFO
bmiHeader As BITMAPINFOHEADER
bmiColors(255) As RGBQUAD
End Type
Private Type POINTAPI
X As Long
Y As Long
End Type
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function CreateDIBSection2 Lib "gdi32" Alias "CreateDIBSection" (ByVal hDC As Long, pBitmapInfo As BITMAPINFO, ByVal un As Long, lplpVoid As Long, ByVal handle As Long, ByVal dw As Long) As Long
Private Declare Function CreateDCAsNull Lib "gdi32" Alias "CreateDCA" (ByVal lpDriverName As String, lpDeviceName As Any, lpOutput As Any, lpInitData As Any) As Long
Private Declare Function BitBlt Lib "gdi32" (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 SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function LoadImage Lib "user32" Alias "LoadImageA" (ByVal hInst As Long, ByVal lpsz As String, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
Private Declare Function GetDIBColorTable Lib "gdi32" (ByVal hDC As Long, ByVal un1 As Long, ByVal un2 As Long, pRGBQuad As RGBQUAD) As Long
Private Declare Function SetDIBColorTable Lib "gdi32" (ByVal hDC As Long, ByVal un1 As Long, ByVal un2 As Long, pcRGBQuad As RGBQUAD) As Long
Private Declare Function GetDIBits256 Lib "gdi32" Alias "GetDIBits" (ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
Private Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function VarPtrArray Lib "msvbvm60.dll" Alias "VarPtr" (Ptr() As Any) As Long
Private Declare Function SetStretchBltMode Lib "gdi32" (ByVal hDC As Long, ByVal nStretchMode As Long) As Long
Private Declare Function StretchBlt Lib "gdi32" (ByVal hDC 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 nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
Private Declare Function PlgBlt Lib "gdi32" (ByVal hdcDest As Long, lpPoint As POINTAPI, ByVal hdcSrc As Long, ByVal nXSrc As Long, ByVal nYSrc As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hbmMask As Long, ByVal xMask As Long, ByVal yMask As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)
Private Const BLACKONWHITE As Long = 1
Private Const COLORONCOLOR As Long = 3
Private Const HALFTONE As Long = 4
Private Const BI_RGB As Long = 0&
Private Const BI_RLE4 As Long = 2&
Private Const BI_RLE8 As Long = 1&
Private Const DIB_RGB_COLORS As Long = 0
Private m_hDIb As Long
Private m_hBmpOld As Long
Private m_hDC As Long
Private m_Ptr As Long
Private m_BI As BITMAPINFO
Private m_RGB(255) As RGBQUAD
Private Sub Clear()
If (m_hDC <> 0) Then
If (m_hDIb <> 0) Then
SelectObject m_hDC, m_hBmpOld
DeleteObject m_hDIb
End If
DeleteObject m_hDC
End If
m_hDC = 0
m_hDIb = 0
m_hBmpOld = 0
m_Ptr = 0
End Sub
Private Sub Class_Terminate()
Clear
End Sub
'================================================= ===================================
' LOAD/COPY IMAGE
'================================================= ===================================
Public Function CopyStdPicture(ByRef TheStdPicture As StdPicture, Optional iBitCount As Integer) As Boolean
Dim lHDC As Long
Dim lhDCDesktop As Long
Dim lhBmpOld As Long
Dim tBMP As BITMAP
Dim CopyPalette As Boolean
GetObjectAPI TheStdPicture.handle, Len(tBMP), tBMP
CopyPalette = (iBitCount = 0)
If CopyPalette Then
iBitCount = tBMP.bmBitsPixel
If iBitCount = 16 Then iBitCount = 24
End If
If Not Create(tBMP.bmWidth, tBMP.bmHeight, iBitCount) Then Exit Function
If m_BI.bmiHeader.biBitCount = 24 Then
lhDCDesktop = GetDC(GetDesktopWindow())
Else
lhDCDesktop = CreateDCAsNull("DISPLAY", ByVal 0&, ByVal 0&, ByVal 0&)
End If
If lhDCDesktop = 0 Then Exit Function
lHDC = CreateCompatibleDC(lhDCDesktop)
DeleteDC lhDCDesktop
If lHDC = 0 Then Exit Function
lhBmpOld = SelectObject(lHDC, TheStdPicture.handle)
If m_BI.bmiHeader.biBitCount = 24 Then
BitBlt m_hDC, 0, 0, m_BI.bmiHeader.biWidth, m_BI.bmiHeader.biHeight, lHDC, 0, 0, vbSrcCopy
Else
If CopyPalette Then
Dim lC As Long
Dim C2 As Long
C2 = 2 ^ m_BI.bmiHeader.biBitCount
lC = GetDIBColorTable(lHDC, 0, C2, m_RGB(0))
If (lC > 0) Then SetDIBColorTable m_hDC, 0, lC, m_RGB(0)
End If
GetDIBits256 lHDC, TheStdPicture.handle, 0, tBMP.bmHeight, ByVal m_Ptr, m_BI, DIB_RGB_COLORS
End If
SelectObject lHDC, lhBmpOld
DeleteObject lHDC
CopyStdPicture = True
End Function
'================================================= ===================================
' DIMENSION / COLOR DEPTH
'================================================= ===================================
Public Function Create(lWidth As Long, lHeight As Long, iBitCount As Integer) As Boolean
Clear
Select Case iBitCount
Case 24
m_hDC = CreateCompatibleDC(0)
Case 1, 4, 8
Dim lHDCDesk As Long
lHDCDesk = CreateDCAsNull("DISPLAY", ByVal 0&, ByVal 0&, ByVal 0&)
m_hDC = CreateCompatibleDC(lHDCDesk)
DeleteDC lHDCDesk
End Select
If m_hDC = 0 Then Exit Function
With m_BI.bmiHeader
.biSize = Len(m_BI.bmiHeader)
.biWidth = lWidth
.biHeight = lHeight
.biPlanes = 1
.biBitCount = iBitCount
.biCompression = BI_RGB
.biSizeImage = BytesPerScanLine * .biHeight
End With
If iBitCount <> 24 Then
Dim i As Long
Dim c As Long
c = 2 ^ iBitCount - 1
For i = 0 To c
With m_BI.bmiColors(i)
.rgbBlue = i * 255# / c
.rgbGreen = .rgbBlue
.rgbRed = .rgbBlue
End With
Next i
End If
m_hDIb = CreateDIBSection2(m_hDC, m_BI, DIB_RGB_COLORS, m_Ptr, 0, 0)
If m_hDIb = 0 Then
DeleteObject m_hDC
Else
m_hBmpOld = SelectObject(m_hDC, m_hDIb)
Create = True
End If
End Function
Public Property Get BytesPerScanLine() As Long
Select Case m_BI.bmiHeader.biBitCount
Case 1: BytesPerScanLine = ((m_BI.bmiHeader.biWidth - 1) \ 8 + 4) And &HFFFFFFFC
Case 4: BytesPerScanLine = ((m_BI.bmiHeader.biWidth - 1) \ 2 + 4) And &HFFFFFFFC
Case 8: BytesPerScanLine = (m_BI.bmiHeader.biWidth + 3) And &HFFFFFFFC
Case Else: BytesPerScanLine = (m_BI.bmiHeader.biWidth * 3 + 3) And &HFFFFFFFC
End Select
End Property
'================================================= ===================================
' PUBLIC PROPERTIES
'================================================= ===================================
Public Property Get Width() As Long
Width = m_BI.bmiHeader.biWidth
End Property
Public Property Get Height() As Long
Height = m_BI.bmiHeader.biHeight
End Property
Public Sub PaintHDC(lHDC As Long, Optional lDestLeft As Long, Optional lDestTop As Long, Optional eRop As RasterOpConstants = vbSrcCopy)
BitBlt lHDC, lDestLeft, lDestTop, m_BI.bmiHeader.biWidth, m_BI.bmiHeader.biHeight, m_hDC, 0, 0, eRop
End Sub
Module:
mCommon.bas
Option Explicit
Private Type OPENFILENAME
lStructSize As Long
hwndOwner 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 Type BrowseInfo
hwndOwner As Long
pIDLRoot As Long
pszDisplayName As Long
lpszTitle As Long
ulFlags As Long
lpfnCallback As Long
lParam As Long
iImage As Long
End Type
Private Const OFN_READONLY As Long = &H1
Private Const OFN_OVERWRITEPROMPT As Long = &H2
Private Const OFN_HIDEREADONLY As Long = &H4
Private Const OFN_NOCHANGEDIR As Long = &H8
Private Const OFN_SHOWHELP As Long = &H10
Private Const OFN_ENABLEHOOK As Long = &H20
Private Const OFN_ENABLETEMPLATE As Long = &H40
Private Const OFN_ENABLETEMPLATEHANDLE As Long = &H80
Private Const OFN_NOVALIDATE As Long = &H100
Private Const OFN_ALLOWMULTISELECT As Long = &H200
Private Const OFN_EXTENSIONDIFFERENT As Long = &H400
Private Const OFN_PATHMUSTEXIST As Long = &H800
Private Const OFN_FILEMUSTEXIST As Long = &H1000
Private Const OFN_CREATEPROMPT As Long = &H2000
Private Const OFN_SHAREAWARE As Long = &H4000
Private Const OFN_NOREADONLYRETURN As Long = &H8000
Private Const OFN_NOTESTFILECREATE As Long = &H10000
Private Const OFN_NONETWORKBUTTON As Long = &H20000
Private Const OFN_NOLONGNAMES As Long = &H40000
Private Const OFN_EXPLORER As Long = &H80000
Private Const OFN_NODEREFERENCELINKS As Long = &H100000
Private Const OFN_LONGNAMES As Long = &H200000
Private Const OFN_SHAREFALLTHROUGH As Long = 2
Private Const OFN_SHARENOWARN As Long = 1
Private Const OFN_SHAREWARN As Long = 0
Private Const BrowseForFolders As Long = &H1
Private Const BrowseForComputers As Long = &H1000
Private Const BrowseForPrinters As Long = &H2000
Private Const BrowseForEverything As Long = &H4000
Private Const CSIDL_BITBUCKET As Long = 10
Private Const CSIDL_CONTROLS As Long = 3
Private Const CSIDL_DESKTOP As Long = 0
Private Const CSIDL_DRIVES As Long = 17
Private Const CSIDL_FONTS As Long = 20
Private Const CSIDL_NETHOOD As Long = 18
Private Const CSIDL_NETWORK As Long = 19
Private Const CSIDL_PERSONAL As Long = 5
Private Const CSIDL_PRINTERS As Long = 4
Private Const CSIDL_PROGRAMS As Long = 2
Private Const CSIDL_RECENT As Long = 8
Private Const CSIDL_SENDTO As Long = 9
Private Const CSIDL_STARTMENU As Long = 11
Private Const MAX_PATH As Long = 260
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 Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32" (lpBI As BrowseInfo) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
Private Declare Function SHGetSpecialFolderLocation Lib "shell32" (ByVal hwndOwner As Long, ByVal nFolder As Long, ListId As Long) As Long
Private Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Private Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Private Declare Function GetTempFileName Lib "kernel32" Alias "GetTempFileNameA" (ByVal lpszPath As String, ByVal lpPrefixString As String, ByVal wUnique As Long, ByVal lpTempFileName As String) As Long
Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
Private Declare Function GetModuleFileName Lib "kernel32" Alias "GetModuleFileNameA" (ByVal hModule As Long, ByVal lpFileName As String, ByVal nSize As Long) As Long
Private Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long
Public Declare Function GetTickCount Lib "kernel32" () As Long
Public Function FileDialog1(FormObject As Form, SaveAsDialog As Boolean, ByVal Title As String, ByVal Filter As String, Optional ByVal SaveAsFileName As String, Optional ByVal Extention As String, Optional ByVal InitDir As String) As String
Dim OFN As OPENFILENAME
Dim r As Long
FormObject.Enabled = False
SaveAsFileName = SaveAsFileName + String(MAX_PATH - Len(SaveAsFileName), 0)
With OFN
.lStructSize = Len(OFN)
.hwndOwner = FormObject.hWnd
.hInstance = App.hInstance
.lpstrFilter = Replace(Filter, "|", vbNullChar)
.lpstrFile = SaveAsFileName
.nMaxFile = MAX_PATH
.lpstrFileTitle = Space$(MAX_PATH - 1)
.nMaxFileTitle = MAX_PATH
.lpstrInitialDir = InitDir
.lpstrTitle = Title
.flags = OFN_HIDEREADONLY Or OFN_OVERWRITEPROMPT Or OFN_CREATEPROMPT
.lpstrDefExt = Extention
End With
Dim L As Long
L = GetTickCount
If SaveAsDialog Then r = GetSaveFileName(OFN) Else r = GetOpenFileName(OFN)
If GetTickCount - L < 20 Then
OFN.lpstrFile = ""
If SaveAsDialog Then r = GetSaveFileName(OFN) Else r = GetOpenFileName(OFN)
End If
If r = 1 Then FileDialog1 = Left$(OFN.lpstrFile, InStr(1, OFN.lpstrFile + vbNullChar, vbNullChar) - 1)
FormObject.Enabled = True
End Function
Public Function FileTitleOnly(FileName As String, Optional ReturnDirectory As Boolean) As String
If ReturnDirectory Then
FileTitleOnly = Left$(FileName, InStrRev(FileName, "\"))
Else
FileTitleOnly = Right$(FileName, Len(FileName) - InStrRev(FileName, "\"))
End If
End Function
vBulletin® v4.2.5, Copyright ©2000-1404, Jelsoft Enterprises Ltd.