dm.bas

一个酒厂派车单管理系统,很方便的系统

Attribute VB_Name = "dm"
Public TJSql As String
Public Loguser As String
Public Flags
Public Sqlrep As String
Public Hcode As String
Public ZselRow As Integer
Public SelName As Form
Public Function FormExists(formName As String) As Boolean
  Dim i     As Integer
  For i = 0 To Forms.Count - 1
          If Forms(i).Name = formName Then
                  FormExists = True
                  Exit Function
          End If
  Next i
  FormExists = False
  End Function
Public Sub Creport(AReport As ActiveReport)
With AReport
  .Toolbar.Tools.Item(0).Tooltip = "各页目录"
  .Toolbar.Tools.Item(2).Caption = "打印..."
  .Toolbar.Tools.Item(2).Tooltip = "打印报表"
  .Toolbar.Tools.Item(4).Tooltip = "拷贝"
  .Toolbar.Tools.Item(6).Tooltip = "查找"
  .Toolbar.Tools.Item(8).Tooltip = "单页显示"
  .Toolbar.Tools.Item(9).Tooltip = "多页显示"
  .Toolbar.Tools.Item(11).Tooltip = "缩小"
  .Toolbar.Tools.Item(12).Tooltip = "放大"
  .Toolbar.Tools.Item(15).Tooltip = "上一页"
  .Toolbar.Tools.Item(16).Tooltip = "下一页"
  .Toolbar.Tools.Item(19).Tooltip = "后退"
  .Toolbar.Tools.Item(19).Caption = "后退"
  .Toolbar.Tools.Item(20).Tooltip = "前进"
  .Toolbar.Tools.Item(20).Caption = "前进"
 End With
End Sub

Public Sub CopyFile(sourcefile As String, destfile As String)
          Dim Bytearray()     As Byte, filesize       As Long     'Dim   our   variables
          Open sourcefile For Binary Access Read As #1                 'Open   our   source   file   to   read   from   it
          Open destfile For Binary Access Write As #2                 'Open   our   destination   file   to   create/write   to   it
          filesize = LOF(1)       'Set   out   filesize   to   use
          ReDim Bytearray(filesize)     'Set   out   array   to   use   our   filesize
          Get #1, , Bytearray         'Use   Get   statement   to   get   the   source   file   attributes
          Put #2, , Bytearray         'Use   Put   statement   to   transfer   the   source   file   attributes   to   the   destination   file
          Close 1     'Close   the   source   file
          Close 2     'Close   the   destination   file
End Sub

Public Function CreateDirectory(vDirectory As String)
'*******************************************************************************
'Sub: CreateDirectory
'Input: you want to build full path
'Subject: loop to build full path
'Prepared Date: 2005/9/06
'Last Modified Date: 2005/10/06
'*******************************************************************************
On Error GoTo Cmd_Err
Dim str1$, vpos%, vpostemp%, strComputerName$ 'vpos 是位置


 vpos = 1
 vpostemp = 1
  '判断全文件是否存在
 If (Dir(vDirectory, vbDirectory)) <> "" Then Exit Function
 
 '判断是否非本机途径 \\jim97\bondale\1
 If Len(vDirectory) >= 3 And VBA.Left$(vDirectory, 2) = "\\" Then
    vpos = InStr(3, vDirectory, "\", vbTextCompare)
    strComputerName = Mid(vDirectory, 1, vpos - 1)
    '从\下位开始
    vpos = vpos + 1
    
 End If
 
 
 'loop建文件夹
 While vpostemp > 0
   vpostemp = InStr(vpos, vDirectory, "\", vbTextCompare)
   If strcomputer <> "" Then
     str1 = strComputerName & "\" & Mid$(vDirectory, 1, vpostemp) '非本机
   Else
     str1 = Mid$(vDirectory, 1, vpostemp)
   End If
   
   If (Dir(str1, vbDirectory)) = "" Then
    MkDir (str1)
   End If
   vpos = vpostemp + 1
 Wend
 '建立全文件夹
 If (Right(vDirectory, 1)) <> "\" Then MkDir vDirectory
  Exit Function
Cmd_Err:
   MsgBox "创建错误: " & Err.Description
End Function