c++,vb,Delphi,Ebook,java,c#,Download,Rapidshare,Programing,php,pdf,آموزش ,برنامه نويسي,وي بي,دلفي,كتاب الكترونيك,كتاب

AVIفرمت فايل

سلام

واقعا كسي كنكور سراسري كامپيوتر قبول نشده!!توي پست قبل كه خاسته بودم حداقل رتبه كشوري

براي قبول شدن رو كسي چيزي ننوشته بود.خواهش مي كنم من به اين اطلاعات براي برنامه ريزي احتياج دارم

پست امروز مربوط به فرمت فايل اي وي آي هست

در ضمن شايد تا مدت نا معلومي نتونم پست كنم

زياد طولش نمي دم كه وبلاگ پر بشه دو تا كلاس و يه ما ژول به پروژه اضافه كنيد واين گوني هارو توش كپي كنيد

يه ليست كه بايد توش رو پر كنيد از آدرس فايل هاي تصويري و يه دكمه براي شروع ذخيره سازي

كد كلاس ها

'نام كلاس=cFileDlg
Option Explicit
Private Const MAX_PATH = 1024
Private Const MAX_FILE = 512
Public Enum SPECIAL_FOLDERS
      vbCSIDL_DESKTOP = &H0&
      vbCSIDL_CONTROLS = &H3&
      vbCSIDL_PRINTERS = &H4&
      vbCSIDL_PERSONAL = &H5&
      vbCSIDL_FAVORITES = &H6&
      vbCSIDL_STARTUP = &H7&
      vbCSIDL_RECENT = &H8&
      vbCSIDL_SENDTO = &H9&
      vbCSIDL_BITBUCKET = &HA&
      vbCSIDL_STARTMENU = &HB&
      vbCSIDL_DESKTOPDIRECTORY = &H10&
      vbCSIDL_DRIVES = &H11&
      vbCSIDL_NETWORK = &H12&
      vbCSIDL_NETHOOD = &H13&
      vbCSIDL_FONTS = &H14&
      vbCSIDL_TEMPLATES = &H15&
End Enum
Private Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" _
                                                (ByVal hWndOwner As Long, _
                                                ByVal nFolder As SPECIAL_FOLDERS, _
                                                pidl As Long) As Long

Private Declare Function SHGetPathFromIDList Lib "shell32.dll" _
   Alias "SHGetPathFromIDListA" _
  (ByVal pidl As Long, _
   ByVal pszPath As String) As Long
Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long)
Private Const NOERROR As Long = &H0
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 Long
End Type
Private Declare Function GetOpenFileName Lib "COMDLG32" _
                         Alias "GetOpenFileNameA" _
                         (filestruct As OPENFILENAME) As Long
Private Declare Function GetSaveFileName Lib "COMDLG32" _
                Alias "GetSaveFileNameA" _
                (filestruct As OPENFILENAME) As Long
Private Declare Function GetFileTitle Lib "COMDLG32" _
     Alias "GetFileTitleA" _
    (ByVal szFile As String, _
     ByVal szTitle As String, _
     ByVal cbBuf As Integer) As Integer '-------------------------------------
Private Declare Function GetOpenFileNamePreview Lib "MSVFW32" _
                                  Alias "GetOpenFileNamePreviewA" _
                                 (filestruct As OPENFILENAME) As Long
Private Declare Function GetSaveFileNamePreview Lib "MSVFW32" _
           Alias "GetSaveFileNamePreviewA" _
           (filestruct As OPENFILENAME) As Long '-----------------------------

Public Enum EOpenFile
    OFN_READONLY = &H1&
    OFN_OVERWRITEPROMPT = &H2&
    OFN_HIDEREADONLY = &H4&
    OFN_NOCHANGEDIR = &H8&
    OFN_SHOWHELP = &H10&
    OFN_ENABLEHOOK = &H20&
    OFN_ENABLETEMPLATE = &H40&
    OFN_ENABLETEMPLATEHANDLE = &H80&
    OFN_NOVALIDATE = &H100&
    OFN_ALLOWMULTISELECT = &H200&
    OFN_EXTENSIONDIFFERENT = &H400&
    OFN_PATHMUSTEXIST = &H800&
    OFN_FILEMUSTEXIST = &H1000&
    OFN_CREATEPROMPT = &H2000&
    OFN_SHAREAWARE = &H4000&
    OFN_NOREADONLYRETURN = &H8000&
    OFN_NOTESTFILECREATE = &H10000
    OFN_NONETWORKBUTTON = &H20000
    OFN_NOLONGNAMES = &H40000
    OFN_EXPLORER = &H80000
    OFN_NODEREFERENCELINKS = &H100000
    OFN_LONGNAMES = &H200000
End Enum
Private Declare Function CommDlgExtendedError Lib "COMDLG32" () As Long
Public Enum EDialogError
    CDERR_DIALOGFAILURE = &HFFFF&
    CDERR_GENERALCODES = &H0&
    CDERR_STRUCTSIZE = &H1&
    CDERR_INITIALIZATION = &H2&
    CDERR_NOTEMPLATE = &H3&
    CDERR_NOHINSTANCE = &H4&
    CDERR_LOADSTRFAILURE = &H5&
    CDERR_FINDRESFAILURE = &H6&
    CDERR_LOADRESFAILURE = &H7&
    CDERR_LOCKRESFAILURE = &H8&
    CDERR_MEMALLOCFAILURE = &H9&
    CDERR_MEMLOCKFAILURE = &HA&
    CDERR_NOHOOK = &HB&
    CDERR_REGISTERMSGFAIL = &HC&

PDERR_PRINTERCODES = &H1000&
    PDERR_SETUPFAILURE = &H1001&
    PDERR_PARSEFAILURE = &H1002&
    PDERR_RETDEFFAILURE = &H1003&
    PDERR_LOADDRVFAILURE = &H1004&
    PDERR_GETDEVMODEFAIL = &H1005&
    PDERR_INITFAILURE = &H1006&
    PDERR_NODEVICES = &H1007&
    PDERR_NODEFAULTPRN = &H1008&
    PDERR_DNDMMISMATCH = &H1009&
    PDERR_CREATEICFAILURE = &H100A&
    PDERR_PRINTERNOTFOUND = &H100B&
    PDERR_DEFAULTDIFFERENT = &H100C&
    CFERR_CHOOSEFONTCODES = &H2000&
    CFERR_NOFONTS = &H2001&
    CFERR_MAXLESSTHANMIN = &H2002&
    FNERR_FILENAMECODES = &H3000&
    FNERR_SUBCLASSFAILURE = &H3001&
    FNERR_INVALIDFILENAME = &H3002&
    FNERR_BUFFERTOOSMALL = &H3003&
    CCERR_CHOOSECOLORCODES = &H5000&
End Enum
Private Const sEmpty      As String = ""
Private m_FileMustExist   As Boolean
Private m_MultiSelect     As Boolean
Private m_ReadOnly        As Boolean
Private m_HideReadOnly    As Boolean
Private m_Filter          As String
Private m_FilterIndex     As Long
Private m_InitDir         As String
Private m_DlgTitle        As String
Private m_DefaultExt      As String
Private m_Flags           As Long
Private m_OverwritePrompt As Boolean
Private m_hWnd            As Long
Private Sub Class_Initialize()
m_hWnd = -1&
m_FileMustExist = True
m_MultiSelect = False
m_HideReadOnly = True
m_DlgTitle = App.title
m_OverwritePrompt = True
m_InitDir = GetSpecialFolderLocation(vbCSIDL_PERSONAL) 'default to My Documents folder
End Sub
Property Get OwnerHwnd() As Long
    OwnerHwnd = m_hWnd
End Property
Property Let OwnerHwnd(ByVal vHwnd As Long)
    m_hWnd = vHwnd
End Property
Property Get FileMustExist() As Boolean
    FileMustExist = m_FileMustExist
End Property
Property Let FileMustExist(ByVal vNewValue As Boolean)
    m_FileMustExist = vNewValue
End Property
Property Get MultiSelect() As Boolean
    MultiSelect = m_MultiSelect
End Property
Property Let MultiSelect(ByVal vNewValue As Boolean)
    m_MultiSelect = vNewValue
End Property
Property Get ReadOnly() As Boolean
    ReadOnly = m_ReadOnly
End Property
Property Get HideReadOnly() As Boolean
    HideReadOnly = m_HideReadOnly
End Property
Property Let HideReadOnly(ByVal vNewValue As Boolean)
    m_HideReadOnly = vNewValue
End Property
Property Get Filter() As String
    Filter = m_Filter
End Property
Property Let Filter(ByVal vFilterString As String)
    m_Filter = vFilterString
End Property
Property Get FilterIndex() As Long
    FilterIndex = m_FilterIndex
End Property
Property Let FilterIndex(ByVal vIndex As Long)
    m_FilterIndex = vIndex
End Property
Property Get InitDirectory() As String
    InitDirectory = m_InitDir
End Property
Property Let InitDirectory(ByVal DirPath As String)
    m_InitDir = DirPath
End Property
Property Let InitDirectorySpecial(ByVal SpecialDirectory As SPECIAL_FOLDERS)
    m_InitDir = GetSpecialFolderLocation(SpecialDirectory)
End Property
Property Get DlgTitle() As String
    DlgTitle = m_DlgTitle
End Property
Property Let DlgTitle(ByVal title As String)
    m_DlgTitle = title
End Property
Property Get DefaultExt() As String
    DefaultExt = m_DefaultExt
End Property
Property Let DefaultExt(ByVal fileExt As String)
    m_DefaultExt = fileExt
End Property
Property Get Flags() As EOpenFile
    Flags = m_Flags
End Property
Property Let Flags(ByVal vFlags As EOpenFile)
    m_Flags = vFlags
End Property
Property Get OverwritePrompt() As Boolean
    OverwritePrompt = m_OverwritePrompt
End Property
Property Let OverwritePrompt(ByVal vShowPrompt As Boolean)
    m_OverwritePrompt = vShowPrompt
End Property
Public Function VBGetOpenFileName(filename As String, _
                           Optional FileTitle As String) As Boolean

Dim opfile  As OPENFILENAME
    Dim s       As String
    Dim afFlags As Long
    Dim ch      As String
    Dim i       As Integer
    With opfile
    .lStructSize = Len(opfile)
            .Flags = (-m_FileMustExist * OFN_FILEMUSTEXIST) Or _
             (-m_MultiSelect * OFN_ALLOWMULTISELECT) Or _
             (-m_ReadOnly * OFN_READONLY) Or _
             (-m_HideReadOnly * OFN_HIDEREADONLY) Or _
             (m_Flags And CLng(Not (OFN_ENABLEHOOK Or _
                                  OFN_ENABLETEMPLATE)))
      If m_hWnd <> -1 Then .hWndOwner = m_hWnd
       .lpstrInitialDir = m_InitDir
        .lpstrDefExt = m_DefaultExt
        .lpstrTitle = m_DlgTitle
        For i = 1 To Len(Filter)
        ch = Mid$(Filter, i, 1)
        If ch = "|" Or ch = ":" Then
            s = s & vbNullChar
        Else
            s = s & ch
        End If
    Next
        s = s & vbNullChar & vbNullChar
    .lpstrFilter = s
    .nFilterIndex = m_FilterIndex
        s = filename & String$(MAX_PATH - Len(filename), 0)
    .lpstrFile = s
    .nMaxFile = MAX_PATH
    s = FileTitle & String$(MAX_FILE - Len(FileTitle), 0)
    .lpstrFileTitle = s
    .nMaxFileTitle = MAX_FILE
    
    If GetOpenFileNamePreview(opfile) Then
        VBGetOpenFileNamePreview = True
        filename = left$(.lpstrFile, InStr(.lpstrFile, vbNullChar) - 1)
        FileTitle = left$(.lpstrFileTitle, InStr(.lpstrFileTitle, vbNullChar) - 1)
        m_Flags = .Flags
               m_FilterIndex = .nFilterIndex
               m_Filter = FilterLookup(.lpstrFilter, m_FilterIndex)
        If (.Flags And OFN_READONLY) Then m_ReadOnly = True
               m_InitDir = .lpstrFile
    Else
        VBGetOpenFileNamePreview = False
        filename = vbNullChar
        FileTitle = vbNullChar
        Flags = 0
        FilterIndex = -1
        Filter = vbNullChar
    End If
End With
End Function
Public Function VBGetSaveFileName(filename As String, _
                           Optional FileTitle As String) As Boolean
            
    Dim opfile As OPENFILENAME, s As String
With opfile
    .lStructSize = Len(opfile)
        .Flags = (-m_OverwritePrompt * OFN_OVERWRITEPROMPT) Or _
             OFN_HIDEREADONLY Or _
             (m_Flags And CLng(Not (OFN_ENABLEHOOK Or _
                                  OFN_ENABLETEMPLATE)))
        If m_hWnd <> -1 Then .hWndOwner = m_hWnd
       .lpstrInitialDir = m_InitDir
       .lpstrDefExt = m_DefaultExt
        .lpstrTitle = m_DlgTitle
            Dim ch As String, i As Integer
    For i = 1 To Len(Filter)
        ch = Mid$(Filter, i, 1)
        If ch = "|" Or ch = ":" Then
            s = s & vbNullChar
        Else
            s = s & ch
        End If
    Next
        s = s & vbNullChar & vbNullChar
    .lpstrFilter = s
    .nFilterIndex = m_FilterIndex
    s = filename & String$(MAX_PATH - Len(filename), 0)
    .lpstrFile = s
    .nMaxFile = MAX_PATH
    s = FileTitle & String$(MAX_FILE - Len(FileTitle), 0)
    .lpstrFileTitle = s
    .nMaxFileTitle = MAX_FILE
       If GetSaveFileName(opfile) Then
        VBGetSaveFileName = True
        filename = left$(.lpstrFile, InStr(.lpstrFile, vbNullChar) - 1)
        FileTitle = left$(.lpstrFileTitle, InStr(.lpstrFileTitle, vbNullChar) - 1)
        m_Flags = .Flags
               m_FilterIndex = .nFilterIndex
                m_Filter = FilterLookup(.lpstrFilter, FilterIndex)
                m_InitDir = .lpstrFile
    Else
        VBGetSaveFileName = False
        filename = vbNullChar
        FileTitle = vbNullChar
        m_Flags = 0
        m_FilterIndex = 0
        m_Filter = vbNullChar
    End If
End With
End Function
Private Function FilterLookup(ByVal sFilters As String, ByVal iCur As Long) As String
    Dim iStart As Long
    Dim iEnd   As Long
    Dim s      As String
        iStart = 1
    If sFilters = vbNullChar Then Exit Function
    Do
         iEnd = InStr(iStart, sFilters, vbNullChar)
        If iEnd = 0 Then Exit Function
        iEnd = InStr(iEnd + 1, sFilters, vbNullChar)
        If iEnd Then
            s = Mid$(sFilters, iStart, iEnd - iStart)
        Else
            s = Mid$(sFilters, iStart)
        End If
        iStart = iEnd + 1
        If iCur = 1 Then
            FilterLookup = s
            Exit Function
        End If
        iCur = iCur - 1
    Loop While iCur
End Function

Private Function StrZToStr(s As String) As String
    Dim TempString As String
    
    TempString = left$(s, InStr(s, vbNullChar) - 1)
    If TempString = "" Then
                StrZToStr = s
    Else
        StrZToStr = TempString
    End If
End Function
Private Function GetSpecialFolderLocation(CSIDL As SPECIAL_FOLDERS) As String
   Dim sPath As String
   Dim pidl  As Long
       If SHGetSpecialFolderLocation(m_hWnd, CSIDL, pidl) = NOERROR Then
          sPath = Space$(MAX_PATH)
      
      If SHGetPathFromIDList(ByVal pidl, ByVal sPath) Then
                 Call CoTaskMemFree(ByVal VarPtr(pidl))
         GetSpecialFolderLocation = left(sPath, InStr(sPath, Chr$(0)) - 1)
         End If
        End If
   End Function
Public Function ExistFile(ByVal sSpec As String) As Boolean
    On Error Resume Next
    Call FileLen(sSpec)
    ExistFile = (Err = 0)
End Function
Public Function VBGetFileTitle(sFile As String) As String
    Dim sFileTitle As String, cFileTitle As Integer
    cFileTitle = MAX_PATH
    sFileTitle = String$(MAX_PATH, 0)
    cFileTitle = GetFileTitle(sFile, sFileTitle, MAX_PATH)
    If cFileTitle Then
        VBGetFileTitle = ""
    Else
        VBGetFileTitle = left$(sFileTitle, InStr(sFileTitle, vbNullChar) - 1)
    End If
End Function

'نام كلاس =cDIB
Option Explicit
Private Type RGBQUAD
    Red As Byte
    Green As Byte
    Blue As Byte
    Reserved 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 Const BI_RGB  As Long = 0&
Private m_memBits() As Byte
Private m_memBitmapInfo() As Byte
Private m_bih As BITMAPINFOHEADER
Private m_bfh As BITMAPFILEHEADER
Public Function CreateFromPackedDIBPointer(ByRef pDIB As Long) As Boolean
Debug.Assert pDIB <> 0
Call CopyMemory(ByVal VarPtr(m_bih.biSize), ByVal pDIB, Len(m_bih))
If m_bih.biBitCount < 16 Then
    Debug.Print "Error! DIB was less than 16 colors."
    Exit Function
End If
If m_bih.biSizeImage < 1 Then Exit Function
ReDim m_memBits(0 To m_bih.biSizeImage - 1)
Call CopyMemory(m_memBits(0), ByVal pDIB + 40, m_bih.biSizeImage)
ReDim m_memBitmapInfo(0 To 39)
Call CopyMemory(m_memBitmapInfo(0), m_bih, Len(m_bih))
With m_bfh
    .bfType = BMP_MAGIC_COOKIE
    .bfSize = 55 + m_bih.biSizeImage
    .bfReserved1 = 0&
    .bfReserved2 = 0&
    .bfOffBits = 54
End With
CreateFromPackedDIBPointer = True
End Function
Public Function CreateFromFile(ByVal filename As String) As Boolean
    Dim hFile As Long
        If Not ExistFile(filename) Then
        MsgBox "File does not exist:" & vbCrLf & filename, vbCritical, App.title
        Exit Function
    End If
    hFile = FreeFile()
    On Error Resume Next
    Open filename For Binary Access Read As #hFile
    If Err Then
        If Err.Number = 70 Then
            MsgBox "File is locked - cannot access:" & vbCrLf & filename, vbCritical, App.title
        Else
            MsgBox Err.Description, vbInformation, App.title
        End If
        Exit Function
    End If
    On Error GoTo 0
    Get #hFile, , m_bfh
    If m_bfh.bfType <> BMP_MAGIC_COOKIE Then
        MsgBox "File is not a supported bitmap format:" & vbCrLf & filename, vbInformation, App.title
        Close #hFile
        Exit Function
    Else
                Get #hFile, Len(m_bfh) + 1, m_bih
                       ReDim m_memBits(0 To m_bih.biSizeImage - 1)
        Get #hFile, m_bfh.bfOffBits + 1, m_memBits
        ReDim m_memBitmapInfo(0 To m_bfh.bfOffBits - 14)
        Get #hFile, Len(m_bfh) + 1, m_memBitmapInfo
        Close #hFile
    End If
    CreateFromFile = True
    End Function
Public Function WriteToFile(ByVal filename As String) As Boolean
Dim hFile As Integer
On Error Resume Next
hFile = FreeFile()
Open filename For Binary As hFile
    Put hFile, 1, m_bfh
    Put hFile, Len(m_bfh) + 1, m_memBitmapInfo
    Put hFile, , m_memBits
Close hFile
WriteToFile = True
End Function
Private Function ExistFile(ByVal sSpec As String) As Boolean
    On Error Resume Next
    Call FileLen(sSpec)
    ExistFile = (Err = 0)
End Function
Public Property Get BitCount() As Long
    BitCount = m_bih.biBitCount
End Property
Public Property Get Height() As Long
    Height = m_bih.biHeight
End Property
Public Property Get Width() As Long
    Width = m_bih.biWidth
End Property
Public Property Get Compression() As Long
    Compression = m_bih.biCompression
End Property
Public Property Get SizeInfoHeader() As Long
    SizeInfoHeader = m_bih.biSize
End Property
Public Property Get SizeImage() As Long
    SizeImage = m_bih.biSizeImage
End Property
Public Property Get Planes() As Long
    Planes = m_bih.biPlanes
End Property
Public Property Get ClrImportant() As Long
    ClrImportant = m_bih.biClrImportant
End Property
Public Property Get ClrUsed() As Long
    ClrUsed = m_bih.biClrUsed
End Property
Public Property Get XPPM() As Long
    XPPM = m_bih.biXPelsPerMeter
End Property
Public Property Get YPPM() As Long
    YPPM = m_bih.biYPelsPerMeter
End Property
Public Property Get FileType() As Long
    FileType = m_bfh.bfType
End Property
Public Property Get SizeFileHeader() As Long
    SizeFileHeader = m_bfh.bfSize
End Property
Public Property Get BitOffset() As Long
    BitOffset = m_bfh.bfOffBits
End Property
Public Property Get PointerToBits() As Long
    PointerToBits = VarPtr(m_memBits(0))
End Property
Public Property Get PointerToBitmapInfo() As Long
    PointerToBitmapInfo = VarPtr(m_memBitmapInfo(0))
End Property
Public Property Get SizeBitmapInfo() As Long
    SizeBitmapInfo = UBound(m_memBitmapInfo()) + 1
End Property

كد ماژول

Option Explicit
Private Declare Function GetSystemDirectory Lib "kernel32" Alias _
                        "GetSystemDirectoryA" (ByVal lpBuffer As String, _
                                               ByVal nSize As Long) As Long
Public Declare Function AVIFileInfo Lib "avifil32.dll" _
                    (ByVal pfile As Long, _
                    pfi As AVI_FILE_INFO, _
                    ByVal lSize As Long) As Long 'HRESULT
Public Declare Function AVIFileCreateStream Lib _
                                        "avifil32.dll" Alias "AVIFileCreateStreamA" _
                                        (ByVal pfile As Long, _
                                         ByRef ppavi As Long, _
                                         ByRef psi As AVI_STREAM_INFO) As Long
Public Declare Function mmioStringToFOURCC Lib "winmm.dll" Alias _
          "mmioStringToFOURCCA" (ByVal sz As String, ByVal uFlags As Long) As Long 'returns fourcc
Public Declare Function VideoForWindowsVersion Lib "msvfw32.dll" () As Long
Public Declare Function AVIFileOpen Lib "avifil32.dll" _
       (ByRef ppfile As Long, _
        ByVal szFile As String, _
        ByVal uMode As Long, _
        ByVal pclsidHandler As Long) As Long  'HRESULT
Public Declare Function AVISaveOptions Lib "avifil32.dll" (ByVal hWnd As Long, _
                        ByVal uiFlags As Long, _
                        ByVal nStreams As Long, _
                        ByRef ppavi As Long, _
                        ByRef ppOptions As Long) As Long 'TRUE if user pressed OK, False if cancel, or error if error
Public Declare Sub AVIFileInit Lib "avifil32.dll" ()
Public Declare Function AVISave Lib "avifil32.dll" Alias "AVISaveVA" (ByVal szFile As String, _
           ByVal pclsidHandler As Long, _
           ByVal lpfnCallback As Long, _
           ByVal nStreams As Long, _
           ByRef ppaviStream As Long, _
           ByRef ppCompOptions As Long) As Long
Public Declare Function AVISaveOptionsFree Lib "avifil32.dll" (ByVal nStreams As Long, _
                     ByRef ppOptions As Long) As Long
Public Declare Function AVIMakeCompressedStream Lib "avifil32.dll" (ByRef ppsCompressed As Long, _
                        ByVal psSource As Long, _
                        ByRef lpOptions As AVI_COMPRESS_OPTIONS, _
                        ByVal pclsidHandler As Long) As Long '
Public Declare Function AVIStreamWrite Lib "avifil32.dll" (ByVal pavi As Long, _
                 ByVal lStart As Long, _
                 ByVal lSamples As Long, _
                 ByVal lpBuffer As Long, _
                 ByVal cbBuffer As Long, _
                 ByVal dwFlags As Long, _
                 ByRef plSampWritten As Long, _
                 ByRef plBytesWritten As Long) As Long
Public Declare Function AVIStreamSetFormat Lib "avifil32.dll" (ByVal pavi As Long, _
          ByVal lPos As Long, _
          ByRef lpFormat As Any, _
          ByVal cbFormat As Long) As Long
Public Declare Function AVIStreamGetFrameOpen Lib "avifil32.dll" (ByVal pAVIStream As Long, _
                                   ByRef bih As Any) As Long
Public Declare Function AVIStreamReadFormat Lib "avifil32.dll" (ByVal pAVIStream As Long, _
                    ByVal lPos As Long, _
                    ByVal lpFormatBuf As Long, _
                    ByRef sizeBuf As Long) As Long
Public Declare Function AVIStreamRead Lib "avifil32.dll" (ByVal pAVIStream As Long, _
                                                            ByVal lStart As Long, _
                                                            ByVal lSamples As Long, _
                                                            ByVal lpBuffer As Long, _
                                                            ByVal cbBuffer As Long, _
                                                            ByRef pBytesWritten As Long, _
                                                            ByRef pSamplesWritten As Long) As Long
Public Declare Function AVIStreamGetFrameClose Lib "avifil32.dll" (ByVal pGetFrameObj As Long) As Long
Public Declare Function AVIPutFileOnClipboard Lib "avifil32.dll" (ByVal pAVIFile As Long) As Long
Public Declare Function AVIFileRelease Lib "avifil32.dll" (ByVal pfile As Long) As Long
Public Declare Function AVIFileGetStream Lib "avifil32.dll" _
                        (ByVal pfile As Long, _
                         ByRef ppaviStream As Long, _
                         ByVal fccType As Long, _
                         ByVal lParam As Long) As Long
Public Declare Function AVIMakeFileFromStreams Lib "avifil32.dll" _
          (ByRef ppfile As Long, _
           ByVal nStreams As Long, _
           ByVal pAVIStreamArray As Long) As Long
Public Declare Function AVIStreamInfo Lib "avifil32.dll" _
                                          (ByVal pAVIStream As Long, _
                                           ByRef psi As AVI_STREAM_INFO, _
                                           ByVal lSize As Long) As Long
Public Declare Function AVIStreamGetFrame Lib "avifil32.dll" (ByVal pGetFrameObj As Long, _
                                                              ByVal lPos As Long) As Long
Public Declare Function AVIStreamRelease Lib "avifil32.dll" (ByVal pavi As Long) As Long 'ULONG
Public Declare Function AVIStreamClose Lib "avifil32.dll" _
                                       Alias "AVIStreamRelease" _
                                      (ByVal pavi As Long) As Long 'ULONG
Public Declare Function AVIStreamLength Lib "avifil32.dll" (ByVal pavi As Long) As Long
Public Declare Function AVIFileClose Lib "avifil32.dll" Alias "AVIFileRelease" (ByVal pfile As Long) As Long
Public Declare Sub AVIFileExit Lib "avifil32.dll" ()
Public Declare Function AVIMakeStreamFromClipboard Lib "avifil32.dll" _
              (ByVal cfFormat As Long, _
               ByVal hGlobal As Long, _
               ByRef ppstream As Long) As Long
Public Declare Function AVIStreamStart Lib "avifil32.dll" (ByVal pavi As Long) As Long
Public Declare Function AVIGetFromClipboard Lib "avifil32.dll" (ByRef ppAVIFile As Long) As Long
Public Declare Function AVIClearClipboard Lib "avifil32.dll" () As Long
Public Const BMP_MAGIC_COOKIE As Integer = 19778
Public Type BITMAPFILEHEADER
        bfType        As Integer
        bfSize        As Long
        bfReserved1   As Integer
        bfReserved2   As Integer
        bfOffBits     As Long
End Type
Public 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
Public Type BITMAPINFOHEADER_MJPEG
   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
   biExtDataOffset   As Long
   JPEGSize          As Long
   JPEGProcess       As Long
   JPEGColorSpaceID  As Long
   JPEGBitsPerSample As Long
   JPEGHSubSampling  As Long
   JPEGVSubSampling  As Long
End Type

Public Type AVI_RECT
    left    As Long
    top     As Long
    right   As Long
    bottom  As Long
End Type
Public Type AVI_STREAM_INFO
    fccType               As Long
    fccHandler            As Long
    dwFlags               As Long
    dwCaps                As Long
    wPriority             As Integer
    wLanguage             As Integer
    dwScale               As Long
    dwRate                As Long
    dwStart               As Long
    dwLength              As Long
    dwInitialFrames       As Long
    dwSuggestedBufferSize As Long
    dwQuality             As Long
    dwSampleSize          As Long
    rcFrame               As AVI_RECT
    dwEditCount           As Long
    dwFormatChangeCount   As Long
    szName                As String * 64
End Type
Public Type AVI_FILE_INFO
    dwMaxBytesPerSecond   As Long
    dwFlags               As Long
    dwCaps                As Long
    dwStreams             As Long
    dwSuggestedBufferSize As Long
    dwWidth               As Long
    dwHeight              As Long
    dwScale               As Long
    dwRate                As Long
    dwLength              As Long
    dwEditCount           As Long
    szFileType            As String * 64
End Type
Public Type AVI_COMPRESS_OPTIONS
    fccType           As Long
    fccHandler        As Long
    dwKeyFrameEvery   As Long
    dwQuality         As Long
    dwBytesPerSecond  As Long
    dwFlags           As Long
    lpFormat          As Long
    cbFormat          As Long
    lpParms           As Long
    cbParms           As Long
    dwInterleaveEvery As Long
End Type
Global Const AVIERR_OK As Long = 0&
Private Const SEVERITY_ERROR    As Long = &H80000000
Private Const FACILITY_ITF      As Long = &H40000
Private Const AVIERR_BASE       As Long = &H4000
Global Const AVIERR_BADFLAGS    As Long = SEVERITY_ERROR Or FACILITY_ITF Or (AVIERR_BASE + 105) '-2147205015
Global Const AVIERR_BADPARAM    As Long = SEVERITY_ERROR Or FACILITY_ITF Or (AVIERR_BASE + 106) '-2147205014
Global Const AVIERR_BADSIZE     As Long = SEVERITY_ERROR Or FACILITY_ITF Or (AVIERR_BASE + 107) '-2147205013
Global Const AVIERR_USERABORT   As Long = SEVERITY_ERROR Or FACILITY_ITF Or (AVIERR_BASE + 198) '-2147204922
Global Const AVIFILEINFO_HASINDEX         As Long = &H10
Global Const AVIFILEINFO_MUSTUSEINDEX     As Long = &H20
Global Const AVIFILEINFO_ISINTERLEAVED    As Long = &H100
Global Const AVIFILEINFO_WASCAPTUREFILE   As Long = &H10000
Global Const AVIFILEINFO_COPYRIGHTED      As Long = &H20000
Global Const AVIFILECAPS_CANREAD          As Long = &H1
Global Const AVIFILECAPS_CANWRITE         As Long = &H2
Global Const AVIFILECAPS_ALLKEYFRAMES     As Long = &H10
Global Const AVIFILECAPS_NOCOMPRESSION    As Long = &H20
Global Const AVICOMPRESSF_INTERLEAVE     As Long = &H1           '// interleave
Global Const AVICOMPRESSF_DATARATE       As Long = &H2           '// use a data rate
Global Const AVICOMPRESSF_KEYFRAMES      As Long = &H4           '// use keyframes
Global Const AVICOMPRESSF_VALID          As Long = &H8           '// has valid data?
Global Const AVIGETFRAMEF_BESTDISPLAYFMT  As Long = 1
Global Const ICMF_CHOOSE_KEYFRAME           As Long = &H1     '// show KeyFrame Every box
Global Const ICMF_CHOOSE_DATARATE           As Long = &H2     '// show DataRate box
Global Const ICMF_CHOOSE_PREVIEW            As Long = &H4     '// allow expanded preview dialog
Global Const ICMF_CHOOSE_ALLCOMPRESSORS     As Long = &H8     '// don't only show those that
Global Const OF_READ             As Long = &H0
Global Const OF_WRITE            As Long = &H1
Global Const OF_SHARE_DENY_WRITE As Long = &H20
Global Const OF_CREATE           As Long = &H1000
Global Const streamtypeVIDEO       As Long = 1935960438 'equivalent to: mmioStringToFOURCC("vids", 0&)
Global Const streamtypeAUDIO       As Long = 1935963489 'equivalent to: mmioStringToFOURCC("auds", 0&)
Global Const streamtypeMIDI        As Long = 1935960429 'equivalent to: mmioStringToFOURCC("mids", 0&)
Global Const streamtypeTEXT        As Long = 1937012852
Global Const AVIIF_KEYFRAME  As Long = &H10
Global Const DIB_RGB_COLORS  As Long = 0
Global Const DIB_PAL_COLORS  As Long = 1
Global Const BI_RGB          As Long = 0
Global Const BI_RLE8         As Long = 1
Global Const BI_RLE4         As Long = 2
Global Const BI_BITFIELDS    As Long = 3
Public Declare Function GetProcessHeap Lib "kernel32.dll" () As Long 'handle
Public Declare Function SetRect Lib "user32.dll" _
             (ByRef lprc As AVI_RECT, _
              ByVal xLeft As Long, _
              ByVal yTop As Long, _
              ByVal xRight As Long, _
              ByVal yBottom As Long) As Long 'BOOL
Public Declare Function HeapFree Lib "kernel32.dll" _
                        (ByVal hHeap As Long, _
                         ByVal dwFlags As Long, _
                         ByVal lpMem As Long) As Long 'BOOL
Public Declare Function HeapAlloc Lib "kernel32.dll" _
        (ByVal hHeap As Long, _
         ByVal dwFlags As Long, _
         ByVal dwBytes As Long) As Long 'Pointer to mem
Public Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" _
                                    (ByRef dest As Any, _
                                     ByRef src As Any, _
                                     ByVal dwLen As Long)
Public Const HEAP_ZERO_MEMORY As Long = &H8
Global gfAbort                As Boolean
Public Function AVISaveCallback(ByVal nPercent As Long) As Long 'should return C BOOL
End Function

Public Sub make_avi(lstDIBList As ListBox)
'------------------------------------------------------------------------------
''//////////////////////////////////////////////////////////////////////////////
On Error GoTo Error
    Dim FF               As String
    Dim file             As cFileDlg
    Dim InitDir          As String
    Dim szOutputAVIFile  As String
    Dim res              As Long
    Dim pfile            As Long
    Dim bmp              As cDIB
    Dim ps               As Long
    Dim psCompressed     As Long
    Dim strhdr           As AVI_STREAM_INFO
    Dim BI               As BITMAPINFOHEADER
    Dim opts             As AVI_COMPRESS_OPTIONS
    Dim pOpts            As Long
    Dim i                As Long
    Dim Fil             As String * 255
    Debug.Print
    Set file = New cFileDlg
        With file
        .DefaultExt = "avi"
        .DlgTitle = "Choose a filename to save AVI to..."
        .Filter = "AVI Files|*.avi"
        .OwnerHwnd = Form1.hWnd
    End With '-----------------Make Random File Name--------------------------
    Randomize Timer: FF$ = Str(Int(2000 * Rnd()))
    szOutputAVIFile = "Nasser_" + right(FF$, Len(FF$) - 1) + ".avi" '-------------
    If file.VBGetSaveFileName(szOutputAVIFile) <> True Then GoTo 66
    res = AVIFileOpen(pfile, szOutputAVIFile, OF_WRITE Or OF_CREATE, 0&)
    If (res <> AVIERR_OK) Then GoTo Error
    Set bmp = New cDIB
    lstDIBList.ListIndex = 0
    If bmp.CreateFromFile(lstDIBList.Text) <> True Then
        MsgBox "Could not load first bitmap file in list!", vbExclamation, App.title
        GoTo Error
    End If
    With strhdr
        .fccType = mmioStringToFOURCC("vids", 0&)
        .fccHandler = 0&
        .dwScale = 1
        .dwRate = 2 ' Val(Text2.Text)'=Secnd Stop On Pic
        .dwSuggestedBufferSize = bmp.SizeImage
        Call SetRect(.rcFrame, 0, 0, bmp.Width, bmp.Height)
    End With
        If strhdr.dwRate < 1 Then strhdr.dwRate = 1
    If strhdr.dwRate > 30 Then strhdr.dwRate = 30
    res = AVIFileCreateStream(pfile, ps, strhdr)
    If (res <> AVIERR_OK) Then GoTo Error
    pOpts = VarPtr(opts)
    res = AVISaveOptions(Form1.hWnd, _
                        ICMF_CHOOSE_KEYFRAME Or ICMF_CHOOSE_DATARATE, _
                        1, _
                        ps, _
                        pOpts)
    If res <> 1 Then
        Call AVISaveOptionsFree(1, pOpts)
        GoTo Error
    End If
    res = AVIMakeCompressedStream(psCompressed, ps, opts, 0&)
    If res <> AVIERR_OK Then GoTo Error
        With BI
        .biBitCount = bmp.BitCount
        .biClrImportant = bmp.ClrImportant
        .biClrUsed = bmp.ClrUsed
        .biCompression = bmp.Compression
        .biHeight = bmp.Height
        .biWidth = bmp.Width
        .biPlanes = bmp.Planes
        .biSize = bmp.SizeInfoHeader
        .biSizeImage = bmp.SizeImage
        .biXPelsPerMeter = bmp.XPPM
        .biYPelsPerMeter = bmp.YPPM
    End With
    res = AVIStreamSetFormat(psCompressed, 0, ByVal bmp.PointerToBitmapInfo, bmp.SizeBitmapInfo)
    If (res <> AVIERR_OK) Then GoTo Error
    Form1.Enabled = False
'      Pr.Value = 0: A = szOutputAVIFile' as progresbar
'    Label6.Caption = "Plase Waith Saving Avi  ...": Label13.Visible = False
'    Pr.Max = lstDIBList.ListCount: Label3.Caption = "Reading Files Of Temp And Save In VideoFile ..."
'    Label9.Caption = left(szOutputAVIFile, 14) + "... ..." + right(szOutputAVIFile, Abs(Len(szOutputAVIFile) - 14))
'------------------------Start Saving VideoFile---------------------------------------
    For i = 0 To lstDIBList.ListCount - 1
'            If Can = True Then GoTo Error
'            Label5.Caption = "Frame" + Str(i \ 2) + "/" + (Label8.Caption): Pr.Value = i: Label12.Caption = TTim(Pr.Value, lstDIBList.ListCount)
            Form1.Caption = "Saving..." + Mid(Str((i * 10) / Val(lstDIBList.ListCount / 10)), 2, 5) + " %"
'            lstDIBList.Selected(i) = True: lstDIBList_1.Selected(i \ 2) = True
'        lstDIBList.ListIndex = i
        bmp.CreateFromFile (lstDIBList.List(i))
        res = AVIStreamWrite(psCompressed, _
                            i, _
                            1, _
                            bmp.PointerToBits, _
                            bmp.SizeImage, _
                            AVIIF_KEYFRAME, _
                            ByVal 0&, _
                            ByVal 0&)
        If res <> AVIERR_OK Then GoTo Error
      '  imgPreview.Picture = LoadPicture(lstDIBList.Text)
        DoEvents
    Next
Error:
         Set file = Nothing
         Set bmp = Nothing
         If (ps <> 0) Then Call AVIStreamClose(ps)
         If (psCompressed <> 0) Then Call AVIStreamClose(psCompressed)
         If (pfile <> 0) Then Call AVIFileClose(pfile)
         Call AVIFileExit
         If (res <> AVIERR_OK) Then
         MsgBox "There was an error writing the file.", vbInformation, App.title
         End If '-------------------Deleting Temp File In Error-------------------------
         If Err.Number Then
66       End If
Form1.Enabled = True
'Pr.Visible = False '----------------Finising Make----------------------
'Cmd(3).Enabled = True
'Frame2.Enabled = True: Cmd(8).Visible = False: Frame1.Visible = True
'Label10.Visible = True
'Label6.Visible = False: Combo1.Visible = True
'If Can = True Then Exit Sub '-------------Run WindowsMediaPlayer For Play File---------
Form1.Caption = "Completed!!": GetSystemDirectory Fil, 255
Shell left(Fil, 2) + "\Program Files\Windows Media Player\wmplayer.exe" + " " + szOutputAVIFile, vbNormalFocus
 End Sub
Public Sub ConvertSize(Model%, Picture1 As PictureBox)
Picture1.ScaleMode = vbTwips 'By Twips : Number + 4 *15 =By Pixel is Standard
Select Case Model
Case 0:  Picture1.Height = (320 + 4) * 15: Picture1.Width = (480 + 4) * 15 '480__320
Case 1:  Picture1.Height = (480 + 4) * 15: Picture1.Width = (640 + 4) * 15 '640__480
Case 2:  Picture1.Height = (600 + 4) * 15: Picture1.Width = (800 + 4) * 15 '800__600
Case 3:  Picture1.Height = (768 + 4) * 15: Picture1.Width = (1024 + 4) * 15 '1024_768
Case 4:  Picture1.Height = (90 + 4) * 15:  Picture1.Width = (120 + 4) * 15 '120__90
Case 5:  Picture1.Height = (160 + 4) * 15: Picture1.Width = (120 + 4) * 15 '120__160
Case 6:  Picture1.Height = (120 + 4) * 15: Picture1.Width = (176 + 4) * 15 '176__120
Case 7:  Picture1.Height = (144 + 4) * 15: Picture1.Width = (176 + 4) * 15 '176__144
Case 8:  Picture1.Height = (144 + 4) * 15: Picture1.Width = (192 + 4) * 15 '192__144
Case 9:  Picture1.Height = (180 + 4) * 15: Picture1.Width = (240 + 4) * 15 '240 180
Case 10: Picture1.Height = (200 + 4) * 15: Picture1.Width = (320 + 4) * 15 '320 200
Case 11: Picture1.Height = (240 + 4) * 15: Picture1.Width = (320 + 4) * 15 '320 240
Case 12: Picture1.Height = (240 + 4) * 15: Picture1.Width = (352 + 4) * 15 '352 240
Case 13: Picture1.Height = (288 + 4) * 15: Picture1.Width = (352 + 4) * 15 '352 288
Case 14: Picture1.Height = (488 + 4) * 15: Picture1.Width = (352 + 4) * 15 '352 488
Case 15: Picture1.Height = (576 + 4) * 15: Picture1.Width = (352 + 4) * 15 '352 576
Case 16: Picture1.Height = (288 + 4) * 15: Picture1.Width = (384 + 4) * 15 '384 288
Case 17: Picture1.Height = (480 + 4) * 15: Picture1.Width = (480 + 4) * 15 '480 480
Case 18: Picture1.Height = (576 + 4) * 15: Picture1.Width = (480 + 4) * 15 '480 576
Case 19: Picture1.Height = (576 + 4) * 15: Picture1.Width = (640 + 4) * 15 '640 576
Case 20: Picture1.Height = (480 + 4) * 15: Picture1.Width = (704 + 4) * 15 '704 480
Case 21: Picture1.Height = (576 + 4) * 15: Picture1.Width = (704 + 4) * 15 '704 576
Case 22: Picture1.Height = (480 + 4) * 15: Picture1.Width = (720 + 4) * 15 '720 480
Case 23: Picture1.Height = (576 + 4) * 15: Picture1.Width = (720 + 4) * 15 '720 576
Case 24: Picture1.Height = (576 + 4) * 15: Picture1.Width = (768 + 4) * 15 '768 576
End Select

End Sub

كد دكمه ذخيره سازي:توجه-فقط فرمت هاي بي ام پي وجي پگ رو مي تونيد ذخيره كنيد ضمن اين كه يك كادر عكس مخفي هم به فرم اضافه كنيد

Private sub Command1_Click()
Dim i%, R%
Call ConvertSize(2, Picture1)
With Picture1
R = list1.ListCount - 1
For i = 0 To R
.Picture = LoadPicture(list1.List(i))
Call .PaintPicture(.Picture, 0, 0, .Width, .Height): Set .Picture = .Image
.Refresh: Call SavePicture(.Picture, App.Path + "\Temp\pic" + Str(i) + ".bmp")
Me.Caption = "Converting..." + Mid((Str((i * 10) / Val(R / 10))), 2, 5) + " %"
DoEvents
Next
End With
list1.Clear
For i = 0 To R
list1.AddItem (App.Path + "\Temp\pic" + Str(i) + ".bmp")
Next
Call make_avi(list1)
end sub

اگه درست تايپ نكردم ببخشيد نظر كه يادتون نمي ره

لينك مقاله |11:25 چهارشنبه 9 اسفند1385 - توسط ناصر نيازي