Tests Copying pasting Cliipboard issues. and otes on API stuff

[DocAElstein]

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

[DocAElstein]

Coding so far , for last post, https://excelfox.com/forum/showthrea...ll=1#post16529

'  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

' 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

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

[DocAElstein]

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

'====================================
' 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

'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 ) )

[DocAElstein]

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

Test Function used to produce the Log below

'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

---------------------------
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:

' 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

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

[DocAElstein]

Per PM request: One full working example of above 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()

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

'_-=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

[DocAElstein]

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


Function CStrSepDbl

'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

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

[DocAElstein]

sölcjslkjcslkjc



https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgxesLhWNr_zNP0GUdh4AaABAg.9hI1CQJMLLo9hWn2pGBe SS
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgzkRujoMw9PblmXDQ14AaABAg.9hJRnEjxQrd9hJoCjomN I2
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgzPZbG7OvUkh35nXDd4AaABAg.9hJOZEEZa6p9hJqLC7El-w
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgwUcEpm8u6ZW3uOHXx4AaABAg.9hIlxxGY7t49hJsB2PWx C4
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgyvDj6NWT1Gxyy2JyR4AaABAg.9hIKlNPeqDn9hJskm92n p6
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=Ugwy7qx_kG9iUmMVO_F4AaABAg.9hI2IGUdmTW9hJuyaQaw qx
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgxesLhWNr_zNP0GUdh4AaABAg.9hI1CQJMLLo9hJwTB9Jl ob
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgyyQWYVP1OnCqavb-x4AaABAg
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgwJKKmExZ1FdZVDJf54AaABAg
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=Ugz_p0kVGrLntPtYzCt4AaABAg
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA

[DocAElstein]

_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

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 ) :

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

[DocAElstein]

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

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

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]"

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 :

   '.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

   .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 )

[DocAElstein]

https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA
https://www.youtube.com/watch?v=TW3l7PkSPD4&lc=UgwAL_Jrv7yg7WWC8x14AaABAg
https://teylyn.com/2017/03/21/dollarsigns/#comment-191
https://stackoverflow.com/questions/32736915/how-to-clear-office-clipboard-with-vba/79137321#79137321
https://stackoverflow.com/questions/64066265/clearing-the-clipboard-in-office-365/79137208#79137208
https://eileenslounge.com/viewtopic.php?p=321817&sid=48f7ab4ec7b36a168c9213377acee8b7#p321817
https://eileenslounge.com/viewtopic.php?p=321817#p321817
https://eileenslounge.com/viewtopic.php?f=30&t=31849&p=321822#p321822
https://stackoverflow.com/questions/33868233/shell-namespace-not-accepting-string-variable-but-accepting-string-itself/77888851#77888851
https://microsoft.public.access.narkive.com/Jl55mts5/problem-using-shell-namespace-method-in-vba#post5
https://stackoverflow.com/questions/77220774/getfolder-method-does-not-return-folder-object-it-returns-a-string-instead/77846716#77846716
https://www.youtube.com/watch?v=zHJPliWS9FQ&lc=Ugz39PGfytiMUCmTPTl4AaABAg.91d_Pbzklsp9zfGbIr8h gW
https://www.youtube.com/watch?v=zHJPliWS9FQ&lc=UgwbcybM8fXnaIK-Y3B4AaABAg.97WIeYeaIeh9zfsJvc21iq
https://stackoverflow.com/questions/77220774/getfolder-method-does-not-return-folder-object-it-returns-a-string-instead/77846716#77846716
https://www.youtube.com/watch?v=vSjTzhoJFdk&lc=UgzTC8V4jCzDHbmfCHF4AaABAg.9zaUSUoUUYs9zciSZa95 9d
https://www.youtube.com/watch?v=vSjTzhoJFdk&lc=UgzTC8V4jCzDHbmfCHF4AaABAg.9zaUSUoUUYs9zckCo1tv PO
https://www.youtube.com/watch?v=vSjTzhoJFdk&lc=UgwMsgdKKlhr2YPpxXl4AaABAg
https://www.youtube.com/watch?v=XQAIYCT4f8Q&lc=UgwTUdEgR4bdt6crKXF4AaABAg.9xmkXGSciKJ9xonTti2s Ix
https://www.youtube.com/watch?v=XQAIYCT4f8Q&lc=UgwWw16qBFX39JCRRm54AaABAg.9xnskBhPnmb9xoq3mGxu _b
https://www.youtube.com/watch?v=XQAIYCT4f8Q&lc=UgzgWvzV-kvC4TJ8O414AaABAg.9xnFzCj8HRM9xon1p2ImxO
https://www.youtube.com/watch?v=XQAIYCT4f8Q&lc=UgybZfNJd3l4FokX3cV4AaABAg.9xm_ufqOILb9xooIlv5P LY
https://www.youtube.com/watch?v=XQAIYCT4f8Q&lc=UgzgWvzV-kvC4TJ8O414AaABAg.9xnFzCj8HRM9y38bzbSqaG
https://www.youtube.com/watch?v=XQAIYCT4f8Q&lc=UgyWm8nL7syjhiHtpBF4AaABAg.9xmt8i0IsEr9y3FT9Y9F eM
https://www.youtube.com/watch?v=bRd4mJglWiM&lc=UgxRmh2gFhpmHNnPemR4AaABAg.A0opm95t2XEA0q3Kshmu uY
https://www.youtube.com/watch?v=bRd4mJglWiM&lc=UgxRmh2gFhpmHNnPemR4AaABAg
https://www.eileenslounge.com/memberlist.php?mode=viewprofile&u=6841
https://eileenslounge.com/viewtopic.php?p=321817&sid=48f7ab4ec7b36a168c9213377acee8b7#p321817
https://eileenslounge.com/viewtopic.php?p=321817#p321817
https://eileenslounge.com/viewtopic.php?f=30&t=31849&p=321822#p321822
https://eileenslounge.com/viewtopic.php?p=320960#p320960
https://eileenslounge.com/viewtopic.php?p=320957#p3209573
https://eileenslounge.com/viewtopic.php?p=318868#p318868
https://eileenslounge.com/viewtopic.php?p=318311#p318311
https://eileenslounge.com/viewtopic.php?p=318302#p318302
https://eileenslounge.com/viewtopic.php?p=317704#p317704
https://eileenslounge.com/viewtopic.php?p=317704#p317704
https://eileenslounge.com/viewtopic.php?p=317857#p317857
https://eileenslounge.com/viewtopic.php?p=317541#p317541
https://eileenslounge.com/viewtopic.php?p=317520#p317520
https://eileenslounge.com/viewtopic.php?p=317510#p317510
https://eileenslounge.com/viewtopic.php?p=317547#p317547
https://eileenslounge.com/viewtopic.php?p=317573#p317573
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA