VBA code to map a drive

Status
This thread has been Locked and is not open to further replies. Please start a New Thread if you're having a similar issue. View our Welcome Guide to learn how to use this site.

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!
 
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
 

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.
 
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
 

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?
 

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.
 
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
 
Status
This thread has been Locked and is not open to further replies. Please start a New Thread if you're having a similar issue. View our Welcome Guide to learn how to use this site.

Users Who Are Viewing This Thread (Users: 0, Guests: 1)

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 807,865 other people just like you!

Latest posts

Members online

Top