VB自定义文件COPY的类.

 

 

 

原代码地址:http://d.download.csdn.net/down/681014/MSTOP

 
  1. '//================================
  2. '//MSTOP(陈建华)
  3. '//         2001/03/16
  4. '//================================
  5. Option Explicit
  6. Dim M_BkColor As Long
  7. Dim M_BlockSize As Long
  8. '
  9. Private Sub UserControl_Initialize()
  10.         Shape1.ZOrder 0
  11.         M_BkColor = 
  12.         Picture1.Move 0, 0, UserControl.Width, UserControl.Height
  13.         Shape1.Move -Picture1.Width, 0, Picture1.Width, UserControl.Height
  14.         LabPer.Move (Picture1.Width - LabPer.Width) / 2, (Picture1.ScaleHeight - LabPer.Height) / 2
  15.         LabPer.Caption = "0%"
  16.         Picture1.BackColor = M_BkColor
  17. End Sub
  18. Private Sub UserControl_Resize()
  19.         Picture1.Move 0, 0, UserControl.Width, UserControl.Height
  20.         Shape1.Move -Picture1.Width, 0, Picture1.Width, UserControl.Height
  21.         LabPer.Move (Picture1.Width - LabPer.Width) / 2, (Picture1.ScaleHeight - LabPer.Height) / 2
  22. End Sub
  23. ''
  24. Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
  25.     BackColor = PropBag.ReadProperty("BackColor", &H80FFFF)
  26.     Picture1.Appearance = PropBag.ReadProperty("Appearance", 0)
  27.     Set LabPer.Font = PropBag.ReadProperty("Font", Ambient.Font)
  28.     LabPer.FontSize = PropBag.ReadProperty("FontSize", LabPer.FontSize)
  29.     LabPer.ForeColor = PropBag.ReadProperty("ForeColor", &H80000012)
  30.     BlockSize = PropBag.ReadProperty("BlockSize", 2)
  31. End Sub
  32. Private Sub UserControl_Show()
  33.         Shape1.ZOrder 0
  34.         Picture1.BackColor = M_BkColor
  35. End Sub
  36. Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
  37.     Call PropBag.WriteProperty("BackColor", BackColor, &H80FFFF)
  38.     Call PropBag.WriteProperty("Appearance", Picture1.Appearance, 0)
  39.     Call PropBag.WriteProperty("Font", LabPer.Font, Ambient.Font)
  40.     Call PropBag.WriteProperty("FontSize", LabPer.FontSize, 9)
  41.     Call PropBag.WriteProperty("ForeColor", LabPer.ForeColor, &H80000012)
  42.     Call PropBag.WriteProperty("BlockSize", BlockSize, 2)
  43.     
  44. End Sub
  45. '
  46. '=====================================================================
  47. '=====================================================================
  48. Public Function Copy(SourFile As String, _
  49.                      ObjFile As String, _
  50.                      Optional MsgTitle As String = "文件复制", _
  51.                      Optional ReplaceFile As Boolean = TrueAs Boolean
  52.                      
  53.         Dim Buf() As Byte
  54.         Dim BTest As Variant, FSize As Variant
  55.         Dim Chunk As Long, F1 As Long, F2 As Long
  56.         Dim Response As Long
  57.         Dim PrgVal As Long
  58.         Dim OleVal As Long
  59.         Dim DltW As Double
  60.         Dim PBar As Control
  61.         Dim BufSize As Long
  62.         
  63.         If M_BlockSize < 1 Then M_BlockSize = 1
  64.         BufSize = M_BlockSize * 1024
  65.         BTest = CDec(BTest): FSize = CDec(FSize)
  66.         
  67.         If Len(Dir(ObjFile)) > 0 Then
  68.            If Not ReplaceFile Then  '//不替换文件
  69.                 Response = MsgBox(ObjFile + Chr(13) + Chr(10) + "文件已存在.是否替换该文件?", vbYesNo + vbQuestion, MsgTitle)
  70.                 If Response = vbNo Then
  71.                    Copy = False
  72.                    Exit Function
  73.                 Else
  74.                    Kill ObjFile
  75.                    If Err.Number <> 0 Then Copy = FalseExit Function
  76.                 End If
  77.            Else  '//可以替换该文件
  78.                Kill ObjFile
  79.                If Err.Number <> 0 Then Copy = FalseExit Function
  80.            End If
  81.         End If
  82.          
  83.         On Error GoTo FileCopyError
  84.         
  85.         Shape1.Left = -Shape1.Width
  86.         Shape1.Visible = True
  87.         
  88.         LabPer.Caption = "0%"
  89.         DltW = Picture1.Width / 100
  90.         
  91.         DoEvents
  92.         
  93.         F1 = FreeFile: Open SourFile For Binary As F1
  94.         F2 = FreeFile: Open ObjFile For Binary As F2
  95.         
  96.         FSize = LOF(F1)
  97.         BTest = FSize - LOF(F2)
  98.         
  99.         While BTest > 0
  100.             If BTest < BufSize Then
  101.                Chunk = BTest
  102.             Else
  103.                Chunk = BufSize
  104.             End If
  105.             
  106.             If Chunk > 0 Then
  107.                 ReDim Buf(Chunk - 1)
  108.                 Get F1, , Buf
  109.                 Put F2, , Buf
  110.                 BTest = FSize - LOF(F2)
  111.             End If
  112.             
  113.             PrgVal = (100 - Int(100 * BTest / FSize))
  114.             
  115.             If OleVal <> PrgVal Then
  116.                 If PrgVal < 0 Then PrgVal = 0
  117.                 If PrgVal > 100 Then PrgVal = 100
  118.                 Shape1.Left = DltW * PrgVal - Shape1.Width
  119.                 LabPer.Caption = PrgVal & "%"
  120.                 DoEvents
  121.             End If
  122.             OleVal = PrgVal
  123.         Wend
  124.         
  125. FileCopyError:
  126.         Copy = (Err.Number = 0 Or Err.Number = 380)
  127.         Err.Clear
  128.         Close F1
  129.         Close F2
  130.         
  131. End Function
  132. '注意!不要删除或修改下列被注释的行!
  133. Public Property Get BackColor() As OLE_COLOR
  134.     BackColor = M_BkColor 'LabPer.BackColor
  135. End Property
  136. Public Property Let BackColor(ByVal New_BackColor As OLE_COLOR)
  137.     M_BkColor = New_BackColor
  138.     Picture1.BackColor = M_BkColor
  139.     PropertyChanged "BackColor"
  140. End Property
  141. Public Property Get Appearance() As Integer
  142.     Appearance = Picture1.Appearance
  143.     Picture1.BackColor = M_BkColor
  144. End Property
  145. Public Property Let Appearance(ByVal New_Appearance As Integer)
  146.     Picture1.Appearance() = New_Appearance
  147.     Picture1.BackColor = M_BkColor
  148.     PropertyChanged "Appearance"
  149. End Property
  150. '注意!不要删除或修改下列被注释的行!
  151. 'MappingInfo=LabPer,LabPer,-1,Font
  152. Public Property Get Font() As Font
  153.     Set Font = LabPer.Font
  154. End Property
  155. Public Property Set Font(ByVal New_Font As Font)
  156.     Set LabPer.Font = New_Font
  157.     PropertyChanged "Font"
  158. End Property
  159. '注意!不要删除或修改下列被注释的行!
  160. 'MappingInfo=LabPer,LabPer,-1,FontSize
  161. Public Property Get FontSize() As Single
  162.     FontSize = LabPer.FontSize
  163. End Property
  164. Public Property Let FontSize(ByVal New_FontSize As Single)
  165.     LabPer.FontSize() = New_FontSize
  166.     PropertyChanged "FontSize"
  167. End Property
  168. '注意!不要删除或修改下列被注释的行!
  169. 'MappingInfo=LabPer,LabPer,-1,ForeColor
  170. Public Property Get ForeColor() As OLE_COLOR
  171.     ForeColor = LabPer.ForeColor
  172. End Property
  173. Public Property Let ForeColor(ByVal New_ForeColor As OLE_COLOR)
  174.     LabPer.ForeColor() = New_ForeColor
  175.     PropertyChanged "ForeColor"
  176. End Property
  177. Public Property Get BlockSize() As Long
  178.     BlockSize = M_BlockSize
  179. End Property
  180. Public Property Let BlockSize(ByVal New_BlockSize As Long)
  181.     If New_BlockSize < 1 Then New_BlockSize = 1
  182.     If New_BlockSize > 1000 Then New_BlockSize = 1000
  183.     
  184.     M_BlockSize = New_BlockSize
  185.     PropertyChanged "BlockSize"
  186. End Property
发布了25 篇原创文章 · 获赞 4 · 访问量 6万+
展开阅读全文

没有更多推荐了,返回首页

©️2019 CSDN 皮肤主题: 大白 设计师: CSDN官方博客

分享到微信朋友圈

×

扫一扫,手机浏览