原代码地址: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