VB自定义文件COPY的类.

来源：互联网发布：mac os sierra卡不卡编辑：程序博客网时间：2024/06/10 00:12
原代码地址:http://d.download.csdn.net/down/681014/MSTOP
'//================================ 
'//MSTOP(陈建华) 
'//         2001/03/16 
'//================================ 
Option Explicit
Dim M_BkColor As Long
Dim M_BlockSize As Long
' 
Private Sub UserControl_Initialize()
        Shape1.ZOrder 0
        M_BkColor = 
        Picture1.Move 0, 0, UserControl.Width, UserControl.Height
        Shape1.Move -Picture1.Width, 0, Picture1.Width, UserControl.Height
        LabPer.Move (Picture1.Width - LabPer.Width) / 2, (Picture1.ScaleHeight - LabPer.Height) / 2
        LabPer.Caption = "0%"
        Picture1.BackColor = M_BkColor
End Sub
Private Sub UserControl_Resize()
        Picture1.Move 0, 0, UserControl.Width, UserControl.Height
        Shape1.Move -Picture1.Width, 0, Picture1.Width, UserControl.Height
        LabPer.Move (Picture1.Width - LabPer.Width) / 2, (Picture1.ScaleHeight - LabPer.Height) / 2
End Sub
'' 
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
    BackColor = PropBag.ReadProperty("BackColor", &H80FFFF)
    Picture1.Appearance = PropBag.ReadProperty("Appearance", 0)
    Set LabPer.Font = PropBag.ReadProperty("Font", Ambient.Font)
    LabPer.FontSize = PropBag.ReadProperty("FontSize", LabPer.FontSize)
    LabPer.ForeColor = PropBag.ReadProperty("ForeColor", &H80000012)
    BlockSize = PropBag.ReadProperty("BlockSize", 2)
End Sub
Private Sub UserControl_Show()
        Shape1.ZOrder 0
        Picture1.BackColor = M_BkColor
End Sub
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
    Call PropBag.WriteProperty("BackColor", BackColor, &H80FFFF)
    Call PropBag.WriteProperty("Appearance", Picture1.Appearance, 0)
    Call PropBag.WriteProperty("Font", LabPer.Font, Ambient.Font)
    Call PropBag.WriteProperty("FontSize", LabPer.FontSize, 9)
    Call PropBag.WriteProperty("ForeColor", LabPer.ForeColor, &H80000012)
    Call PropBag.WriteProperty("BlockSize", BlockSize, 2)
    
End Sub
' 
'===================================================================== 
'===================================================================== 
Public Function Copy(SourFile As String, _
                     ObjFile As String, _
                     Optional MsgTitle As String = "文件复制", _
                     Optional ReplaceFile As Boolean = True) As Boolean
                     
        Dim Buf() As Byte
        Dim BTest As Variant, FSize As Variant
        Dim Chunk As Long, F1 As Long, F2 As Long
        Dim Response As Long
        Dim PrgVal As Long
        Dim OleVal As Long
        Dim DltW As Double
        Dim PBar As Control
        Dim BufSize As Long
        
        If M_BlockSize < 1 Then M_BlockSize = 1
        BufSize = M_BlockSize * 1024
        BTest = CDec(BTest): FSize = CDec(FSize)
        
        If Len(Dir(ObjFile)) > 0 Then
           If Not ReplaceFile Then  '//不替换文件 
                Response = MsgBox(ObjFile + Chr(13) + Chr(10) + "文件已存在.是否替换该文件?", vbYesNo + vbQuestion, MsgTitle)
                If Response = vbNo Then
                   Copy = False
                   Exit Function
                Else
                   Kill ObjFile
                   If Err.Number <> 0 Then Copy = False: Exit Function
                End If
           Else  '//可以替换该文件 
               Kill ObjFile
               If Err.Number <> 0 Then Copy = False: Exit Function
           End If
        End If
         
        On Error GoTo FileCopyError
        
        Shape1.Left = -Shape1.Width
        Shape1.Visible = True
        
        LabPer.Caption = "0%"
        DltW = Picture1.Width / 100
        
        DoEvents
        
        F1 = FreeFile: Open SourFile For Binary As F1
        F2 = FreeFile: Open ObjFile For Binary As F2
        
        FSize = LOF(F1)
        BTest = FSize - LOF(F2)
        
        While BTest > 0
            If BTest < BufSize Then
               Chunk = BTest
            Else
               Chunk = BufSize
            End If
            
            If Chunk > 0 Then
                ReDim Buf(Chunk - 1)
                Get F1, , Buf
                Put F2, , Buf
                BTest = FSize - LOF(F2)
            End If
            
            PrgVal = (100 - Int(100 * BTest / FSize))
            
            If OleVal <> PrgVal Then
                If PrgVal < 0 Then PrgVal = 0
                If PrgVal > 100 Then PrgVal = 100
                Shape1.Left = DltW * PrgVal - Shape1.Width
                LabPer.Caption = PrgVal & "%"
                DoEvents
            End If
            OleVal = PrgVal
        Wend
        
FileCopyError:
        Copy = (Err.Number = 0 Or Err.Number = 380)
        Err.Clear
        Close F1
        Close F2
        
End Function
'注意！不要删除或修改下列被注释的行！ 
Public Property Get BackColor() As OLE_COLOR
    BackColor = M_BkColor 'LabPer.BackColor 
End Property
Public Property Let BackColor(ByVal New_BackColor As OLE_COLOR)
    M_BkColor = New_BackColor
    Picture1.BackColor = M_BkColor
    PropertyChanged "BackColor"
End Property
Public Property Get Appearance() As Integer
    Appearance = Picture1.Appearance
    Picture1.BackColor = M_BkColor
End Property
Public Property Let Appearance(ByVal New_Appearance As Integer)
    Picture1.Appearance() = New_Appearance
    Picture1.BackColor = M_BkColor
    PropertyChanged "Appearance"
End Property
'注意！不要删除或修改下列被注释的行！ 
'MappingInfo=LabPer,LabPer,-1,Font 
Public Property Get Font() As Font
    Set Font = LabPer.Font
End Property
Public Property Set Font(ByVal New_Font As Font)
    Set LabPer.Font = New_Font
    PropertyChanged "Font"
End Property
'注意！不要删除或修改下列被注释的行！ 
'MappingInfo=LabPer,LabPer,-1,FontSize 
Public Property Get FontSize() As Single
    FontSize = LabPer.FontSize
End Property
Public Property Let FontSize(ByVal New_FontSize As Single)
    LabPer.FontSize() = New_FontSize
    PropertyChanged "FontSize"
End Property
'注意！不要删除或修改下列被注释的行！ 
'MappingInfo=LabPer,LabPer,-1,ForeColor 
Public Property Get ForeColor() As OLE_COLOR
    ForeColor = LabPer.ForeColor
End Property
Public Property Let ForeColor(ByVal New_ForeColor As OLE_COLOR)
    LabPer.ForeColor() = New_ForeColor
    PropertyChanged "ForeColor"
End Property
Public Property Get BlockSize() As Long
    BlockSize = M_BlockSize
End Property
Public Property Let BlockSize(ByVal New_BlockSize As Long)
    If New_BlockSize < 1 Then New_BlockSize = 1
    If New_BlockSize > 1000 Then New_BlockSize = 1000
    
    M_BlockSize = New_BlockSize
    PropertyChanged "BlockSize"
End Property