Attribute VB_Name = "modProgress"
 Option Explicit
Public Declare Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Public Declare Function FillRect Lib "user32" (ByVal hDC As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Public Declare Function FrameRect Lib "user32" (ByVal hDC As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Public Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Public Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
'Public Type RECT
'        Left As Long
'        Top As Long
'        Right As Long
'        Bottom As Long
'End Type
Public Type POINTAPI
        x As Long
        y As Long
End Type
Public Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Public Declare Function WindowFromDC Lib "user32" (ByVal hDC As Long) As Long
Public Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function GetBkColor Lib "gdi32" (ByVal hDC As Long) As Long
Public Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hDC As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
Public Const DT_BOTTOM = &H8
Public Const DT_CALCRECT = &H400
Public Const DT_CENTER = &H1
Public Const DT_CHARSTREAM = 4
Public Const DT_DISPFILE = 6
Public Const DT_EXPANDTABS = &H40
Public Const DT_EXTERNALLEADING = &H200
Public Const DT_INTERNAL = &H1000
Public Const DT_LEFT = &H0
Public Const DT_METAFILE = 5
Public Const DT_NOCLIP = &H100
Public Const DT_NOPREFIX = &H800
Public Const DT_PLOTTER = 0
Public Const DT_RASCAMERA = 3
Public Const DT_RASDISPLAY = 1
Public Const DT_RASPRINTER = 2
Public Const DT_RIGHT = &H2
Public Const DT_SINGLELINE = &H20
Public Const DT_TABSTOP = &H80
Public Const DT_TOP = &H0
Public Const DT_VCENTER = &H4
Public Const DT_WORDBREAK = &H10
Public Declare Function SetBkMode Lib "gdi32" (ByVal hDC As Long, ByVal nBkMode As Long) As Long
Public Declare Function GetTextExtentPoint32 Lib "gdi32" Alias "GetTextExtentPoint32A" (ByVal hDC As Long, ByVal lpsz As String, ByVal cbString As Long, lpSize As Size) As Long
Public Type Size
        cx As Long
        cy As Long
End Type
Public Declare Function RedrawWindow Lib "user32" (ByVal hwnd As Long, lprcUpdate As RECT, ByVal hrgnUpdate As Long, ByVal fuRedraw As Long) As Long
Public Declare Function InvalidateRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT, ByVal bErase As Long) As Long

Private Declare Function mciSendString Lib "winmm" Alias "mciSendStringA" _
    (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, _
    ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long

Private Declare Function mciGetErrorString Lib "winmm" Alias _
    "mciGetErrorStringA" (ByVal dwError As Long, ByVal lpstrBuffer As String, _
    ByVal uLength 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 GetFullPathName Lib "kernel32" Alias "GetFullPathNameA" (ByVal lpFileName As String, ByVal nBufferLength As Long, ByVal lpBuffer As String, ByVal lpFilePart As String) As Long
Public Declare Function SetTextColor Lib "gdi32" (ByVal hDC As Long, ByVal crColor As Long) As Long
Public Declare Function GetTextColor Lib "gdi32" (ByVal hDC As Long) As Long
Public Declare Function GetPixel Lib "gdi32" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long) As Long
Public Declare Function SetPixel Lib "gdi32" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long, ByVal crColor As Long) As Long
Public Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long, ByVal lpString As String, ByVal nCount As Long) As Long
Public Declare Function CopyRect Lib "user32" (lpDestRect As RECT, lpSourceRect As RECT) As Long
Public Declare Function IsWindow Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function SetROP2 Lib "gdi32" (ByVal hDC As Long, ByVal nDrawMode As Long) As Long
Public Const R2_BLACK = 1       '   0
Public Const R2_COPYPEN = 13    '  P
Public Const R2_LAST = 16
Public Const R2_MASKNOTPEN = 3  '  DPna
Public Const R2_MASKPEN = 9     '  DPa
Public Const R2_MASKPENNOT = 5  '  PDna
Public Const R2_MERGENOTPEN = 12        '  DPno
Public Const R2_MERGEPEN = 15   '  DPo
Public Const R2_MERGEPENNOT = 14        '  PDno
Public Const R2_NOP = 11        '  D
Public Const R2_NOT = 6 '  Dn
Public Const R2_NOTCOPYPEN = 4  '  PN
Public Const R2_NOTMASKPEN = 8  '  DPan
Public Const R2_NOTMERGEPEN = 2 '  DPon
Public Const R2_NOTXORPEN = 10  '  DPxn
Public Const R2_WHITE = 16      '   1
Public Const R2_XORPEN = 7      '  DPx

'CreateFont  Bold Options
    Public Const FW_NORMAL = 400
    Public Const FW_SEMIBOLD = 600
    Public Const FW_THIN = 100
    Public Const FW_BOLD = 700
    Public Const FW_DONTCARE = 0
    Public Const FW_EXTRABOLD = 800
    Public Const FW_EXTRALIGHT = 200
    Public Const FW_HEAVY = 900
    Public Const FW_LIGHT = 300
    Public Const FW_MEDIUM = 500
    Public Const FW_BLACK = FW_HEAVY
    Public Const FW_DEMIBOLD = FW_SEMIBOLD
    Public Const FW_REGULAR = FW_NORMAL
    Public Const FW_ULTRABOLD = FW_EXTRABOLD
    Public Const FW_ULTRALIGHT = FW_EXTRALIGHT
'CreateFont  Out Precisions
    Public Const OUT_CHARACTER_PRECIS = 2
    Public Const OUT_DEFAULT_PRECIS = 0
    Public Const OUT_DEVICE_PRECIS = 5
    Public Const OUT_OUTLINE_PRECIS = 8
    Public Const OUT_RASTER_PRECIS = 6
    Public Const OUT_STRING_PRECIS = 1
    Public Const OUT_STROKE_PRECIS = 3
    Public Const OUT_TT_ONLY_PRECIS = 7
    Public Const OUT_TT_PRECIS = 4
'CreateFont Charsets
    Public Const ANSI_CHARSET = 0
    Public Const CHINESEBIG5_CHARSET = 136
'CreateFont Clip Precisions
    Public Const CLIP_CHARACTER_PRECIS = 1
    Public Const CLIP_DEFAULT_PRECIS = 0
    Public Const CLIP_EMBEDDED = 128
    Public Const CLIP_LH_ANGLES = 16
    Public Const CLIP_MASK = &HF
    Public Const CLIP_STROKE_PRECIS = 2
    Public Const CLIP_TO_PATH = 4097
    Public Const CLIP_TT_ALWAYS = 32
'CreateFont Quality Options
    Public Const DEFAULT_QUALITY = 0
    Public Const DRAFT_QUALITY = 1
    Public Const PROOF_QUALITY = 2
    Public Const NONANTIALIASED_QUALITY = 3
    Public Const ANTIALIASED_QUALITY = 4
    Public Const CLEARTYPE_QUALITY = 5
    Public Const CLEARTYPE_NATURAL_QUALITY = 6
'CreateFont Pitch And Family(FF_ or _Pitch)
    Public Const FF_DECORATIVE = 80 '  Old English, etc.
    Public Const FF_DONTCARE = 0    '  Don't care or don't know.
    Public Const FF_MODERN = 48     '  Constant stroke width, serifed or sans-serifed.
    Public Const FF_ROMAN = 16      '  Variable stroke width, serifed.
    Public Const FF_SCRIPT = 64     '  Cursive, etc.
    Public Const FF_SWISS = 32      '  Variable stroke width, sans-serifed.
    Public Const DEFAULT_PITCH = 0
    Public Const FIXED_PITCH = 1
    Public Const VARIABLE_PITCH = 2
    Public Const MONO_FONT = 8
Public Declare Function CreateFont Lib "gdi32" Alias "CreateFontA" (ByVal H As Long, ByVal W As Long, ByVal E As Long, ByVal O As Long, ByVal W As Long, ByVal I As Long, ByVal U As Long, ByVal S As Long, ByVal C As Long, ByVal OP As Long, ByVal CP As Long, ByVal Q As Long, ByVal PAF As Long, ByVal F As String) As Long
Public Declare Function GetTextFace Lib "gdi32" Alias "GetTextFaceA" (ByVal hDC As Long, ByVal nCount As Long, ByVal lpFacename As String) As Long
Public Const PS_ALTERNATE = 8
Public Const PS_COSMETIC = &H0
Public Const PS_DASH = 1                    '  -------
Public Const PS_DASHDOT = 3                 '  _._._._
Public Const PS_DASHDOTDOT = 4              '  _.._.._
Public Const PS_DOT = 2                     '  .......
Public Const PS_ENDCAP_FLAT = &H200
Public Const PS_ENDCAP_MASK = &HF00
Public Const PS_ENDCAP_ROUND = &H0
Public Const PS_ENDCAP_SQUARE = &H100
Public Const PS_GEOMETRIC = &H10000
Public Const PS_INSIDEFRAME = 6
Public Const PS_JOIN_BEVEL = &H1000
Public Const PS_JOIN_MASK = &HF000
Public Const PS_JOIN_MITER = &H2000
Public Const PS_JOIN_ROUND = &H0
Public Const PS_NULL = 5
Public Const PS_SOLID = 0
Public Const PS_STYLE_MASK = &HF
Public Const PS_TYPE_MASK = &HF0000
Public Const PS_USERSTYLE = 7
Public Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
'Public Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Public Declare Function CreatePatternBrush Lib "gdi32" (ByVal hBitmap As Long) As Long
Public Declare Function OleTranslateColor Lib "oleaut32.dll" (ByVal lOleColor As Long, ByVal lHPalette As Long, lColorRef As Long) As Long
Public Declare Function BeginPaint Lib "user32" (ByVal hwnd As Long, lpPaint As PAINTSTRUCT) As Long
Public Declare Function EndPaint Lib "user32" (ByVal hwnd As Long, lpPaint As PAINTSTRUCT) As Long
Public Type PAINTSTRUCT
        hDC As Long
        fErase As Long
        rcPaint As RECT
        fRestore As Long
        fIncUpdate As Long
        rgbReserved(32) As Byte
End Type
Public Declare Function LockWindowUpdate Lib "user32" (ByVal hwndLock As Long) As Long
Public Declare Function UpdateWindow Lib "user32" (ByVal hwnd As Long) As Long
Public Const WM_SETREDRAW = &HB

Function MakeFont(ByVal FaceName As String, ByVal Size As Integer, _
    Optional ByVal b As Boolean = False, _
    Optional ByVal I As Boolean = False, Optional ByVal U As Boolean = False, _
    Optional ByVal S As Boolean = False, Optional ByVal Rotation As Long, _
    Optional ByVal Width As Long, Optional ByVal Orientation As Long, _
    Optional ByVal Weight As Long, Optional ByVal CharSet As Byte, _
    Optional ByVal OutPrecision As Byte, Optional ByVal ClipPrecision As Byte, _
    Optional ByVal Quality As Byte, Optional ByVal PitchAndFamily As Byte) As Long
' Windows expects the font size to be in pixels and to
        ' be negative if you are specifying the character height
        ' you want.
                If Rotation <> 0 Then
                    Rotation = Rotation = Rotation * 10
                End If
    If b = True Then
        Weight = FW_BOLD '700
    End If
MakeFont = CreateFont((Size * -20) / Screen.TwipsPerPixelY, Width, _
    Rotation, Orientation, Weight, Abs(I), Abs(U), Abs(S), CharSet, OutPrecision, _
     ClipPrecision, Quality, PitchAndFamily, FaceName)

End Function
Function GetFontName(ByVal hDC As Long) As String
Dim str As String, Ret As Long
    str = Space$(255)
Ret = GetTextFace(hDC, 255, str)
If Ret <> 0 Then
    GetFontName = TrimNull(str, Ret)
End If
End Function
Function GetShortName(sFile As String) As String
Dim Ret As Long, str As String * 260
    Ret = GetShortPathName(sFile, str, 260)
'If Ret > 0 Then
'    str = Mid(str, 1, Ret - 1)
'Else
'    str = Mid(str, 1, InStr(str, Chr(0)) - 1)
'End If
    GetShortName = TrimNull(str, Ret)
End Function
Function TrimNull(ByVal str As String, ByVal Ret As Long) As String
Dim sRet As String
If Ret > 0 Then
    sRet = Mid(str, 1, Ret)
Else
    sRet = Mid(str, 1, InStr(str, Chr(0)) - 1)
End If
    TrimNull = Trim$(sRet)
End Function
Function GetFullName(sFile As String) As String
Dim Ret As Long, str As String * 1024, pBase As String
    Ret = GetFullPathName(sFile, 1024, str, pBase)
GetFullName = TrimNull(str, Ret)
End Function

Public Sub CopyFast(Source As String, Destination As String, Picture As Object, PB As Object, Optional BufLen As Long = 2000)
'This sub copies a file, and displays a progress bar of your choice whilst it is doing it.
'It is dead useful for saving large files in your program.
'When calling it, you need to pass to it the source and destination files,
'and the name of the progressbar, e.g:
'CopyFast "file1.txt", "file2.txt", FrmMain.ProgressBar1
'it reads the file in 20k chunks, which is much faster than reading byte
'by byte and displaying progress.
'You'll have to do your own errorhandling! e.g. if destination file cannot be accessed.
'by Andrew Beverley
'email: andrew.beverley@parthus.com
Dim Buffer As String 'buffer used for copying
Dim Pointer As Long 'position of pointer in file
Dim x As Long 'used in for...next loop
Dim Whole As Long
Dim Part As Long
Dim n As Long, Val As Long
Dim Playing As Boolean
Static Processing As Boolean
    If Processing = True Then Exit Sub
        Processing = True
If Dir(Destination) <> "" Then Kill (Destination) 'checks if destination file exists. if it does, delete it
    Val = 0
Open Source For Binary As #1
Open Destination For Binary As #2

'Whole = LOF(1) \ 20000 'number of whole 20k chunks
'Part = LOF(1) Mod 20000 'remainder at the end
'Buffer = String$(20000, 0) 'buffer
    Whole = LOF(1) \ BufLen 'number of whole 20k chunks
    Part = LOF(1) Mod BufLen 'remainder at the end
    Buffer = String$(BufLen, 0) 'buffer
Pointer = 1 'start at position 1
n = LOF(1)
'ProgressBar.Max = LOF(1)
        If Playing = False Then
'            Playing = PlayAVI(App.Path & "\Copying.avi", Picture)
        End If

For x = 1 To Whole
'             Playing = PlayAVI(App.Path & "\Copying.avi", Picture)
       DoEvents
       On Error Resume Next
    Get #1, Pointer, Buffer 'get data
    Put #2, Pointer, Buffer 'put it to destination file
'    Pointer = Pointer + 20000 'put pointer 20k later
    Pointer = Pointer + BufLen 'put pointer 20k later
    If Pointer < n Then
'            Playing = PlayAVI(App.Path & "\Copying.avi", Picture)
'        PlayAVI vbNullString, Picture
        Playing = False
    End If
    'Else: ProgressBar.Value = ProgressBar.Max 'update progressbar, make sure it doesn't overflow
    Progress PB.hwnd, n, Val
        Val = Val + BufLen
Next x

Buffer = String$(Part, 0)  'copy the last bit
Get #1, Pointer, Buffer        'get the remaining bytes at the end
Put #2, Pointer, Buffer       'put them
'PlayAVI App.Path & "Copying.avi", Picture
PlayAVI vbNullString, Picture
'ProgressBar.Value = ProgressBar.Max
    Progress PB.hwnd, n, 0
Close

Buffer = "" 'reclaim space
    Processing = False
End Sub
Public Function PlayAVI(ByVal sFile As String, PB As PictureBox) As Boolean
   Dim mciCmd As String
   Dim sReturn As String * 128
   Dim nWidth As Long, nHeight As Long
   Dim lStart As Long, lPos As Long, RetVal As Long
    Static deviceIsOpen As Boolean
    RetVal = mciSendString("close video", 0&, 0, 0)
   mciCmd = "open " & GetShortName(sFile) & " Type avivideo Alias video parent " & PB.hwnd & " Style child"
   RetVal = mciSendString(mciCmd, sReturn, 127, 0)
'RetVal = mciSendString("Where video destination", ByVal sReturn, Len(sReturn) - 1, 0)
RetVal = mciSendString("Where video source", ByVal sReturn, Len(sReturn) - 1, 0)
   lStart = InStr(1, sReturn, " ")
   lPos = InStr(lStart + 1, sReturn, " ")
   lStart = InStr(lPos + 1, sReturn, " ")
    If Replace(sReturn, Chr(0), "") <> "" Then
        nWidth = Mid(sReturn, lPos, lStart - lPos) '* Screen.TwipsPerPixelX
        nHeight = Mid(sReturn, lStart + 1) '* Screen.TwipsPerPixelY
    Else
        nWidth = PB.ScaleWidth
        nHeight = PB.ScaleHeight
    End If
   PB.Move 0, 0, PB.ScaleX(nWidth, 3, 1), PB.ScaleY(nHeight, 3, 1)
'RetVal = mciSendString("where video window", ByVal sReturn, Len(sReturn) - 1, 0)
   RetVal = mciSendString("put video window at 0 0 " & (nWidth) & " " & (nHeight), sReturn, 127, 0)
   RetVal = mciSendString("play video notify repeat", sReturn, 127, PB.hwnd)
'   RetVal = mciSendString("play video repeat", sReturn, 127, 0)
'    ' Play the file
'    mciCmd = "Play video wait"
'    RetVal = mciSendString(mciCmd, sReturn, 127, 0&)
'        mciCmd = "Close video"
'       RetVal = mciSendString(mciCmd, sReturn, 127, 0&)
'    If RetVal <> 0 Then GoTo error
'play mydevice from 0 to 100 wait
PlayAVI = True
error:
End Function
Function GetMCIError(ErrNo) As String
    Dim ErrorString As String
    ErrorString = Space$(256)
    mciGetErrorString CLng(Val(ErrNo)), ErrorString, Len(ErrorString)
    ErrorString = Left$(ErrorString, InStr(ErrorString, vbNullChar) - 1)
GetMCIError = ErrorString
End Function

Function TranslateColor(ByVal clr As OLE_COLOR, Optional hPal As Long = 0) As Long
    If OleTranslateColor(clr, hPal, TranslateColor) Then
        TranslateColor = -1
    End If
End Function

Sub Progress(ByVal Wnd As Long, ByVal Max As Long, Optional ByVal Val As Long = 0, _
    Optional ByVal Color As Long = vbCyan, Optional ByVal DrawCap As Boolean = True, _
    Optional ByVal sCap As String = "", Optional ByVal lStyle As Long = DT_CENTER, _
    Optional ByVal ForeColor As Long = vbRed)
Dim R As RECT, hDC As Long, mVal As Long, R2 As RECT, OldTextColor As Long, OldRop As Long
Dim hFontOld As Long, hFont As Long, hPenOld As Long, hPen As Long
Dim hBrush As Long, hBrushOld As Long
    hDC = GetDC(Wnd)
    GetClientRect Wnd, R
OldTextColor = GetTextColor(hDC)
        hBrush = CreateSolidBrush(TranslateColor(GetBkColor(hDC)))
            If hBrush <> 0 Then
                hBrushOld = SelectObject(hDC, hBrush)
            End If
Rectangle hDC, R.Left, R.Top, R.Right, R.Bottom
        mVal = (R.Right / Max) * Val
'    SetRect R, R.Left, R.Top, R.Right, R.Bottom
'        R.Right = R.Left + mVal + (R.Right / Max)
        R.Right = R.Left + mVal + ((R.Right - R.Left) / Max)
        hPen = CreatePen(PS_SOLID, 1, TranslateColor(Color))
            If hPen <> 0 Then
                hPenOld = SelectObject(hDC, hPen)
            End If
        hBrush = CreateSolidBrush(TranslateColor(Color))
            If hBrush <> 0 Then
                hBrushOld = SelectObject(hDC, hBrush)
            End If
Rectangle hDC, R.Left, R.Top, R.Right, R.Bottom
            OldRop = SetROP2(hDC, R2_MASKPEN)
    If DrawCap = True Then
            If sCap = "" Then
                sCap = Format$(Val / Max, "percent")
            End If
        Dim Ret As Long, sz As Size
                Ret = GetTextExtentPoint32(hDC, sCap, Len(sCap), sz)
'            SetBkMode hDC, 3
            GetClientRect Wnd, R2
'        If R.Right + SZ.Cx < (R2.Right / 2) Then
'        If (R.Right + (SZ.Cx / 2)) < (((R2.Right - R2.Left) / 2)) Then
                R2.Left = ((R2.Right - R2.Left) / 2) - (sz.cx / 2)
                R2.Right = R2.Left + (sz.cx * 1)
'    DrawRect hDC, R2, GetBkColor(hDC), True
    SetTextColor hDC, TranslateColor(ForeColor) 'Color
'        hFont = MakeFont(GetFontName(hDc), 10)
'            If hFont <> 0 Then
'                hFontOld = SelectObject(hDc, hFont)
'            End If
            DrawText hDC, sCap, Len(sCap), R2, lStyle
    End If
If Val >= Max Or Val <= 0 Then
    Color = GetBkColor(hDC)
    GetClientRect Wnd, R2
    DrawRect hDC, R2, Color, True
End If
SetTextColor hDC, OldTextColor
If hFontOld <> 0 Then
    SelectObject hDC, hFontOld
End If
If hFont <> 0 Then
    DeleteObject hFont
End If
If hPenOld <> 0 Then
    SelectObject hDC, hPenOld
End If
If hPen <> 0 Then
    DeleteObject hPen
End If
If hBrushOld <> 0 Then
    SelectObject hDC, hBrushOld
End If
If hBrush <> 0 Then
    DeleteObject hBrush
End If
    SetROP2 hDC, OldRop
End Sub

Private Sub DrawRect(hDC As Long, RC As RECT, lcolor As Long, bFilled As Boolean)
    Dim lNewBrush As Long
    lNewBrush = CreateSolidBrush(lcolor)
    If bFilled Then
        Call FillRect(hDC, RC, lNewBrush)
        Call DeleteObject(lNewBrush)
    Else
        Call FrameRect(hDC, RC, 0)
    End If
End Sub

