My Exel VBA saves a pdf file to OneDrive locally "C:\Users\Name\OneDrive\FileName.pdf".
I need to find some code that gives med the URL to this file, so that it can be typed into a cell. The URL is used to create a QR code, so that anyone can read the pdf-file.
For now I have to find the URL manually and paste it in to the spreadsheet, before VBA creates the QR-code.
I am working in Office 365, but the .xlsm-file will be distributed to user with different Excel versions.
I've been struggling with this for a while, so I'm very happy if anyone can help.
CODE:
Sub QrLabelCreate()
'STEP 1:
'Excel VBA put data into a word-document, and export it to pdf-file (saved to OneDrive):
.ActiveDocument.ExportAsFixedFormat _
OutputFileName:="C:Users\Name\OneDrive\MyMap\" & ID & ".pdf", _
ExportFormat:=wdExportFormatPDF
'STEP 2: THE PROBLEM
'====== I am not able to create code that gives me the URL to the pdf-file. ==========
'STEP 3:
'The URL is pasted into the spreadsheet, and VBA creates the QR-code.
End Sub
Doing this generally is not easy at all, but luckily it is related to the more common problem of finding the local path when given the URL.
That's why I can now offer a kind of solution here.
Note that this solution does not create a OneDrive 'share' link, to create such a link you need to use the Microsoft Graph API! The links created by this function will only work for the account that owns the remote folder that's being synchronized.
To use my solution, copy the following function into any standard code module:
'Function for converting OneDrive/SharePoint Local Paths synchronized to
'OneDrive in any way to an OneDrive/SharePoint URL, containing for example
'.sharepoint.com/sites, my.sharepoint.com/personal/, or https://d.docs.live.net/
'depending on the type of OneDrive account and synchronization.
'If no url path can be found, the input value will be returned unmodified.
'Author: Guido Witt-Dörring
'Source: https://gist.github.com/guwidoe/6f0cbcd22850a360c623f235edd2dce2
Public Function GetWebPath(ByVal path As String, _
Optional ByVal rebuildCache As Boolean = False) _
As String
#If Mac Then
Const vbErrPermissionDenied As Long = 70
Const vbErrInvalidFormatInResourceFile As Long = 325
Const ps As String = "/"
#Else
Const ps As String = "\"
#End If
Const vbErrFileNotFound As Long = 53
Static locToWebColl As Collection, lastTimeNotFound As Collection
Static lastCacheUpdate As Date
Dim webRoot As String, locRoot As String, vItem As Variant
Dim s As String, keyExists As Boolean
If path Like "http*" Then GetWebPath = path: Exit Function
If Not locToWebColl Is Nothing And Not rebuildCache Then
locRoot = path: GetWebPath = ""
If locRoot Like "*" & ps Then locRoot = Left(locRoot, Len(locRoot) - 1)
Do
On Error Resume Next: locToWebColl locRoot: keyExists = _
(Err.Number = 0): On Error GoTo -1: On Error GoTo 0
If keyExists Or InStr(locRoot, ps) = 0 Then Exit Do
locRoot = Left(locRoot, InStrRev(locRoot, ps) - 1)
Loop
If InStr(locRoot, ps) > 0 Then _
GetWebPath = Replace(Replace(path, locRoot, _
locToWebColl(locRoot)(1), , 1), ps, "/"): Exit Function
If Not lastTimeNotFound Is Nothing Then
On Error Resume Next: lastTimeNotFound path
keyExists = (Err.Number = 0): On Error GoTo -1: On Error GoTo 0
If keyExists Then
If DateAdd("s", 10, lastTimeNotFound(path)) > Now() Then _
GetWebPath = path: Exit Function
End If
End If
GetWebPath = path
End If
Dim cid As String, fileNum As Long, line As Variant, parts() As String
Dim tag As String, mainMount As String, relPath As String, email As String
Dim b() As Byte, n As Long, i As Long, size As Long, libNr As String
Dim parentID As String, folderID As String, folderName As String
Dim folderIdPattern As String, fileName As String, folderType As String
Dim siteID As String, libID As String, webID As String, lnkID As String
Dim odFolders As Object, cliPolColl As Object, libNrToWebColl As Object
Dim sig1 As String: sig1 = StrConv(Chr$(&H2), vbFromUnicode)
Dim sig2 As String: sig2 = ChrW$(&H1) & String(3, vbNullChar)
Dim vbNullByte As String: vbNullByte = MidB$(vbNullChar, 1, 1)
#If Mac Then
Dim utf16() As Byte, utf32() As Byte, j As Long, k As Long, m As Long
Dim charCode As Long, lowSurrogate As Long, highSurrogate As Long
ReDim b(0 To 3): b(0) = &HAB&: b(1) = &HAB&: b(2) = &HAB&: b(3) = &HAB&
Dim sig3 As String: sig3 = b: sig3 = vbNullChar & vbNullChar & sig3
#Else
ReDim b(0 To 1): b(0) = &HAB&: b(1) = &HAB&
Dim sig3 As String: sig3 = b: sig3 = vbNullChar & sig3
#End If
Dim settPath As String, wDir As String, clpPath As String
#If Mac Then
s = Environ("HOME")
settPath = Left(s, InStrRev(s, "/Library/Containers")) & _
"Library/Containers/com.microsoft.OneDrive-mac/Data/" & _
"Library/Application Support/OneDrive/settings/"
clpPath = s & "/Library/Application Support/Microsoft/Office/CLP/"
#Else
settPath = Environ("LOCALAPPDATA") & "\Microsoft\OneDrive\settings\"
clpPath = Environ("LOCALAPPDATA") & "\Microsoft\Office\CLP\"
#End If
#If Mac Then
Dim possibleDirs(0 To 11) As String: possibleDirs(0) = settPath
For i = 1 To 9: possibleDirs(i) = settPath & "Business" & i & ps: Next i
possibleDirs(10) = settPath & "Personal" & ps: possibleDirs(11) = clpPath
If Not GrantAccessToMultipleFiles(possibleDirs) Then _
Err.Raise vbErrPermissionDenied
#End If
Dim oneDriveSettDirs As Collection: Set oneDriveSettDirs = New Collection
Dim dirName As Variant: dirName = Dir(settPath, vbDirectory)
Do Until dirName = ""
If dirName = "Personal" Or dirName Like "Business#" Then _
oneDriveSettDirs.Add dirName
dirName = Dir(, vbDirectory)
Loop
#If Mac Then
s = ""
For Each dirName In oneDriveSettDirs
wDir = settPath & dirName & ps
cid = IIf(dirName = "Personal", "????????????????", _
"????????-????-????-????-????????????")
If dirName = "Personal" Then s = s & "//" & wDir & "GroupFolders.ini"
s = s & "//" & wDir & "global.ini"
fileName = Dir(wDir, vbNormal)
Do Until fileName = ""
If fileName Like cid & ".ini" Or _
fileName Like cid & ".dat" Or _
fileName Like "ClientPolicy*.ini" Then _
s = s & "//" & wDir & fileName
fileName = Dir
Loop
Next dirName
If Not GrantAccessToMultipleFiles(Split(Mid(s, 3), "//")) Then _
Err.Raise vbErrPermissionDenied
#End If
If Not locToWebColl Is Nothing And Not rebuildCache Then
s = ""
For Each dirName In oneDriveSettDirs
wDir = settPath & dirName & ps
cid = IIf(dirName = "Personal", "????????????????", _
"????????-????-????-????-????????????")
If Dir(wDir & "global.ini") <> "" Then _
s = s & "//" & wDir & "global.ini"
fileName = Dir(wDir, vbNormal)
Do Until fileName = ""
If fileName Like cid & ".ini" Then _
s = s & "//" & wDir & fileName
fileName = Dir
Loop
Next dirName
For Each vItem In Split(Mid(s, 3), "//")
If FileDateTime(vItem) > lastCacheUpdate Then _
rebuildCache = True: Exit For
Next vItem
If Not rebuildCache Then
If lastTimeNotFound Is Nothing Then _
Set lastTimeNotFound = New Collection
On Error Resume Next: lastTimeNotFound.Remove path: On Error GoTo 0
lastTimeNotFound.Add Item:=Now(), Key:=path
Exit Function
End If
End If
lastCacheUpdate = Now()
Set lastTimeNotFound = Nothing
Set locToWebColl = New Collection
For Each dirName In oneDriveSettDirs
wDir = settPath & dirName & ps
If Dir(wDir & "global.ini", vbNormal) = "" Then GoTo NextFolder
fileNum = FreeFile()
Open wDir & "global.ini" For Binary Access Read As #fileNum
ReDim b(0 To LOF(fileNum)): Get fileNum, , b
Close #fileNum: fileNum = 0
#If Mac Then
b = StrConv(b, vbUnicode)
#End If
For Each line In Split(b, vbNewLine)
If line Like "cid = *" Then cid = Mid(line, 7): Exit For
Next line
If cid = "" Then GoTo NextFolder
If (Dir(wDir & cid & ".ini") = "" Or _
Dir(wDir & cid & ".dat") = "") Then GoTo NextFolder
If dirName Like "Business#" Then
folderIdPattern = Replace(Space(32), " ", "[a-f0-9]")
ElseIf dirName = "Personal" Then
folderIdPattern = Replace(Space(16), " ", "[A-F0-9]") & "!###*"
End If
Set cliPolColl = New Collection
fileName = Dir(wDir, vbNormal)
Do Until fileName = ""
If fileName Like "ClientPolicy*.ini" Then
fileNum = FreeFile()
Open wDir & fileName For Binary Access Read As #fileNum
ReDim b(0 To LOF(fileNum)): Get fileNum, , b
Close #fileNum: fileNum = 0
#If Mac Then
b = StrConv(b, vbUnicode)
#End If
cliPolColl.Add Key:=fileName, Item:=New Collection
For Each line In Split(b, vbNewLine)
If InStr(1, line, " = ", vbBinaryCompare) Then
tag = Left(line, InStr(line, " = ") - 1)
s = Mid(line, InStr(line, " = ") + 3)
Select Case tag
Case "DavUrlNamespace"
cliPolColl(fileName).Add Key:=tag, Item:=s
Case "SiteID", "IrmLibraryId", "WebID"
s = Replace(LCase(s), "-", "")
If Len(s) > 3 Then s = Mid(s, 2, Len(s) - 2)
cliPolColl(fileName).Add Key:=tag, Item:=s
End Select
End If
Next line
End If
fileName = Dir
Loop
fileNum = FreeFile
Open wDir & cid & ".dat" For Binary Access Read As #fileNum
ReDim b(0 To LOF(fileNum)): Get fileNum, , b: s = b: size = LenB(s)
Close #fileNum: fileNum = 0
Set odFolders = New Collection
For Each vItem In Array(16, 8)
i = InStrB(vItem, s, sig2)
Do While i > vItem And i < size - 168
If MidB$(s, i - vItem, 1) = sig1 Then
i = i + 8: n = InStrB(i, s, vbNullByte) - i
If n < 0 Then n = 0
If n > 39 Then n = 39
folderID = StrConv(MidB$(s, i, n), vbUnicode)
i = i + 39: n = InStrB(i, s, vbNullByte) - i
If n < 0 Then n = 0
If n > 39 Then n = 39
parentID = StrConv(MidB$(s, i, n), vbUnicode)
i = i + 121: n = -Int(-(InStrB(i, s, sig3) - i) / 2) * 2
If n < 0 Then n = 0
#If Mac Then
utf32 = MidB$(s, i, n)
ReDim utf16(LBound(utf32) To UBound(utf32))
j = LBound(utf32): k = LBound(utf32)
Do While j < UBound(utf32)
If utf32(j + 2) = 0 And utf32(j + 3) = 0 Then
utf16(k) = utf32(j): utf16(k + 1) = utf32(j + 1)
k = k + 2
Else
If utf32(j + 3) <> 0 Then Err.Raise _
vbErrInvalidFormatInResourceFile
charCode = utf32(j + 2) * &H10000 + _
utf32(j + 1) * &H100& + utf32(j)
m = charCode - &H10000
highSurrogate = &HD800& + (m \ &H400&)
lowSurrogate = &HDC00& + (m And &H3FF)
utf16(k) = CByte(highSurrogate And &HFF&)
utf16(k + 1) = CByte(highSurrogate \ &H100&)
utf16(k + 2) = CByte(lowSurrogate And &HFF&)
utf16(k + 3) = CByte(lowSurrogate \ &H100&)
k = k + 4
End If
j = j + 4
Loop
ReDim Preserve utf16(LBound(utf16) To k - 1)
folderName = utf16
#Else
folderName = MidB$(s, i, n)
#End If
If folderID Like folderIdPattern Then
odFolders.Add VBA.Array(parentID, folderName), folderID
End If
End If
i = InStrB(i + 1, s, sig2)
Loop
If odFolders.Count > 0 Then Exit For
Next vItem
fileNum = FreeFile()
Open wDir & cid & ".ini" For Binary Access Read As #fileNum
ReDim b(0 To LOF(fileNum)): Get fileNum, , b
Close #fileNum: fileNum = 0
#If Mac Then
b = StrConv(b, vbUnicode)
#End If
Select Case True
Case dirName Like "Business#"
mainMount = "": Set libNrToWebColl = New Collection
For Each line In Split(b, vbNewLine)
webRoot = "": locRoot = ""
Select Case Left$(line, InStr(line, " = ") - 1)
Case "libraryScope"
parts = Split(line, """"): locRoot = parts(9)
If locRoot = "" Then libNr = Split(line, " ")(2)
folderType = parts(3): parts = Split(parts(8), " ")
siteID = parts(1): webID = parts(2): libID = parts(3)
If mainMount = "" And folderType = "ODB" Then
mainMount = locRoot: fileName = "ClientPolicy.ini"
On Error Resume Next
webRoot = cliPolColl(fileName)("DavUrlNamespace")
On Error GoTo 0
Else
fileName = "ClientPolicy_" & libID & siteID & ".ini"
On Error Resume Next
webRoot = cliPolColl(fileName)("DavUrlNamespace")
On Error GoTo 0
End If
If webRoot = "" Then
For Each vItem In cliPolColl
If vItem("SiteID") = siteID And vItem("WebID") = _
webID And vItem("IrmLibraryId") = libID Then
webRoot = vItem("DavUrlNamespace"): Exit For
End If
Next vItem
End If
If webRoot = "" Then Err.Raise vbErrFileNotFound
If locRoot = "" Then
libNrToWebColl.Add VBA.Array(libNr, webRoot), libNr
Else
locToWebColl.Add VBA.Array(locRoot, webRoot, email), _
locRoot
End If
Case "libraryFolder"
locRoot = Split(line, """")(1): libNr = Split(line, " ")(3)
For Each vItem In libNrToWebColl
If vItem(0) = libNr Then
s = "": parentID = Left(Split(line, " ")(4), 32)
Do
On Error Resume Next: odFolders parentID
keyExists = (Err.Number = 0): On Error GoTo 0
If Not keyExists Then Exit Do
s = odFolders(parentID)(1) & "/" & s
parentID = odFolders(parentID)(0)
Loop
webRoot = vItem(1) & s: Exit For
End If
Next vItem
locToWebColl.Add VBA.Array(locRoot, webRoot, email), locRoot
Case "AddedScope"
parts = Split(line, """")
relPath = parts(5): If relPath = " " Then relPath = ""
parts = Split(parts(4), " "): siteID = parts(1)
webID = parts(2): libID = parts(3): lnkID = parts(4)
fileName = "ClientPolicy_" & libID & siteID & lnkID & ".ini"
On Error Resume Next
webRoot = cliPolColl(fileName)("DavUrlNamespace") & relPath
On Error GoTo 0
If webRoot = "" Then
For Each vItem In cliPolColl
If vItem("SiteID") = siteID And vItem("WebID") = _
webID And vItem("IrmLibraryId") = libID Then
webRoot = vItem("DavUrlNamespace") & relPath
Exit For
End If
Next vItem
End If
If webRoot = "" Then Err.Raise vbErrFileNotFound
s = "": parentID = Left(Split(line, " ")(3), 32)
Do
On Error Resume Next: odFolders parentID
keyExists = (Err.Number = 0): On Error GoTo 0
If Not keyExists Then Exit Do
s = odFolders(parentID)(1) & ps & s
parentID = odFolders(parentID)(0)
Loop
locRoot = mainMount & ps & s
locToWebColl.Add VBA.Array(locRoot, webRoot, email), locRoot
Case Else
Exit For
End Select
Next line
Case dirName = "Personal"
For Each line In Split(b, vbNewLine)
If line Like "library = *" Then _
locRoot = Split(line, """")(3): Exit For
Next line
On Error Resume Next
webRoot = cliPolColl("ClientPolicy.ini")("DavUrlNamespace")
On Error GoTo 0
If locRoot = "" Or webRoot = "" Or cid = "" Then GoTo NextFolder
locToWebColl.Add VBA.Array(locRoot, webRoot & "/" & cid, email), _
locRoot
If Dir(wDir & "GroupFolders.ini") = "" Then GoTo NextFolder
cid = "": fileNum = FreeFile()
Open wDir & "GroupFolders.ini" For Binary Access Read As #fileNum
ReDim b(0 To LOF(fileNum)): Get fileNum, , b
Close #fileNum: fileNum = 0
#If Mac Then
b = StrConv(b, vbUnicode)
#End If
For Each line In Split(b, vbNewLine)
If InStr(line, "BaseUri = ") And cid = "" Then
cid = LCase(Mid(line, InStrRev(line, "/") + 1, 16))
folderID = Left(line, InStr(line, "_") - 1)
ElseIf cid <> "" Then
locToWebColl.Add VBA.Array(locRoot & ps & odFolders( _
folderID)(1), webRoot & "/" & cid & "/" & _
Mid(line, Len(folderID) + 9), email), _
locRoot & ps & odFolders(folderID)(1)
cid = "": folderID = ""
End If
Next line
End Select
NextFolder:
cid = "": s = "": email = "": Set odFolders = Nothing
Next dirName
Dim tmpColl As Collection: Set tmpColl = New Collection
For Each vItem In locToWebColl
locRoot = vItem(0): webRoot = vItem(1): email = vItem(2)
If Right(webRoot, 1) = "/" Then webRoot = Left(webRoot, Len(webRoot) - 1)
If Right(locRoot, 1) = ps Then locRoot = Left(locRoot, Len(locRoot) - 1)
tmpColl.Add VBA.Array(locRoot, webRoot, email), locRoot
Next vItem
Set locToWebColl = tmpColl
GetWebPath = GetWebPath(path, False): Exit Function
End Function
You can then easily convert the local path to the corresponding OneDrive URL like this:
'Requires the function GetWebPath! (https://stackoverflow.com/a/74165973/12287457)
Dim oneDriveUrl as String
oneDriveUrl = GetWebPath(yourLocalPath)
Your code could look like this:
Sub QrLabelCreate()
Dim localPath as String
localPath = "C:Users\Name\OneDrive\MyMap\" & ID & ".pdf"
'STEP 1:
'Excel VBA put data into a word-document, and export it to pdf-file (saved to OneDrive):
.ActiveDocument.ExportAsFixedFormat _
OutputFileName:=localPath, _
ExportFormat:=wdExportFormatPDF
'STEP 2: THE PROBLEM
'====== I am not able to create code that gives me the URL to the pdf-file. ==========
'Requires the function GetWebPath! (https://stackoverflow.com/a/74165973/12287457)
Dim oneDriveUrl as String
oneDriveUrl = GetWebPath(localPath)
'STEP 3:
'The URL is pasted into the spreadsheet, and VBA creates the QR-code.
End Sub
I want to point out that this is also possible using the excellent VBA-FileTools
library by #Cristian Buse (GitHub), as he already pointed out in the comments! If you import his library, you can convert the path to an URL in exactly the same way as with the function I provided in this answer:
'Requires the library VBA-FileTools! (https://github.com/cristianbuse/VBA-FileTools)
Dim oneDriveUrl as String
oneDriveUrl = GetWebPath(yourLocalPath)
You can use the VBA "ENVIRON" command to get the "OneDrive" environment variable that contains the local root to the current user's OneDrive folders.
For example:
Sub ShowOneDrivePath()
Dim OutputFilePath As String
OutputFilePath = Environ("OneDrive") & "\MyMap\MyPdfName.pdf"
Debug.Print "OneDrive file path is:" & OutputFilePath
End Sub
I have this problem that my excel crash whenever I try to run my code.
I do believe I have a solution but I don't know how to execute it.
I have this code:
If (AnswerGame1A <> "") And (AnswerGame1B <> "") Then
Score1A.Visible = False
Score1B.Visible = False
Resultlist1.Visible = False
SubmitGame1.Visible = False
Dash1.Visible = False
GameLabel1.Visible = True
GameLabel1.Left = 36
End If
If (AnswerGame2A <> "") And (AnswerGame2B <> "") Then
Score2A.Visible = False
Score2B.Visible = False
Resultlist2.Visible = False
SubmitGame2.Visible = False
Dash2.Visible = False
GameLabel2.Visible = True
GameLabel2.Left = 36
End If
And this continues for another 51 times.
If I remove this code, the file does not chrash, My idea is to write a loop instead.
something like this, but this doesn't work.
INFO: all these names are controls within a multipage, that is within a userform. It is comboboxes, labels, commandbuttons and textboxes. The code run when the userform initialize.
For i = 1 to 51
If (Indirect("AnswerGame" & i & "A") <> "") And (Indirect("AnswerGame" & i & "B") <> "") Then
Indirect("Score" & i & "A").Visible = False
Indirect("Score" & i & "B").Visible = False
Indirect("Resultlist" & i).Visible = False
Indirect("SubmitGame" & i).Visible = False
Indirect("Dash" & i).Visible = False
Indirect("GameLabel" & i).Visible = True
Indirect("GameLabel" & i).Left = 36
End If
Next i
Do you think this could help excel from not crashing? and how can I fix the code to work?
Supposing that your combo boxes are of sheet ActiveX type, try the next code, please:
Sub testAvoitManyIterationsCombo()
Dim sh As Worksheet, i As Long
Set sh = ActiveSheet ' use here your necessary sheet
For i = 1 To 51
If sh.OLEObjects("AnswerGame" & i & "A").Object.Value <> "" And sh.OLEObjects("AnswerGame" & i & "B").Object.Value <> "" Then
sh.Shapes("Score" & i & "A").Visible = False
sh.Shapes("Score" & i & "B").Visible = False
sh.Shapes("Resultlist" & i).Visible = False
sh.Shapes("SubmitGame" & i).Visible = False
sh.Shapes("Dash" & i).Visible = False
sh.Shapes("GameLabel" & i).Visible = True
sh.Shapes("GameLabel" & i).left = 36
End If
Next i
End Sub
and if they are not activeX this should get you on track:
Option Explicit
Private Sub UserForm_Click()
Dim i As Long, str As String
For i = 1 To 10
str = "AnswerGame" & i & "A"
If Me.Controls(str).Value = "" Then
Score1A.Visible = False
End If
Next i
End Sub
My solution that works for my purpose. The file does not seem to crash anymore.
thank you #ceci for showing how to do it.
sorry for using "x" instead of "i", "i" is already being used elsewhere.
Dim x As Long, str1 As String, str2 As String, SCO1 As String, SCO2 As String, Res As String
Dim SubmitG As String, Da As String, GameL As String
For x = 1 To 51
str1 = "AnswerGame" & x & "A"
str2 = "AnswerGame" & x & "B"
If Me.Controls(str1) <> "" Then
If Me.Controls(str2) <> "" Then
SCO1 = "Score" & x & "A"
SCO2 = "Score" & x & "B"
Me.Controls(SCO1).Visible = False
Me.Controls(SCO2).Visible = False
Res = "Resultlist" & x
Me.Controls(Res).Visible = False
SubmitG = "SubmitGame" & x
Me.Controls(SubmitG).Visible = False
Da = "Dash" & x
Me.Controls(Da).Visible = False
GameL = "GameLabel" & x
Me.Controls(GameL).Visible = True
Me.Controls(GameL).Left = 36
End If
End If
Next x
I'm new in programming. this is the first system application that I did. I'm struggling in closing or killing the excel application once the system has successfully uploaded in a repository. this is my code. I do hope you can help me to fix it. thank you in advance.
Private Sub bgw_DoWork(sender As Object, e As DoWorkEventArgs) Handles bgw.DoWork
srcXlApp = New Excel.Application
dstXlApp = New Excel.Application
Dim numToDo As Integer = CInt(e.Argument)
Dim ComputerName As String
Dim strMissingValues As String
Try
System.Runtime.InteropServices.Marshal.ReleaseComObject(srcXlWb)
System.Runtime.InteropServices.Marshal.ReleaseComObject(dstXlWb)
isValidUploading = True
strMissingValues = "Cannot upload there are missing fields: "
bgwState = e
strRemarks = txtRemarks.Text
srcXlApp.DisplayAlerts = False
srcXlWbs = srcXlApp.Workbooks
srcXlWb = srcXlWbs.Open(srcFilePath)
srcXlWrksht = srcXlWb.Worksheets(1)
srcXlApp.Visible = False
'Step 1 - open source
bgw.ReportProgress(Convert.ToInt32((1 / numToDo) * 100))
'System.Threading.Thread.Sleep(5000)
ComputerName = System.Net.Dns.GetHostName
'dstFilePath = "C:\Users\" & ComputerName & "\Desktop\Mazza\trunk\QA Task Monitoring_2020.xlsx"
If ComputerName = "jonas" Then
'MessageBox.Show(ComputerName)
dstFilePath = "C:\Users\jonas.ONE-SOURCE\Desktop\Mazza\trunk\QA Task Monitoring_for_testing_only.xlsx"
Else
dstFilePath = "C:\Users\" & ComputerName & "\Desktop\Mazza\trunk\QA Task Monitoring_for_testing_only.xlsx"
End If
'dstFilePath = "C:\Users\jonas.ONE-SOURCE\Desktop\Mazza\trunk\QA Task Monitoring_2020.xlsx"
'dstFilePath = "C:\Users\" & ComputerName & "\Desktop\Mazza\trunk\QA Task Monitoring_for_testing_only.xlsx"
dstXlApp.DisplayAlerts = False
dstXlWbs = dstXlApp.Workbooks
dstXlWb = dstXlWbs.Open(dstFilePath)
dstXlApp.Visible = False
'Step 2 - open destination
bgw.ReportProgress(Convert.ToInt32((2 / numToDo) * 100))
'System.Threading.Thread.Sleep(5000)
'Step 3 - Copy Range
bgw.ReportProgress(Convert.ToInt32((3 / numToDo) * 100))
'System.Threading.Thread.Sleep(3000)
'Code for copying cells
srcXlWrksht = srcXlWb.Worksheets(1)
strTicketNumber = srcXlWrksht.Range("B3").Value
strCID = srcXlWrksht.Range("B4").Value
strIteration = srcXlWrksht.Range("B13").Value
If Not IsNothing(strIteration) Then
strIteration = strIteration.Substring(2)
End If
strSystem = srcXlWrksht.Range("B17").Value
strAssignedBy = srcXlWrksht.Range("B10").Value
strPMOBA = srcXlWrksht.Range("B9").Value
strRequest = srcXlWrksht.Range("B5").Value
strAssign = srcXlWrksht.Range("B6").Value
strStart = srcXlWrksht.Range("B14").Value
strEnd = srcXlWrksht.Range("B15").Value
strStatus = srcXlWrksht.Range("C24").Value
strTask = srcXlWrksht.Range("B16").Value
If srcXlWb.Worksheets.Count >= 2 Then
srcXlWrksht = srcXlWb.Worksheets(2)
strDescription = srcXlWrksht.Range("D3").Value
Else
'strMissingValues = strMissingValues & vbCrLf & "Title/Description"
isValidUploading = False
End If
'srcXlWrksht = srcXlWb.Worksheets(2)
'strDescription = srcXlWrksht.Range("D3").Value
If strTicketNumber = "" Then
strMissingValues = strMissingValues & vbCrLf & "Ticket ID"
isValidUploading = False
End If
If strCID = "" Then
strMissingValues = strMissingValues & vbCrLf & "Change ID"
isValidUploading = False
End If
If strIteration = "" Then
strMissingValues = strMissingValues & vbCrLf & "Iteration Number"
isValidUploading = False
End If
If strSystem = "" Then
strMissingValues = strMissingValues & vbCrLf & "System Name"
isValidUploading = False
End If
If strAssignedBy = "" Then
strMissingValues = strMissingValues & vbCrLf & "Assigned By"
isValidUploading = False
End If
If strPMOBA = "" Then
strMissingValues = strMissingValues & vbCrLf & "Assigned PMO/BA"
isValidUploading = False
End If
If strRequest = "" Then
strMissingValues = strMissingValues & vbCrLf & "Requested Date"
isValidUploading = False
End If
If strAssign = "" Then
strMissingValues = strMissingValues & vbCrLf & "Assigned Date"
isValidUploading = False
End If
If strStart = "" Then
strMissingValues = strMissingValues & vbCrLf & "Start Date"
isValidUploading = False
End If
If strEnd = "" Then
strMissingValues = strMissingValues & vbCrLf & "End Date"
isValidUploading = False
End If
If strStatus = "" Then
strMissingValues = strMissingValues & vbCrLf & "Status"
isValidUploading = False
End If
If strTask = "" Then
strMissingValues = strMissingValues & vbCrLf & "Task type"
isValidUploading = False
End If
If strDescription = "" Then
strMissingValues = strMissingValues & vbCrLf & "Title/Description"
isValidUploading = False
End If
'If CheckBox1.CheckState = CheckState.Checked And txtRemarks.Text = "" Then
' strMissingValues = strMissingValues & vbCrLf & "Empty Remarks"
' MessageBox.Show("Please input remarks", "Empty Remarks", MessageBoxButtons.OK, MessageBoxIcon.Exclamation)
' isValidUploading = False
'End If
If Not isValidUploading Then
MessageBox.Show(strMissingValues, "ERROR", MessageBoxButtons.OK, MessageBoxIcon.Error)
srcXlWb.Close()
dstXlWb.Close()
srcXlApp.UserControl = True
dstXlApp.UserControl = True
srcXlApp.Quit()
dstXlApp.Quit()
Marshal.ReleaseComObject(dstXlWrksht)
Marshal.ReleaseComObject(dstXlWb)
Marshal.ReleaseComObject(dstXlWbs)
Marshal.ReleaseComObject(dstXlApp)
Marshal.ReleaseComObject(dstXlWrksht)
Marshal.ReleaseComObject(srcXlWb)
Marshal.ReleaseComObject(srcXlWbs)
Marshal.ReleaseComObject(srcXlApp)
GC.Collect()
GC.WaitForPendingFinalizers()
GC.Collect()
GC.WaitForPendingFinalizers()
GC.Collect()
GC.WaitForPendingFinalizers()
bgw.CancelAsync()
e.Cancel = True
Exit Sub
End If
'strTicketNumber = srcXlWrksht.Range("B4").Value.ToString
'code for pastespecial
dstXlWb.Worksheets("Tasks").Range("A3").Select()
Last_Row = dstXlWb.Worksheets("Tasks").Range("A3").End(Excel.XlDirection.xlDown).Row + 1
dstXlWb.Worksheets("Tasks").Range("A" & Last_Row).Select()
'Step 4 - Pasting values
bgw.ReportProgress(Convert.ToInt32((4 / numToDo) * 100))
'System.Threading.Thread.Sleep(3000)
dstXlWb.Worksheets("Tasks").Range("C" & Last_Row).Value = strTicketNumber
dstXlWb.Worksheets("Tasks").Range("B" & Last_Row).Value = strQAT
dstXlWb.Worksheets("Tasks").Range("D" & Last_Row).Value = strCID
dstXlWb.Worksheets("Tasks").Range("E" & Last_Row).Value = strIteration
dstXlWb.Worksheets("Tasks").Range("F" & Last_Row).Value = strDescription
dstXlWb.Worksheets("Tasks").Range("G" & Last_Row).Value = strSystem
dstXlWb.Worksheets("Tasks").Range("H" & Last_Row).Value = strAssignedBy
dstXlWb.Worksheets("Tasks").Range("I" & Last_Row).Value = strPMOBA
dstXlWb.Worksheets("Tasks").Range("J" & Last_Row).Value = strSBU
dstXlWb.Worksheets("Tasks").Range("K" & Last_Row).Value = strTypes
dstXlWb.Worksheets("Tasks").Range("L" & Last_Row).Value = strProcess
dstXlWb.Worksheets("Tasks").Range("M" & Last_Row).Value = strRequest
dstXlWb.Worksheets("Tasks").Range("N" & Last_Row).Value = strAssign
dstXlWb.Worksheets("Tasks").Range("O" & Last_Row).Value = strStart
dstXlWb.Worksheets("Tasks").Range("P" & Last_Row).Value = strEnd
dstXlWb.Worksheets("Tasks").Range("Q" & Last_Row).Value = strStatus
dstXlWb.Worksheets("Tasks").Range("S" & Last_Row).Value = strRemarks
dstXlWb.Worksheets("Tasks").Range("Y" & Last_Row).Value = strTask
dstXlWb.Worksheets("Tasks").Range("W" & Last_Row).Value = "=+TEXT(QATM[[#This Row],[End Date]]," & """MM""" & ")"
dstXlWb.Worksheets("Tasks").Range("X" & Last_Row).Value = "=+TEXT(QATM[[#This Row],[End Date]]," & """YYYY""" & ")"
If CheckBox1.CheckState = CheckState.Checked Then
dstXlWb.Worksheets("Tasks").Range("R" & Last_Row).Value = "=""FOR QAT"" " & "& " & "TEXT(" & dstXlWb.Worksheets("Tasks").Range("E" & Last_Row).Value + 1 & ", ""00"")"
Else
dstXlWb.Worksheets("Tasks").Range("R" & Last_Row).Value = "YES"
End If
'Step 5 - Saving
bgw.ReportProgress(Convert.ToInt32((5 / numToDo) * 100))
'System.Threading.Thread.Sleep(3000)
dstXlApp.ActiveWorkbook.Save()
Catch ex As Exception
'MsgBox(ex.Message)
Me.Cursor = Cursors.Default
MessageBox.Show("Please check excel file.")
'MsgBox("Error has occured. " & ex.Message, MsgBoxStyle.OkOnly + MsgBoxStyle.Critical, "Error")
bgw.CancelAsync()
Exit Sub
srcXlWb.Close()
dstXlWb.Close()
srcXlApp.UserControl = True
dstXlApp.UserControl = True
srcXlApp.Quit()
dstXlApp.Quit()
Marshal.ReleaseComObject(dstXlWb)
Marshal.ReleaseComObject(dstXlWbs)
Marshal.ReleaseComObject(dstXlApp)
Marshal.ReleaseComObject(srcXlWb)
Marshal.ReleaseComObject(srcXlWbs)
Marshal.ReleaseComObject(srcXlApp)
GC.Collect()
GC.WaitForPendingFinalizers()
GC.Collect()
GC.WaitForPendingFinalizers()
GC.Collect()
GC.WaitForPendingFinalizers()
GC.Collect()
GC.WaitForPendingFinalizers()
Finally
'srcXlWb.Close()
'dstXlWb.Close()
'srcXlApp.UserControl = True
'dstXlApp.UserControl = True
'srcXlApp.Quit()
'dstXlApp.Quit()
Marshal.ReleaseComObject(dstXlWb)
Marshal.ReleaseComObject(dstXlWbs)
Marshal.ReleaseComObject(dstXlApp)
Marshal.ReleaseComObject(srcXlWb)
Marshal.ReleaseComObject(srcXlWbs)
Marshal.ReleaseComObject(srcXlApp)
GC.Collect()
GC.WaitForPendingFinalizers()
GC.Collect()
GC.WaitForPendingFinalizers()
GC.Collect()
GC.WaitForPendingFinalizers()
GC.Collect()
GC.WaitForPendingFinalizers()
End Try
End Sub
Private Declare Function GetWindowThreadProcessId Lib "user32.dll" (ByVal hwnd As IntPtr,
ByRef lpdwProcessId As Integer) As Integer
Friend Sub KillSpecificExcel(xlsApplication As Excel.Application)
Try
Dim psi As ProcessStartInfo = New ProcessStartInfo
Dim XLProcID As Integer = 0
Dim hwd As Integer
hwd = xlsApplication.Hwnd
GetWindowThreadProcessId(hwd, XLProcID)
Dim XLProc As Process = Process.GetProcessById(XLProcID)
psi.Arguments = $"/PID {XLProc.Id} /T /F"
psi.FileName = "taskkill"
Dim p As Process = New Process()
p.StartInfo = psi
p.Start()
Catch ex As Exception
Throw
End Try
End Sub
I am fairly new to vba but have developed a code to use in excel to move text/numbers to a txt file. My issue is I currently have three functions that need to go to the same txt file. When I run it currently the first function has
Set fs = CreateObject("scripting.FileSystemObject")
Set a = fs.createTextFile(Module1.NYS45Uploadfilename, True)
a.writeline (str)
a.Close.
The other two functions had save.
Set fs = CreateObject("scripting.FileSystemObject")
Set a = fs.saveTextFile(Module1.NYS45Uploadfilename, True)
a.writeline (str)
a.Close.
The first function will go to the txt file, the other two I get an error
Object doesn't support this property or method.
When I changed all three to create the last function goes to the txt file. I can not figure out what word to use in order to make the other two functions follow into the txt file in the order they are keyed.
The entire code is as follows
Private Sub addRecord_Click()
On Error GoTo ErrHandler
Module1.NYS45Uploadfilename = Application.GetSaveAsFilename(FileFilter:="Textfiles (*.txt), *.txt")
If Module1.NYS45Uploadfilename = "False" Then Exit Sub
Header_Rec
Detail_Rec1
Detail_Rec2
Dim strmsg As String
strmsg = "Your file has been added here: " & Module1.NYS45Uploadfilename
MsgBox strmsg
Exit Sub
ErrHandler:
MsgBox Err.Number & vbNewLine & Err.Description
Resume Next
End Sub
Function Header_Rec()
Dim str, strfilename, txtpath As String
Dim strlencount, strspacer As Integer
str = str & Range("a3").Value
str = str & Range("b3").Value
str = str & Trim(Range("c3").Value)
strlencount = Len(Trim(Range("c3").Value))
strspacer = 30 - strlencount
str = Module1.SpaceAdd(str, strspacer)
str = str & Range("d3").Value
str = str & Range("E3").Value
str = Module1.SpaceAdd(str, 159)
' Debug.Print Len(str)
Set fs = CreateObject("scripting.FileSystemObject")
Set a = fs.createTextFile(Module1.NYS45Uploadfilename, True)
a.writeline (str)
a.Close
' Debug.Print str
End Function
Function Detail_Rec1()
Dim str, strnum, str2, strfilename, txtpath As String
Dim strlencount, strspacer As Integer
If Range("a7").Value <> "5" Then
Exit Function
End If
str = str & Range("a7").Value
str = str & Range("b7").Value
str = str & Range("c7").Value
str = Module1.SpaceAdd(str, 1)
str = str & Trim(Range("d7").Value)
strlencount = Len(Trim(Range("d7").Value))
strspacer = 30 - strlencount
str = Module1.SpaceAdd(str, strspacer)
str = str & Range("E7").Value
' Debug.Print Len(str)
Set fs = CreateObject("scripting.FileSystemObject")
Set a = fs.addTextFile(Module1.NYS45Uploadfilename, True)
a.writeline (str)
a.Close
' Debug.Print str
End Function
Function Detail_Rec2()
Dim str, strnum, str2, strfilename, strnew, txtpath As String
Dim strlencount, strspacer As Integer
If Range("a11").Value <> "6" Then
Exit Function
End If
str = str & Range("a11").Value
str = str & Range("b11").Value
str = str & Trim(Range("c11").Value)
strlencount = Len(Trim(Range("c11").Value))
strspacer = 11 - strlencount
str = Module1.SpaceAdd(str, strspacer)
strspacer = 30 - strlencount
str = Module1.SpaceAdd(str, strspacer)
str = str & Range("f11").Value
str = str & Range("g11").Value
' Debug.Print Len(str)
Set fs = CreateObject("scripting.FileSystemObject")
Set a = fs.getTextFile(Module1.NYS45Uploadfilename, True)
a.writeline (str)
a.Close
' Debug.Print str
End Function
Consider the below example showing how to write text to the file using OpenTextFile method:
Sub Test()
Const ForWriting = 2
Const ForAppending = 8
Const FormatDefault = -2
Const FormatUnicode = -1
Const FormatASCII = 0
strFile = "C:\TestFile.txt"
strText = "New Unicode text file created, this is the first line." & vbCrLf
WriteTextFile strFile, strText, ForWriting, FormatUnicode
strText = "New line added, this is the second line." & vbCrLf
WriteTextFile strFile, strText, ForAppending, FormatUnicode
strText = "One more line." & vbCrLf
WriteTextFile strFile, strText, ForAppending, FormatUnicode
End Sub
Sub WriteTextFile(strPath, strContent, lngMode, lngFormat)
' strPath: path to the text file
' strContent: text to be written to the file
' lngMode: 2 - For Writing, 8 - For Appending
' lngFormat: -2 - System default, -1 - Unicode, 0 - ASCII
With CreateObject("Scripting.FileSystemObject").OpenTextFile(strPath, lngMode, True, lngFormat)
.Write strContent
.Close
End With
End Sub
This is the code i use to create a graph which searches for .csv {created using excel application} file in the path specified. It plots the column 'B' { Y axis } against column 'C' {X-axis}.. I want to one more column 'A' to my Y axis keeping column 'C' as the X axis.. How can i do that???
here is the code...
Sub Draw_Graph()
Dim strPath As String
Dim strFile As String
Dim strChart As String
Dim i As Integer
Dim j As Integer
strPath = "C:\PortableRvR\report\"
strFile = Dir(strPath & "*.csv")
i = 1
Do While strFile <> ""
With ActiveWorkbook.Worksheets.Add
With .QueryTables.Add(Connection:="TEXT;" & strPath & strFile, _
Destination:=.Range("A1"))
Parent.Name = Replace(strFile, ".csv", "")
TextFileParseType = xlDelimited
TextFileTextQualifier = xlTextQualifierDoubleQuote
TextFileConsecutiveDelimiter = False
TextFileTabDelimiter = False
TextFileSemicolonDelimiter = False
TextFileCommaDelimiter = True
TextFileSpaceDelimiter = False
TextFileColumnDataTypes = Array(1)
TextFileTrailingMinusNumbers = True
Refresh BackgroundQuery:=False
Files(i) = .Parent.Name
i = i + 1
End With
End With
strFile = Dir
Loop
numOfFiles = i - 1
chartName = "Chart 1"
For j = 1 To numOfFiles
strFile = Files(j)
Sheets(strFile).Select
Plot_y = Range("B1", Selection.End(xlDown)).Rows.Count
Plot_x = Range("C1", Selection.End(xlDown)).Rows.Count
Sheets("GraphDisplay").Select
If j = 1 Then ActiveSheet.ChartObjects(chartName).Activate
ActiveChart.SeriesCollection.NewSeries
ActiveChart.SeriesCollection(j).Name = strFile
ActiveChart.SeriesCollection(j).XValues = Sheets(strFile).Range("C1:C" & Plot_x)
ActiveChart.SeriesCollection(j).Values = Sheets(strFile).Range("B1:B" & Plot_y)
ActiveChart.SeriesCollection(j).MarkerStyle = -4142
ActiveChart.SeriesCollection(j).Smooth = False
Next j
ActiveSheet.ChartObjects(chartName).Activate
ActiveChart.Axes(xlValue).DisplayUnit = xlMillions
ActiveChart.Axes(xlValue).HasDisplayUnitLabel = False
End Sub
you can add 2 series for every file (j and j+1 inside for j = 1 to 2*numOfFiles step 2) and repeat everything for j+1 series except:
ActiveChart.SeriesCollection(j).Values = Sheets(strFile).Range("A1:A" & Plot_y)
ActiveChart.SeriesCollection(j+1).Values = Sheets(strFile).Range("B1:B" & Plot_y)
Not for points
I was planning to post this as a comment (and hence do not select this as an answer. All credit to #Aprillion) but the comment would not have formatted the code as this post would have done.
Whenever you add a series as Aprillion mentioned you have to also add one more line. I just tested this with small piece of data and it works.
'<~~ You have to call this everytime you add a new series
ActiveChart.SeriesCollection.NewSeries
ActiveChart.SeriesCollection(1).Values = "=Sheet1!$B$1:$B$6"
'<~~ You have to call this everytime you add a new series
ActiveChart.SeriesCollection.NewSeries
ActiveChart.SeriesCollection(2).Values = "=Sheet1!$A$1:$A$6"
Also since there is a huge difference between your Series 1 Data and Series 2 data (as per the snapshot), the 2nd series will be very close to X Axis.
Hope this is what you wanted?
FOLLOWUP
Is this what you are trying?
Dim files(1 To 20) As String
Dim numOfFiles As Integer
Dim chartName As String, shName as String
Sub Time_Graph()
Dim strPath As String, strFile As String, strChart As String
Dim i As Long, j As Long, n As Long
strPath = "C:\PortableRvR\report\"
strFile = Dir(strPath & "*.csv")
i = 1
Do While strFile <> ""
With ActiveWorkbook.Worksheets.Add
shName = strFile
ActiveSheet.Name = Replace(shName, ".csv", "")
With .QueryTables.Add(Connection:="TEXT;" & strPath & strFile, _
Destination:=.Range("A1"))
.Name = Replace(strFile, ".csv", "")
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = False
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = True
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
files(i) = .Parent.Name
i = i + 1
End With
End With
strFile = Dir
Loop
numOfFiles = i - 1
chartName = "Chart 1"
For j = 1 To numOfFiles
If n = 0 Then n = j Else n = n + 2
strFile = files(j)
Sheets(strFile).Select
Plot_y = Range("B1", Selection.End(xlDown)).Rows.Count
Plot_x = Range("C1", Selection.End(xlDown)).Rows.Count
Sheets("GraphDisplay").Select
If j = 1 Then ActiveSheet.ChartObjects(chartName).Activate
ActiveChart.SeriesCollection.NewSeries
ActiveChart.SeriesCollection(n).Name = strFile & " - Col B Values"
ActiveChart.SeriesCollection(n).XValues = "=" & strFile & "!$C$1:$C$" & Plot_x
ActiveChart.SeriesCollection(n).Values = "=" & strFile & "!$B$1:$B$" & Plot_y
ActiveChart.SeriesCollection.NewSeries
ActiveChart.SeriesCollection(n + 1).Name = strFile & " - Col A Values"
ActiveChart.SeriesCollection(n + 1).XValues = "=" & strFile & "!$C$1:$C$" & Plot_x
ActiveChart.SeriesCollection(n + 1).Values = "=" & strFile & "!$A$1:$A$" & Plot_y
ActiveChart.SeriesCollection(j).MarkerStyle = -4142
ActiveChart.SeriesCollection(j).Smooth = False
ActiveChart.SeriesCollection(n + 1).MarkerStyle = -4142
ActiveChart.SeriesCollection(n + 1).Smooth = False
Next j
ActiveSheet.ChartObjects(chartName).Activate
ActiveChart.Axes(xlValue).DisplayUnit = xlMillions
ActiveChart.Axes(xlValue).HasDisplayUnitLabel = False
End Sub