This is a test Test Let it be

[Admin]

Test: Let it be....
Closed !
:)
Alan


<b>Sheet1</b><br /><br /><table border="1" cellspacing="0" cellpadding="0" style="font-family:Calibri,Arial; font-size:11pt; background-color:#ffffff; padding-left:2pt; padding-right:2pt; "> <colgroup><col style="font-weight:bold; width:30px; " /><col style="width:64px;" /><col style="width:64px;" /></colgroup><tr style="background-color:#cacaca; text-align:center; font-weight:bold; font-size:8pt; "><td > </td><td >A</td><td >B</td></tr><tr style="height:18px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >1</td><td >sdf</td><td style="text-align:right; ">34</td></tr><tr style="height:18px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >2</td><td >sdfsdf</td><td style="text-align:right; ">345</td></tr><tr style="height:18px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >3</td><td >sdf</td><td style="text-align:right; ">435</td></tr><tr style="height:18px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >4</td><td >sd</td><td style="text-align:right; ">34</td></tr><tr style="height:18px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >5</td><td >sfd</td><td style="text-align:right; ">235</td></tr><tr style="height:18px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >6</td><td >fsd</td><td style="text-align:right; ">43</td></tr><tr style="height:18px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >7</td><td > </td><td style="text-align:right; ">3</td></tr><tr style="height:18px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >8</td><td > </td><td style="text-align:right; ">1129</td></tr></table><br /><table style="font-family:Arial; font-size:10pt; border-style: groove ;border-color:#00ff00;background-color:#fffcf9; color:#000000; "><tr><td ><b>Spreadsheet Formulas</b></td></tr><tr><td ><table border = "1" cellspacing="0" cellpadding="2" style="font-family:Arial; font-size:9pt;"><tr style="background-color:#cacaca; font-size:10pt;"><td >Cell</td><td >Formula</td></tr><tr><td >B8</td><td >=SUM(B1:B7)</td></tr></table></td></tr></table> <br /><br /><span style="font-family:Arial; font-size:9pt; font-weight:bold;background-color:#ffffff; color:#000000; ">Excel tables to the web >> </span><a style ="font-family:Arial; font-size:9pt; color:#fcf507; background-color:#800040; font-weight:bold;" href="http://www.excel-jeanie-html.de/index.php?f=1" target="_blank"> Excel Jeanie HTML 4 </a>

[Excel Fox]

Fabulous. Looks like this is going to be very helpful


Sub pGetData()
Dim obj As Object
Dim lngRow As Long
Dim lngRowToPick As Long
Dim lngControlSheetLoop As Long
Dim strResponseText As String
Dim strDataToGoTo As String
Dim lngFieldsCombination As String
Dim strTempText As String
Dim varPickData As Variant
Dim rngToCopy As Range
For lngRow = 2 To Worksheets("Control Sheet").Cells(Rows.Count, 1).End(xlUp).Row
With Worksheets(Worksheets("Control Sheet").Cells(lngRow, 1).Value).Cells(1).CurrentRegion
.Offset(1).EntireRow.Delete
End With
Next lngRow
strTempText = ThisWorkbook.Path & "\" & FreeFile
Set obj = CreateObject("msxml2.xmlhttp")
For lngRow = 6 To Worksheets("URLs").Cells(Rows.Count, 1).End(xlUp).Row
With obj
.Open "GET", Worksheets("URLs").Range("C" & lngRow).Value, False
.send
strResponseText = "" & vbLf & Replace(.Responsetext, "
", " ") & ""
strResponseText = Replace(strResponseText, "
", " ")
Open strTempText For Output As #1
Print #1, strResponseText
Close #1
End With
With Workbooks.Open(strTempText)
For lngControlSheetLoop = 2 To Worksheets("Control Sheet").Cells(Rows.Count, 1).End(xlUp).Row
If Worksheets("Control Sheet").Cells(lngControlSheetLoop, "R").Value = fComboFields(Worksheets("Control Sheet").Cells(lngControlSheetLoop, "B").Value, .Worksheets(1)) Then
strDataToGoTo = Worksheets("Control Sheet").Cells(lngControlSheetLoop, "A").Value
lngRowToPick = Worksheets("Control Sheet").Cells(lngControlSheetLoop, "B").Value
Set rngToCopy = .Sheets(1).Range(.Sheets(1).Cells(lngRowToPick + 1, "A"), .Sheets(1).UsedRange.SpecialCells(xlCellTypeLastCe ll)(-1))
With Worksheets(strDataToGoTo).Cells(Rows.Count, 1).End(xlUp)
rngToCopy.Copy .Cells(2, 3)
.Cells(2, 1).Resize(rngToCopy.Rows.Count).Value = Worksheets("URLs").Range("A" & lngRow).Value
.Cells(2, 2).Resize(rngToCopy.Rows.Count).Value = Worksheets("URLs").Range("B" & lngRow).Value
End With
End If
Next lngControlSheetLoop
.Close 0
End With
Kill strTempText
Next lngRow
For lngRow = 2 To Worksheets("Control Sheet").Cells(Rows.Count, 1).End(xlUp).Row
With Worksheets(Worksheets("Control Sheet").Cells(lngRow, 1).Value).Cells(1).CurrentRegion
.WrapText = False
.EntireColumn.AutoFit
With .Borders
.LineStyle = xlContinuous
.Weight = xlThin
End With
End With
Next lngRow
Set obj = Nothing

End Sub


Private Function fComboFields(lngRow As Long, wks As Worksheet) As String


Dim strFieldsCombo As String
Dim lngCol As Long

For lngCol = 1 To wks.Cells(lngRow, wks.Columns.Count).End(xlToLeft).Column
strFieldsCombo = strFieldsCombo & wks.Cells(lngRow, lngCol).Value
Next lngCol
fComboFields = strFieldsCombo

End Function




Option Explicit


Sub Consolidator()

Dim objIE As Object 'InternetExplorer
Dim objTable As Object 'HTMLTable
Dim objTableCell As Object 'HTMLTableCell
Dim objDiv As Object 'HTMLDivElement
Dim objDoc As Object 'HTMLDocument
Dim objDic As Object
Dim varArray As Variant
Dim rng As Range
Dim lngCount As Long
Dim lngRows As Long
Dim lngCells As Long
Dim lngCols As Long
Dim lngRangeLoop As Long
Const clngTopRowsToDiscard As Long = 2
Const clngStartingColumn As Long = 2
Dim strYears(1 To 2) As String
Dim strUrl As String
Const cstrTableIdentifierText As String = "Sl.NoDonor"
Const cstrCountryTableIdentifierText As String = "Sl.NoCountry Name"

strYears(1) = "2010-2011": strYears(2) = "2011-2012"
With Worksheets("Main")
lngRows = .Cells(.Rows.Count, 1).End(xlUp).Row
If vbYes = MsgBox("Do you want to refresh the entire data, or only fetch the missing ones?" & vbLf & vbLf & "YES - Refresh Entire Data. NO - Fetch Missing Data Only", vbQuestion + vbYesNo, "FCRA Consolidator") Then
.Range("E2:E" & lngRows).ClearContents
On Error Resume Next
.Range("C2:D" & lngRows).ClearComments
Err.Clear: On Error GoTo 0: On Error GoTo -1
End If
.Range("C2:D" & lngRows).Formula = _
"=HYPERLINK(""http://fcraonline.nic.in/fc3_verify.aspx?RCN=""&TEXT($B2,REPT(0,9))&""R&by=""&REPLACE(C$1,5,999,"""")&""-""&REPLACE(C$1,5,999,"""")+1,INDEX('2011 FCRA Submissions ALL'!$A:$A,MATCH(Main!$B2,'2011 FCRA Submissions ALL'!$B:$B,)))"
End With
Set objIE = CreateObject("InternetExplorer.Application")
objIE.Visible = True
strUrl = "http://fcraonline.nic.in/fc3_verify.aspx?RCN=[<>]R&by=|<>|"
Set objDic = CreateObject("Scripting.Dictionary")
For Each rng In Worksheets("Main").Range("B2:B" & Worksheets("Main").Cells(Rows.Count, 1).End(xlUp).Row)
If IsEmpty(rng.Offset(, 3)) Then
Application.Goto rng
ActiveWindow.ScrollRow = rng.Row - 1
ReDim varArray(1 To 3)
With objIE
.Navigate Replace(Replace(strUrl, "|<>|", strYears(1)), "[<>]", Right("0" & rng.Value, 9))
Do While .readyState <> READYSTATE_COMPLETE Or .Busy
DoEvents
Loop
Set objDoc = .document
With objDoc
For Each objTable In .getElementsByTagName("table")
If Left(objTable.innerText, Len(cstrTableIdentifierText)) = cstrTableIdentifierText Then
lngRows = objTable.Rows.Length
For Each objTableCell In objTable.Cells
lngCells = lngCells + objTableCell.colSpan
Next objTableCell
lngCols = lngCells / lngRows
For Each objDiv In objTable.getElementsByTagName("TR")
lngCount = lngCount + 1
If objDiv.Cells.Length = lngCols And lngCount > clngTopRowsToDiscard Then
objDic.Item(objDiv.Cells(clngStartingColumn - 1).innerText) = Empty
End If
Next objDiv
varArray(1) = objDic.Keys
objDic.RemoveAll
Exit For
End If
Next objTable
lngCount = Empty: lngRows = Empty: lngCells = Empty: lngCols = Empty
For Each objTable In .getElementsByTagName("table")
If Left(objTable.innerText, Len(cstrCountryTableIdentifierText)) = cstrCountryTableIdentifierText Then
lngRows = objTable.Rows.Length
For Each objTableCell In objTable.Cells
lngCells = lngCells + objTableCell.colSpan
Next objTableCell
lngCols = lngCells / lngRows
For Each objDiv In objTable.getElementsByTagName("TR")
lngCount = lngCount + 1
If objDiv.Cells.Length = lngCols And lngCount > clngTopRowsToDiscard Then
objDic.Item(objDiv.Cells(clngStartingColumn - 1).innerText) = Empty
End If
Next objDiv
varArray(3) = objDic.Keys
objDic.RemoveAll
Exit For
End If
Next objTable
End With
lngCount = Empty: lngRows = Empty: lngCells = Empty: lngCols = Empty
.Navigate Replace(Replace(strUrl, "|<>|", strYears(2)), "[<>]", Right("0" & rng.Value, 9))
Do While .readyState <> READYSTATE_COMPLETE Or .Busy
DoEvents
Loop
Set objDoc = .document
With objDoc
For Each objTable In .getElementsByTagName("table")
If Left(objTable.innerText, Len(cstrTableIdentifierText)) = cstrTableIdentifierText Then
lngRows = objTable.Rows.Length
For Each objTableCell In objTable.Cells
lngCells = lngCells + objTableCell.colSpan
Next objTableCell
lngCols = lngCells / lngRows
For Each objDiv In objTable.getElementsByTagName("TR")
lngCount = lngCount + 1
If objDiv.Cells.Length = lngCols And lngCount > clngTopRowsToDiscard Then
objDic.Item(objDiv.Cells(clngStartingColumn - 1).innerText) = Empty
End If
Next objDiv
varArray(2) = objDic.Keys
objDic.RemoveAll
Exit For
End If
Next objTable
End With
lngCount = Empty: lngRows = Empty: lngCells = Empty: lngCols = Empty
End With
AddComments rng.Offset(, 3), varArray
End If
'lngRangeLoop = lngRangeLoop + 1: If lngRangeLoop = 1 Then Exit For
Next rng
objIE.Quit
Application.Goto Worksheets("Main").Cells(1)
Set objIE = Nothing

End Sub


Public Sub AddComments(rngData As Range, varArray As Variant)

Dim objCmt As Comment
Dim objShp As Shape
Dim strComment(1 To 2) As String
Dim intIndex As Integer
Dim intLoop As Integer

On Error Resume Next
rngData.Comment.Delete
Err.Clear: On Error GoTo -1: On Error GoTo 0
Set objCmt = rngData.AddComment
If Not IsEmpty(varArray(2)) Then
SortStringArray varArray(2)
strComment(1) = "Donors for " & "2011-2012:" & vbLf & WorksheetFunction.Proper(Left(Join(varArray(2), vbLf), 8192)) & vbLf & vbLf
End If
If Not IsEmpty(varArray(1)) Then
SortStringArray varArray(1)
strComment(2) = "Donors for " & "2010-2011:" & vbLf & WorksheetFunction.Proper(Left(Join(varArray(1), vbLf), 8192))
End If
objCmt.Text (strComment(1) & strComment(2))
With objCmt.Shape
.AutoShapeType = msoShapeRoundedRectangle
With .TextFrame.Characters.Font
.Name = "Arial"
.Color = 5287936
.Size = 9
End With
.Fill.ForeColor.RGB = 65535
.Line.ForeColor.RGB = 65535
.Fill.Visible = msoTrue
.Fill.Solid
.TextFrame.AutoSize = True
End With
With rngData
.Value = GetRepeats(varArray, objCmt, rngData.Offset(, 1))
.NumberFormat = "0%"
End With
Set objCmt = Nothing

End Sub


'This sub uses the Bubble Sort algorithm to sort an array of strings.
Private Sub SortStringArray(ByRef paintArray As Variant)


Dim lngX As Long
Dim lngY As Long
Dim intTemp

For lngX = LBound(paintArray) To (UBound(paintArray) - 1)
For lngY = LBound(paintArray) To (UBound(paintArray) - 1)
If UCase(paintArray(lngY)) > UCase(paintArray(lngY + 1)) Then
'exchange the items
intTemp = paintArray(lngY)
paintArray(lngY) = paintArray(lngY + 1)
paintArray(lngY + 1) = intTemp
End If
Next
Next


End Sub


Private Function GetRepeats(varArray As Variant, objCmt As Comment, ByRef rngCountOfDonors As Range) As Single


Dim lngCount As Long
Dim lngTotal As Long
Dim lngLoop As Long
Dim lngSubLoop As Long
Dim lngStart As Long
Dim lngLength As Long
Dim strComment As String

For lngLoop = 1 To objCmt.Shape.TextFrame.Characters.Count Step 200
strComment = strComment & objCmt.Shape.TextFrame.Characters(lngLoop, 200).Text
Next lngLoop
If Not IsEmpty(varArray(2)) And Not IsEmpty(varArray(1)) Then
For lngLoop = LBound(varArray(2)) To UBound(varArray(2))
If UCase(varArray(2)(lngLoop)) <> "OTHER" Then
lngTotal = lngTotal + 1
End If
For lngSubLoop = LBound(varArray(1)) To UBound(varArray(1))
If UCase(varArray(2)(lngLoop)) <> "OTHER" Then
If UCase(varArray(2)(lngLoop)) = UCase(varArray(1)(lngSubLoop)) Then
lngCount = lngCount + 1
lngStart = InStr(1, strComment, varArray(2)(lngLoop), vbTextCompare)
lngLength = Len(varArray(2)(lngLoop))
With objCmt.Shape.TextFrame.Characters(lngStart, lngLength).Font
.Bold = True
.Color = 0 '49407 '5287936
End With
End If
End If
Next lngSubLoop
Next lngLoop
If lngTotal Then
GetRepeats = lngCount / lngTotal
End If
End If
rngCountOfDonors = lngCount
If Not IsEmpty(varArray(3)) Then
If UBound(varArray(3)) >= 0 Then
rngCountOfDonors(, 2).Resize(, UBound(varArray(3))).Value = varArray(3)
End If
End If

End Function


Private Sub Workbook_Open()


On Error Resume Next
Worksheets("Main").Shapes("rngRun").Delete
Err.Clear: On Error GoTo 0: On Error GoTo -1
With Worksheets("Main").Shapes.AddShape(msoShapeRoundedRectangle, 828.75, 17.25, 96, 30.75)
.Name = "rngRun"
.TextFrame2.TextRange.Characters.Text = "Fetch Data"
With .TextFrame2.TextRange.Characters(1, 10).ParagraphFormat
.FirstLineIndent = 0
.Alignment = msoAlignLeft
End With
.TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignCenter
.TextFrame2.VerticalAnchor = msoAnchorMiddle
.OnAction = "=ThisWorkbook.Consolidator"
End With

End Sub

[S M C]

Well, I'll be


Option Explicit

Private Declare Function WNetGetConnection Lib "mpr.dll" Alias "WNetGetConnectionA" (ByVal lpszLocalName As String, ByVal lpszRemoteName As String, cbRemoteName As Long) As Long


Sub SaveEmailAttachmentsToFolder()


Dim objApp As Application
Dim objSession As NameSpace
Dim objStartFolder As MAPIFolder
Dim objAtmt As Attachment
Dim objItem As Object
Dim lngCount As Long
Dim strDestinationFolder As String
Dim strFileName As String


'On Error GoTo Err_Handler


Set objApp = GetObject(, "Outlook.Application")
Set objSession = objApp.GetNamespace("MAPI")
Set objStartFolder = objSession.PickFolder


lngCount = 0
' Check subfolder for messages and exit of none found
If objStartFolder.Items.Count = 0 Then
MsgBox "There are no messages in this folder : " & objStartFolder.Name, vbInformation, "Nothing Found"
GoTo ThisMacro_exit
End If


'Create strDestinationFolder if strDestinationFolder = ""
strDestinationFolder = BrowseForFolder + "\"
strDestinationFolder = ConvertToUNC(strDestinationFolder)
' Check each message for attachments and extensions
For Each objItem In objStartFolder.Items
For Each objAtmt In objItem.Attachments
strFileName = strDestinationFolder & AddTimeStamp(objAtmt.FileName)
objAtmt.SaveAsFile strFileName
lngCount = lngCount + 1
Next objAtmt
Next objItem


' Show this message when Finished
If lngCount > 0 Then
MsgBox "You can find the files here: " & strDestinationFolder, vbInformation, "Finished!"
Else
MsgBox "Could not find any e-mail attachments in the selected folder", vbInformation, "Finished!"
End If




' Error information
Err_Handler:
If Err.Number Then
MsgBox "An unexpected error has occurred." _
& vbCrLf & "Please note and report the following information." _
& vbCrLf & "Macro Name: SaveEmailAttachmentsToFolder" _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
End If

ThisMacro_exit:
'Clear memory
Set objStartFolder = Nothing
Set objSession = Nothing
Set objApp = Nothing
Set objAtmt = Nothing
Set objItem = Nothing

End Sub


Function BrowseForFolder(Optional OpenAt As Variant) As Variant
'Function purpose: To Browser for a user selected folder.
'If the "OpenAt" path is provided, open the browser at that directory
'NOTE: If invalid, it will open at the Desktop level


Dim ShellApp As Object


'Create a file browser window at the default folder
Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose a folder", 0, OpenAt)


'Set the folder to that selected. (On error in case cancelled)
On Error Resume Next
BrowseForFolder = ShellApp.self.Path
On Error GoTo 0: On Error GoTo -1


'Destroy the Shell Application
Set ShellApp = Nothing


'Check for invalid or non-entries and send to the Invalid error
'handler if found
'Valid selections can begin L: (where L is a letter) or
'\\ (as in \\servername\sharename. All others are invalid
Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":"
If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
Case Else
GoTo Invalid
End Select


Exit Function


Invalid:
'If it was determined that the selection was invalid, set to False
BrowseForFolder = False
End Function


Function AddTimeStamp(strToWhat As String) As String

AddTimeStamp = Mid(strToWhat, 1, InStrRev(strToWhat, ".") - 1) & "_" & Format(Now(), "yyyymmdd hhmmss.00") & "_" & Mid(strToWhat, InStrRev(strToWhat, "."))

End Function




'Purpose : Returns the UNC Path given a path
'Inputs : sPathName The path to convert
'Outputs : The UNC path of sPathName
'Notes : Requires NT/2000
'Revisions :


Function ConvertToUNC(sPathName As String) As String


Dim szValue As String, szValueName As String, sUNCName As String
Dim lErrCode As Long, lEndBuffer As Long
Const lLenUNC As Long = 520
'Return values for WNetGetConnection
Const NO_ERROR As Long = 0
Const ERROR_NOT_CONNECTED As Long = 2250
Const ERROR_BAD_DEVICE = 1200&
Const ERROR_MORE_DATA = 234
Const ERROR_CONNECTION_UNAVAIL = 1201&
Const ERROR_NO_NETWORK = 1222&
Const ERROR_EXTENDED_ERROR = 1208&
Const ERROR_NO_NET_OR_BAD_PATH = 1203&


'Verify whether the disk is connected to the network
If Mid$(sPathName, 2, 1) = ":" Then
sUNCName = String$(lLenUNC, 0)
lErrCode = WNetGetConnection(Left$(sPathName, 2), sUNCName, lLenUNC)
lEndBuffer = InStr(sUNCName, vbNullChar) - 1
'Can ignore the errors below (will still return the correct UNC)
If lEndBuffer > 0 And (lErrCode = NO_ERROR Or lErrCode = ERROR_CONNECTION_UNAVAIL Or lErrCode = ERROR_NOT_CONNECTED) Then
'Success
sUNCName = Trim$(Left$(sUNCName, InStr(sUNCName, vbNullChar) - 1))
ConvertToUNC = sUNCName & Mid$(sPathName, 3)
Else
'Error, return original path
ConvertToUNC = sPathName
End If
Else
'Already a UNC Path
ConvertToUNC = sPathName
End If

End Function

Ensured total continuity of IT services and managed cent percent issue resolution for desktop/laptop installations and trouble shooting at DCO and Chairman’s residence. Was accountable for the maintenance of all network components within area of work, and oversaw the installation, testing and evaluation of success of the installations. Ensured tight protection for deployment of all new computing devices and enterprise endpoints, and managed its security compliance. Provided 100% update of latest patch definition and antivirus file in all standalone computers. Handled escalations for unresolved incidents in coordination with HO. Ensured that the resident and visiting corporate senior users are provided with quick and immediate IT support, thereby ensuring more than 98% uptime for handheld devices. Maintained a high sense of documentation and incidence reporting, by ensuring that all calls related to corporate affairs users and IT assets are logged in the service desk tool.

Ensured that all IT policy compliance activities are continued as per schedule by conducting periodic reviews of all standalone computers (desktops/laptos) at DCO and B-63 G.K-1, and kept the systems up-to-date by ensuring all endpoints have the latest versions of anti-virus , and MS hot-fixes and patches. Compiled and updated a quarterly list of assets inventory and software licenses and co-ordinated with MIS and HO for any license gaps. Conducted a detailed physical substantiation of IT assets on a half year basis.

Ensured monitoring of system activity and performed auditing to maintain sufficient disk space and ensure file system integrity is maintained, thereby ensuring 100% uptime of the application without performance issues at user end. Addressed all day today activities like maintenance tasks, monitoring mail, print and other applications, installation, configuration and removal of software packages as required, install, mount and configure peripheral devices, manage new user creation, account unlock, password reset and application related queries. Ensured regular liaison and follow-up with the ASG team for debugging and enhancements.

[Excel Fox]

Sub Consolidator()


'Microsoft Internet Controls & Microsoft HTML Object Library references to be added
Dim objIE As InternetExplorer
Dim objFrame As HTMLIFrame
Dim objButton As HTMLButtonElement
Dim objTable As HTMLTable
Dim objDoc As HTMLDocument
Dim objStartDate As HTMLInputElement
Dim objEndDate As HTMLInputElement
Dim objTR As Object
Dim objTD As Object
Dim objCol As Object
Dim objRow As Object
Dim lngRow As Long
Dim lngCol As Long
Dim strUrl As String
Dim dtmNextMonthFirstDay As Date
Dim sngTimer As Single
Const clngMonthInAdvance As Long = 1
Const clngStartingColumn As Long = 2
Const clngStartingRow As Long = 3

dtmNextMonthFirstDay = DateSerial(Year(Date), Month(Date) + clngMonthInAdvance, 1)
Set objIE = CreateObject("InternetExplorer.Application")
strUrl = "https://kapalk1.mavir.hu/kapar/lt-publication.jsp?locale=en_GB"
With objIE
.Visible = True
.Navigate strUrl
Do While .readyState <> READYSTATE_COMPLETE Or .Busy: Loop
Set objDoc = .document
Do While objFrame Is Nothing
Set objFrame = objDoc.getElementById("com.astron.kapar.WebClient")
Loop
Set objDoc = objFrame.document
With objDoc
With objDoc.getElementsByClassName("gwt-DateBox")
Set objStartDate = .Item(0)
objStartDate.Value = Format(dtmNextMonthFirstDay, "DD/MM/YYYY")
Set objEndDate = .Item(1)
objEndDate.Value = Format(DateSerial(Year(dtmNextMonthFirstDay), Month(dtmNextMonthFirstDay) + 1, 0), "DD/MM/YYYY")
End With
Set objButton = .getElementsByClassName("gwt-Button")(0)
End With
sngTimer = Timer
Do While objTable Is Nothing
objButton.Click
On Error Resume Next
Set objTable = objDoc.getElementsByClassName("astron-gwTable")(0)
Err.Clear: On Error GoTo 0: On Error GoTo -1
If Timer - sngTimer > 10 Then
Exit Do
End If
Loop
If objTable Is Nothing Then
MsgBox "The process to too long. Exiting now. Please try again later. If the problem persists, please contact XYZ at xyz@abcmail.com"
Else
Set objRow = objTable.getElementsByTagName("TR")
lngRow = clngStartingRow: lngCol = clngStartingColumn
For Each objTR In objRow
Set objCol = objTR.getElementsByTagName("TD")
For Each objTD In objCol
Cells(lngRow, lngCol).Value = objTD.innerText
lngCol = lngCol + 1
Next objTD
lngRow = lngRow + 1
lngCol = clngStartingColumn
Next objTR
End If
End With
objIE.Quit

Set objIE = Nothing
Set objDoc = Nothing
Set objFrame = Nothing
Set objTable = Nothing
Set objButton = Nothing
Set objStartDate = Nothing
Set objEndDate = Nothing
Set objTR = Nothing
Set objTD = Nothing
Set objCol = Nothing
Set objRow = Nothing

End Sub

[mokko]

I wanna make sure if this forum allow to post link word like home automation NY, what can you say on this matter?

[Excel Fox]

Yes, it does. So now that you know it can, I'm deleting the link in the post content

=MATCH(9E+99,INDIRECT("'"&Sheet1!$F2&" source data'!A:A"),1)
=INDIRECT("'"&Sheet1!$F2&" source data'!G"&rngLastRow-12&":G"&rngLastRow)


'Objective
'This code is intended to provide the user an easy way to send a quick thank you note to multiple senders
'The default text reply is "Thank you very much <sender's first name>"
'If you need an additional line following that, please modify the cmstrAdditionalText below


'WARNING: This code is provided for example purposes ONLY. Business Transformation team,
'nor the author, will be held liable for any damages resulting from its use.
'
'NOTE: This code is pretty much bare-bones. Error handling is minimal, and there are very many safety nets,
'version checks, and other practices which should be followed that are not implemented below.
'
'To use this example, copy and paste the following code into the ThisOutlookSession
'object of a new VBA project in Outlook 2002 or above up to Outlook 2007.
'IMPORTANT: This will not work in Outlook 2010 or above

Option Explicit

'CommandBars object of Active Explorer. Note that we are not considering the active explorer window changes,
'and ideally should set this object whenever the active explorer window changes, but
'that's not done in this example.

Private WithEvents wtecbrActiveExplorerCBars As CommandBars
Private WithEvents wtecbbContextMenuButton As CommandBarButton

'A flag, so we don't respond to our own changes in OnUpdate
Private blnIgnoreCommandbarsChanges As Boolean
'Additional line if required
Private Const cmstrAdditionalText As String = "" ' "Please have some sweet from my desk "

Private Sub Application_Startup()

Install

End Sub

'Run this first
Public Sub Install()

Set wtecbrActiveExplorerCBars = ActiveExplorer.CommandBars

End Sub
Private Sub wtecbbContextMenuButton_Click(ByVal cbbCtrl As Office.CommandBarButton, CancelDefault As Boolean)

Dim objSelectedItems As Selection
Dim mliEachMailItem As MailItem
Set objSelectedItems = Outlook.ActiveExplorer.Selection
For Each mliEachMailItem In objSelectedItems
With mliEachMailItem.Reply
.HTMLBody = FormatText("Thank you very much " & FirstName(mliEachMailItem.SenderName) & ". " & cmstrAdditionalText) & .HTMLBody
.Display: .Save: .Send
End With
Next mliEachMailItem

End Sub

'This fires when the user right-clicks a contact, and also for a lot of other things!
Private Sub wtecbrActiveExplorerCBars_OnUpdate()

Dim cbrCommandBar As CommandBar

If blnIgnoreCommandbarsChanges Then Exit Sub

'Try for the context menu
On Error Resume Next
Set cbrCommandBar = wtecbrActiveExplorerCBars.Item("Context Menu")
Err.Clear: On Error GoTo 0: On Error GoTo -1

If Not cbrCommandBar Is Nothing Then
AddContextButton cbrCommandBar
End If

End Sub

Private Sub AddContextButton(cbrContextMenu As CommandBar)

Dim cbcContextMenuControl As CommandBarControl

'User cannot play with the Context Menu, so we know there is at most
'only one copy of the cbcContextMenuControl there
Set cbcContextMenuControl = cbrContextMenu.FindControl(Type:=MsoControlType.ms oControlButton, Tag:="&Thank You")

If cbcContextMenuControl Is Nothing Then

'Unprotect context menu
ChangingBar cbrContextMenu, False

'Create the cbcContextMenuControl
Set cbcContextMenuControl = cbrContextMenu.Controls.Add(Type:=msoControlButton , Before:=1)

'Set up cbcContextMenuControl
With cbcContextMenuControl
.Tag = "Thank You"
.FaceId = 265
.Caption = "&Thank You"
.Priority = 1
.Visible = True
End With

'Reprotect context menu
ChangingBar cbrContextMenu, True

'Hook the Click event
Set wtecbbContextMenuButton = cbcContextMenuControl
Else
'Note that Outlook has a bad habbit of changing our Context Menu buttons
'to be priority dropped.
cbcContextMenuControl.Priority = 1
End If

End Sub

'Called once to prepare for changes to the command bar, then again with
'blnRestore = true once changes are complete.
Private Sub ChangingBar(cbrCommandBar As CommandBar, blnRestore As Boolean)

Static blnOldProtectFromCustomize As Boolean
Dim blnOldIgnore As Boolean

If blnRestore Then
'Restore the Ignore Changes flag
blnIgnoreCommandbarsChanges = blnOldIgnore
'Restore the protect-against-customization bit
If blnOldProtectFromCustomize Then
cbrCommandBar.Protection = cbrCommandBar.Protection And msoBarNoCustomize
End If
Else
'Store the old Ignore Changes flag
blnOldIgnore = blnIgnoreCommandbarsChanges
blnIgnoreCommandbarsChanges = True

'Store old protect-against-customization bit setting then clear
'CAUTION: Be careful not to alter the property if there is no need,
'as changing the Protection will cause any visible CommandBarPopup
'to disappear unless it is the popup we are altering.
blnOldProtectFromCustomize = cbrCommandBar.Protection And msoBarNoCustomize
If blnOldProtectFromCustomize Then
cbrCommandBar.Protection = cbrCommandBar.Protection And Not msoBarNoCustomize
End If
End If

End Sub

Function ResolveDisplayNameToSMTP(sFromName)

Dim oRecip As Recipient
Dim oEU As ExchangeUser
Dim oEDL As ExchangeDistributionList

Set oRecip = Application.Session.CreateRecipient(sFromName)
oRecip.Resolve
If oRecip.Resolved Then
Select Case oRecip.AddressEntry.AddressEntryUserType
Case OlAddressEntryUserType.olSmtpAddressEntry
ResolveDisplayNameToSMTP = oRecip.Address 'If that doesn't work, try oRecip.AddressEntry
Case OlAddressEntryUserType.olExchangeUserAddressEntry, OlAddressEntryUserType.olOutlookContactAddressEntr y
Set oEU = oRecip.AddressEntry.GetExchangeUser
If Not (oEU Is Nothing) Then
ResolveDisplayNameToSMTP = oEU.PrimarySmtpAddress
End If
Case OlAddressEntryUserType.olExchangeDistributionListA ddressEntry
Set oEDL = oRecip.AddressEntry.GetExchangeDistributionList
If Not (oEDL Is Nothing) Then
ResolveDisplayNameToSMTP = oEDL.PrimarySmtpAddress
End If
End Select
End If

End Function

Private Function FormatText(str) As String

Const strHTML1 As String = "<span style='font-size:11.0pt;color:#1F497D'>"
Const strHTML2 As String = "</span><span style='font-size:11.0pt;color:#1F497D;mso-char-type:symbol;mso-symbol-font-family:Wingdings'>J</span>"

FormatText = strHTML1 & str & strHTML2

End Function

Public Function FirstName(str) As String

FirstName = Left(str, InStr(1, str, " ") - 1)

End Function

[tenda]

Cool testing, table tag is working :) , BTW its default vbulletin feature :) :cheers:


Function Code for getting Column Letter from Column Number
Shortened version used in Post #14
http://www.excelfox.com/forum/showthread.php/2083-Delete-One-Row-From-A-2D-Variant-Array?p=9837#post9837
Public Function CL(ByVal lclm As Long) As String

And Fuller version with explaining 'Comments



Public Function CL(ByVal lclm As Long) As String ' http://www.excelforum.com/development-testing-forum/1101544-thread-post-appendix-no-reply-needed-please-do-not-delete-thanks-4.html#post4213980
Do: Let CL = Chr(65 + (((lclm - 1) Mod 26))) & CL: Let lclm = (lclm - (1)) \ 26: Loop While lclm > 0
End Function

Function FukOutChrWithDoWhile(ByVal lclm As Long) As String 'Using chr function and Do while loop For example http://www.excelforum.com/excel-programming-vba-macros/796472-how-to-go-from-column-number-to-column-letter.html
Dim rest As Long 'Variable for what is "left over" after subtracting as many full 26's as possible
Do
' Let rest = ((lclm - 1) Mod 26) 'Gives 0 to 25 for Column Number "Left over" 1 to 26. Better than ( lclm Mod 26 ) which gives 1 to 25 for clm 1 to 25 then 0 for 26
' Let FukOutChrWithDoWhile = Chr(65 + rest) & FukOutChrWithDoWhile 'Convert rest to Chr Number, initially with full number so the "units" (0-25), then number of 26's left over (if the number was so big to give any amount of 26's in it, then number of 26's in the 26's left over (if the number was so big to give any amount of 26 x 26's in it, Enit ?
' 'OR
Let FukOutChrWithDoWhile = Chr(65 + (((lclm - 1) Mod 26))) & FukOutChrWithDoWhile
Let lclm = (lclm - (1)) \ 26 'This gives the number of 26's ( if any ), but just the excact part, in the next number down , - so applying the rest formula to this new number will again leave a difference "left over" rest.
'lclm = (lclm - (rest + 1)) \ 26 ' As the number is effectively truncated here, any number from 1 to (rest +1) will do in the formula
Loop While lclm > 0 'Only loop further if number was big enough to still have 0-25's in it
End Function
Rem Ref http://www.excelforum.com/development-testing-forum/1101544-thread-post-appendix-no-reply-needed-please-do-not-delete-thanks-4.html#post4213980
Rem Ref http://www.excelforum.com/tips-and-tutorials/1108643-vba-column-letter-from-column-number-explained.html




Let it be
2 reasons really:
_1) I am not sure if I have it right, I may not be using exactly the correct terminology, but my thinking is that you can broadly/ approximately speaking do three things to/with stuff/things in VB
_1(i) You assign an object , which VB knows to do if you use Set
_1(ii) You assign a value , which VB knows to do if you use Let
_1(iii) You use a Method/Property/Function of something , which VB knows to do if you don't use anything
But because VB is good at guessing/ distinguishing between (ii) and (iii) you can leave it out in cases (ii), and VB will use Let "internally" for you as the implicit default in whatever compile thingy it does/has.
I prefer not to use implicit defaults.

_2) Aesthetics.
My coding distinguishes itself, I feel, from others, in its beauty. My coding is beautiful. Those extra pretty blue Lets further add to its beauty, IMHO
:)

http://www.eileenslounge.com/viewtopic.php?p=271519#p271519




Another reason is it helps to distinguish the two Public Property procedures in Class things , ( The Let and Get stuff )
Simplified example: I have a Class module called Car, and I have a color property of it , CrColor

The relevant bit of my simplified Class Module is this
Private PrvteCrColor As String
Public Property Let CrColor(Clr As String)
Let PrvteCrColor = Clr
End Property

In a simple use within a normal code module I would use something of this form
Dim objCr As Car: Set objCr = New Car
__ objCr.CrColor = "Yellow"

That last code line is what effectively uses the Public Property Let . But I can write it as
Let objCr.CrColor = "Yellow"

So that’s quite helpful to the novice to help not get the Public Property Let and Get mixed up




https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)