1. Computer problem? Tech Support Guy is completely free -- paid for by advertisers and donations. Click here to join today! If you're new to Tech Support Guy, we highly recommend that you visit our Guide for New Members.

VBA code to map a drive

Discussion in 'Software Development' started by gmoukled, Nov 18, 2011.

Thread Status:
Not open for further replies.
Advertisement
  1. gmoukled

    gmoukled Thread Starter

    Joined:
    Oct 17, 2011
    Messages:
    33
    I am currently using the code below, to import a csv file from a drive.

    I am mapping the drive manually before running the macro.

    What I would like to do is to add some line of code to my existing macro to make it map the drive automatically ( the drive has credentials too)
    Code:
    Sub RunAll()
    
    
    Dim ImportFilePath As String, ExportFilePath As String
    Dim File2Import As String, File2Export As String
    ImportFilePath = "\\[COLOR="Red"]DRIVE NAME[/COLOR]\c$\UPS32"
    ExportFilePath = "C:\Users\TZFTQF\Fall 2011 Coop term\Server Cycle Time\Template"
    File2Import = "copy_2_server_cycle_time.csv"
    File2Export = "Template"
    Call Macro1(ImportFilePath, File2Import, ExportFilePath, File2Export)
    Call Macro2(ImportFilePath, File2Import, ExportFilePath, File2Export)
    
    
    
     ActiveWorkbook.SaveAs Filename:= _
            "C:\Users\TZFTQF\Fall 2011 Coop term\Server Cycle Time\SpreadSheet.xlsx", _
            FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    End Sub
    
    Sub Macro1(ImportFilePath, File2Import, ExportFilePath, File2Export)
    '
    ' Macro1 Macro
    '
    
    '
        With ActiveSheet.QueryTables.Add(Connection:= _
            "TEXT;\\[COLOR="red"]DRIVE NAME[/COLOR]\c$\UPS32\copy_2_server_cycle_time.csv" _
            , Destination:=Range("$A$1"))
            .Name = "copy_2_server_cycle_time"
            .FieldNames = True
            .RowNumbers = False
            .FillAdjacentFormulas = False
            .PreserveFormatting = True
            .RefreshOnFileOpen = False
            .RefreshStyle = xlInsertDeleteCells
            .SavePassword = False
            .SaveData = True
            .AdjustColumnWidth = True
            .RefreshPeriod = 0
            .TextFilePromptOnRefresh = False
            .TextFilePlatform = 437
            .TextFileStartRow = 1
            .TextFileParseType = xlDelimited
            .TextFileTextQualifier = xlTextQualifierDoubleQuote
            .TextFileConsecutiveDelimiter = False
            .TextFileTabDelimiter = False
            .TextFileSemicolonDelimiter = False
            .TextFileCommaDelimiter = True
            .TextFileSpaceDelimiter = False
            .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1)
            .TextFileTrailingMinusNumbers = True
            .Refresh BackgroundQuery:=False
        End With
        Cells.Select
        ActiveWorkbook.Worksheets("RAW DATA").Sort.SortFields.Clear
        ActiveWorkbook.Worksheets("RAW DATA").Sort.SortFields.Add Key:=Columns( _
            "D:D"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
            xlSortNormal
        ActiveWorkbook.Worksheets("RAW DATA").Sort.SortFields.Add Key:=Columns( _
            "A:A"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
            xlSortNormal
        ActiveWorkbook.Worksheets("RAW DATA").Sort.SortFields.Add Key:=Columns( _
            "E:E"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
            xlSortNormal
        With ActiveWorkbook.Worksheets("RAW DATA").Sort
            .SetRange Range("A1:E99999")
            .Header = xlGuess
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        
        Dim rngFind As Range
        Dim strValueToPick As String
        Dim rngPicked As Range
        Dim rngLook As Range
        Dim strFirstAddress As String
        
        Set rngLook = Selection
        strValueToPick = "COLDTEST1"
        With rngLook
            Set rngFind = .Find(strValueToPick, .Cells(1, 1), LookIn:=xlValues, lookat:=xlWhole)
            If Not rngFind Is Nothing Then
                strFirstAddress = rngFind.Address
                Set rngPicked = rngFind
                Do
                    Set rngPicked = Union(rngPicked, rngFind)
                    Set rngFind = .FindNext(rngFind)
                Loop While Not rngFind Is Nothing And rngFind.Address <> strFirstAddress
            End If
        End With
        
        If Not rngPicked Is Nothing Then
            rngPicked.Offset(0, 1).Select
            
            Selection.Copy
            Sheets("COLDTEST1 CHART").Activate
            Range("$A$1").Select
            Selection.PasteSpecial
            ActiveSheet.Shapes.AddChart.Select
            ActiveChart.ChartType = xlXYScatter
            ActiveChart.SetElement (msoElementPrimaryValueAxisTitleRotated)
            ActiveChart.Axes(xlValue, xlPrimary).AxisTitle.Text = "Time"
            ActiveChart.Legend.Select
            Selection.Delete
            ActiveSheet.Shapes("Chart 1").ScaleWidth 1.5, msoFalse, msoScaleFromTopLeft
            ActiveSheet.Shapes("Chart 1").ScaleHeight 1.5, msoFalse, msoScaleFromTopLeft
        End If
        
    End Sub
    
    I was originally using this code to import the csv file from my desktop. All i did is that i replaced the file path with the drive name. But i am mapping the drive manually before running the macro!

    Your help is appreciated!
     
  2. Rollin_Again

    Rollin_Again

    Joined:
    Sep 4, 2003
    Messages:
    4,912
    This should do the trick. Just change the drive letter, path, username, and password which are highlighted in red below.

    Code:
    Dim objNetwork As Object
    Set objNetwork = CreateObject("WScript.Network")
    objNetwork.MapNetworkDrive "[COLOR="Red"]F[/COLOR]:", "[COLOR="Red"]\\DRIVE NAME\c$\UPS32[/COLOR]", False, "[COLOR="Red"]username[/COLOR]", "[COLOR="Red"]password[/COLOR]"
    
    
    Rollin
     
  3. gmoukled

    gmoukled Thread Starter

    Joined:
    Oct 17, 2011
    Messages:
    33
    Thanks Rollin

    I tried to add your code to my existing code as follows:
    Code:
    Sub RunAll()
    
    
       [COLOR="Red"] Dim objNetwork As Object
    Set objNetwork = CreateObject("WScript.Network")
    objNetwork.MapNetworkDrive "C:", "\\DRIVE NAME\c$\UPS32", False, "gm", "gm"[/COLOR]
    
    
    Dim ImportFilePath As String, ExportFilePath As String
    Dim File2Import As String, File2Export As String
    [COLOR="red"]ImportFilePath = "\\DRIVE NAME\c$\UPS32"[/COLOR]
    ExportFilePath = "C:\Users\TZFTQF\Fall 2011 Coop term\Server Cycle Time\Template"
    File2Import = "copy_2_server_cycle_time.csv"
    File2Export = "Template"
    Call Macro1(ImportFilePath, File2Import, ExportFilePath, File2Export)
    Call Macro2(ImportFilePath, File2Import, ExportFilePath, File2Export)
    
    
    
     ActiveWorkbook.SaveAs Filename:= _
            "C:\Users\TZFTQF\Fall 2011 Coop term\Server Cycle Time\SpreadSheet.xlsx", _
            FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    End Sub
    
    Sub Macro1(ImportFilePath, File2Import, ExportFilePath, File2Export)
    '
    ' Macro1 Macro
    '
    
    '
        With ActiveSheet.QueryTables.Add(Connection:= _
          [COLOR="red"]  "TEXT;\\CASCFSA0CLD01\c$\UPS32\copy_2_server_cycle_time.csv" _[/COLOR]
            , Destination:=Range("$A$1"))
            .Name = "copy_2_server_cycle_time"
            .FieldNames = True
            .RowNumbers = False
            .FillAdjacentFormulas = False
            .PreserveFormatting = True
            .RefreshOnFileOpen = False
            .RefreshStyle = xlInsertDeleteCells
            .SavePassword = False
            .SaveData = True
            .AdjustColumnWidth = True
            .RefreshPeriod = 0
            .TextFilePromptOnRefresh = False
            .TextFilePlatform = 437
            .TextFileStartRow = 1
            .TextFileParseType = xlDelimited
            .TextFileTextQualifier = xlTextQualifierDoubleQuote
            .TextFileConsecutiveDelimiter = False
            .TextFileTabDelimiter = False
            .TextFileSemicolonDelimiter = False
            .TextFileCommaDelimiter = True
            .TextFileSpaceDelimiter = False
            .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1)
            .TextFileTrailingMinusNumbers = True
            .Refresh BackgroundQuery:=False
        End With
        Cells.Select
        ActiveWorkbook.Worksheets("RAW DATA").Sort.SortFields.Clear
        ActiveWorkbook.Worksheets("RAW DATA").Sort.SortFields.Add Key:=Columns( _
            "D:D"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
            xlSortNormal
        ActiveWorkbook.Worksheets("RAW DATA").Sort.SortFields.Add Key:=Columns( _
            "A:A"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
            xlSortNormal
        ActiveWorkbook.Worksheets("RAW DATA").Sort.SortFields.Add Key:=Columns( _
            "E:E"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
            xlSortNormal
        With ActiveWorkbook.Worksheets("RAW DATA").Sort
            .SetRange Range("A1:E99999")
            .Header = xlGuess
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        
        Dim rngFind As Range
        Dim strValueToPick As String
        Dim rngPicked As Range
        Dim rngLook As Range
        Dim strFirstAddress As String
        
        Set rngLook = Selection
        strValueToPick = "COLDTEST1"
        With rngLook
            Set rngFind = .Find(strValueToPick, .Cells(1, 1), LookIn:=xlValues, lookat:=xlWhole)
            If Not rngFind Is Nothing Then
                strFirstAddress = rngFind.Address
                Set rngPicked = rngFind
                Do
                    Set rngPicked = Union(rngPicked, rngFind)
                    Set rngFind = .FindNext(rngFind)
                Loop While Not rngFind Is Nothing And rngFind.Address <> strFirstAddress
            End If
        End With
        
        If Not rngPicked Is Nothing Then
            rngPicked.Offset(0, 1).Select
            
            Selection.Copy
            Sheets("COLDTEST1 CHART").Activate
            Range("$A$1").Select
            Selection.PasteSpecial
            ActiveSheet.Shapes.AddChart.Select
            ActiveChart.ChartType = xlXYScatter
            ActiveChart.SetElement (msoElementPrimaryValueAxisTitleRotated)
            ActiveChart.Axes(xlValue, xlPrimary).AxisTitle.Text = "Time"
            ActiveChart.Legend.Select
            Selection.Delete
            ActiveSheet.Shapes("Chart 1").ScaleWidth 1.5, msoFalse, msoScaleFromTopLeft
            ActiveSheet.Shapes("Chart 1").ScaleHeight 1.5, msoFalse, msoScaleFromTopLeft
        End If
        
    End Sub
    
    The changes I made are in red.
    I am getting the error : '-2147024811(80070055)'
    The local device name is already in use.
     
  4. Rollin_Again

    Rollin_Again

    Joined:
    Sep 4, 2003
    Messages:
    4,912
    You are trying to use C: as the mapped drive letter and it is already being used since this is where the operating system files are located. You'll have to pick a different drive letter to use.

    Rollin
     
  5. gmoukled

    gmoukled Thread Starter

    Joined:
    Oct 17, 2011
    Messages:
    33
    OK, that worked fine. However, when i tried to run my program a second time, I got the same error. I changed the drive letter again and it worked. It seems that i would need to change the letter each time i want to run the program!

    How do I fix that?
     
  6. gmoukled

    gmoukled Thread Starter

    Joined:
    Oct 17, 2011
    Messages:
    33
    I am thinking i might need to unmap the drive, i tried to add this
    Code:
    MyDrive.RemoveNetworkDrive "Drive Letter:", bForce:=True
    but whenever i run the code it just crashes.
     
  7. Rollin_Again

    Rollin_Again

    Joined:
    Sep 4, 2003
    Messages:
    4,912
    You need to check to see if the drive is mapped first or add error handling to accommodate for the error.

    Rollin
     
  8. gmoukled

    gmoukled Thread Starter

    Joined:
    Oct 17, 2011
    Messages:
    33
    How do i do that?
     
  9. Sponsor

As Seen On
As Seen On...

Welcome to Tech Support Guy!

Are you looking for the solution to your computer problem? Join our site today to ask your question. This site is completely free -- paid for by advertisers and donations.

If you're not already familiar with forums, watch our Welcome Guide to get started.

Join over 733,556 other people just like you!

Loading...
Thread Status:
Not open for further replies.

Short URL to this thread: https://techguy.org/1027357

  1. This site uses cookies to help personalise content, tailor your experience and to keep you logged in if you register.
    By continuing to use this site, you are consenting to our use of cookies.
    Dismiss Notice