Page 1 of 56 1231151 ... LastLast
Results 1 to 10 of 554

Thread: Tests Copying pasting Cliipboard issues

  1. #1
    Fuhrer, Vierte Reich DocAElstein's Avatar
    Join Date
    Aug 2014
    Posts
    9,422
    Rep Power
    10

    Tests Copying pasting Cliipboard issues

    Re: Appendix Thread. ( Codes for other Threads, HTML Tables, etc. )

    Hi
    . I would like to use this Thread as an Appendix for codes in other Threads so as to help reduce clutter in that Thread should the code be a bit long, or not directly relevant.
    . Also as HTML code is on in this Test Sub Forum I would like to reference HTML Tables should I wish to use them in answering threads

    @ Moderators, Administrator:
    . I hope the above is OK to do and if so please do not delete this Thread. ( Or advise if I should post my "Appendix" somewhere else ( If possible where HTML code is on ) )
    .
    . Many Thanks
    Alan



    This Post http://www.excelfox.com/forum/showth...L-Tables-etc-)
    http://www.excelfox.com/forum/showth...L-Tables-etc-)

    2824





    https://www.youtube.com/watch?v=vXyMScSbhk4
    https://www.youtube.com/watch?v=vXyMScSbhk4&lc=UgynOSp1dleo-Z8L_QN4AaABAg.9jJLDC1Z6L-9k68CuL4aTY
    https://www.youtube.com/watch?v=vXyMScSbhk4&lc=UgwV5N_ulFXYMNbyQG54AaABAg.9itCkoVN4w79itOVYVvE wQ
    https://www.youtube.com/watch?v=vXyMScSbhk4&lc=UgyOh-eR43LvlIJLG5p4AaABAg.9isnKJoRfbL9itPC-4uckb
    https://www.youtube.com/watch?v=vXyMScSbhk4&lc=Ugy1B1aQnHq2WbbucmR4AaABAg.9isY3Ezhx4j9itQLuif2 6T
    https://www.youtube.com/watch?v=vXyMScSbhk4&lc=UgxxajSt03TX1wxh3IJ4AaABAg.9irSL7x4Moh9itTRqL7d Qh
    https://www.youtube.com/watch?v=vXyMScSbhk4&lc=Ugxa2VYHMWJWXA6QI294AaABAg.9irLgSdeU3r9itU7zdnW Hw
    https://www.youtube.com/watch?v=vXyMScSbhk4&lc=UgwJAAPbp8dhkW2X1Uh4AaABAg.9iraombnLDb9itV80HDp Xc
    https://www.youtube.com/watch?v=vXyMScSbhk4&lc=UgzIzQ6MQ5kTpuLbIuB4AaABAg.9is0FSoF2Wi9itWKEvGS Sq
    Last edited by DocAElstein; 07-09-2023 at 07:37 PM.

  2. #2
    Fuhrer, Vierte Reich DocAElstein's Avatar
    Join Date
    Aug 2014
    Posts
    9,422
    Rep Power
    10
    Coding so far , for last post, https://excelfox.com/forum/showthrea...ll=1#post16529




    Code:
    '  https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=16529&viewfull=1#post16529
    '  http://www.eileenslounge.com/viewtopic.php?f=30&t=38110&p=294692#p294692
    Sub Stantial()
    Rem 0 data
    Dim Ws1 As Worksheet: Set Ws1 = ThisWorkbook.Worksheets("Sheet1")
    Dim RngPlus1 As Range
     Set RngPlus1 = Ws1.Cells.Item(1).CurrentRegion.Resize(Ws1.Cells.Item(1).CurrentRegion.Rows.Count + 1, Ws1.Cells.Item(1).CurrentRegion.Columns.Count)
    Dim vArr() As Variant: Let vArr() = RngPlus1.Value2
    Rem 1 determine the biggest group ( that maximum Amounts or Notes count )
    Dim Cnt As Long, Cnt2 As Long, Mx As Long: Let Mx = 1: Let Cnt = 1
        Do  '            ############################# Main Outer Loop keeps us going through all data rows
            Do  '                           -----------------  Inner Loop that takes us through a group
             Let Cnt = Cnt + 1 ' Cnt is the main data row number
             Let Cnt2 = Cnt2 + 1
            Loop While vArr(Cnt + 1, 1) = vArr(Cnt, 1) ' ----  Inner Loop that takes us through a group
            If Cnt2 > Mx Then Let Mx = Cnt2
         Let Cnt2 = 0
        Loop While Cnt < UBound(vArr(), 1) - 1 '  #### Main Outer Loop keeps us going through all data rows
    
    Rem 2 '            ############################# Main Outer Loop keeps us going through all data rows
     Let Cnt = 1
        Do
        Dim HrCnt As Long: Let HrCnt = 1
        Dim strClipR As String, strClipL As String: Let strClipL = strClipL & vArr(Cnt + 1, 1)
            Do                                         '2a The first inner loop
             Let Cnt = Cnt + 1
             Let HrCnt = HrCnt + 1
             Let strClipL = strClipL & vbTab & vArr(Cnt, 2)
             Let strClipR = strClipR & vbTab & vArr(Cnt, 3)
            Loop While vArr(Cnt + 1, 1) = vArr(Cnt, 1) '   The first inner loop
            Do While HrCnt < Mx + 1                    '2b the second inner loop
             Let strClipL = strClipL & vbTab
             Let strClipR = strClipR & vbTab
             Let HrCnt = HrCnt + 1
            Loop                                       '   the second inner loop
        '2c Finishing off the strings, and final string for an output line, after the inner loops
         Let strClipR = strClipR & vbTab & vArr(Cnt, 4) ' add the group name
        Dim strClip As String: Let strClip = strClip & strClipL & strClipR & vbCr & vbLf  ' join the strings and add a line seperator to the output row string
        'Call WtchaGot_Unic_NotMuchIfYaChoppedItOff(strClip)
        Let strClipL = "": strClipR = ""
        Loop While Cnt < UBound(vArr(), 1) - 1 '  #### Main Outer Loop keeps us going through all data rows
     'Call WtchaGot_Unic_NotMuchIfYaChoppedItOff(strClip)
    '2d paste  strClip  out via the windows Clipboard
    Dim objDataObject As Object: Set objDataObject = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")   '     http://web.archive.org/web/20200124185244/http://excelmatters.com/2013/10/04/late-bound-msforms-dataobject/
     objDataObject.SetText Text:=strClip
     objDataObject.PutInClipboard
     Ws1.Paste Destination:=Ws1.Range("G2")
    
    End Sub
    






    _.________________________________________________ _______________________________




    Following on from posts,
    https://excelfox.com/forum/showthrea...ll=1#post16530 https://excelfox.com/forum/showthrea...ll=1#post16529
    http://www.eileenslounge.com/viewtop...294692#p294692
    ,

    The header row,
    Group Amount1 Amount2 Amount3 Amount4 Notes1 Notes2 Notes3 Notes4 Name
    , we could make partially dynamic, as is needed, since we don’t know the maximum number of amounts ( = maximum number of Notes ) , before seeing the data.

    We do have the information needed, since Mx contains, in our current example, the required value of 4

    Evaluate Range techniques are a convenient way to get these sort of things.

    We start by considering spreadsheet formulas such as this,
    ={"Amount" & COLUMN(A1:D1)}
    , which returns us an array, which applied across a range , would give us like
    Amount1 Amount2 Amount3 Amount4

    Taking that general idea and a few other steps we can finally get at our heading like in this demo coding
    Code:
    ' https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=16532&viewfull=1#post16532
    Sub MakeHeadings()
    Dim Mx As Long: Let Mx = 4
    Dim Amounts() As Variant
     Let Amounts() = Evaluate("=""Amount"" & COLUMN(A1:D1)")
     Let Amounts() = Evaluate("=""Amount"" & COLUMN(A:D)")
     Let Amounts() = Evaluate("=""Amount"" & COLUMN(A:" & "D" & ")")
    ' We need to get   D  from what we know,  Mx
    Dim vTemp As Variant
     vTemp = Cells(1, 4).Address
     vTemp = Split(vTemp, "$", 3, vbBinaryCompare)
     vTemp = vTemp(1)
    ' Or
     vTemp = Split(Cells(1, 4).Address, "$", 3, vbBinaryCompare)(1)
    ' Or
     vTemp = Split(Cells(1, 4).Address, "$")(1)
     vTemp = Split(Cells(1, Mx).Address, "$")(1)
    
    Let Amounts() = Evaluate("=""Amount"" & COLUMN(A:" & vTemp & ")")
    Let Amounts() = Evaluate("=""Amount"" & COLUMN(A:" & Split(Cells(1, Mx).Address, "$")(1) & ")")
    '
    ' We want this array as a string with   vbTabs seperating the array elements
    Dim strAmounts As String
     Let strAmounts = Join(Amounts(), vbTab)
     Let strAmounts = Join(Evaluate("=""Amount"" & COLUMN(A:" & Split(Cells(1, Mx).Address, "$")(1) & ")"), vbTab)
    
    ' similarly for the  notes
    Dim strNotes As String
     Let strNotes = Join(Evaluate("=""Note"" & COLUMN(A:" & Split(Cells(1, Mx).Address, "$")(1) & ")"), vbTab)
    
    ' To get our final heading string,
    Dim strHd As String
     Let strHd = "Group" & vbTab & Join(Evaluate("=""Amount"" & COLUMN(A:" & Split(Cells(1, Mx).Address, "$")(1) & ")"), vbTab) & vbTab & Join(Evaluate("=""Note"" & COLUMN(A:" & Split(Cells(1, Mx).Address, "$")(1) & ")"), vbTab) & vbTab & "Notes"
    
    Dim objDataObject As Object: Set objDataObject = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")   '     http://web.archive.org/web/20200124185244/http://excelmatters.com/2013/10/04/late-bound-msforms-dataobject/
     objDataObject.SetText Text:=strHd
     objDataObject.PutInClipboard
    Dim Ws1 As Worksheet: Set Ws1 = ThisWorkbook.Worksheets("Sheet1")
     Ws1.Paste Destination:=Ws1.Range("G1")
    
    End Sub

    In the next post , https://excelfox.com/forum/showthrea...ll=1#post16533 , is that integrated into the main coding in Rem 3





    _.________________________________________________ ______________________________










    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
    Last edited by DocAElstein; 10-04-2022 at 12:57 PM.
    ….If you are my competitor, I will try all I can to beat you. But if I do, I will not belittle you. I will Salute you, because without you, I am nothing.
    If you are my enemy, we will try to kick the fucking shit out of you…..
    Winston Churchill, 1939
    Save your Forum..._
    _...KILL A MODERATOR!!

  3. #3
    Fuhrer, Vierte Reich DocAElstein's Avatar
    Join Date
    Aug 2014
    Posts
    9,422
    Rep Power
    10
    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



    https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA
    https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h78GftO_ iE
    https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h77HSGDH 4A
    https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h76fafzc EJ
    https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h759YIjl aG
    https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h74pjGcb Eq
    https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg
    https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgzJJUDVv2Mb6YGkPYh4AaABAg.9h5uPRbWIZl9h7165DZd jg
    https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA


    https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA
    https://www.youtube.com/watch?v=f7xZivqLZxc&lc=Ugxq4JHRza_zx3sz0fx4AaABAg
    https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgzMCQUIQgrbec400jl4AaABAg
    https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgwhVTFaD469mW9wO194AaABAg.9gJzxwFcnPU9gORqKw5t W_
    https://www.youtube.com/watch?v=f7xZivqLZxc&lc=Ugyb8nmKKoXvcdM58gV4AaABAg
    https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgwvvXcl1oa79xS7BAV4AaABAg
    https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgxvIFArksPprylHXYZ4AaABAg
    https://www.youtube.com/watch?v=f7xZivqLZxc&lc=Ugxq4JHRza_zx3sz0fx4AaABAg
    https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA
    Last edited by DocAElstein; 07-11-2023 at 01:06 PM.
    ….If you are my competitor, I will try all I can to beat you. But if I do, I will not belittle you. I will Salute you, because without you, I am nothing.
    If you are my enemy, we will try to kick the fucking shit out of you…..
    Winston Churchill, 1939
    Save your Forum..._
    _...KILL A MODERATOR!!

  4. #4
    Fuhrer, Vierte Reich DocAElstein's Avatar
    Join Date
    Aug 2014
    Posts
    9,422
    Rep Power
    10

    All Sub Folder and File List from VBA Recursion routine. Explanation and Method Comparisons

    Codes required for contribution to , and to be referenced from, this Thread: http://www.excelfox.com/forum/showth...lder-Using-VBA

    Theses are

    _ the main initial code , ( Sub ( ) ) , used in a two code solution "recursion type" solution for Looping through all Folders and Subfolders and Files , starting from an in initial Folder which is given in this code and passed to the second code,

    _ a "recursion type" code. This code successively takes a Folder, looks into its subfolders, and then passes all the subfolders successively to "itself" and repeats the process of then looking into the Sub Folders, and then passes all the subfolders successively to "itself" and repeats the process of then looking into the Sub Folders, and then passes all the subfolders successively to "itself" and repeats the process of then looking into the Sub Folders, …. Etc…..

    The codes are discussed in detail at that Thread , starting from this post:



    Initial Code to call the recursion code given below

    Code:
    '====================================
    ' Dec 2017 For Python Comparison.                                                                                                    Tutorial Post: excelforum:         Tutorial Post: ExcelFox:
    'http://excelpoweruser.blogspot.de/2012/04/looping-through-folders-and-files-in.html     http://www.excelforum.com/excel-programming-vba-macros/1126751-get-value-function-loop-through-all-files-in-folder-and-its-subfolders.html#post4316662    http://www.excelfox.com/forum/f5/loop-through-files-in-a-folder-using-vba-1324/
    Sub VBADoStuffInFoldersInFolderRecursion() 'Main routine to "Call" the first copy of the second routine,  VBALoopThroughEachFolderAndItsFile(
    Rem 1A) Some Worksheets and General Variables Info
    Dim Ws As Worksheet           '_-Dim: Prepares "Pointer" to a "Blue Print" (or Form, Questionaire not yet filled in, a template etc.)"Pigeon Hole" in Memory, sufficient in construction to house a piece of Paper with code text giving the relevant information for the particular Variable Type. VBA is sent to it when it passes it. In a Routine it may be given a particular "Value", or ("Values" for Objects).  There instructions say then how to do that and handle(store) that(those). At Dim the created Paper is like a Blue Print that has some empty spaces not yet filled in. A String is a a bit tricky. The Blue Print code line Paper in the Pigeon Hole will allow to note the string Length and an Initial start memory Location. This Location well have to change frequently as strings of different length are assigned. Instructiions will tell how to do this. Theoretically a specilal value vbNullString is set to aid in quich checks.. But..http://www.mrexcel.com/forum/excel-questions/361246-vbnullstring-2.html#post4411
     Set Ws = ThisWorkbook.Worksheets.Item(1) 'Worksheets("EFFldr") 'CHANGE TO SUIT YOUR WORKSHEET    '_- Set: Fill or partially Fill: Setting to a Class will involve the use of an extra New at this code line. I will then have an Object referred to as an instance of a Class. At this point I include information on my Pointer Pigeon hole for a distinct distinguishable usage of an Object of the Class. For the case of something such as a Workbook this instancing has already been done, and in addition some values are filled in specific memory locations which are also held as part of the information in the Pigeon Hole Pointer. We will have a different Pointer for each instance. In most excel versions we already have a few instances of Worksheets. Such instances Objects can be further used., - For this a Dim to the class will be necessary, but the New must be omitted at Set. I can assign as many variables that I wish to the same existing instance
     Ws.Range("B3:F30").ClearContents ' This line only needed for demo code
    Dim celTL As Range: Set celTL = Ws.Range("B3") 'Top left of where Listing should go
    Rem 2A) Get Folder Info
    Dim strWB As String ' "Pointer" to a "Blue Print" (or Form, Questionaire not yet filled in, a template etc.)"Pigeon Hole" in Memory, sufficient in construction to house a piece of Paper with code text giving the relevant information for the particular Variable Type. VBA is sent to it when it passes it. In a Routine it may be given a particular "Value", or ("Values" for Objects).  There instructions say then how to do that and handle(store) that(those). At Dim the created Paper is like a Blue Print that has some empty spaces not yet filled in. A String is a a bit tricky. The Blue Print code line Paper in the Pigeon Hole will allow to note the string Length and an Initial start memory Location. This Location well have to change frequently as strings of different length are assigned. Instructiions will tell how to do this. Theoretically a specilal value vbNullString is set to aid in quich checks.. But..http://www.mrexcel.com/forum/excel-questions/361246-vbnullstring-2.html#post44116
     Let strWB = ThisWorkbook.Path & "\" & "EileensFldr" ' 'CHANGE TO SUIT if you store the main Folder to be looked through somewhere other than in the same Folder as this workbook in which the codes are in
    Rem 3A ) ' FileSystemObject Object
    Dim FSO As Object: Set FSO = CreateObject("Scripting.FileSystemObject") 'Late Binding
    'Dim FSO As Scripting.FileSystemObject 'Early Binding alternative  activate a reference to the Microsoft Scripting Runtime Library ( MSRL ) in the Tools References menu of VB Editor Options.
    'Set FSO = New Scripting.FileSystemObject 'Create an Instance of the Class Scripting FileSystemObject
    Dim myFolder As Object 'An Object from myFolder, can be an declared as Dim myFolder As Folder also for Early Binding
    Set myFolder = FSO.GetFolder(strWB) 'Set the selected Folder to the Object Folder using this Method which takes as arbument the Full String Path
    Rem 4A )
    Dim rCnt As Long: Let rCnt = 1: Dim CopyNumber1 As Long: Let CopyNumber1 = 1 '"Run progressin ( "down vertical" ) axis ( Row count for output ), "Down Folder chain to the right", The Count of the Copy of the called Procedue, here set to 1 for the first called copy of the second routine, which is done from this Sub( )  . Any subsequent calls of further second routine copies will be made by the current copy as it "freezes" and sets of that next copy
    celTL.Value = myFolder.Path: celTL.Offset(0, 1).Value = myFolder.Name: Ws.Columns("A:C").AutoFit 'First output Row
    '( -- Rem 5A) )
    Call LoopThroughEachFolderAndItsFile(myFolder, celTL, rCnt, CopyNumber1) 'Up until now we just got the initial Folder. Now we go to all sub folders  then all subfolders   then all subfolders.......
    ' let Application.ScreenUpdating = True ' If this had been set to False earlier towards the start, as is often done, then the code might run a bit quicker by virtue of not updating the worksheet everytime an entry is made, but it is not really nacerssary unless the number of Files and Folders is massive. Even then it is probably better not to do that so that in the case of an error one has an additional way in the worksheet to see where the code stopped / errored
    MsgBox "All Excel Files processed", vbInformation
    Ws.Columns("A:H").AutoFit
    End Sub
    'Rem 5A) --

    _........

    _._________________

    Second code. Recursion routine

    Code:
    'Rem 5A) --
    Sub VBALoopThroughEachFolderAndItsFile(ByVal fldFldr As Object, ByRef celTL As Range, ByRef rCnt As Long, ByVal CopyNumberFroNxtLvl As Long)  'In below function we have a nested loop to iterate each files also
    Dim myFldrs As Object ''This is used continuously as the "steering" thing, that is to say each Sub Folder in Folder loops, in loops, in loops......etc   ....can be Dim myFldrs As Folder for early bindingDim CopyNumber As Long 'equivalent to clmLvl in Rudis Q code
    Dim CopyNumber As Long 'equivalent to clmLvl in Rudis Q code
     Let CopyNumber = CopyNumberFroNxtLvl 'This variable is local to the current running or paused copy of this routine.
        '5Ab) Doing stuff for current Folder
        For Each myFldrs In fldFldr.SubFolders 'SubFolders collection used to get at all Sub Folders
        ''''''''Doing stuff for each Folder, .. in this example giving '_-
                '_- its full path including name :                 and just Flder Name                             ' -- *
         Let rCnt = rCnt + 1 + 1 ''At each folder we always move down a line, and a dd amm extra line  as a space between Folders ( The indication of the "column" or "down" to the right comes from the Copy Number of the Sub Procedure
         Let celTL.Cells(rCnt, 1).Value = myFldrs.Path: celTL.Cells(rCnt, CopyNumber).Offset(0, 2).Value = myFldrs.Name ' -- *                                            'Print out current Folder Path and Name in next free row.
        ''''''''End doing stuff for each Folder
        '5Ac) Doing stuff for current file.
        Dim oFile As Object '  ... for early binding can Dim oFile As file
                For Each oFile In myFldrs.Files 'Looking at all Files types initially '#####
                ''''''''Doing Stuff for Each File
        '            Dim Extension As String: Let Extension = Right(oFile.Name, (Len(oFile.Name) - (InStrRev(oFile.Name, ".")))) 'To get the bit just after the . dot.  #####
        '                If Left(Extension, 3) = "xls" Then 'Check for your required File Type    #####
                    Let rCnt = rCnt + 1
                    celTL.Cells(rCnt, CopyNumber).Offset(0, 2).Value = oFile.Name ' Do your stuff here
        '                Dim wkb As Workbook
                         On Error GoTo ErrHdlr 'In case problem opening file for example
        '                Set wkb = Workbooks.Open(oFile)
        '                wkb.Close SaveChanges:=True
        '                Else 'Do not do stuff for a Bad Extension                        ' #####
        '                End If '                                                         #####
                ''''''''End Doing Sttuff for Each File
    NxtoFile:   Next oFile ' Spring Point after error handler so as to go on to next File after the File action that errored
        Call LoopThroughEachFolderAndItsFile(myFldrs, celTL, rCnt, CopyNumber + 1) 'This is an example of recursion. It is actually very simple once you understand it. But it is just incredibly difficult to put in words. It is basically a Procedure that keeps calling itself as much as necessary as it goes "along",  "down", or "to the right" of the Path "roots". Every time it goes off calling itself VBA runs a copy of that Procedure. It "Stacks" all info carefully for each "Copy" Run and continues to do this "drilling" down as far as it must, in this case finding the Next Folder, and then the next Folder in that, then the next Folder in that, then the next Folder in that...I think you get the point! Each time VBA makes a copy of the Routine and you go into that. The calling Routine then "freezes at its current state and all variable keep there values. The "Frozen" Routine then re starts when the copy finishes
        Next
    Exit Sub 'Normal End for no Errors
    Rem 6 ) Error handler section just put here for convenience
    ErrHdlr: 'Hopefully we know why we are here, and after informing can continue ( to next file )
    MsgBox prompt:="Error " & Err.Description & " with File " & oFile & ""
    On Error GoTo -1 'This needs to be done to reset the VBA exceptional error state of being. Otherwise VBA "thinks" Errors are being handeled and will not respond again to the Error handler.
    On Error GoTo 0 ' Swiches off the current error handler. I do not really need to do this. But it is good practice so the error handler is only in place at the point where i next am expecting an error
    GoTo NxtoFile
    End Sub
    _..

    ( Codes are also in the first Worksheet Code module of this Workbook: ( '== ' Dec 2017 For Python Comparison. https://app.box.com/s/gfuintgifu1hgw5nap3jriz2x8mp911x ) )

  5. #5
    Fuhrer, Vierte Reich DocAElstein's Avatar
    Join Date
    Aug 2014
    Posts
    9,422
    Rep Power
    10

    Dumping Logs. Recurring Excample

    Dumping Logs for support of this Thread Post:
    http://www.excelfox.com/forum/showth...0476#post10476

    Test Function used to produce the Log below

    Code:
    'Going a HoldYaBackCalledYaBackClapTrapRuc - Copy number_GlobinalCntChopsLog - a few copies of this are made and run. (Recursion)
    '_-=Rem 4===================??? Got me hook lochprocedue in my code ,                5 times simple run then  another + 29 new copies of it are run  = 5+30=35 times  in total                     calling it it a few times  http://www.excelfox.com/forum/showthread.php/1324-Loop-Through-Files-In-A-Folder-Using-VBA#post10421   .... wanking myself up and down a few times
    Private Function HoldYaBackCalledYaBackClapTrapRuc(ByVal lMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long   '                                   ByVal CopyNumberFroNxtLvl As Long) As Long
                                Let GlobinalCntChopsLog = GlobinalCntChopsLog + 1: Debug.Print " Going a HoldYaBackCalledYaBackClapTrapRuc"; GlobinalCntChopsLog; "(1Msg"; lMsg; ", wParam"; wParam; ", lParam"; lParam; ") Function Copy Number_"; GlobinalCntChopsLog
                                'If GlobinalCntChopsLog = 2 Then Let GlobinalCntChopsLog = GlobinalCntChopsLog - 1: UnHookWindowsHookCodEx hHookTrapCrapNumber: Exit Function
        If lMsg = 5 Then '_-.... ( Hook type: HCBT_ACTIVATE = 5 but not here?) ... this runs a further 29 copies of HoldYaBackCalledYaBackClapTrap all coming here, so 30 times in total
                                Debug.Print "Expose Interface"; Tab(30); GlobinalCntChopsLog
         SetWindowPosition wParam, 0, poX, pussY, 400, 150, 40 '             SWP_NOZORDER is 4 ..  but not here?? 'SWP_NOSIZE + SWP_NOZORDER ' Pull the Chainge position ...
         UnHookWindowsHookCodEx hHookTrapCrapNumber         ' Release the Hook 30 times this is done
        Else
                                Debug.Print "No InterOfCourse"; Tab(30); GlobinalCntChopsLog; Tab(50); hHookTrapCrapNumber
        End If ' 5 times here then '_-....
                                Debug.Print "Wipe chain WRap"; Tab(30); GlobinalCntChopsLog; Tab(50); hHookTrapCrapNumber
        Let HoldYaBackCalledYaBackClapTrapRuc = 0 '  Done  5+30=35 times in total  '0 (or False) makes it work, all other numbers and I get no Message box
                                Let GlobinalCntChopsLog = GlobinalCntChopsLog - 1
    End Function ' HoldYaBackCalledYaBackClapTrapRuc


    Code:
    ---------------------------
    MutsNuts AkaApi working ApplicationPromptToRangeInputBox
    ---------------------------
    Select Range
    ---------------------------
    OK   
    ---------------------------
    
    WndNumber 66770    HandleWndOfMyParent 983700    hWndDskTop 66204    hHookTrapCrapNumber
    State of Much Such Penialtration's Number   HookCodeXcretion's
    ================== AliAs Pull of my chain   AliAs my long Hook
                                                                               0 
     Going a HoldYaBackCalledYaBackClapTrapRuc 1 (1Msg 3 , wParam 2623104 , lParam 2353392 ) Function Copy Number_ 1 
    No InterOfCourse              1                   276039693 
    Wipe chain WRap               1                   276039693 
     Going a HoldYaBackCalledYaBackClapTrapRuc 1 (1Msg 3 , wParam 1377832 , lParam 2353500 ) Function Copy Number_ 1 
    No InterOfCourse              1                   276039693 
    Wipe chain WRap               1                   276039693 
     Going a HoldYaBackCalledYaBackClapTrapRuc 1 (1Msg 3 , wParam 3934358 , lParam 2353500 ) Function Copy Number_ 1 
    No InterOfCourse              1                   276039693 
    Wipe chain WRap               1                   276039693 
     Going a HoldYaBackCalledYaBackClapTrapRuc 1 (1Msg 3 , wParam 984706 , lParam 2353480 ) Function Copy Number_ 1 
    No InterOfCourse              1                   276039693 
    Wipe chain WRap               1                   276039693 
     Going a HoldYaBackCalledYaBackClapTrapRuc 1 (1Msg 9 , wParam 3934358 , lParam 66766 ) Function Copy Number_ 1 
    No InterOfCourse              1                   276039693 
    Wipe chain WRap               1                   276039693 
     Going a HoldYaBackCalledYaBackClapTrapRuc 1 (1Msg 5 , wParam 2623104 , lParam 2353812 ) Function Copy Number_ 1 
    Expose Interface              1 
     Going a HoldYaBackCalledYaBackClapTrapRuc 2 (1Msg 5 , wParam 2623104 , lParam 2353500 ) Function Copy Number_ 2 
    Expose Interface              2 
     Going a HoldYaBackCalledYaBackClapTrapRuc 3 (1Msg 5 , wParam 2623104 , lParam 2353188 ) Function Copy Number_ 3 
    Expose Interface              3 
     Going a HoldYaBackCalledYaBackClapTrapRuc 4 (1Msg 5 , wParam 2623104 , lParam 2352876 ) Function Copy Number_ 4 
    Expose Interface              4 
     Going a HoldYaBackCalledYaBackClapTrapRuc 5 (1Msg 5 , wParam 2623104 , lParam 2352564 ) Function Copy Number_ 5 
    Expose Interface              5 
     Going a HoldYaBackCalledYaBackClapTrapRuc 6 (1Msg 5 , wParam 2623104 , lParam 2352252 ) Function Copy Number_ 6 
    Expose Interface              6 
     Going a HoldYaBackCalledYaBackClapTrapRuc 7 (1Msg 5 , wParam 2623104 , lParam 2351940 ) Function Copy Number_ 7 
    Expose Interface              7 
     Going a HoldYaBackCalledYaBackClapTrapRuc 8 (1Msg 5 , wParam 2623104 , lParam 2351628 ) Function Copy Number_ 8 
    Expose Interface              8 
     Going a HoldYaBackCalledYaBackClapTrapRuc 9 (1Msg 5 , wParam 2623104 , lParam 2351316 ) Function Copy Number_ 9 
    Expose Interface              9 
     Going a HoldYaBackCalledYaBackClapTrapRuc 10 (1Msg 5 , wParam 2623104 , lParam 2351004 ) Function Copy Number_ 10 
    Expose Interface              10 
     Going a HoldYaBackCalledYaBackClapTrapRuc 11 (1Msg 5 , wParam 2623104 , lParam 2350692 ) Function Copy Number_ 11 
    Expose Interface              11 
     Going a HoldYaBackCalledYaBackClapTrapRuc 12 (1Msg 5 , wParam 2623104 , lParam 2350380 ) Function Copy Number_ 12 
    Expose Interface              12 
     Going a HoldYaBackCalledYaBackClapTrapRuc 13 (1Msg 5 , wParam 2623104 , lParam 2350068 ) Function Copy Number_ 13 
    Expose Interface              13 
     Going a HoldYaBackCalledYaBackClapTrapRuc 14 (1Msg 5 , wParam 2623104 , lParam 2349756 ) Function Copy Number_ 14 
    Expose Interface              14 
     Going a HoldYaBackCalledYaBackClapTrapRuc 15 (1Msg 5 , wParam 2623104 , lParam 2349444 ) Function Copy Number_ 15 
    Expose Interface              15 
     Going a HoldYaBackCalledYaBackClapTrapRuc 16 (1Msg 5 , wParam 2623104 , lParam 2349132 ) Function Copy Number_ 16 
    Expose Interface              16 
     Going a HoldYaBackCalledYaBackClapTrapRuc 17 (1Msg 5 , wParam 2623104 , lParam 2348820 ) Function Copy Number_ 17 
    Expose Interface              17 
     Going a HoldYaBackCalledYaBackClapTrapRuc 18 (1Msg 5 , wParam 2623104 , lParam 2348508 ) Function Copy Number_ 18 
    Expose Interface              18 
     Going a HoldYaBackCalledYaBackClapTrapRuc 19 (1Msg 5 , wParam 2623104 , lParam 2348196 ) Function Copy Number_ 19 
    Expose Interface              19 
     Going a HoldYaBackCalledYaBackClapTrapRuc 20 (1Msg 5 , wParam 2623104 , lParam 2347884 ) Function Copy Number_ 20 
    Expose Interface              20 
     Going a HoldYaBackCalledYaBackClapTrapRuc 21 (1Msg 5 , wParam 2623104 , lParam 2347572 ) Function Copy Number_ 21 
    Expose Interface              21 
     Going a HoldYaBackCalledYaBackClapTrapRuc 22 (1Msg 5 , wParam 2623104 , lParam 2347260 ) Function Copy Number_ 22 
    Expose Interface              22 
     Going a HoldYaBackCalledYaBackClapTrapRuc 23 (1Msg 5 , wParam 2623104 , lParam 2346948 ) Function Copy Number_ 23 
    Expose Interface              23 
     Going a HoldYaBackCalledYaBackClapTrapRuc 24 (1Msg 5 , wParam 2623104 , lParam 2346636 ) Function Copy Number_ 24 
    Expose Interface              24 
     Going a HoldYaBackCalledYaBackClapTrapRuc 25 (1Msg 5 , wParam 2623104 , lParam 2346324 ) Function Copy Number_ 25 
    Expose Interface              25 
     Going a HoldYaBackCalledYaBackClapTrapRuc 26 (1Msg 5 , wParam 2623104 , lParam 2346012 ) Function Copy Number_ 26 
    Expose Interface              26 
     Going a HoldYaBackCalledYaBackClapTrapRuc 27 (1Msg 5 , wParam 2623104 , lParam 2345700 ) Function Copy Number_ 27 
    Expose Interface              27 
     Going a HoldYaBackCalledYaBackClapTrapRuc 28 (1Msg 5 , wParam 2623104 , lParam 2345388 ) Function Copy Number_ 28 
    Expose Interface              28 
     Going a HoldYaBackCalledYaBackClapTrapRuc 29 (1Msg 5 , wParam 2623104 , lParam 2345076 ) Function Copy Number_ 29 
    Expose Interface              29 
     Going a HoldYaBackCalledYaBackClapTrapRuc 30 (1Msg 5 , wParam 2623104 , lParam 2344764 ) Function Copy Number_ 30 
    Expose Interface              30 
    Wipe chain WRap               30                  276039693 
    Wipe chain WRap               29                  276039693 
    Wipe chain WRap               28                  276039693 
    Wipe chain WRap               27                  276039693 
    Wipe chain WRap               26                  276039693 
    Wipe chain WRap               25                  276039693 
    Wipe chain WRap               24                  276039693 
    Wipe chain WRap               23                  276039693 
    Wipe chain WRap               22                  276039693 
    Wipe chain WRap               21                  276039693 
    Wipe chain WRap               20                  276039693 
    Wipe chain WRap               19                  276039693 
    Wipe chain WRap               18                  276039693 
    Wipe chain WRap               17                  276039693 
    Wipe chain WRap               16                  276039693 
    Wipe chain WRap               15                  276039693 
    Wipe chain WRap               14                  276039693 
    Wipe chain WRap               13                  276039693 
    Wipe chain WRap               12                  276039693 
    Wipe chain WRap               11                  276039693 
    Wipe chain WRap               10                  276039693 
    Wipe chain WRap               9                   276039693 
    Wipe chain WRap               8                   276039693 
    Wipe chain WRap               7                   276039693 
    Wipe chain WRap               6                   276039693 
    Wipe chain WRap               5                   276039693 
    Wipe chain WRap               4                   276039693 
    Wipe chain WRap               3                   276039693 
    Wipe chain WRap               2                   276039693 
    Wipe chain WRap               1                   276039693
    _-.__________________________________

    Windows Handleing Info:
    Code:
    ' 1b)        To hang in the Excel Window malking it effectively a Excel Msgbox... Normally if I did not do this  ... don't do this .. that is to say leave it at 0 , specifically no window is 0 , and it "hanging in mid air so isn't even if it is   imaginatively speaking
    Public Declare Function FindWndNumber Lib "user32" Alias "FindWindowA" (Optional ByVal lpClassName As String, Optional ByVal lpWindowName As String) As Long
    Dim HandleWndOfMyParent As Long      ' I wanted to comment  this  1b)(i) and ( 1b(ii) later )   out to leave it hanging in mid air in a virtual  inadvirtual not thereness  ... but somehow this complicated hook stuff does hang it somwhere but not in my Excel Window                                                                                                            but I don't know what my parent's fart has to do with anything
    ' 1d)        For some Misc experiments
    Private Declare Function FindWindowExtremeNutty Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
    Dim WndNumber As Long, hWndDskTop As Long
    Code:
    Sub AkaApiApplicationPromptToRangeInputBox()  ' This one works.. but HTF
            ' 1b(ii)  This section is some how over written in / by the section part or some strange Addressing of HoldYaBackCalledYaBackClapTrap
             Let WndNumber = FindWndNumber(lpClassName:=vbNullString, lpWindowName:=vbNullString)
             Let HandleWndOfMyParent = FindWndNumber(lpClassName:="XLMAIN", lpWindowName:=vbNullString) ' This is a case where vbNullstring is important - that signifies that I am not giving it, which i do not have to. The second option is a bit flaky and does not often work. it certainly won't work if you make it "" as that is a specific string of zero.  Null  is a special idea in computing of not set yet / not defined - that is required if I do not want to give it
            ' 1d) Just some experiments, I forgot why as my brain has goine comfortably numb
             Dim HeavyWindBreak As Long: Let HeavyWindBreak = HandleWndOfMyParent
             Let hWndDskTop = FindWindowExtremeNutty(HandleWndOfMyParent, 0&, "XLDESK", vbNullString)
                                Debug.Print "WndNumber"; WndNumber; "   HandleWndOfMyParent"; HandleWndOfMyParent; "   hWndDskTop"; hWndDskTop; "   hHookTrapCrapNumber"
    Rem 3                                   Mess with me hook? God knows what this all does and it seems to make no difference if the proXYs poX or pussY are before or after SetWindowsHooksExample
    ….If you are my competitor, I will try all I can to beat you. But if I do, I will not belittle you. I will Salute you, because without you, I am nothing.
    If you are my enemy, we will try to kick the fucking shit out of you…..
    Winston Churchill, 1939
    Save your Forum..._
    _...KILL A MODERATOR!!

  6. #6
    Fuhrer, Vierte Reich DocAElstein's Avatar
    Join Date
    Aug 2014
    Posts
    9,422
    Rep Power
    10
    Per PM request: One full working example of above code:

    Code:
    Option Explicit
    Rem 1 ' This I understand. it is a simple more basic version of the VBA Message Box Function                                       http://www.eileenslounge.com/viewtopic.php?f=18&t=28885#p223629
    ' 1a)          UnWRap it and..
    Private Declare Function APIssinUserDLL_MsgBox Lib "user32" Alias "MessageBoxA" (Optional ByVal HowManyFartsCanYouHandle As Long, Optional ByVal Prompt As String, Optional ByVal Title As String, Optional ByVal buttons As Long) As Long '
    ' 1b)        To hang in the Excel Window malking it effectively a Excel Msgbox... Normally if I did not do this  ... don't do this .. that is to say leave it at 0 , specifically no window is 0 , and it "hanging in mid air so isn't even if it is   imaginatively speaking
    Public Declare Function FindWndNumber Lib "user32" Alias "FindWindowA" (Optional ByVal lpClassName As String, Optional ByVal lpWindowName As String) As Long
    Dim HandleWndOfMyParent As Long      ' I wanted to comment  this  1b)(i) and ( 1b(ii) later )   out to leave it hanging in mid air in a virtual  inadvirtual not thereness  ... but somehow this complicated hook stuff does hang it somwhere but not in my Excel Window                                                                                                            but I don't know what my parent's fart has to do with anything
    ' 1d)        For some Misc experiments
    Private Declare Function FindWindowExtremeNutty Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
    Dim WndNumber As Long, hWndDskTop As Long
    Dim Booloks As Boolean
    '_-_._______________________________________________-
    '_-=================??? main Declarations that I don't really understand
    Rem 2 Position my box --- From here on I do not really have a clue
    ' 2(a)                                        This will tie something on the chain for when you pull it                                                                                                      https://msdn.microsoft.com/en-us/library/windows/desktop/ms644990(v=vs.85).aspx
    Private Declare Function SetWindowsHooksExample Lib "user32" Alias "SetWindowsHookExA" (ByVal Hooktype As Long, ByVal lokprocedureAddress As Long, Optional ByVal hmod As Long, Optional ByVal dwThreadId As Long) As Long
    ' 2(b)                                        Wipe the chain clean
    Private Declare Function UnHookWindowsHookCodEx Lib "user32" Alias "UnhookWindowsHookEx" (ByVal hHookTrapCrapNumber As Long) As Long
    ' 2(c)                                        Don't loose the Thread? - This seems to have no effect , - maybe it would if something else was going on at the time. You don't want to loose the Thread I guess
    'Public Declare Function GetCurrentThreadId Lib "kernel32" () As Long ' Effectively long Null acttuall not ?? -
    Public Declare Function GetCurrentFredId Lib "kernel32" Alias "GetCurrentThreadId" () As Long ' Effectively long Null acttuall not ?? -
    ' 2(d)                                        This looks understandable almost, z(0 for top), posLeft, posTop, x pixels, y pixels,
    Private Declare Function SetWindowPosition Lib "user32" Alias "SetWindowPos" (ByVal hWnd As Long, ByVal zNumber As Long, ByVal CoedX As Long, ByVal CoedY As Long, ByVal xPiXel As Long, ByVal yPiYel As Long, ByVal wFlags As Long) As Long
    ' 2e)
    Private hHookTrapCrapNumber As Long                         ' Handle to the Hook procedure
    ' 2f)
    Private poX As Long: Private pussY As Long    ' Positional By proXYs
                                Dim GlobinalCntChopsLog As Long   ' Only used in this test code to keep track of the copies of a Function(HoldYaBackCalledYaBackClapTrap) used in a recursion process
    ' 2g) bits to do with 1 that i am resonably happy with
    Sub AkaApiApplicationPromptToRangeInputBox()  ' This one works.. but HTF
            ' 1b(ii)  This section is some how over written in / by the section part or some strange Addressing of HoldYaBackCalledYaBackClapTrap
             Let WndNumber = FindWndNumber(lpClassName:=vbNullString, lpWindowName:=vbNullString)
             Let HandleWndOfMyParent = FindWndNumber(lpClassName:="XLMAIN", lpWindowName:=vbNullString) ' This is a case where vbNullstring is important - that signifies that I am not giving it, which i do not have to. The second option is a bit flaky and does not often work. it certainly won't work if you make it "" as that is a specific string of zero.  Null  is a special idea in computing of not set yet / not defined - that is required if I do not want to give it
            ' 1d) Just some experiments, I forgot why as my brain has goine comfortably numb
             Dim HeavyWindBreak As Long: Let HeavyWindBreak = HandleWndOfMyParent
             Let hWndDskTop = FindWindowExtremeNutty(HandleWndOfMyParent, 0&, "XLDESK", vbNullString)
                                Debug.Print "WndNumber"; WndNumber; "   HandleWndOfMyParent"; HandleWndOfMyParent; "   hWndDskTop"; hWndDskTop; "   hHookTrapCrapNumber"
    Rem 3                                   Mess with me hook? God knows what this all does and it seems to make no difference if the proXYs poX or pussY are before or after SetWindowsHooksExample
                                Debug.Print "State of Much Such"; Tab(20); "Penialtration's Number"; Tab(45); "HookCodeXcretion's"
                                Debug.Print "=================="; Tab(20); "AliAs Pull of my chain"; Tab(45); "AliAs my long Hook"
                                Let GlobinalCntChopsLog = 0:
    '_-======================== Weird thing with an AddressOf ???
    Let poX = 10: pussY = 50 ' These can go before or after the next line, makes no diffference.. -                                                    I bet no Pro noticed that...
    'Let hHookTrapCrapNumber = SetWindowsHooksExample(5, AddressOf HoldYaBackCalledYaBackClapTrap, 0, GetCurrentThreadId)   ' (5-pull before flush,  somehow arranges that the function gets called  ,
                                Debug.Print ; Tab(75); hHookTrapCrapNumber '                                                                                           'APIssinUserDLL_MsgBox HeavyWindBreak, "Excel MsgBox", "This is Center Position", vbOKOnly ' This breaks Wnd in Excel Window
     Call HookAPIssinUserDLL_MsgBoxThenDropIt
     'APIssinUserDLL_MsgBox &H0, "Select Range", "MutsNuts AkaApi working ApplicationPromptToRangeInputBox", vbOKOnly ' Pseudo Non Modal
     'APIssinUserDLL_MsgBox &H0, "Select Range", "MutsNuts AkaApi working ApplicationPromptToRangeInputBox", vbOKOnly ' Pseudo Non Modal
     'HookAPIssinUserDLL_MsgBoxThenDropIt
                                                                                                              
                                                                                                              Dim Rng As Range: Set Rng = Selection
    ' (Optional ByVal hwnd As Long, Optional ByVal Prompt As String, Optional ByVal Title As String, Optional ByVal buttons As Long) As Long '
    End Sub ' AkaApiApplicationPromptToRangeInputBox
    Sub HookAPIssinUserDLL_MsgBoxThenDropIt()
    Code:
    Sub HookAPIssinUserDLL_MsgBoxThenDropIt()
    ' a) HOOK Hook the pseudo Windows Sub Class Function WinSubWinCls_JerkBackOffHooKerd
    Dim BookMarkClassTeachMeWind As Long: Let BookMarkClassTeachMeWind = 5
     'Let hHookTrapCrapNumber = SetWindowsHooksExample(BookMarkClassTeachMeWind, AddressOf HoldYaBackCalledYaBackClapTraped, 0, GetCurrentThreadId)   ' (5-pull before flush,  somehow arranges that the function gets called  ,
     'Let hHookTrapCrapNumber = SetWindowsHooksExample(BookMarkClassTeachMeWind, AddressOf HoldYaBackCalledYaBackClapTrapRuc, 0, GetCurrentThreadId)   ' (5-pull before flush,  somehow arranges that the function gets called  ,
     Let hHookTrapCrapNumber = SetWindowsHooksExample(BookMarkClassTeachMeWind, AddressOf HoldYaBackCalledYaBackClapTrapRuc, 0, GetCurrentFredId)   ' (5-pull before flush,  somehow arranges that the function gets called  ,
    ' b) Call the MessageBoxA
     APIssinUserDLL_MsgBox &H0, "Select Range", "MutsNuts AkaApi working ApplicationPromptToRangeInputBox", vbOKOnly ' Pseudo Non Modal
    End Sub
    '_-=Rem 4===================??? Got me hook lochprocedue in my code ,                5 times simple run then  another + 29 new copies of it are run  = 6+29=35 times  in total                     calling it it a few times  http://www.excelfox.com/forum/showthread.php/1324-Loop-Through-Files-In-A-Folder-Using-VBA#post10421   .... wanking myself up and down a few times
    Code:
    '_-=Rem 4===================??? Got me hook lochprocedue in my code ,                5 times simple run then  another + 29 new copies of it are run  = 5+30=35 times  in total                     calling it it a few times  http://www.excelfox.com/forum/showthread.php/1324-Loop-Through-Files-In-A-Folder-Using-VBA#post10421   .... wanking myself up and down a few times
    Private Function HoldYaBackCalledYaBackClapTrapRuc(ByVal lMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long   '                                   ByVal CopyNumberFroNxtLvl As Long) As Long
                                Let GlobinalCntChopsLog = GlobinalCntChopsLog + 1: Debug.Print " Going a HoldYaBackCalledYaBackClapTrapRuc"; GlobinalCntChopsLog; "(1Msg"; lMsg; ", wParam"; wParam; ", lParam"; lParam; ") Function Copy Number_"; GlobinalCntChopsLog
                                'If GlobinalCntChopsLog = 2 Then Let GlobinalCntChopsLog = GlobinalCntChopsLog - 1: UnHookWindowsHookCodEx hHookTrapCrapNumber: Exit Function
        If lMsg = 5 Then '_-.... ( Hook type: HCBT_ACTIVATE = 5 but not here?) ... this runs a further 29 copies of HoldYaBackCalledYaBackClapTrap all coming here, so 30 times in total
                                Debug.Print "Expose Interface"; Tab(30); GlobinalCntChopsLog
         Call SetWindowPosition(wParam, 0, poX, pussY, 400, 150, 40) '             SWP_NOZORDER is 4 ..  but not here?? 'SWP_NOSIZE + SWP_NOZORDER ' Pull the Chainge position ...
         UnHookWindowsHookCodEx hHookTrapCrapNumber         ' Release the Hook 30 times this is done
        Else
                                Debug.Print "No InterOfCourse"; Tab(30); GlobinalCntChopsLog; Tab(50); hHookTrapCrapNumber
        End If ' 5 times here then '_-....
                                Debug.Print "Wipe chain WRap"; Tab(30); GlobinalCntChopsLog; Tab(50); hHookTrapCrapNumber
        Let HoldYaBackCalledYaBackClapTrapRuc = 0 '  Done  5+30=35 times in total  '0 (or False) makes it work, all other numbers and I get no Message box
                                Let GlobinalCntChopsLog = GlobinalCntChopsLog - 1
    End Function ' HoldYaBackCalledYaBackClapTrapRuc
    ….If you are my competitor, I will try all I can to beat you. But if I do, I will not belittle you. I will Salute you, because without you, I am nothing.
    If you are my enemy, we will try to kick the fucking shit out of you…..
    Winston Churchill, 1939
    Save your Forum..._
    _...KILL A MODERATOR!!

  7. #7
    Fuhrer, Vierte Reich DocAElstein's Avatar
    Join Date
    Aug 2014
    Posts
    9,422
    Rep Power
    10

    Function CStrSepDbl Excel VBA comma point thousand decimal separator number problem

    Code for this Thread:
    http://www.excelfox.com/forum/showth...0503#post10503
    http://www.excelfox.com/forum/forumd...ips-and-Tricks


    Function CStrSepDbl
    Code:
    '10   '   http://www.eileenslounge.com/viewtopic.php?f=27&t=22850#p208624
    Function CStrSepDbl(Optional ByVal strNumber As String) As Double '    Return a Double based on a String Input which is asssumed to "Look" like a Number. The code will work for Leading and Trailing zeros, but will not return them. )
    20   Rem 0        At the Dim stage  a  '_-String  is "Pointer" to a "Blue Print" (or Form, Questionaire not yet filled in, a template etc.)"Pigeon Hole" in Memory, sufficient in construction to house a piece of Paper with code text giving the relevant information for the particular Variable Type. VBA is sent to it when it passes it. In a Routine it may be given a particular “Value”, or (“Values” for Objects).  There instructions say then how to do that and handle(store) that(those). At Dim the created Paper is like a Blue Print that has some empty spaces not yet filled in. A String is a bit tricky. The Blue Print code line Paper in the Pigeon Hole will allow to note the string Length and an Initial start memory Location. This Location well have to change frequently as strings of different length are assigned. Instructiions will tell how to do this. Theoretically a specilal value vbNullString is set to aid in quich checks, But http://www.mrexcel.com/forum/excel-questions/361246-vbnullstring-2.html#post44116
    30     If StrPtr(strNumber) = 0 Then Let CStrSepDbl = "9999999999": Exit Function '_- StrPtr(MyVaraibleNotYetUsed)=0 ..  http://www.excelfox.com/forum/showthread.php/1828-How-To-React-To-The-Cancel-Button-in-a-VB-(not-Application)-InputBox?p=10463#post10463       https://www.mrexcel.com/forum/excel-questions/35206-test-inputbox-cancel-2.html?highlight=strptr#post2845398    https://www.mrexcel.com/forum/excel-questions/917689-passing-array-class-byval-byref.html#post4412382
    40   Rem 1  'Adding a leading zero if no number before a comma or point, change all seperators to comma  ,
    50     If VBA.Strings.Left$(strNumber, 1) = "," Or VBA.Strings.Left$(strNumber, 1) = "." Then Let strNumber = "0" & strNumber  ' case for like .12  or ,7   etc 'VBA Strings collection Left function returns a Variant- initially tries to coerces the first parameter into Variant, Left$ does not, that's why Left$ is preferable over Left, it's theoretically slightly more efficient, as it avoids the overhead/inefficieny associated with the Variant. It allows a Null to be returned if a Null is given. https://www.excelforum.com/excel-new...ml#post4084816 .. it is all to do with ya .."Null propagation".. maties ;) '_-.. http://allenbrowne.com/casu-12.html Null is a special "I do not know, / answer unknown" - handy to hav... propogetion wonks - math things like = 1+2+Null returns you null. Or string manipulation stuff like, left(Null returns you Null. Count things like Cnt (x,y,Null) will return 2 - there are two known things there..Hmm -bit iffy although you could argue that Null has not been entered yet..may never
    60     If VBA.Strings.Left$(strNumber, 2) = "-," Or VBA.Strings.Left$(strNumber, 2) = "-." Then Let strNumber = Application.WorksheetFunction.Replace(strNumber, 1, 1, "-0") ' case for like  -.12  or -,274   etc
    70    Let strNumber = Replace(strNumber, ".", ",", 1, -1, vbBinaryCompare) 'Replace at start any . to a ,  After this point there should be either no or any amount of ,
    80     'Check If a Seperator is present, then MAIN CODE is done
    90     If InStr(1, strNumber, ",") > 0 Then 'Check we have at least one seperator, case we have, then..
    100  Rem 2 'MAIN CODE part ====
    110    'Length of String:  Position of last ( Decimal ) Seperator
    120    Dim LenstrNumber As Long: Let LenstrNumber = Len(strNumber): Dim posDecSep As Long: Let posDecSep = VBA.Strings.InStrRev(strNumber, ",", LenstrNumber) '  from right the positom "along" from left  (   (in strNumber)  ,  for a  (",")    ,   starting at the ( Last character ) which BTW. is the default
    130    'Whole Number Part
    140    Dim strHlNumber As String: Let strHlNumber = VBA.Strings.Left$(strNumber, (posDecSep - 1))
    150     Let strHlNumber = Replace(strHlNumber, ",", Empty, 1, -1) 'In (strHlNumber)   ,   I look for a (",")   ,    and replace it with "VBA Nothing there"    ,     considering and returning the strNumber from  the start of the string    ,     and replace all occurances ( -1 ).
    160    Dim HlNumber As Long: Let HlNumber = CLng(strHlNumber) 'Long Number is a Whole Number, no fractional Part
    170    'Fraction Part of Number
    180    Dim strFrction As String: Let strFrction = VBA.Strings.Mid$(strNumber, (posDecSep + 1), (LenstrNumber - posDecSep)) 'Part of string (strNumber )  ,  starting from just after Decimal separator  ,    and extending to a length of = ( the length  of the whole strNumber minus  the position of the separator )
    190    Dim LenstrFrction As Long: Let LenstrFrction = Len(strFrction) 'Digits after Seperator. This must be done at the String Stage, as length of Long, Double etc will allways be 8, I think?.
    200    Dim Frction As Double: Let Frction = CDbl(strFrction) 'This will convert to a Whole Double Number. Double Number can have  Fractional part
    210     Let Frction = Frction * 1 / (10 ^ (LenstrFrction)) 'Use 1/___, rather than a x 0.1 or 0,1 so as not to add another , . uncertainty!!
    220    'Re join, using Maths to hopefully get correct Final Value
    230    Dim DblReturn As Double 'Double Number to be returned in required Format after maniplulation.
    240         If Left(strHlNumber, 1) <> "-" Then 'Case positive number
    250          Let DblReturn = CDbl(HlNumber) + Frction 'Hopefully a simple Mathematics + will give the correct Double Number back
    260         Else 'Case -ve Number
    270          Let strHlNumber = Replace(strHlNumber, "-", "", 1, 1, vbBinaryCompare) ' strHlNumber * (-1) ' "Remove" -ve sign
    280          Let DblReturn = (-1) * (CDbl(strHlNumber) + Frction) 'having constructed the value of the final Number we multiply by -1 to put the Minus sign back
    290         End If 'End checking polarity.
    300    'Final Code Line(s)   At this point we have what we want. We need to place this in the "Double Type variable" , CStrSepDbl , so that an assinment like    = CStrSepDbl( ) will return this final value
    310     Let CStrSepDbl = DblReturn 'Final Double value to be returned by Function
    320    Else 'End MAIN CODE. === We came here if we have a Whole Number with no seperator, case no seperator
    330    'Simple conversion of a string "Number" with no Decimal Seperator to Double Format
    340     Let CStrSepDbl = CDbl(strNumber) 'String to be returned by Function is here just a simple convert to Double ' I guess this will convert a zero length string "" to 0 also
    350    End If 'End checking for if a Seperator is present.
    End Function
    
    
    
    
    
    
    
    
    
    
    
    
    
    
    
    
    
    
    
    
    
    
    
    
    'Long code lines:  Referrences    http://www.mrexcel.com/forum/about-board/830361-board-wish-list-2.html          http://www.mrexcel.com/forum/test-here/928092-http://www.eileenslounge.com/viewtopic.php?f=27&t=22850
    Function CStrSepDblshg(strNumber As String) As Double '          http://excelxor.com/2014/09/05/index-returning-an-array-of-values/      http://www.techonthenet.com/excel/formulas/split.php
    5      If Left(strNumber, 1) = "," Or Left(strNumber, 1) = "." Then Let strNumber = "0" & strNumber
    20   Let strNumber = Replace(strNumber, ".", ",", 1, -1)
    40     If InStr(1, strNumber, ",") > 0 Then
    170         If Left(Replace(Left(strNumber, (InStrRev(strNumber, ",", Len(strNumber)) - 1)), ",", Empty, 1, 1), 1) <> "-" Then
    180          Let CStrSepDblshg = CDbl(CLng(Replace(Left(strNumber, (InStrRev(strNumber, ",", Len(strNumber)) - 1)), ",", Empty, 1, 1))) + CDbl(Mid(strNumber, (InStrRev(strNumber, ",", Len(strNumber)) + 1), (Len(strNumber) - InStrRev(strNumber, ",", Len(strNumber))))) * 1 / (10 ^ (Len(Mid(strNumber, (InStrRev(strNumber, ",", Len(strNumber)) + 1), (Len(strNumber) - InStrRev(strNumber, ",", Len(strNumber)))))))
    190         Else
    210          Let CStrSepDblshg = (-1) * (CDbl(Replace(Left(strNumber, (InStrRev(strNumber, ",", Len(strNumber)) - 1)), ",", Empty, 1, 1) * (-1)) + CDbl(Mid(strNumber, (InStrRev(strNumber, ",", Len(strNumber)) + 1), (Len(strNumber) - InStrRev(strNumber, ",", Len(strNumber))))) * 1 / (10 ^ (Len(Mid(strNumber, (InStrRev(strNumber, ",", Len(strNumber)) + 1), (Len(strNumber) - InStrRev(strNumber, ",", Len(strNumber))))))))
    220         End If
    250    Else
    270     Let CStrSepDblshg = CDbl(strNumber)
    280    End If
    End Function
    Demo Code to call Function
    Code:
    Sub TestieCStrSepDbl() ' using adeptly named  TabulatorSyncranartor ' / Introducing LSet TabulatorSyncranartor Statement :   http://www.excelfox.com/forum/showthread.php/2230-Built-in-VBA-methods-and-functions-to-alter-the-contents-of-existing-character-strings
    Dim LooksLikeANumber(1 To 17) As String
     Let LooksLikeANumber(1) = "001,456"
     Let LooksLikeANumber(2) = "1.0007"
     Let LooksLikeANumber(3) = "123,456.2"
     Let LooksLikeANumber(4) = "0023.345,0"
     Let LooksLikeANumber(5) = "-0023.345,0"
     Let LooksLikeANumber(6) = "1.007"
     Let LooksLikeANumber(7) = "1.3456"
     Let LooksLikeANumber(8) = "1,2345"
     Let LooksLikeANumber(9) = "01,0700000"
     Let LooksLikeANumber(10) = "1.3456"
     Let LooksLikeANumber(11) = "1,2345"
     Let LooksLikeANumber(12) = ".2345"
     Let LooksLikeANumber(13) = ",4567"
     Let LooksLikeANumber(14) = "-,340"
     Let LooksLikeANumber(15) = "00.04"
     Let LooksLikeANumber(16) = "-0,56000000"
     Let LooksLikeANumber(17) = "-,56000001"
    Dim Stear As Variant, MyStringsOut As String
        For Each Stear In LooksLikeANumber()
        Dim Retn As Double
         Let Retn = CStrSepDbl(Stear)
        Dim TabulatorSyncranartor As String: Let TabulatorSyncranartor = "                         "
         LSet TabulatorSyncranartor = Stear
         Let MyStringsOut = MyStringsOut & TabulatorSyncranartor & Retn & vbCrLf
         Debug.Print Stear; Tab(15); Retn
        Next Stear
     MsgBox MyStringsOut
    End Sub



    Code also Here:
    https://pastebin.com/1kq6h9Bn
    ….If you are my competitor, I will try all I can to beat you. But if I do, I will not belittle you. I will Salute you, because without you, I am nothing.
    If you are my enemy, we will try to kick the fucking shit out of you…..
    Winston Churchill, 1939
    Save your Forum..._
    _...KILL A MODERATOR!!

  8. #8
    Fuhrer, Vierte Reich DocAElstein's Avatar
    Join Date
    Aug 2014
    Posts
    9,422
    Rep Power
    10
    Last edited by DocAElstein; 07-09-2023 at 10:41 PM.
    ….If you are my competitor, I will try all I can to beat you. But if I do, I will not belittle you. I will Salute you, because without you, I am nothing.
    If you are my enemy, we will try to kick the fucking shit out of you…..
    Winston Churchill, 1939
    Save your Forum..._
    _...KILL A MODERATOR!!

  9. #9
    Fuhrer, Vierte Reich DocAElstein's Avatar
    Join Date
    Aug 2014
    Posts
    9,422
    Rep Power
    10

    VBA to automate Send and Automatically Sending of E-Mai

    _1 ) Way 1) Use the CDO (Collaboration Data Objects ) object library available in VBA
    Main Code , Sub PetrasDailyProWay1_COM_Way() ,
    and
    Function Code for solution to this Thread and Post
    http://www.excelfox.com/forum/showth...kbooks-at-once
    http://www.excelfox.com/forum/showth...0518#post10518





    Code:
    Option Explicit ' Daily Diet plan, Sending of Notes and an Excel File
    Sub PetrasDailyProWay1_COM_Way() '  Allow access to deep down cods wollops from Microsoft to collaborating in particular in the form of messaging. An available library of ddl library functions and associated things is available on request, the  Microsoft CDO for Windows 2000. We require some of these '  CDO is an object library that exposes the interfaces of the Messaging Application Programming Interface (MAPI). API: interfaces that are fairly easy to use from a fairly higher level from within a higher level programming language. In other words this allows you to get at and use some of the stuff to do with the COM OLE Bollocks from within a programming language such as VBA  API is often referring loosely to do with using certain shipped with Windows software in Folders often having the extension dll. This extension , or rather the dll stands for direct link libraries. These are special sort of executable files of functions shared by many other (Windows based usually) software’s.
    ' Rem1 The deep down fundamental stuff , which includes stuff been there the longest goes by the name of Component Object Model. Stuff which is often, but not always, later stuff, or at a slightly higher level of the computer workings, or slightly more to a specific application ( an actual running "runtime" usage / at an instance in time , "instance of" ) orientated goes to the name of Object Linking and Embedding. At this lower level, there are protocols for communicating between things, and things relate are grouped into the  to Office  application available Library, CDO. An important object there goes by the name of Message.
    'Rem 1) Library made available            ====================#
      With CreateObject("CDO.Message") '   Folders mostly but not always are in some way referenced using dll, either as noted with the extension or maybe refered to as dll Files or dll API files.
    'Rem 2 ' Intraction protocols are given requird infomation and then set
        '2a) 'With --------------------* my Created LCDCW Library, (LCD 1.0 Library ) (Linking Configuration Data_Cods Wollups) which are used and items configured for the Exchange at Microsoft’s protocol thereof;   http://schemas.microsoft.com/cdo/configuration/ ......This section provides the configuration information for the remote SMTP server
        Dim LCD_CW As String: Let LCD_CW = "http://schemas.microsoft.com/cdo/configuration/" ' Linking Configuration Data : defines the majority of fields used to set configurations for various Linking Collaboration (LCD) Objects Cods Wollops: These configuration fields are set using an implementation of the IConfiguration.Fields collection.  https://msdn.microsoft.com/en-us/library/ms872853(v=exchg.65).aspx
         .Configuration(LCD_CW & "smtpusessl") = True ' ' ' HTTPS (Hyper Text Transfer Protocol Secure) appears in the URL when a website is secured by an SSL certificate. The details of the certificate, including the issuing authority and the corporate name of the website owner, can be viewed by clicking on the lock symbol on the browser bar. in short, it's the standard technology for keeping an internet connection secure and safeguarding any sensitive data that is being sent between two systems, preventing criminals from reading and modifying any information transferred, including potential personal details.  ' SSL protocol has always been used to encrypt and secure transmitted data
         .Configuration(LCD_CW & "smtpauthenticate") = 1  ' ... possibly this also needed ..   When you also get the Authentication Required Error you can add this three lines.
        '  ' Sever info
         .Configuration(LCD_CW & "smtpserver") = "smtp.gmail.com" ' "securesmtp.t-online.de"                 '"smtp.gmail.com" "smtp.mail.yahoo.com" "smtp.live.com" "pod51017.outlook.com"  "smtp-mail.outlook.com" "smtp.live.com"  "securesmtp.t-online.de"  465         SMTP is just used to mean the common stuff.....  Simple Mail Transport Protocol (SMTP) server is used to send outgoing e-mails. The SMTP server receives emails from your Mail program and sends them over the Internet to their destination.
        '  The mechanism to use to send messages.
         .Configuration(LCD_CW & "sendusing") = 2  '  Based on the LCD_OLE Data Base of type DBTYPE_I4
         .Configuration(LCD_CW & "smtpserverport") = 25 ' 465or25fort-online ' 465 'or 587 'or 25   ' The port of type somehow refered to by the last line
        '
         .Configuration(LCD_CW & "sendusername") = "excelvbaexp@gmail.com" ' "Doc.AElstein@t-online.de" ' .... "server rejected your response".  AFAIK : This will happen if you haven't setup an account in Outlook Express or Windows Mail .... Runtime error '-2147220975 (800440211)': The message could not be sent to the SMTP server. The transport error code is 0x80040217. The server response is not available
         .Configuration(LCD_CW & "sendpassword") = "Bollocks" '              "Bollox"
        ' Optional - How long to try     ( End remote SMTP server configuration section )
         .Configuration(LCD_CW & "smtpconnectiontimeout") = 30 '    Or there Abouts ;) :)
        ' Intraction protocol is Set/ Updated
         .Configuration.Fields.Update ' 'Not all infomation is given, some will have defaults. - possibly this might be needed initially ..    .Configuration.Load -1 ' CDO Source Defaults
        'End With ' -------------------* my Created  LCDCW Library ( Linking Configuration Data Cods Wollups)  which are  used and items configured for the Exchange at Microsoft's protocol therof;
       '2b) ' Data to be sent
       '.To = "Doc.AElstein@t-online.de"
       .To = "excelvbaexp@gmail.com"
       .CC = ""
       .BCC = ""
       .from = """Alan"" "
       .Subject = "Bollox"
       '.TextBody = "Hi" & vbNewLine & vbNewLine & "Please find the Excel workbook attached."
       .HTMLBody = MyLengthyStreaming
       .AddAttachment "G:\ALERMK2014Marz2016\NeueBlancoAb27.01.2014\AbJan2016\Übersicht aktuell.xlsx" ' ' Full File path and name. File must be closed
     Rem 3 Do it
       .Send
     End With ' CreateObject("CDO.Message") (Rem 1 Library End =======#
    End Sub
    Public Function MyLengthyStreaming() As String
    Rem 1 Make a long string from a Microsoft Word doc
    '1(i) makes available the Library of stuff, objects, Methods etc.
    Dim Fso As Object: Set Fso = CreateObject("Scripting.FileSystemObject")
    '1(ii) makes the big File Object                       " Full path and file name of Word doc saved as .htm       "
    Dim FileObject As Object: Set FileObject = Fso.GetFile("G:\ALERMK2014Marz2016\NeueBlancoAb27.01.2014\AbJan2016\ProMessage.htm"): Debug.Print FileObject
    '1(iii) sets up the data  "stream highway"
    Dim Textreme As Object:  Set Textreme = FileObject.OpenAsTextStream(iomode:=1, Format:=-2)        '   reading only, Opens using system default            https://msdn.microsoft.com/en-us/library/aa265341(v=vs.60).aspx
    '1(iv) pulls in the data, in our case into a simple string variable
     Let MyLengthyStreaming = Textreme.ReadAll         '        Let MyLengthyStreaming = Replace(MyLengthyStreaming, "align=center x:publishsource=", "align=left x:publishsource=")
     Textreme.Close
     Set Textreme = Nothing
     Set Fso = Nothing
    Rem 2 possible additions to MyLengthyStreaming
    Last bit of Function ( must go here in the excelfox Test Sub Forum in HTML Tags as there are HTML Tags in the final text string string and this makes a mess in normal BB code tags, because in excelfox Test Forum HTML is activated ) :
    HTML Code:
    Rem 2
     Let MyLengthyStreaming = "<p><span style=""color: #ff00ff;"">Start=========== " & Format(Now(), "DD MMMM YYYY") & " " & Now() & " ------------------------------------</span></p>" & MyLengthyStreaming & "<p><span style=""color: #ff00ff;"">-- " & Format(Now(), "DD MMMM YYYY") & " " & Now() & " ==End, Sent from Doc.AElstein Mail ======</span></p>"
    End Function
    ….If you are my competitor, I will try all I can to beat you. But if I do, I will not belittle you. I will Salute you, because without you, I am nothing.
    If you are my enemy, we will try to kick the fucking shit out of you…..
    Winston Churchill, 1939
    Save your Forum..._
    _...KILL A MODERATOR!!

  10. #10
    Fuhrer, Vierte Reich DocAElstein's Avatar
    Join Date
    Aug 2014
    Posts
    9,422
    Rep Power
    10
    Function Code for solution to this Thread and Post
    http://www.excelfox.com/forum/showth...0518#post10518




    HTML For CDO.Message.HTMLBody in VBA Emails sending

    Linked in my Binding Function, MyLenghtyString LBF_MLS
    In support of this Thread:
    http://www.excelfox.com/forum/showth...kbooks-at-once

    HTM / HTML is a very typical electronic message language recognised by most software devices associated with Email and similar.
    In two ways considered in this Thread , http://www.excelfox.com/forum/showth...0512#post10512 , the main Message Text body to be sent in an Email can be supplied as a single HTML code string.

    One convenient way to supply this is with a simple Word.doc file which can simply saved with a htm file extension
    Word doc to htm.JPG : https://imgur.com/vhRE9CC

    By opening this with a simple text editor, the actual text along with much more htm code detail can be revealed
    LastBitOfProMessage htm.JPG : https://imgur.com/mT6l40I
    LastBitOfProMessage htm 2.JPG : https://imgur.com/s0U8419

    This is the actual text required to be given after the an Email data filling code line like:
    _ .HTMLBody =

    The actual file held anywhere will likely include all sorts of computery stuff in addition to that text.
    We can get at just the text in several ways.
    A typical way in VBA is to make use of one of a number of Object Orientated stuff held in the Visual Basic FileSystemObject Object. This is in turn part of the Bundle in the available to application programs (such as Excel VBA) Library, Microsoft Scripting Runtime

    The way this works is as follows.
    For a given file, a large object can be made within the Microsoft Scripting Runtime Library Class type Module like Library, ** Polymorphically speaking.
    The Microsoft Scripting Runtime FileSystemObject Object GetFile method returns this object requiring only its full file path in order to “Get at it” . ( The returned object is pseudo in the streaming runtime instant direct compiling linking .Net technology held as a running link, ( indeed by assigning the object to, or using in an environment of, String will itself return that arguments string reference ) )
    **:From Microsoft documentation: Visual Basic provides polymorphism through multiple ActiveX interfaces. In the Component Object Model (COM) that forms the infrastructure of the ActiveX specification, multiple interfaces allow systems of software components to evolve and break existing code.
    In this sense interface is a set of related properties and methods. Much of the ActiveX specification is concerned with implementing standard interfaces to obtain system services or to provide malfunctionality to other programs.
    The actual processes involved are in the meantime so messed up that it is a wonder that anything still works, and I doubt it will be long before nothing does.
    The large FileObject in the Microsoft Scripting Runtime Library Class type Module like Library has information , amongst other things of neighbouring things , and as is typical in this mixed up messed up process , a short tem path or highway is made, and more often than not a “text stream object”, something like a continuous stream of data or like a highways going around in circles, and this will only be of a runtime existence, or at any rate should.. during this lifetime it can be “read”. I guess for any file of any type data within it will be recognised as such and can be handled in this simple text stream way.

    The original coding goes quite a way back and does not really fit in Object Orientated Visual basic hierarchical structure of the original implementation of File I/O in Visual Basic. But it does at lest work well in getting at text stream string things which we are interested in

    The available methods and the such reflect all the above…
    -…So code will have a string getting section that..
    1(i) makes available the Library of stuff, objects, Methods etc.
    1(ii) makes the big File Object
    1(iii) sets up the data “stream highway”
    1(iv) pulls in the data, in our case into a simple string variable


    _.____
    I have decided for my requirement to use a “Function” for this, not just to house tidily the above steps, but also as I may add some additional bits from time to time too the main inner body string for my Email message, which the main function of this all is to produce.
    To recap on the Function idea here ( http://www.excelfox.com/forum/showth...blem#post10503 )

    In end effect I want a String. In fact in the main code in which this should be embedded has this as a variable
    Pseudo, Linked in my Binding Function, ObjectLinkedEbeded Stuff
    In place of an actual static linked variable_...
    Dim MyLenghtyString As String
    _ Let MyLenghtyString = “static linked at pseudo Compile String”

    _.. I have
    Function MyLenghyString(Export) As String
    _ Pall MyLenghyString()_Import
    _.. or Let MyLenghtyString = “direct linked runny runable library”


    The end result is that in my code I will have simply pulling of

    _ .HTMLBody = MyLengthyStreaming


    Function Code description:
    Rem 1
    This uses the File System Object way discussed above to finally produce a long text string in variable _ MyLengthyStreaming _ This string probably has a of unnecessary stuff as well as the required part of the HTML code, but appears to be able to be handled and manipulated as if it were just the required part. Presumably the rest is ignored by things such as internet browsers

    Rem 2
    This allows for some extra simple string data to be added. If you are not familiar with HTML code then you can easily get the required string from text to HTML converters of which there are many freely available in internet
    Note: If you have any in your required HTML string, then you will need to replace them in the given string in the VBA code with “”
    http://www.excelfox.com/forum/showth...rmat#post10448






    ' https://support.microsoft.com/en-in/kb/186118
    https://www.youtube.com/watch?v=nj8mU3ecwsM
    https://www.youtube.com/watch?v=f8s-jY9y220&t=1813s




    Note: ' path in code must be changed to reflect where you save .htm file
    Pubic Function MyLengthyStreaming() As String
    Code:
    Public Function MyLengthyStreaming() As String
    Rem 1 Make a long string from a Microsoft Word doc
    '1(i) makes available the Library of stuff, objects, Methods etc.
    Dim Fso As Object: Set Fso = CreateObject("Scripting.FileSystemObject")
    '1(ii) makes the big File Object                       " Full path and file name of Word doc saved as .htm       "
    Dim FileObject As Object: Set FileObject = Fso.GetFile("G:\ALERMK2014Marz2016\NeueBlancoAb27.01.2014\AbJan2016\ProMessage.htm"): Debug.Print FileObject  ' path in code must be changed to reflect where you save it
    '1(iii) sets up the data  "stream highway"
    Dim Textreme As Object:  Set Textreme = FileObject.OpenAsTextStream(iomode:=1, Format:=-2)        '   reading only, Opens using system default            https://msdn.microsoft.com/en-us/library/aa265341(v=vs.60).aspx
    '1(iv) pulls in the data, in our case into a simple string variable
     Let MyLengthyStreaming = Textreme.ReadAll         '        Let MyLengthyStreaming = Replace(MyLengthyStreaming, "align=center x:publishsource=", "align=left x:publishsource=")
     Textreme.Close
     Set Textreme = Nothing
     Set Fso = Nothing
    Rem 2 possible additions to MyLengthyStreaming
    HTML Code:
    Rem 2
     Let MyLengthyStreaming = "<p><span style=""color: #ff00ff;"">Start=========== " & Format(Now(), "DD MMMM YYYY") & " " & Now() & " ------------------------------------</span></p>" & MyLengthyStreaming & "<p><span style=""color: #ff00ff;"">-- " & Format(Now(), "DD MMMM YYYY") & " " & Now() & " ==End, Sent from Doc.AElstein Mail ======</span></p>"
    End Function


    MyLengthyStreaming = "<p><span style=""color: #ff00ff;"">Start=========== " & Format(Now(), "DD MMMM YYYY") & " " & Now() & " ------------------------------------</span></p>" & MyLengthyStreaming & "<p><span style=""color: #ff00ff;"">-- " & Format(Now(), "DD MMMM YYYY") & " " & Now() & " ==End, Sent from Doc.AElstein Mail ======</span></p>"
    MyLengthyStreaming = "[color=Black]<[/color]p[color=Black]>[/color][color=Black]<[/color]span style=""color: #ff00ff;""[color=Black]>[/color]Start=========== " & Format(Now(), "DD MMMM YYYY") & " " & Now() & " ------------------------------------[color=Black]<[/color]/span[color=Black]>[/color][color=Black]<[/color]/p[color=Black]>[/color]" & MyLengthyStreaming & "[color=Black]<[/color]p[color=Black]>[/color][color=Black]<[/color]span style=""color: #ff00ff;""[color=Black]>[/color]-- " & Format(Now(), "DD MMMM YYYY") & " " & Now() & " ==End, Sent from Doc.AElstein Mail ======[color=Black]<[/color]/span[color=Black]>[/color][color=Black]<[/color]/p[color=Black]>[/color]"

    Code:
    Public Function MyLengthyStreaming() As String
    Rem 1 Make a long string from a Microsoft Word doc
    '1(i) makes available the Library of stuff, objects, Methods etc.
    Dim Fso As Object: Set Fso = CreateObject("Scripting.FileSystemObject")
    '1(ii) makes the big File Object                       " Full path and file name of Word doc saved as .htm       "
    Dim FileObject As Object: Set FileObject = Fso.GetFile("G:\ALERMK2014Marz2016\NeueBlancoAb27.01.2014\AbJan2016\ProMessage.htm"): Debug.Print FileObject
    '1(iii) sets up the data  "stream highway"
    Dim Textreme As Object:  Set Textreme = FileObject.OpenAsTextStream(iomode:=1, Format:=-2)        '   reading only, Opens using system default            https://msdn.microsoft.com/en-us/library/aa265341(v=vs.60).aspx
    '1(iv) pulls in the data, in our case into a simple string variable
     Let MyLengthyStreaming = Textreme.ReadAll         '        Let MyLengthyStreaming = Replace(MyLengthyStreaming, "align=center x:publishsource=", "align=left x:publishsource=")
     Textreme.Close
     Set Textreme = Nothing
     Set Fso = Nothing
    Rem 2 possible additions to MyLengthyStreaming
     Let MyLengthyStreaming = "<p><span style=""color: #ff00ff;"">Start=========== " & Format(Now(), "DD MMMM YYYY") & " " & Now() & " ------------------------------------</span></p>" & MyLengthyStreaming & "<p><span style=""color: #ff00ff;"">-- " & Format(Now(), "DD MMMM YYYY") & " " & Now() & " ==End, Sent from Doc.AElstein Mail ======</span></p>"
    End Function

    Results Example:

    Used htm Word File.JPG : https://imgur.com/mwihFBT
    "ProMessage.htm" ( Saved from Word as .htm ) : https://app.box.com/s/cbtodk5srg76a5lowfemrdvei91mfmdq
    Attachment 1969

    Recieved Email gmail.jpg : https://imgur.com/x0NybLa :
    Code:
       '.To = "Doc.AElstein@t-online.de"
       .To = "excelvbaexp@gmail.com"
    Attachment 1972


    Recieved EMail Telekom : https://imgur.com/wqPJSCt
    Recieved EMail Telekom 2.JPG : https://imgur.com/o5mRkak
    Code:
       .To = "Doc.AElstein@t-online.de"
       '.To = "excelvbaexp@gmail.com"
    Attachment 1970Attachment 1971








    _.________________________________________________ ____________________________

    Uploaded file had to be done as .docx to get it to upload at excelfox ( .htm were not permitted to be uploaded )
    To use in code it must be resaved as .html ( ' and path in code must be changed to reflect where you save it )
    Attached Images Attached Images
    Attached Files Attached Files
    ….If you are my competitor, I will try all I can to beat you. But if I do, I will not belittle you. I will Salute you, because without you, I am nothing.
    If you are my enemy, we will try to kick the fucking shit out of you…..
    Winston Churchill, 1939
    Save your Forum..._
    _...KILL A MODERATOR!!

Similar Threads

  1. Table Tests. And Thread Copy Tests No Reply needed
    By DocAElstein in forum Test Area
    Replies: 1
    Last Post: 11-20-2018, 01:11 PM
  2. Table Tests. And Thread Copy Tests No Reply needed
    By DocAElstein in forum Test Area
    Replies: 1
    Last Post: 11-20-2018, 01:11 PM
  3. Replies: 11
    Last Post: 10-13-2013, 10:53 PM
  4. Replies: 1
    Last Post: 09-14-2013, 12:49 PM
  5. Replies: 7
    Last Post: 08-28-2013, 12:57 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
  •