frmserverpath.frm

一个用VB写的财务软件源码

VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Begin VB.Form frmServerPath 
   BorderStyle     =   1  'Fixed Single
   Caption         =   "位置"
   ClientHeight    =   5370
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   5970
   Icon            =   "frmServerPath.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   5370
   ScaleWidth      =   5970
   StartUpPosition =   3  '窗口缺省
   Begin MSComctlLib.ImageList ImageList1 
      Left            =   2160
      Top             =   2280
      _ExtentX        =   1005
      _ExtentY        =   1005
      BackColor       =   -2147483643
      ImageWidth      =   16
      ImageHeight     =   16
      MaskColor       =   12632256
      _Version        =   393216
      BeginProperty Images {2C247F25-8591-11D1-B16A-00C0F0283628} 
         NumListImages   =   3
         BeginProperty ListImage1 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "frmServerPath.frx":030A
            Key             =   "Drive"
         EndProperty
         BeginProperty ListImage2 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "frmServerPath.frx":0624
            Key             =   "Path"
         EndProperty
         BeginProperty ListImage3 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "frmServerPath.frx":0A76
            Key             =   "File"
         EndProperty
      EndProperty
   End
   Begin VB.TextBox txtFileName 
      Height          =   270
      Left            =   1080
      TabIndex        =   4
      Top             =   3960
      Width           =   4815
   End
   Begin VB.CommandButton cmdCancel 
      Cancel          =   -1  'True
      Caption         =   "取消(&C)"
      Height          =   300
      Left            =   3825
      TabIndex        =   2
      Top             =   5025
      Width           =   975
   End
   Begin VB.CommandButton cmdOk 
      Caption         =   "确定(&O)"
      Default         =   -1  'True
      Height          =   300
      Left            =   1665
      TabIndex        =   1
      Top             =   5040
      Width           =   975
   End
   Begin MSComctlLib.TreeView tvwPath 
      Height          =   3855
      Left            =   0
      TabIndex        =   0
      Top             =   0
      Width           =   5895
      _ExtentX        =   10398
      _ExtentY        =   6800
      _Version        =   393217
      Indentation     =   295
      LabelEdit       =   1
      LineStyle       =   1
      Style           =   7
      ImageList       =   "ImageList1"
      Appearance      =   1
   End
   Begin VB.Label lblSelectFile 
      Height          =   510
      Left            =   1080
      TabIndex        =   6
      Top             =   4440
      Width           =   4815
      WordWrap        =   -1  'True
   End
   Begin VB.Label Label2 
      AutoSize        =   -1  'True
      Caption         =   "选定的文件："
      Height          =   180
      Left            =   0
      TabIndex        =   5
      Top             =   4440
      Width           =   1080
   End
   Begin VB.Label Label1 
      AutoSize        =   -1  'True
      Caption         =   "文件名："
      Height          =   180
      Left            =   0
      TabIndex        =   3
      Top             =   3960
      Width           =   720
   End
End
Attribute VB_Name = "frmServerPath"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private WithEvents Cnn As ADODB.Connection
Attribute Cnn.VB_VarHelpID = -1
Private mDrives As New Collection
Private mPathLongName As New Collection
Private mPathShortName As New Collection
Private mFileLongName As New Collection
Private mFileShortName As New Collection
Public OK As Boolean


Public Property Get uConnection() As ADODB.Connection
Set uConnection = Cnn
End Property

Public Property Let uConnection(ByVal vNewValue As ADODB.Connection)
Set Cnn = vNewValue
End Property

Private Sub cmdCancel_Click()
OK = False
Me.Hide
End Sub

Private Sub cmdOk_Click()
OK = True
Me.Hide
End Sub

Private Sub Form_Load()
Dim i As Integer
ScanDrive
tvwPath.Nodes.Clear
For i = 1 To mDrives.Count
    tvwPath.Nodes.Add , , mDrives(i), CStr(mDrives(i)), "Drive", "Drive"
Next
End Sub


Private Function LoadFileLongName(ByVal sPath As String)
Dim rSt As New Recordset
Dim s As String

While mFileLongName.Count > 0
    mFileLongName.Remove 1
Wend
rSt.Open "master..xp_cmdShell 'dir /a-d /b " + sPath + "\'", Cnn, adOpenKeyset, adLockOptimistic
While rSt.EOF = False
    If IsNull(rSt.Fields(0).Value) = False Then
        If rSt.Fields(0).Value <> "找不到文件" And rSt.Fields(0).Value <> "系统找不到指定的路径。" And rSt.Fields(0).Value <> "系统找不到指定的文件。" Then
            mFileLongName.Add rSt.Fields(0).Value
        End If
    End If
    rSt.MoveNext
Wend
rSt.Close
End Function


Private Function LoadFileShortName(ByVal sPath As String)
Dim rSt As New Recordset
Dim s As String
Dim i As Integer
While mFileShortName.Count > 0
    mFileShortName.Remove 1
Wend
rSt.Open "master..xp_cmdShell 'dir /-n /a-d " + sPath + "\'", Cnn, adOpenKeyset, adLockOptimistic
While rSt.EOF = False
    If IsNull(rSt.Fields(0).Value) = False Then
        If rSt.Fields(0).Value <> "找不到文件" And rSt.Fields(0).Value <> "系统找不到指定的路径。" And rSt.Fields(0).Value <> "系统找不到指定的文件。" And Left$(rSt.Fields(0).Value, 1) <> " " And Trim$(Left$(rSt.Fields(0).Value, 3)) <> "." And Trim$(Left$(rSt.Fields(0).Value, 3)) <> ".." Then
            s = rSt.Fields(0).Value
            If Trim$(Mid$(s, 10, 3)) = "" Then
                mFileShortName.Add Trim$(Left$(s, 8))
            Else
                mFileShortName.Add Trim$(Left$(s, 8)) + "." + Trim$(Mid$(s, 10, 3))
            End If
        End If
    End If
    rSt.MoveNext
Wend
rSt.Close
End Function

Private Function LoadPathLongName(ByVal sPath As String)
Dim rSt As New Recordset
Dim s As String
While mPathLongName.Count > 0
    mPathLongName.Remove 1
Wend
rSt.Open "master..xp_cmdShell 'dir /ad /b " + sPath + "\'", Cnn, adOpenKeyset, adLockOptimistic
While rSt.EOF = False
    If IsNull(rSt.Fields(0).Value) = False Then
        If rSt.Fields(0).Value <> "找不到文件" And rSt.Fields(0).Value <> "系统找不到指定的路径。" And rSt.Fields(0).Value <> "系统找不到指定的文件。" Then
            mPathLongName.Add rSt.Fields(0).Value
        End If
    End If
    rSt.MoveNext
Wend
rSt.Close
End Function

Private Function LoadPathShortName(ByVal sPath As String)
Dim rSt As New Recordset
Dim s As String
Dim i As Integer
While mPathShortName.Count > 0
    mPathShortName.Remove 1
Wend
rSt.Open "master..xp_cmdShell 'dir /-n /ad  " + sPath + "\'", Cnn, adOpenKeyset, adLockOptimistic
While rSt.EOF = False
    If IsNull(rSt.Fields(0).Value) = False Then
        If rSt.Fields(0).Value <> "找不到文件" And rSt.Fields(0).Value <> "系统找不到指定的路径。" _
            And rSt.Fields(0).Value <> "系统找不到指定的文件。" And _
            Left$(rSt.Fields(0).Value, 1) <> " " And Trim$(Left$(rSt.Fields(0).Value, 3)) <> "." And _
            Trim$(Left$(rSt.Fields(0).Value, 3)) <> ".." Then
            s = rSt.Fields(0).Value
            If Trim$(Mid$(s, 10, 3)) = "" Then
                mPathShortName.Add Trim$(Left$(s, 8))
            Else
                mPathShortName.Add Trim$(Left$(s, 8)) + "." + Trim$(Mid$(s, 10, 3))
            End If
        End If
    End If
    rSt.MoveNext
Wend
rSt.Close
End Function


Private Function ScanDrive()
Dim i As Integer
While mDrives.Count > 0
    mDrives.Remove 1
Wend
For i = Asc("A") To Asc("Z")
    If IsExistDrive(Chr(i) + ":") Then
        mDrives.Add Chr(i) + ":"
    End If
Next
End Function

Private Function IsExistDrive(ByVal sDriveName As String) As Boolean
Dim rSt As New Recordset
IsExistDrive = False
'rSt.Open "master..xp_cmdShell 'vol " + sDriveName + "'", Cnn, adOpenKeyset, adLockOptimistic
rSt.Open "master..xp_cmdShell 'vol " + sDriveName + "'", Cnn, adOpenKeyset, adLockOptimistic
If rSt.EOF = False Then
    IsExistDrive = Not IsNull(rSt.Fields(0).Value)
End If
rSt.Close
End Function

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
If UnloadMode <> 1 Then Me.Hide
End Sub

Private Sub tvwPath_NodeClick(ByVal Node As MSComctlLib.Node)
Dim i As Integer
Me.MousePointer = 11
If Node.Children = 0 And Node.Image <> "File" Then
    'LoadPathLongName Node.Key
    'LoadPathShortName Node.Key
    LoadPathLongName Node.FullPath
    LoadPathShortName Node.FullPath
    For i = 1 To mPathLongName.Count
        tvwPath.Nodes.Add Node.Key, tvwChild, Node.Key + "\" + mPathShortName(i), mPathLongName(i), "Path", "Path"
    Next
    LoadFileLongName Node.FullPath
    LoadFileShortName Node.FullPath
    For i = 1 To mFileLongName.Count
        tvwPath.Nodes.Add Node.Key, tvwChild, Node.Key + "\" + mFileShortName(i), mFileLongName(i), "File", "File"
    Next
    Node.Expanded = True
End If
If Node.Image = "File" Then
    txtFileName = Node.text
    lblSelectFile.Caption = Node.FullPath
Else
    txtFileName = ""
    lblSelectFile.Caption = Node.FullPath + "\"
End If
Me.MousePointer = 0
End Sub

Public Function FormatTo83(ByVal s As String, ByVal sOld As String, ByVal IsPath As Boolean) As String
Dim i As Integer
Dim iSeed As Integer
s = Replace(s, " ", "")
If Len(s) > 9 Then
    i = InStr(1, s, ".")
    If i > 9 Then
        If StrComp(Mid$(s, 1, 6), Mid$(sOld, 1, 6), vbTextCompare) = 0 Then
            If Mid$(sOld, 7, 1) = "~" Then
                iSeed = CInt(Mid$(sOld, 8, 1)) + 1
            Else
                iSeed = 1
            End If
        Else
            iSeed = 1
        End If
        FormatTo83 = Mid$(s, 1, 6) + "~" + CStr(iSeed)
        If i < LenB(s) And i > 0 And IsPath = False Then
            FormatTo83 = FormatTo83 + Mid$(s, i)
        End If
    Else
        FormatTo83 = s
    End If
Else
    FormatTo83 = s
End If
End Function

Public Property Get filename() As String
filename = lblSelectFile.Caption
End Property

Private Sub txtFileName_Change()
If tvwPath.SelectedItem Is Nothing Then Exit Sub
If tvwPath.SelectedItem.Image = "File" Then
    lblSelectFile.Caption = tvwPath.SelectedItem.Parent.FullPath + "\" + txtFileName
Else
    lblSelectFile.Caption = tvwPath.SelectedItem.FullPath + "\" + txtFileName
End If
End Sub