windows - VB6 中的企业支持，FileCopy 问题

Question

固件工程师目前正在从事企业错误搜索。好的，问题来了：该程序在用 VB6 编写的 windows XP/7 中运行。该程序可以将附件添加到零件编号（这是数据库中的键）。它通过通用文件对话窗口添加附件。然后它使用 FileCopy 将选择的文件复制到网络驱动器上的特定位置。如果用户决定从他桌面上的文件夹而不是桌面上的文件复制，他不能删除该文件夹，因为 Windows 7 会抛出“文件/文件夹正在被另一个程序使用”。如果程序不是每次都关闭，有时（？？为什么只是有时？？）在程序关闭后直到机器重新启动，就会出现此问题。我确信有一种很好的方法来处理这个问题，因为其他程序一直在做这件事而没有问题，我只是不这样做 不知道那个合适的方式是什么。我还“找到”了一个修复问题的注册表编辑，这样的修复是不合适的。

好的，代码如下。是的，我知道这是一个丑陋的混乱，不，我不需要提醒。我不是要让人们做我的功课，我只是在 VB6/Windows 方面需要一些帮助。

Private Sub Command1_Click()
On Error GoTo Command1_Click_Error
Dim File_To_Copy As String
Dim File_To_Copy_Path As String
Dim strTargetF As String
Dim filethere As String
Dim fPath As String
Dim Type_Of_Part As String
Dim Long_File_To_Read As String
Dim File_To_Read As String
Dim pointer_to_remote As Long
Dim another_pointer_to_remote As String
Dim wnet_return_val As Long
Dim temp As String
Dim File_To_Write As String
Dim revert_to_self_return_val As Boolean
Dim Output_File_Var
Dim Input_File_Len
Dim temp_str As String

Me.txtComp.Text = Global_Company_Name
CommonDialog1.InitDir = "c:\"
If Len(Trim(Global_Part_Var)) = 5 Then
    Type_Of_Part = "Part_Type_A"
Else
    Type_Of_Part = Mid(Global_Part_Var, 1, 3)
    If Type_Of_Part = "Part_Type_B" Then
        Type_Of_Part = "Part_Type_C"
    End If
End If
CommonDialog1.ShowOpen
CommonDialog1.CancelError = True
File_To_Copy = CommonDialog1.FileTitle
File_To_Copy_Path = CommonDialog1.FileName
If Err = cdlCancel Then
    Exit Sub
End If
Err.Clear
If File_To_Copy = "" Or IsNull(File_To_Copy) Or File_To_Copy = Empty Then
    Exit Sub
End If

strTargetF = File_To_Copy
'runasuser copy will not allow a path and file longer than 76 characters total..including drive and extension
If Len(File_To_Copy_Path) > 76 Then
    DoMessage GetLangString(STRING_TOO_LONG) & CStr(Len(File_To_Copy_Path)) & vbCr & File_To_Copy_Path
    Exit Sub
End If
fPath = PartsLinkPath & Type_Of_Part & "\" & Trim(Global_Part_Var) & "\" & "FAI_" & Company & "_" & lineinc
If Not (Mid(fPath, (Len(fPath)), 1) = "\") Then
    fPath = fPath & "\"
End If
If Not DirExists(fPath) Then
    Dim FolderToCreate
    FolderToCreate = "Obscure_Proprietary_Business_Process_Name_" & Global_Company_Name & "_" & lineinc
    RunAsUser SuperUser, SuperUserPassword, MyDomain, "C:\Windows\System32\cmd.exe /c ""mkdir """ & _
        PartsLinkPath & Type_Of_Part & "\" & Trim(Global_Part_Var) & "\" & FolderToCreate, "c:\"
    revert_to_self_return_val = RevertToSelf()
End If
Sleep SLEEP_1_SECOND    'wait for folder to be created
revert_to_self_return_val = RevertToSelf()
filethere = fPath & strTargetF
filethere = Dir(filethere)

'If the file is on the User's share on the H:\ drive, first copy it into C:\temp
If StrComp(UCase(Left(File_To_Copy_Path, 2)), "H:") = 0 Then
    If Not DirExists(TEMP_FILE_LOC_STR) Then 'If C:\temp does not exist then create it
        Dim temp_folder
        temp_folder = TEMP_FILE_LOC_STR
        RunAsUser SuperUser, SuperUserPassword, MyDomain, "C:\Windows\System32\cmd.exe /c ""mkdir "" " & _
            TEMP_FILE_LOC_STR, "c:\"
        revert_to_self_return_val = RevertToSelf()
        Sleep SLEEP_1_SECOND    'wait for folder to be created
    End If
    temp_str = TEMP_FILE_LOC_STR & File_To_Copy
    If FileExists(temp_str) Then 'delete the file from C:\temp if it exists
        Kill temp_str
    End If

    FileCopy File_To_Copy_Path, temp_str
    Sleep SLEEP_1_SECOND    'wait for file to be copied
    File_To_Copy_Path = temp_str
End If

If IsNull(filethere) Or filethere = "" Then
    Long_File_To_Read = File_To_Copy_Path
    File_To_Read = GetShortFileName(File_To_Copy_Path, True)
    If Left(File_To_Read, 2) Like "[F-Z][:]" Then
        pointer_to_remote = lBUFFER_SIZE
        another_pointer_to_remote = another_pointer_to_remote & Space(lBUFFER_SIZE)
        wnet_return_val = WNetGetConnection32(Left(File_To_Read, 2), another_pointer_to_remote, pointer_to_remote)
        temp = Trim(another_pointer_to_remote)
        File_To_Read = GetShortFileName(Left(temp, Len(temp) - 1) + Right(File_To_Read, Len(File_To_Read) - 2), True)
    End If
    File_To_Copy_Path = Long_File_To_Read
    If File_To_Copy_Path = "" Then
        Exit Sub
    End If
    Input_File_Len = FileLen(File_To_Copy_Path)
    File_To_Write = ParseOutputFilename("", File_To_Copy_Path)
    Output_File_Var = fPath & "\" & File_To_Write
    RunAsUser SuperUser, SuperUserPassword, MyDomain, "C:\Windows\System32\cmd.exe /c ""copy " + _
        File_To_Read + " """ + fPath + Mid(File_To_Copy_Path, Len(fPath) + 1, 3) + _
        "\" + Mid(File_To_Copy_Path, Len(fPath) + 1, 3) + File_To_Write + """""", "c:\"
    Sleep SLEEP_1_SECOND        'wait for file to copy over
    filethere = fPath & strTargetF
    filethere = Dir(filethere)
Else
    OpenFormYesNo = True
    FormYesNo.lblMsgbox.Caption = strTargetF & GetLangString(STRING_ALREADY_EXISTS)
    FormYesNo.Visible = True
    FormYesNo.cmdNo.SetFocus
    FormFAIData.ZOrder 0
    FormYesNo.ZOrder 0
    Do
        If (FormCount("FormYesNo") > 0) Then
            If (Screen.ActiveForm.Name <> "FormYesNo") And (OpenFormYesNo = True) Then
                FormYesNo.cmdNo.SetFocus
            End If
        End If
        DoEvents
        Sleep SLEEP_TIME
    Loop While FormCount("FormYesNo") > 0 And (OpenFormYesNo = True)
    FormFAIData.ZOrder 0
    If YesNo = vbYes Then
        Long_File_To_Read = File_To_Copy_Path
        File_To_Read = GetShortFileName(File_To_Copy_Path, True)
        If Left(File_To_Read, 2) Like "[F-Z][:]" Then
            pointer_to_remote = lBUFFER_SIZE
            another_pointer_to_remote = another_pointer_to_remote & Space(lBUFFER_SIZE)
            wnet_return_val = WNetGetConnection32(Left(File_To_Read, 2), another_pointer_to_remote, pointer_to_remote)
            temp = Trim(another_pointer_to_remote)
            File_To_Read = GetShortFileName(Left(temp, Len(temp) - 1) + Right(File_To_Read, _
                Len(File_To_Read) - 2), True)
        End If
        File_To_Copy_Path = Long_File_To_Read
        If File_To_Copy_Path = "" Then
            Exit Sub
        End If
        Input_File_Len = FileLen(File_To_Copy_Path)
        File_To_Write = ParseOutputFilename("", File_To_Copy_Path)
        Output_File_Var = fPath & "\" & File_To_Write
        RunAsUser SuperUser, SuperUserPassword, MyDomain, "C:\Windows\System32\cmd.exe /c ""copy " + _
            File_To_Read + " """ + fPath + Mid(File_To_Copy_Path, Len(fPath) + 1, 3) + _
            "\" + Mid(File_To_Copy_Path, Len(fPath) + 1, 3) + File_To_Write + """""", "c:\"
        Sleep SLEEP_1_SECOND            'wait for file to be copied
        filethere = fPath & strTargetF
        filethere = Dir(filethere)
    Else
        DoMessage GetLangString(STRING_USER_ENDED)
    End If
End If
Sleep SLEEP_1_SECOND
filethere = fPath & strTargetF
filethere = Dir(filethere)
Dim Output_File_Len
Output_File_Len = FileLen(Output_File_Var)
Close 'Close all open files
If Not Input_File_Len = Output_File_Len Then
    DoMessage GetLangString(STRING_NOT_COPIED)
Else
    DoMessage GetLangString(STRING_FILE_COPIED)
End If
Exit Sub


Command1_Click_Error:
    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure Command1_Click of Form Purposely_Changed_Form_Name"
End Sub

编辑：添加源代码。第二次编辑，修正了一个变量名。第三次编辑，删除了“Close #fileno”语句（这是错误的），在末尾添加了 Close 语句，并删除了“On error Resume Next”语句。

Answer 1

@jac，你说得对，这是通用对话框的问题。调查一个相关的问题，我在这里找到了答案：

http://www.xtremevbtalk.com/showthread.php?t=228622

解决方法是ChDir("C:\my_favorite_file_path")在过程退出时调用。如果它是当前工作目录，Windows 显然会锁定您搜索的文件夹。要解决这个问题，您只需更改当前工作目录。

感谢您的所有帮助@jac，VB6 对业务线应用程序的支持绝对不是我的强项，但看起来我将在未来一两年内做很多事情。

编辑：格式化

Answer 2

我想我记得很久以前就遇到过这个问题，我相信我认为这与通用对话框控件有关。至少我认为这就是我编写一个使用SHBrowseForFolder API 函数来选择文件的函数的原因。随意使用或不使用它，但它会避免您遇到的问题。该函数返回一个文件名，如果没有选择文件，则返回一个空字符串。我希望我得到了示例代码中的所有声明，我从一个更大的通用实用程序模块中提取了这些部分。

Option Explicit

Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BROWSEINFO) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As String) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, lpSecurityAttributes As SECURITY_ATTRIBUTES, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Any) As Long

Private Const BIF_INITIALIZED = 1
Private Const BIF_SELCHANGED = 2
Private Const WM_USER = &H400
Private Const BFFM_SETSTATUSTEXT = (WM_USER + 100)
Private Const BFFM_SETSELECTION = (WM_USER + 102)
Private Const BIF_EDITBOX = &H10
Private Const BIF_RETURNONLYFSDIRS = 1
Private Const BIF_STATUSTEXT = &H4&
Private Const BIF_BROWSEINCLUDEFILES As Long = &H4000
Private Const MAX_PATH = 260
Private Const OPEN_EXISTING = 3
Private Const FILE_SHARE_READ = &H1
Private Const FILE_SHARE_WRITE = &H2
Private Const INVALID_HANDLE_VALUE = -1
Private Const GENERIC_READ = &H80000000
Private Const GENERIC_WRITE = &H40000000
Private Const ERROR_SHARING_VIOLATION = 32&

Private Type SECURITY_ATTRIBUTES
    nLength As Long
    lpSecurityDescriptor As Long
    bInheritHandle As Long
End Type

Private Type BROWSEINFO
    hwndOwner      As Long
    pidlRoot       As Long
    pszDisplayName As Long
    lpszTitle      As String
    ulFlags        As Long
    lpfnCallback   As Long
    lParam         As Long
    iImage         As Long
End Type

Private mstrInitDir As String 'holds the path from the getfolder function
Private mstrFindFile As String   'holds the filename from the getfolder function

Public Function BrowseForFolder(ByVal hwndOwner As Long, ByVal sDefaultPath As String, ByVal sFindFile As String, _
                Optional ByVal sTitle As String = "Select Folder", Optional ByVal ShowMsg As Boolean = True, Optional ShowFiles As Boolean = True) As String
    Dim lpIDList As Long
    Dim sBuffer As String
    Dim szTitle As String
    Dim tBrowseInfo As BROWSEINFO
    Dim MSG As String

    mstrInitDir = sDefaultPath & vbNullChar
    mstrFindFile = sFindFile

    If ShowMsg = True Then
        'display what's happening to the user
        MSG = ProgramTitle & " was unable to find the file, '" & sFindFile & "'. " _
              & "Please use the following dialog box to set path to this file." _
              & vbCrLf & vbCrLf & "If this path is not set " _
              & ProgramTitle() & " will be unable to continue."
        MsgBox MSG, vbOKOnly + vbInformation, "File Not Found"
    End If

    'give the user the box
    szTitle = sTitle
    With tBrowseInfo
        .hwndOwner = hwndOwner
        .lpszTitle = szTitle 'lstrcat(szTitle, "")
        .ulFlags = BIF_RETURNONLYFSDIRS Or BIF_STATUSTEXT '
        If ShowFiles = True Then
            .ulFlags = .ulFlags Or BIF_BROWSEINCLUDEFILES
        End If
       .pidlRoot = 0
       .lpfnCallback = GetAddressOf(AddressOf BrowseCallBack)
    End With

    lpIDList = SHBrowseForFolder(tBrowseInfo)

    If (lpIDList) Then
        sBuffer = Space(MAX_PATH)
        SHGetPathFromIDList lpIDList, sBuffer
        sBuffer = Left(sBuffer, InStr(sBuffer, vbNullChar) - 1)
        BrowseForFolder = sBuffer
    End If

End Function

Private Function BrowseCallBack(ByVal hwnd As Long, ByVal uMsg As Long, ByVal lParam As Long, ByVal lpData As Long) As Long
    Dim Rtn As Long
    Dim sBuffer As String * MAX_PATH
    Dim strPath As String

    On Error Resume Next 'attempt to prevent error propagation to caller

    Select Case uMsg
        Case Is = BIF_SELCHANGED
            sBuffer = Space$(MAX_PATH)
            Rtn = SHGetPathFromIDList(lParam, sBuffer)
            If Rtn = 1 Then
                If Len(mstrFindFile) > 1 Then
                    strPath = Left$(sBuffer, InStr(sBuffer, vbNullChar) - 1)
                    If Right$(strPath, 1) <> "\" Then
                        strPath = strPath & "\"
                    End If
                    If FileExists(strPath & mstrFindFile) = True Then
                        Rtn = SendMessage(hwnd, BFFM_SETSTATUSTEXT, 0, ByVal (mstrFindFile & " found!" & vbNullChar))
                    Else
                        Rtn = SendMessage(hwnd, BFFM_SETSTATUSTEXT, 0, ByVal ("not found, " & mstrFindFile))
                    End If
                Else
                    Rtn = SendMessage(hwnd, BFFM_SETSTATUSTEXT, 0, ByVal FormatPath(sBuffer))
                End If
            End If

        Case Is = BIF_INITIALIZED
            Rtn = SendMessage(hwnd, BFFM_SETSELECTION, 1, ByVal (mstrInitDir))

    End Select

End Function

Function FileExists(ByVal fSpec As String) As Boolean
    Dim lngResult As Long
    Dim udtSA As SECURITY_ATTRIBUTES

    On Error GoTo errFileExists

    If Len(fSpec) > 0 Then
        udtSA.nLength = Len(udtSA)
        udtSA.bInheritHandle = 1&
        udtSA.lpSecurityDescriptor = 0&
        lngResult = CreateFile(fSpec, GENERIC_READ, FILE_SHARE_READ, udtSA, OPEN_EXISTING, 0&, 0&)
        If lngResult <> INVALID_HANDLE_VALUE Then
            Call CloseHandle(lngResult)
            FileExists = True
        Else
            Select Case Err.LastDllError  'some errors may indicate the file exists, but there was an error opening it
                Case Is = ERROR_SHARING_VIOLATION
                    FileExists = True

                Case Else
                    FileExists = False

            End Select
        End If
    End If

    Exit Function

errFileExists:
    Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext

End Function

Private Function GetAddressOf(ByVal lpAddr As Long) As Long

    GetAddressOf = lpAddr

End Function

Public Function ProgramTitle() As String
    Dim sDefaultTitle As String

    On Error GoTo errProgramTitle

    sDefaultTitle = StrConv(App.EXEName, vbProperCase)
    ProgramTitle = IIf(Len(App.ProductName) > 0, App.ProductName, sDefaultTitle)

    Exit Function

errProgramTitle:
    ProgramTitle = sDefaultTitle

End Function

'format a path to look like C:\Windows\Folder from c:\windows\folder
Public Function FormatPath(ByVal Path As String) As String
    Dim sReturn As String
    Dim sCurChar As String * 1
    Dim sLastChar As String * 1
    Dim i As Integer

    For i = 1 To Len(Trim$(Path))
        sCurChar = Mid$(Path, i, 1)

        If sLastChar = vbNullChar Then
            sReturn = StrConv(sCurChar, vbUpperCase)
        ElseIf sLastChar Like "[/\: ]" Then
            sReturn = sReturn & StrConv(sCurChar, vbUpperCase)
        Else
            sReturn = sReturn & StrConv(sCurChar, vbLowerCase)
        End If
            sLastChar = sCurChar
    Next i

    FormatPath = sReturn

End Function

Answer 3

奇怪的是，把Close程序放在最后并没有解决问题。我认为它是奇怪的 Win7 和 VB6 交互的组合。不幸的是，这不是关于为什么会发生这种行为的真正答案，但我需要继续前进并处理其他事情。所以这是我的妥协：

如果您查看上面的代码，您会发现 RunAsUser 不能接受长度超过 76 个字符的文件路径。最终用户意识到了这一点；因此他们会将相关文件夹从网络上的某个位置复制到桌面并从中附加文件。我将上面的代码更改为始终将文件复制到 C:\temp 中，然后将其提供给 RunAsUser。（而不是仅仅将它复制到 C;\temp 如果它来自 H:) 然后从 C:\temp 中删除它。这样一开始就没有人需要将任何东西复制到他们的桌面上，他们可以从网络上的任何地方选择相关文件，程序会先将其复制到 temp 中，然后将其复制到受限区域，然后从 temp 中删除文件. 如果最终用户正确使用该程序，则最终结果是为他们节省了一些时间和精力。