VB6中的企业支持，FileCopy问题

时间：2013-10-18 15:33:00

标签： windows vb6 enterprise

固件工程师目前正在进行企业漏洞攻击。好的，这是问题： 该程序在用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

编辑：添加了源代码。第二次编辑，修复了一个变量名。第三次编辑，删除“关闭#fileno”语句（这是错误的），在结束时添加了Close语句，并删除了“On Error Resume Next”语句。

3 个答案:

答案 0 :(得分：1)

@jac，你是对的，这是Common Dialog的一个问题。看一个相关的问题，我在这里找到了答案：

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

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

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

编辑：格式化

答案 1 :(得分：0)

我想我很久以前就记得遇到过这个问题，我相信我认为这与常见的对话框控件有关。至少我认为这就是我编写一个使用 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

答案 2 :(得分：0)

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

如果查看上面的代码，您将看到RunAsUser无法接受超过76个字符的文件路径。最终用户意识到了这一点;所以他们会从网络上的某个地方将相关文件夹复制到桌面并附加文件。我将上面的代码更改为始终将文件复制到C：\ temp中，然后将其提供给RunAsUser。 （而不是仅将其复制到C; \ temp，如果它来自H :)然后从C：\ temp中删除它。这样一来，没有人必须将任何内容复制到他们的桌面上，他们可以从网络上的任何地方选择相关文件，程序会先将其复制到temp，然后将其复制到限制区域，然后从temp中删除文件。如果他们适当地使用该程序，这最终会为最终用户节省一些时间和精力。

相关问题
最新问题