Results 1 to 7 of 7

Thread: This is a test Test Let it be

  1. #1
    Administrator Admin's Avatar
    Join Date
    Mar 2011
    Posts
    1,122
    Rep Power
    10

    This is a test Test Let it be

    Test: Let it be....
    Closed !

    Alan


    Sheet1

    AB
    1sdf34
    2sdfsdf345
    3sdf435
    4sd34
    5sfd235
    6fsd43
    7 3
    8 1129

    Spreadsheet Formulas
    CellFormula
    B8=SUM(B1:B7)


    Excel tables to the web >> Excel Jeanie HTML 4
    Last edited by DocAElstein; 07-19-2020 at 12:25 PM.

  2. #2
    Administrator Excel Fox's Avatar
    Join Date
    Mar 2011
    Posts
    1,401
    Rep Power
    10
    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
    A dream is not something you see when you are asleep, but something you strive for when you are awake.

    It's usually a bad idea to say that something can't be done.

    The difference between dream and aim, is that one requires soundless sleep to see and the other requires sleepless efforts to achieve

    Join us at Facebook

  3. #3
    Grand Master
    Join Date
    Apr 2011
    Posts
    22
    Rep Power
    10
    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.

  4. #4
    Administrator Excel Fox's Avatar
    Join Date
    Mar 2011
    Posts
    1,401
    Rep Power
    10
    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
    A dream is not something you see when you are asleep, but something you strive for when you are awake.

    It's usually a bad idea to say that something can't be done.

    The difference between dream and aim, is that one requires soundless sleep to see and the other requires sleepless efforts to achieve

    Join us at Facebook

  5. #5
    Junior Member
    Join Date
    Jul 2013
    Posts
    1
    Rep Power
    0

    let's try this one...

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

  6. #6
    Administrator Excel Fox's Avatar
    Join Date
    Mar 2011
    Posts
    1,401
    Rep Power
    10
    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
    A dream is not something you see when you are asleep, but something you strive for when you are awake.

    It's usually a bad idea to say that something can't be done.

    The difference between dream and aim, is that one requires soundless sleep to see and the other requires sleepless efforts to achieve

    Join us at Facebook

  7. #7
    Junior Member tenda's Avatar
    Join Date
    May 2014
    Posts
    3
    Rep Power
    0
    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
    Last edited by DocAElstein; 06-12-2023 at 05:42 PM.

Similar Threads

  1. Testing Image Links
    By DocAElstein in forum Test Area
    Replies: 5
    Last Post: 04-19-2022, 01:57 PM
  2. Test
    By DocAElstein in forum Test Area
    Replies: 0
    Last Post: 03-30-2020, 07:20 PM
  3. test
    By EFmanagement in forum Test Area
    Replies: 0
    Last Post: 09-29-2019, 11:01 PM
  4. Test
    By Excel Fox in forum Den Of The Fox
    Replies: 0
    Last Post: 07-31-2013, 08:15 AM
  5. Test
    By Excel Fox in forum Word Help
    Replies: 0
    Last Post: 07-05-2011, 01:51 AM

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •