Dim ws As Worksheet
Dim rng As Range
Dim i As integer, j as integer
Dim txtFilePath As String
Dim txtFileNumber As Integer
Dim rowDataH As String, rowDataB As String, thStart1 As String,thStart2 As String, thEnd1 As String,thEnd2 As String
Dim tbStart1 As String, tbStart2 As String,tbStart3 As String, tbEnd1 As String,tbEnd2 As String,tbEnd3 As String
'Set the worksheet you want to export from
Set ws = ThisWorkbook.Sheets("Sheet1") 'Change "Sheet1" to your sheet name
'Define the path to the text file
txtFilePath = Application.GetSaveAsFilename( _
InitialFileName:="ExportedData.txt", _
FileFilter:="Text Files (*.txt), *.txt")
If txtFilePath = "False" Then Exit Sub 'User cancelled the file dialog
'Get a free file number
txtFileNumber = FreeFile
'Open the text file for output
Open txtFilePath For Output As txtFileNumber
'HTML code for table header
thStart1 = "<div>" & vbNewLine & "<table align=""center"" style=""width: 50%;"">" & vbNewLine & "<thead>" & vbNewLine & "<tr>" & vbNewLine & "<th style=""background-color: #cccccc;"">"
thStart2 = "<th style=""background-color: #cccccc;"">"
thEnd1 = "</th>"
thEnd2 = "</th>" & vbNewLine & "</tr>" & vbNewLine & "</thead>" & vbNewLine & "<tbody>"
' Loop through each cell for the table header
For i = 1 To WorksheetFunction.CountA(Range("1:1"))
If i = 1 Then
rowDataH = thStart1 & Cells(1, i).Value & thEnd1
ElseIf i = WorksheetFunction.CountA(Range("1:1")) Then
rowDataH = thStart2 & Cells(1, i).Value & thEnd2
Else
rowDataH = thStart2 & Cells(1, i).Value & thEnd1
End If
Print #txtFileNumber, rowDataH
Next i
'HTML code for table body
tbStart1 = "<tr style=""background-color: #f2f2f2;"">" & vbNewLine & "<td>"
tbStart2 = "<tr style=""background-color: white;"">" & vbNewLine & "<td>"
tbStart3 = "<td>"
tbEnd1 = "</td>"
tbEnd2 = "</td>" & vbNewLine & "</tr>"
tbEnd3 = "</td>" & vbNewLine & "</tr>" & vbNewLine & "</tbody>" & vbNewLine & "</table>" & vbNewLine & "</div>"
' Loop through each cell for the table body
For j = 2 To WorksheetFunction.CountA(Range("A:A"))
For i = 1 To WorksheetFunction.CountA(Range("1:1"))
If j Mod 2 = 0 Then
If i = 1 Then
rowDataB = tbStart1 & Cells(j, i).Value & tbEnd1
ElseIf i = WorksheetFunction.CountA(Range("1:1")) And j = WorksheetFunction.CountA(Range("A:A")) Then
rowDataB = tbStart3 & Cells(j, i).Value & tbEnd3
ElseIf i = WorksheetFunction.CountA(Range("1:1")) Then
rowDataB = tbStart3 & Cells(j, i).Value & tbEnd2
Else
rowDataB = tbStart3 & Cells(j, i).Value & tbEnd1
End If
Else
If i = 1 Then
rowDataB = tbStart2 & Cells(j, i).Value & tbEnd1
ElseIf i = WorksheetFunction.CountA(Range("1:1")) And j = WorksheetFunction.CountA(Range("A:A")) Then
rowDataB = tbStart3 & Cells(j, i).Value & tbEnd3
ElseIf i = WorksheetFunction.CountA(Range("1:1")) Then
rowDataB = tbStart3 & Cells(j, i).Value & tbEnd2
Else
rowDataB = tbStart3 & Cells(j, i).Value & tbEnd1
End If
End If
'print each line into text file
Print #txtFileNumber, rowDataB
Next i
Next j
' Close the text file
Close txtFileNumber
MsgBox "HTML created successfully to " & txtFilePath
End Sub
Open browser in background
Sub OpenEricollFolders()
Dim URL As String
Dim IE As InternetExplorer
'Create InternetExplorer Object
Set IE = New InternetExplorerMedium
With IE
'Set IE.Visible = True to make IE visible, or False for IE to run in the background
.Visible = False
'Define URL
URL = "https://yourdomain.sharepoint.com/sites/Finmigrationtest/"
'Navigate to URL
.Navigate URL
Do While .ReadyState = 4: DoEvents: Loop
Do While .ReadyState <> 4: DoEvents: Loop
'Application.Wait (Now() + TimeValue("00:00:20"))
.Quit
End With
eEricollFolder = Shell("explorer.exe """ & SharepointAddress_LogFile & "", vbHide)
'eEricollFolder1 = Shell("iexplorer.exe """ & "" & "", vbHide)
'Set IE = Nothing
End Sub
Words count on a web page
Sub WordCountOnWebPage()
Dim http As Object, html As Object, text As String
Dim words As Variant
Set http = CreateObject("MSXML2.XMLHTTP")
http.Open "GET", "https://yourwebsite.com", False
http.Send
Set html = CreateObject("HTMLFile")
html.body.innerHTML = http.responseText
text = html.body.innerText
words = Split(Trim(text))
MsgBox "Word Count: " & UBound(words) + 1
End Sub
SharePoint File Download
#If Win64 Then
Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" Alias _
"URLDownloadToFileA" ( _
ByVal pCaller As LongLong, _
ByVal szURL As String, _
ByVal szFileName As String, _
ByVal dwReserved As LongLong, _
ByVal lpfnCB As LongLong) As LongLong
#Else
Private Declare Function URLDownloadToFile Lib "urlmon" Alias _
"URLDownloadToFileA" ( _
ByVal pCaller As Long, _
ByVal szURL As String, _
ByVal szFileName As String, _
ByVal dwReserved As Long, _
ByVal lpfnCB As Long) As Long
#End If
Sub SharePointFileDownload()
Dim strUrl As String, strSavePath As String, strFile As String, countSlash As Byte
strUrl = "https://www.sharepoint.com/sites/filename.xlsb" 'SharePoint Path for the file
strSavePath = "C:\Users\username\Downloads\" 'Folder to save the file
'countSlash = ""
strFile = "filename.xlsb"
If DownloadFile(strUrl, strSavePath & strFile) Then
'If DownloadFile(strUrl, strSavePath) Then
MsgBox "File saved to: " & vbNewLine & strSavePath
Else
MsgBox "Unable to downloaf file:" & vbNewLine & strFile & vbNewLine & "Check url string and that document is shared", vbCritical
End If
End Sub
Function DownloadFile(Url As String, SavePathName As String) As Boolean
DownloadFile = URLDownloadToFile(0, Replace(Url, "\", "/"), SavePathName, 0, 0) = 0
End Function
Open Share Point Folder
Sub OpenSharePointFolder()
Dim URL As String
Dim IE As SHDocVw.InternetExplorer
Set IE = New SHDocVw.InternetExplorer
With IE
'Set IE.Visible = True to make IE visible, or False for IE to run in the background
.Visible = True
'Define URL
URL = "https://www.sharepoint.com/sites/Shared%20Documents/Test/"
'Navigate to URL
.Navigate URL
End With
Application.Wait (Now + TimeValue("0:00:02"))
'reconnect Internet Explorer to VBA
'*********************************************
Dim shellWins As SHDocVw.ShellWindows
Dim explorer As SHDocVw.InternetExplorer
Set shellWins = New SHDocVw.ShellWindows
For Each explorer In shellWins
If explorer.Name = "Internet Explorer" Then
Set IEObject1 = explorer
Debug.Print explorer.LocationURL
Debug.Print explorer.LocationName
End If
Next
Set shellWins = Nothing
Set explorer = Nothing
'*********************************************
Do While IEObject1.ReadyState <> READYSTATE_COMPLETE
DoEvents
Loop
IEObject1.Quit
Set IE = Nothing
Set IEObject1 = Nothing
End Sub
Sync Files
Sub SyncFiles()
Dim f As String
Const LaptopFolder = "C:\Users\username\MyFolder\"
Const ServerFolder = "https://www.sharepoint.com/sites/Forms/AllItems.aspx"
f = Dir(LaptopFolder & "*.*")
While Len(f)
GetAttr ServerFolder & f
If Err Then
Err.Clear
FileCopy LaptopFolder & f, ServerFolder & f
End If
f = Dir()
Wend
End Sub
Close Internet Explorer
Sub CloseIE()
Dim IE As InternetExplorer
Set IE = New InternetExplorerMedium
IE.Visible = True
IE.Navigate "https://www.sharepoint.com/sites/"
Application.Wait (Now() + TimeValue("00:00:05"))
IE.Quit
End Sub
Open Edge browser with predefined url
Sub Edge_Open()
Call Shell("C:\Program Files (x86)\Microsoft\Edge\Application\msedge.exe", vbNormalFocus)
CreateObject("Shell.Application").ShellExecute "microsoft-edge:https://www.sharepoint.com/sites/home.aspx"
Application.Wait (Now + TimeValue("00:00:10"))
DoEvents
End Sub
Open SharePoint using Shell
Sub OpenSharePointFolder()
Dim sCmd As String
Dim sURL As String
sURL = "https://www.sharepoint.com/sites/test/"
sCmd = "start microsoft-edge:" & sURL
Shell "cmd /c """ & sCmd & """", vbHide
End Sub
0 टिप्पणियाँ
Please do not enter any spam link in the comment box.