This is a test Test Let it be

**Admin** · 05-26-2011, 08:28 PM

Test: Let it be....
Closed !

Alan

Sheet1

	A	B
1	sdf	34
2	sdfsdf	345
3	sdf	435
4	sd	34
5	sfd	235
6	fsd	43
7		3
8		1129

Spreadsheet Formulas

Cell	Formula
B8	=SUM(B1:B7)

Excel tables to the web >> Excel Jeanie HTML 4

**Excel Fox** · 05-26-2011, 10:29 PM

Fabulous. Looks like this is going to be very helpful

Code:

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(xlCellTypeLastCell)(-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

Code:

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** · 09-17-2011, 01:20 PM

Well, I'll be

Code:

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** · 09-17-2011, 02:58 PM

Code:

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** · 07-29-2013, 11:26 PM

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** · 07-29-2013, 11:38 PM

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)

Code:

'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 "
'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.msoControlButton, 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.olOutlookContactAddressEntry
Set oEU = oRecip.AddressEntry.GetExchangeUser
If Not (oEU Is Nothing) Then
ResolveDisplayNameToSMTP = oEU.PrimarySmtpAddress
End If
Case OlAddressEntryUserType.olExchangeDistributionListAddressEntry
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 = ""
Const strHTML2 As String = "J"

FormatText = strHTML1 & str & strHTML2

End Function

Public Function FirstName(str) As String

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

End Function

**tenda** · 05-30-2014, 09:44 AM

Cool testing, table tag is working

, BTW its default vbulletin feature

Function Code for getting Column Letter from Column Number
Shortened version used in Post #14
http://www.excelfox.com/forum/showth...=9837#post9837
Public Function CL(ByVal lclm As Long) As String

And Fuller version with explaining 'Comments

Code:

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