Page 3 of 4 FirstFirst 1234 LastLast
Results 21 to 30 of 40

Thread: test BB Code

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

    PHP Code:
    '   http://www.ozgrid.com/forum/showthread.php?t=198172&page=2&p=763613#post763613
    '   
    http://www.excelfox.com/forum/f13/bbcode-table-2077/
    '   '//Original code is written by Rick Rothstein
        
    '//http://www.excelfox.com/forum/f22/get-displayed-cell-color-whether-from-conditional-formatting-or-not-338/
    '   
    No User FormRun Main Code  Sub BB_Table_Clipboard_PikeFoxAlan()
    Option Explicit
    ' First Declaring Bit of my Code version of the code from Pike, Kris and Rick. http://www.excelfox.com/forum/f17/test-bb-code-2079/#post9642
    Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
    Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
    Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
    Declare Function CloseClipboard Lib "User32" () As Long
    Declare Function OpenClipboard Lib "User32" (ByVal hwnd As Long) As Long
    Declare Function EmptyClipboard Lib "User32" () As Long
    Declare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long
    Declare Function SetClipboardData Lib "User32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
    Private Const GHND = &H42
    Private Const CF_TEXT = 1
    Private Const MAXSIZE = 4096
    '
    'Main Code     http://www.excelfox.com/forum/f17/test-bb-code-2079/#post9643
    Sub BB_Table_Clipboard_PikeFoxAlan() '
    http://www.excelfox.com/forum/f13/bbcode-table-2077/    http://www.ozgrid.com/forum/showthread.php?t=198172&page=2&p=763613#post763613
         
        
    Dim BB_Row As RangeBB_Cells As RangeBB_Range As Range
        Dim BB_Code 
    As StringstrFontColour As StringstrBackColour As StringstrAlign As StringstrWidth As String
        
    'Const csHEADER_COLOR As String = """#FFFFFF"""
        Const csHEADER_COLOR As String = "black"
        '
    Const csHEADER_BACK As String "#888888"
        
    Const csHEADER_BACK As String "powderblue"
        
    Const csROW_BACK As String "#FFFFFF"
        
    Set BB_Range Selection
        BB_Code 
    "[color=lightgrey]Using " ExcelVersion "[/color]" vbCrLf 'Give Excel version
        BB_Code = BB_Code & "[size=" & 0 & "][table=" & """" & "class:thin_grid" & """" & "]" & vbNewLine
        '
    BB_Code BB_Code "[tr][td][font=Wingdings]v[/font][/td]" vbNewLine
        BB_Code 
    BB_Code "[tr=bgcolor:" csHEADER_BACK "][th][COLOR=" csHEADER_COLOR "][sub]Row[/sub]\[sup]Col[/sup][/COLOR][/th]"      ' top left cell
        For Each BB_Cells In BB_Range.Rows(1).Cells '
    Column Letters
            strWidth 
    Application.WorksheetFunction.RoundUp(BB_Cells.ColumnWidth 7.50)
            
    'BB_Code = BB_Code & "[td=" & """" & "bgcolor:#ECF0F0, align:center, width:" & strWidth & """" & "][B]" & Split(BB_Cells.Address, "$")(1) & "[/B][/td]" & vbNewLine
            BB_Code = BB_Code & "[th][CENTER][COLOR=" & csHEADER_COLOR & "]" & ColLtr(BB_Cells.Column) & "[/COLOR][/CENTER][/th]" '
    Column Letter Row
        Next BB_Cells
        BB_Code 
    BB_Code "[/tr]"
        
    For Each BB_Row In BB_Range.Rows 'Row Numbers
            BB_Code = BB_Code & "[tr]"
            '
    BB_Code BB_Code "[td=" """" "bgcolor:#ECF0F0, align:center" """" "][B]" BB_Row.Row "[/B][/td]" vbNewLine
            BB_Code 
    BB_Code "[td=" """" "bgcolor:" csHEADER_BACK ", align:center" """" "][B]" BB_Row.Row "[/B][/td]" vbNewLine
            
    For Each BB_Cells In BB_Row.Cells
                
    If BB_Cells.FormatConditions.Count Then
                    strFontColour 
    objColour(DisplayedColor(BB_CellsFalseFalse))
                    
    strBackColour objColour(DisplayedColor(BB_CellsTrueFalse))
                Else
                    
    strFontColour objColour(BB_Cells.Font.Color)
                    
    strBackColour objColour(BB_Cells.Interior.Color)
                
    End If
                
    strAlign FontAlignment(BB_Cells)
                
    BB_Code BB_Code "[td=" """" "bgcolor:" strBackColour ", align:" strAlign """" "][COLOR=""" strFontColour """]" IIf(BB_Cells.Font.Bold"[B]""") & BB_Cells.Text IIf(BB_Cells.Font.Bold"[/B]""") & "[/COLOR][/td]" vbNewLine
            Next BB_Cells
            BB_Code 
    BB_Code "[/tr]" vbNewLine
        Next BB_Row
        BB_Code 
    BB_Code "[/table][/size]"
        'End of main table
        BB_Code = BB_Code & "[Table=""width:, class:grid""][tr][td]Sheet: [b]" & BB_Range.Parent.Name & "[/b][/td][/tr][/table]" '
    The parent One up the OOP change of the selects range is used to get at the sheet name.
        
    ClipBoard_SetData (BB_Code)
        
    Set BB_Range Nothing
    End Sub
    '
    '
    Some required functions.    http://www.excelfox.com/forum/f17/test-bb-code-2079/#post9644
    Private Function objColour(strCell As String) As String
        objColour 
    "#" Right(Right("000000" Hex(strCell), 6), 2) & Mid(Right("000000" Hex(strCell), 6), 32) & Left(Right("000000" Hex(strCell), 6), 2)
    End Function
     
    Private Function 
    FontAlignment(ByVal objCell As Object) As String
        With objCell
            Select 
    Case .HorizontalAlignment
            
    Case xlLeft
                FontAlignment 
    "LEFT"
            
    Case xlRight
                FontAlignment 
    "RIGHT"
            
    Case xlCenter
                FontAlignment 
    "CENTER"
            
    Case Else
                
    Select Case VarType(.Value2)
                Case 
    8
                    FontAlignment 
    "LEFT"
                
    Case 1011
                    FontAlignment 
    "CENTER"
                
    Case Else
                    
    FontAlignment "RIGHT"
                
    End Select
            End Select
        End With
    End 
    Function
     
    Private Function 
    ClipBoard_SetData(MyString As String)
        
    Dim hGlobalMemory As LonglpGlobalMemory As Long
        Dim hClipMemory 
    As LongAs Long
         
        hGlobalMemory 
    GlobalAlloc(GHNDLen(MyString) + 1)
        
    lpGlobalMemory GlobalLock(hGlobalMemory)
        
    lpGlobalMemory lstrcpy(lpGlobalMemoryMyString)
        If 
    GlobalUnlock(hGlobalMemory) <> 0 Then
            MsgBox 
    "Could not unlock memory location. Copy aborted."
            
    GoTo OutOfHere2
        End 
    If
        If 
    OpenClipboard(0&) = 0 Then
            MsgBox 
    "Could not open the Clipboard. Copy aborted."
            
    Exit Function
        
    End If
        
    EmptyClipboard()
        
    hClipMemory SetClipboardData(CF_TEXThGlobalMemory)
    OutOfHere2:
        If 
    CloseClipboard() = 0 Then
            MsgBox 
    "Could not close Clipboard."
        
    End If
    End Function
     
    Private Function 
    DisplayedColor(Cell As RangeOptional CellInterior As Boolean True_
        Optional ReturnColorIndex 
    As Long True) As Long
         
        Dim X 
    As LongTest As BooleanCurrentCell As StringdColor   As Variant
        Dim F   
    As StringR  As Range
         
         
    '//Original code is written by Rick Rothstein
         '
    //http://www.excelfox.com/forum/f22/get-displayed-cell-color-whether-from-conditional-formatting-or-not-338/
         
        
    If Cell.Count 1 Then Err.Raise vbObjectError 999, , "Only single cell references allowed for 1st argument."
        
    CurrentCell ActiveCell.Address(00)
        For 
    1 To Cell.FormatConditions.Count
            With Cell
    .FormatConditions(X)
                If .
    Type xlCellValue Then
                    Select 
    Case .Operator
                    
    Case xlBetween:      Test Cell.Value >= Evaluate(.Formula1) And Cell.Value <= Evaluate(.Formula2)
                    Case 
    xlNotBetween:   Test Cell.Value <= Evaluate(.Formula1) Or Cell.Value >= Evaluate(.Formula2)
                    Case 
    xlEqual:        Test Evaluate(.Formula1) = Cell.Value
                    
    Case xlNotEqual:     Test Evaluate(.Formula1) <> Cell.Value
                    
    Case xlGreater:      Test Cell.Value Evaluate(.Formula1)
                    Case 
    xlLess:         Test Cell.Value Evaluate(.Formula1)
                    Case 
    xlGreaterEqualTest Cell.Value >= Evaluate(.Formula1)
                    Case 
    xlLessEqual:    Test Cell.Value <= Evaluate(.Formula1)
                    
    End Select
                
    ElseIf .Type xlExpression Then
                    Application
    .ScreenUpdating False
                     
    'Cell.Select
                    F = Replace(.Formula1, "$", vbNullString)
                    F = Replace(F, CurrentCell, Cell.Address(0, 0))
                     '
    Test Evaluate(.Formula1)
                    
    Test Evaluate(F)
                     
    'Range(CurrentCell).Select
                    Application.ScreenUpdating = True
                End If
                If Test Then
                    If CellInterior Then
                        dColor = IIf(ReturnColorIndex, .Interior.ColorIndex, .Interior.Color)
                        If IsNull(dColor) Then
                            dColor = IIf(ReturnColorIndex, Cell.Interior.ColorIndex, Cell.Interior.Color)
                        End If
                    Else
                        dColor = IIf(ReturnColorIndex, .Font.ColorIndex, .Font.Color)
                        If IsNull(dColor) Then
                            dColor = IIf(ReturnColorIndex, Cell.Font.ColorIndex, Cell.Font.Color)
                        End If
                    End If
                    DisplayedColor = dColor
                    Exit Function
                End If
            End With
        Next
        If CellInterior Then
            dColor = IIf(ReturnColorIndex, Cell.Interior.ColorIndex, Cell.Interior.Color)
        Else
            dColor = IIf(ReturnColorIndex, Cell.Font.ColorIndex, Cell.Font.Color)
        End If
        DisplayedColor = dColor
         
    End Function
    '
    Private Function ExcelVersion() As String
        Dim temp                  
    As String
        
    'On Error Resume Next
    #If Mac Then
        Select Case Val(Application.Version)
            Case 11: temp = "Excel 2004"
            Case 12: temp = "Excel 2008" ' 
    this should NEVER happen!
            Case 
    14temp "Excel 2011"
            
    Case 15temp "vNext"
            
    Case Else: temp "Unknown"
        
    End Select
    #Else
        
    Select Case Val(Application.Version)
            Case 
    9temp "Excel 2000"
            
    Case 10temp "Excel 2002"
            
    Case 11temp "Excel 2003"
            
    Case 12temp "Excel 2007"
            
    Case 14temp "Excel 2010"
            
    Case 15temp "Excel 2013"
            
    Case Else: temp "Unknown"
        
    End Select
    #End If
        
    ExcelVersion temp
    End 
    Function
    '
    '
    Private Function ColLtr(ByVal iCol As Long) As String
    ' shg 2012 Alan 2016 http://www.excelforum.com/tips-and-tutorials/1108643-vba-column-letter-from-column-number-explained.html
    Good for any positive Long
        
    If iCol 0 Then
        ColLtr 
    ColLtr((iCol 1) \ 26) & Chr(65 + (iCol 1Mod 26)
        Else
        
    End If
    End Function 

  2. #22
    Fuhrer, Vierte Reich DocAElstein's Avatar
    Join Date
    Aug 2014
    Posts
    9,270
    Rep Power
    10
    Google Chrome

    PikeCode

    Code:
    Option Explicit'   http://www.ozgrid.com/forum/showthread.php?t=198172&page=2&p=763613#post763613
    'http://www.excelforum.com/development-testing-forum/1122041-test-new-table-to-bb-code.html
    'Pike    http://www.ozgrid.com/forum/showthread.php?t=198172&page=2&p=763370#post763370
    'Copy the syntax in the "VB:" window below to a standard Module
    'Select the range in the worksheet to be converted
    'Run the "BB_Table_Clipboard()" Marco to create the table in BBcode.
    Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
    Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
    Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
    Declare Function CloseClipboard Lib "User32" () As Long
    Declare Function OpenClipboard Lib "User32" (ByVal hwnd As Long) As Long
    Declare Function EmptyClipboard Lib "User32" () As Long
    Declare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long
    Declare Function SetClipboardData Lib "User32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
    Private Const GHND = &H42
    Private Const CF_TEXT = 1
    Private Const MAXSIZE = 4096
    
    
    Sub BB_Table_Clipboard_Pike() 'http://www.ozgrid.com/forum/showthread.php?t=198172&page=2&p=763370#post763370
        Dim BB_Row As Range, BB_Cells As Range, BB_Range As Range
        Dim BB_Code As String, strFontColour As String, strBackColour As String, strAlign As String, strWidth As String
    
    
        Set BB_Range = Selection
        BB_Code = "
    v " & Split(BB_Cells.Address, "$")(1) & "
    " & BB_Row.Row & " [COLOR=""" & strFontColour & """]" & IIf(BB_Cells.Font.Bold, "", "") & BB_Cells.Text & IIf(BB_Cells.Font.Bold, "", "") & "[/COLOR]
    " ClipBoard_SetData (BB_Code) Set BB_Range = Nothing End Sub Private Function objColour(strCell As String) As String objColour = "#" & Right(Right("000000" & Hex(strCell), 6), 2) & Mid(Right("000000" & Hex(strCell), 6), 3, 2) & Left(Right("000000" & Hex(strCell), 6), 2) End Function Private Function FontAlignment(ByVal objCell As Object) As String With objCell Select Case .HorizontalAlignment Case xlLeft FontAlignment = "LEFT" Case xlRight FontAlignment = "RIGHT" Case xlCenter FontAlignment = "CENTER" Case Else Select Case VarType(.Value2) Case 8 FontAlignment = "LEFT" Case 10, 11 FontAlignment = "CENTER" Case Else FontAlignment = "RIGHT" End Select End Select End With End Function Private Function ClipBoard_SetData(MyString As String) 'Changed to private as evaryone is / was using this Dim hGlobalMemory As Long, lpGlobalMemory As Long Dim hClipMemory As Long, X As Long hGlobalMemory = GlobalAlloc(GHND, Len(MyString) + 1) lpGlobalMemory = GlobalLock(hGlobalMemory) lpGlobalMemory = lstrcpy(lpGlobalMemory, MyString) If GlobalUnlock(hGlobalMemory) <> 0 Then MsgBox "Could not unlock memory location. Copy aborted." GoTo OutOfHere2 End If If OpenClipboard(0&) = 0 Then MsgBox "Could not open the Clipboard. Copy aborted." Exit Function End If X = EmptyClipboard() hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory) OutOfHere2: If CloseClipboard() = 0 Then MsgBox "Could not close Clipboard." End If End Function

  3. #23
    Fuhrer, Vierte Reich DocAElstein's Avatar
    Join Date
    Aug 2014
    Posts
    9,270
    Rep Power
    10
    HTML Code:
    Option Explicit'   http://www.ozgrid.com/forum/showthread.php?t=198172&page=2&p=763613#post763613'http://www.excelforum.com/development-testing-forum/1122041-test-new-table-to-bb-code.html'Pike    http://www.ozgrid.com/forum/showthread.php?t=198172&page=2&p=763370#post763370'Copy the syntax in the "VB:" window below to a standard Module'Select the range in the worksheet to be converted'Run the "BB_Table_Clipboard()" Marco to create the table in BBcode.Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As LongDeclare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As LongDeclare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As LongDeclare Function CloseClipboard Lib "User32" () As LongDeclare Function OpenClipboard Lib "User32" (ByVal hwnd As Long) As LongDeclare Function EmptyClipboard Lib "User32" () As LongDeclare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As LongDeclare Function SetClipboardData Lib "User32" (ByVal wFormat As Long, ByVal hMem As Long) As LongPrivate Const GHND = &H42Private Const CF_TEXT = 1Private Const MAXSIZE = 4096
    Sub BB_Table_Clipboard_Pike() 'http://www.ozgrid.com/forum/showthread.php?t=198172&page=2&p=763370#post763370    Dim BB_Row As Range, BB_Cells As Range, BB_Range As Range    Dim BB_Code As String, strFontColour As String, strBackColour As String, strAlign As String, strWidth As String
        Set BB_Range = Selection    BB_Code = "[table=" & """" & "class:thin_grid" & """" & "]" & vbNewLine    BB_Code = BB_Code & "[tr][td][font=Wingdings]v[/font][/td]" & vbNewLine    For Each BB_Cells In BB_Range.Rows(1).Cells        strWidth = Application.WorksheetFunction.RoundUp(BB_Cells.ColumnWidth * 7.5, 0)        BB_Code = BB_Code & "[td=" & """" & "bgcolor:#ECF0F0, align:center, width:" & strWidth & """" & "][B]" & Split(BB_Cells.Address, "$")(1) & "[/B][/td]" & vbNewLine    Next BB_Cells    BB_Code = BB_Code & "[/tr]"    For Each BB_Row In BB_Range.Rows        BB_Code = BB_Code & "[tr]"        BB_Code = BB_Code & "[td=" & """" & "bgcolor:#ECF0F0, align:center" & """" & "][B]" & BB_Row.Row & "[/B][/td]" & vbNewLine        For Each BB_Cells In BB_Row.Cells            strFontColour = objColour(BB_Cells.Font.Color)            strBackColour = objColour(BB_Cells.Interior.Color)            strAlign = FontAlignment(BB_Cells)            BB_Code = BB_Code & "[td=" & """" & "bgcolor:" & strBackColour & ", align:" & strAlign & """" & "][COLOR=""" & strFontColour & """]" & IIf(BB_Cells.Font.Bold, "[B]", "") & BB_Cells.Text & IIf(BB_Cells.Font.Bold, "[/B]", "") & "[/COLOR][/td]" & vbNewLine        Next BB_Cells        BB_Code = BB_Code & "[/tr]" & vbNewLine    Next BB_Row    BB_Code = BB_Code & "[/table]"    ClipBoard_SetData (BB_Code)    Set BB_Range = NothingEnd Sub
    Private Function objColour(strCell As String) As String    objColour = "#" & Right(Right("000000" & Hex(strCell), 6), 2) & Mid(Right("000000" & Hex(strCell), 6), 3, 2) & Left(Right("000000" & Hex(strCell), 6), 2)End Function
    Private Function FontAlignment(ByVal objCell As Object) As String    With objCell        Select Case .HorizontalAlignment        Case xlLeft            FontAlignment = "LEFT"        Case xlRight            FontAlignment = "RIGHT"        Case xlCenter            FontAlignment = "CENTER"        Case Else            Select Case VarType(.Value2)            Case 8                FontAlignment = "LEFT"            Case 10, 11                FontAlignment = "CENTER"            Case Else                FontAlignment = "RIGHT"            End Select        End Select    End WithEnd Function
    Private Function ClipBoard_SetData(MyString As String) 'Changed to private as evaryone is / was using this    Dim hGlobalMemory As Long, lpGlobalMemory As Long    Dim hClipMemory As Long, X As Long
        hGlobalMemory = GlobalAlloc(GHND, Len(MyString) + 1)    lpGlobalMemory = GlobalLock(hGlobalMemory)    lpGlobalMemory = lstrcpy(lpGlobalMemory, MyString)    If GlobalUnlock(hGlobalMemory) <> 0 Then        MsgBox "Could not unlock memory location. Copy aborted."        GoTo OutOfHere2    End If    If OpenClipboard(0&) = 0 Then        MsgBox "Could not open the Clipboard. Copy aborted."        Exit Function    End If    X = EmptyClipboard()    hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory)OutOfHere2:    If CloseClipboard() = 0 Then        MsgBox "Could not close Clipboard."    End IfEnd Function

  4. #24
    Fuhrer, Vierte Reich DocAElstein's Avatar
    Join Date
    Aug 2014
    Posts
    9,270
    Rep Power
    10
    After running cod to put in vbCR

    HTML Code:
    '    http://www.eileenslounge.com/viewtopic.php?f=26&t=22603&start=20#p176255        http://www.excelfox.com/forum/f13/bbcode-table-2077/#post9687   ( Manual Solution Alternative: http://www.excelfox.com/forum/f13/bbcode-table-2077/#post9645 )
    Sub PutInAvbLfInClipboadText() '    "Replcace vbCr with vbCr & vbLf "
    'Get Current Text from Clipboard
    Dim objDat As dataobject
    Set objDat = New dataobject 'Set to a new Instance ( Blue Print ) of dataobject
    'Dim obj As Object
    'Set obj = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
    objDat.GetFromClipboard 'All that is in the Clipboard goes in this Data Object instance of the Class.
    Let TxtOut = objDat.GetText() 'retrieve the text in this instance of the Class. ( In this case all I have in it is the text typically I think as it is coming from a Ctrl C Copy from the VB Editor )
    Dim originalClipboardText As String: Let originalClipboardText = TxtOut
    Dim TextWithExtravbLF As String
    Let TextWithExtravbLF = Replace(TxtOut, vbCr, vbCr & vbLf, 1, -1)
    'Dump in Clipboard: This second instance of Data Object used to put in Clipboard
    Dim objCliS As dataobject   '**Early Binding.   This is for an Object from the class MS Forms. This will be a Data Object of what we "send" to the Clipboard. So I name it CLIpboardSend. But it is a DataObject. It has the Methods I need to send text to the Clipboard
    Set objCliS = New dataobject '**Must enable Forms Library: In VB Editor do this:  Tools -- References - scroll down to Microsoft Forms 2.0 Object Library -- put checkmark in.  Note if you cannot find it try   OR IF NOT THERE..you can add that manually: VBA Editor -- Tools -- References -- Browse -- and find FM20.DLL file under C:\WINDOWS\system32 and select it --> Open --> OK.
    ' ( or instead of those two lines  Dim obj As New DataObject ).    or  next two lines are.....Late Binding equivalent'
    'Dim obj As Object'  Late Binding equivalent'   If you declare a variable as Object, you are late binding it.  http://excelmatters.com/2013/09/23/vba-references-and-early-binding-vs-late-binding/
    'Set obj = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")' http://excelmatters.com/2013/10/04/late-bound-msforms-dataobject/
    objCliS.SetText TextWithExtravbLF 'Make Data object's text equal to a copy of ORefiginalText
    objCliS.PutInClipboard 'Place current Data object into the Clipboard
    ' Get from clipboard. This a Another Object from class to be sure we have the data in the Clipboard
    MsgBox prompt:="You dumped in Clipboard originally  this " & vbCr & TxtOut & vbCr & "and if you try to get it, you should get" & vbCr & TextWithExtravbLF & ""
    ' End clean up.
    'TheEnd: ' ( Come here always, even on a unpredictable error )
    Set objDat = Nothing '   Good practice...   maybe....
    Set objCliS = Nothing '  .......   http://www.mrexcel.com/forum/excel-questions/361246-vbnullstring.html#post4414065
    End Sub

  5. #25
    Fuhrer, Vierte Reich DocAElstein's Avatar
    Join Date
    Aug 2014
    Posts
    9,270
    Rep Power
    10
    Code:
    Option Explicit'   http://www.ozgrid.com/forum/showthread.php?t=198172&page=2&p=763613#post763613
    'http://www.excelforum.com/development-testing-forum/1122041-test-new-table-to-bb-code.html
    'Pike    http://www.ozgrid.com/forum/showthread.php?t=198172&page=2&p=763370#post763370
    'Copy the syntax in the "VB:" window below to a standard Module
    'Select the range in the worksheet to be converted
    'Run the "BB_Table_Clipboard()" Marco to create the table in BBcode.
    Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
    Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
    Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
    Declare Function CloseClipboard Lib "User32" () As Long
    Declare Function OpenClipboard Lib "User32" (ByVal hwnd As Long) As Long
    Declare Function EmptyClipboard Lib "User32" () As Long
    Declare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long
    Declare Function SetClipboardData Lib "User32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
    Private Const GHND = &H42
    Private Const CF_TEXT = 1
    Private Const MAXSIZE = 4096
    
    
    Sub BB_Table_Clipboard_Pike() 'http://www.ozgrid.com/forum/showthread.php?t=198172&page=2&p=763370#post763370
        Dim BB_Row As Range, BB_Cells As Range, BB_Range As Range
        Dim BB_Code As String, strFontColour As String, strBackColour As String, strAlign As String, strWidth As String
    
    
        Set BB_Range = Selection
        BB_Code = "[table=" & """" & "class:thin_grid" & """" & "]" & vbNewLine
        BB_Code = BB_Code & "[tr][td][font=Wingdings]v[/font][/td]" & vbNewLine
        For Each BB_Cells In BB_Range.Rows(1).Cells
            strWidth = Application.WorksheetFunction.RoundUp(BB_Cells.ColumnWidth * 7.5, 0)
            BB_Code = BB_Code & "[td=" & """" & "bgcolor:#ECF0F0, align:center, width:" & strWidth & """" & "][B]" & Split(BB_Cells.Address, "$")(1) & "[/B][/td]" & vbNewLine
        Next BB_Cells
        BB_Code = BB_Code & "[/tr]"
        For Each BB_Row In BB_Range.Rows
            BB_Code = BB_Code & "[tr]"
            BB_Code = BB_Code & "[td=" & """" & "bgcolor:#ECF0F0, align:center" & """" & "][B]" & BB_Row.Row & "[/B][/td]" & vbNewLine
            For Each BB_Cells In BB_Row.Cells
                strFontColour = objColour(BB_Cells.Font.Color)
                strBackColour = objColour(BB_Cells.Interior.Color)
                strAlign = FontAlignment(BB_Cells)
                BB_Code = BB_Code & "[td=" & """" & "bgcolor:" & strBackColour & ", align:" & strAlign & """" & "][COLOR=""" & strFontColour & """]" & IIf(BB_Cells.Font.Bold, "[B]", "") & BB_Cells.Text & IIf(BB_Cells.Font.Bold, "[/B]", "") & "[/COLOR][/td]" & vbNewLine
            Next BB_Cells
            BB_Code = BB_Code & "[/tr]" & vbNewLine
        Next BB_Row
        BB_Code = BB_Code & "[/table]"
        ClipBoard_SetData (BB_Code)
        Set BB_Range = Nothing
    End Sub
    
    
    Private Function objColour(strCell As String) As String
        objColour = "#" & Right(Right("000000" & Hex(strCell), 6), 2) & Mid(Right("000000" & Hex(strCell), 6), 3, 2) & Left(Right("000000" & Hex(strCell), 6), 2)
    End Function
    
    
    Private Function FontAlignment(ByVal objCell As Object) As String
        With objCell
            Select Case .HorizontalAlignment
            Case xlLeft
                FontAlignment = "LEFT"
            Case xlRight
                FontAlignment = "RIGHT"
            Case xlCenter
                FontAlignment = "CENTER"
            Case Else
                Select Case VarType(.Value2)
                Case 8
                    FontAlignment = "LEFT"
                Case 10, 11
                    FontAlignment = "CENTER"
                Case Else
                    FontAlignment = "RIGHT"
                End Select
            End Select
        End With
    End Function
    
    
    Private Function ClipBoard_SetData(MyString As String) 'Changed to private as evaryone is / was using this
        Dim hGlobalMemory As Long, lpGlobalMemory As Long
        Dim hClipMemory As Long, X As Long
    
    
        hGlobalMemory = GlobalAlloc(GHND, Len(MyString) + 1)
        lpGlobalMemory = GlobalLock(hGlobalMemory)
        lpGlobalMemory = lstrcpy(lpGlobalMemory, MyString)
        If GlobalUnlock(hGlobalMemory) <> 0 Then
            MsgBox "Could not unlock memory location. Copy aborted."
            GoTo OutOfHere2
        End If
        If OpenClipboard(0&) = 0 Then
            MsgBox "Could not open the Clipboard. Copy aborted."
            Exit Function
        End If
        X = EmptyClipboard()
        hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory)
    OutOfHere2:
        If CloseClipboard() = 0 Then
            MsgBox "Could not close Clipboard."
        End If
    End Function
    Last edited by DocAElstein; 05-02-2016 at 03:22 PM.

  6. #26
    Junior Member pike's Avatar
    Join Date
    Dec 2011
    Posts
    27
    Rep Power
    0
    Code:
    v 
    " & Split(BB_Cells.Address, "$")(1) & " 
    
    
    " & BB_Row.Row & " 
    [COLOR=""" & strFontColour & """]" & IIf(BB_Cells.Font.Bold, "", "") & BB_Cells.Text & IIf(BB_Cells.Font.Bold, "", "") & "[/COLOR] 
    
    
    
    
    "

  7. #27
    Fuhrer, Vierte Reich DocAElstein's Avatar
    Join Date
    Aug 2014
    Posts
    9,270
    Rep Power
    10
    Code:
    Sub AlanHansClipboardTextGetFindReplace() 'Using the "Dialogue Find Replace" way.
    Rem 1) Put Selected Text in Clipboard.
    Dim objCliS As DataObject '**Early Binding. Object from the class MS Forms, This is for an Object from the class MS Forms. This will be a Data Object of what we "send" to the Clipboard. It has the Methods I need to send text to the Clipboard. I will use this to put Things in the Clipboard. Bringing things out I will do with another Data Object
    Set objCliS = New DataObject '**Must enable Forms Library: In VB Editor do this: Tools -- References - scroll down to Microsoft Forms 2.0 Object Library -- put checkmark in. Note if you cannot find it try OR IF NOT THERE..you can add that manually: VBA Editor -- Tools -- References -- Browse -- and find FM20.DLL file under C:\WINDOWS\system32 and select it --> Open --> OK.
    ' ( or instead of those two lines Dim obj As New DataObject which is the same ). or next two lines are...
    'Dim objCliS As Object ' ...Late Binding equivalent'
    'Set objCliS = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")' http://excelmatters.com/2013/10/04/l...ms-dataobject/
    Dim Txtin As String: Let Txtin = Selection.Text: Debug.Print Txtin 'Copies the selection as a continuous string: Hit Ctrl G to see it in the Immediate window! You will see it with carriage returns , the Copmuter just sees it as a long "Horizontal" string
    objCliS.SetText Txtin 'Make object's text equal above string variable
    objCliS.PutInClipboard 'Place current object dataObject into the Clipboard ( Our original selected text ....!!!.... is in that )
    'Rem 2) 'Bit of a bodge to get the text in a selection: create a Word file and paste to it
    Dim FullFilePathAndFullName As String 'Initial Pigion Hole given for this String variable, and given a special vbNullString "Value", theoretically to simplify comparisons.
    Documents.Add: ActiveDocument.Content.Paste 'Make a File Copy in current Application based on Default Type : And Paste from Clipoard ( ...!!!...our original selected text ) using the Default Copy which should at least have all the text, which is all we are interested in here.
    ActiveDocument.SaveAs Filename:="TempBBCodeCopyTidledInSpaces.docx", FileFormat:=wdFormatXMLDocument 'Without this the document will not really "exist jet". It has a tempory name ( Used in Windows referrence ), but no path.
    Let FullFilePathAndFullName = ActiveDocument.path & "\" & ActiveDocument.Name
    Selection.WholeStory 'Selects whole document which here is just our selection of interest from the oroiginal document
    'Rem 3) Han's Text Find Replacement Dialogue 'http://www.eileenslounge.com/viewtopic.php?f=26&t=22603#p175712
    With Selection.Find 'This is the VBA code ( or very similar ) used by Excel when Using the Find eplace text Dialogue box. So this is an improved version of what a macro recording would give.
    .ClearFormatting: .Replacement.ClearFormatting ' Don't use formatting, ? not sure this comes into the equation ??
    .Wrap = wdFindStop ' Tell Word not to continue past the end of the selection ( And therefore prevents also a display Alert asking )
    .MatchWildcards = False ' Don't use wildcards. The default anyway, but in this code is an important concept...
    .Text = " " ' Search text is two spaces
    .Replacement.Text = "~~" ' Replace text is with two tildas.
    .Execute Replace:=wdReplaceAll ' Replace all within selection. This is the "OK" button!
    .Text = "~ " ' Search text is tilda followed by space
    .Execute Replace:=wdReplaceAll ' Replace all within selection. This is the "OK" button!
    .Text = "~{1;}" 'or [~]{1;} It is still not totally clear whether this is a Reg Ex Pattern or a Wild Card String. Important is that it is a String in a Dialogue to be applied to A ( Word in this case ) document. Sort of as you write in a cell, so the ; , convention must be carefully checked and appropriately used here
    .Replacement.Text = "^&" ' Enclose in BB codes ...... This "Wildcard" applies only to the Replace. It inserts the found string, or strings.
    .MatchWildcards = True 'The next line does the Replce, here we are still selecting an option,( Use wildcards )
    .Execute Replace:=wdReplaceAll ' Replace all within selection. This is the "OK" button!
    End With
    ActiveDocument.Select 'Re select the...( actually this line alone seems to do it )
    Selection.WholeStory '...while document
    Rem 4) "Reset the "Find Replace Text Dialogue" "Thing" "
    With Selection.Find
    .ClearFormatting: .Replacement.ClearFormatting: .Text = "": .Replacement.Text = "": .Forward = True: .Wrap = wdFindAsk: .Format = False: .MatchCase = False: .MatchWholeWord = False: .MatchKashida = False: .MatchDiacritics = False: .MatchAlefHamza = False: .MatchControl = False: .MatchWildcards = False: .MatchSoundsLike = False: .MatchAllWordForms = False '
    End With
    Rem 5) Final result to and from Clipboard
    '5b) Using again objCliS we put the modified text in the Clipboard, so overwritng the original
    objCliS.SetText Selection.Text 'Replace the text in the data object
    objCliS.PutInClipboard 'Place current object dataObject into the Clipboard, so putting the modified text in there
    '5b) Another data Object to get the data from the clipboard.
    Dim objDat As DataObject
    Set objDat = New DataObject 'Set to a new Instance ( Blue Print ) of dataobject
    'Dim obj As Object
    'Set obj = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
    objDat.GetFromClipboard 'All that is in the Clipboard goes in this Data Object second instance of the Class.
    Dim TxtOut As String: Let TxtOut = objDat.GetText() 'retrieve the text in this second instance of the Class. ( In this case all I have in it is the text )
    MsgBox prompt:="You dumped in Clipboard this " & vbCr & objCliS.GetText() & vbCr & "and if you try to get it, you should get" & vbCr & TxtOut & ""
    Rem 6) Optional to delete Temporary File
    ActiveDocument.Close (wdDoNotSaveChanges) 'Giving the option will also prevent being asked for it. You must close. VBA will not let you kill an open sheet, as you are affectively working on a copy, and VBA is assumng the Original can be got at by saving for example. http://www.mrexcel.com/forum/excel-q...ml#post4425428
    Kill FullFilePathAndFullName 'Use the Kill wisely!!!! - where this goes there 'aint no coming back!!
    End Sub
    Last edited by DocAElstein; 05-02-2016 at 04:00 PM.

  8. #28
    Fuhrer, Vierte Reich DocAElstein's Avatar
    Join Date
    Aug 2014
    Posts
    9,270
    Rep Power
    10
    Pike FontFartsWonks
    http://www.excelfox.com/forum/showth...-BB-Code/page3
    ....there you go font name added .. but will default if the worksheet font name is not avalibale in the forum BBcode font list


    Old:
    Using Excel 2007
    Row\Col
    F
    G
    14 PikeCalibri Fooaarrnst Arial Narrow
    15 Verdana Batang
    Sheet: Molly
    _.................................................


    New Fonts

    Using Excel 2007
    Row\Col
    F
    G
    14 PikeCalibri Fooaarrnst Arial Narrow
    15 Verdana Batang
    Sheet: Molly
    Last edited by DocAElstein; 05-16-2016 at 01:44 PM.

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

    Pike Fonts 16th may 2016

    http://www.excelfox.com/forum/showth...=9801#post9801
    Piike 16 may 2016
    ..........there you go font name added .. but will default if the worksheet font name is not avalibale in the forum BBcode font list.................................



    Code:
    ' To Copy this to a Forum Post you need Alan's HTML Text for copy in HTML Window Bodge Wonk http://www.excelfox.com/forum/f13/bbcode-table-2077/#post9639
    
    
    
    
    '   http://www.ozgrid.com/forum/showthread.php?t=198172&page=2&p=763613#post763613
    '   http://www.excelfox.com/forum/f13/bbcode-table-2077/
    '   '//Original code is written by Rick Rothstein
        '//http://www.excelfox.com/forum/f22/get-displayed-cell-color-whether-from-conditional-formatting-or-not-338/
    '   No User Form. Run Main Code  Sub BB_Table_Clipboard_PikeFoxAlan()
    '   PikeFoarnts  16th Mai 2016   --XX   http://www.excelfox.com/forum/showthread.php/2077-BBCode-Table?p=9801#post9801
    Option Explicit
    ' First Declaring Bit of my Code version of the code from Pike, Kris and Rick. http://www.excelfox.com/forum/f17/test-bb-code-2079/#post9642
    Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
    Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
    Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
    Declare Function CloseClipboard Lib "User32" () As Long
    Declare Function OpenClipboard Lib "User32" (ByVal hwnd As Long) As Long
    Declare Function EmptyClipboard Lib "User32" () As Long
    Declare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long
    Declare Function SetClipboardData Lib "User32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
    Private Const GHND = &H42
    Private Const CF_TEXT = 1
    Private Const MAXSIZE = 4096
    '
    'Main Code     http://www.excelfox.com/forum/f17/test-bb-code-2079/#post9643
    Sub BB_Table_Clipboard_PikeFoarnts() '     http://www.excelfox.com/forum/f13/bbcode-table-2077/    http://www.ozgrid.com/forum/showthread.php?t=198172&page=2&p=763613#post763613
        Dim BB_Row As Range, BB_Cells As Range, BB_Range As Range
        Dim BB_Code As String, strFontColour As String, strBackColour As String, strAlign As String, strWidth As String
        Dim strFontName As String ' --XX
        'Const csHEADER_COLOR As String = """#FFFFFF"""
        Const csHEADER_COLOR As String = "black"
        'Const csHEADER_BACK As String = "#888888"
        Const csHEADER_BACK As String = "powderblue"
        Const csROW_BACK As String = "#FFFFFF"
        Set BB_Range = Selection
        BB_Code = "[color=lightgrey]Using " & ExcelVersion & "[/color]" & vbCrLf 'Give Excel version
        BB_Code = BB_Code & "[size=" & 0 & "][table=" & """" & "class:thin_grid" & """" & "]" & vbNewLine
        'BB_Code = BB_Code & "[tr][td][font=Wingdings]v[/font][/td]" & vbNewLine
        BB_Code = BB_Code & "[tr=bgcolor:" & csHEADER_BACK & "][th][COLOR=" & csHEADER_COLOR & "][sub]Row[/sub]\[sup]Col[/sup][/COLOR][/th]"      ' top left cell
        For Each BB_Cells In BB_Range.Rows(1).Cells 'Column Letters
            strWidth = Application.WorksheetFunction.RoundUp(BB_Cells.ColumnWidth * 7.5, 0)
            'BB_Code = BB_Code & "[td=" & """" & "bgcolor:#ECF0F0, align:center, width:" & strWidth & """" & "][B]" & Split(BB_Cells.Address, "$")(1) & "[/B][/td]" & vbNewLine
            BB_Code = BB_Code & "[th][CENTER][COLOR=" & csHEADER_COLOR & "]" & ColLtr(BB_Cells.Column) & "[/COLOR][/CENTER][/th]" 'Column Letter Row
        Next BB_Cells
        BB_Code = BB_Code & "[/tr]"
        For Each BB_Row In BB_Range.Rows 'Row Numbers
            BB_Code = BB_Code & "[tr]"
            'BB_Code = BB_Code & "[td=" & """" & "bgcolor:#ECF0F0, align:center" & """" & "][B]" & BB_Row.Row & "[/B][/td]" & vbNewLine
            BB_Code = BB_Code & "[td=" & """" & "bgcolor:" & csHEADER_BACK & ", align:center" & """" & "][B]" & BB_Row.Row & "[/B][/td]" & vbNewLine
            For Each BB_Cells In BB_Row.Cells
    ' --XX       If BB_Cells.FormatConditions.Count Then
    '                strFontColour = objColour(DisplayedColor(BB_Cells, False, False))
    '                strBackColour = objColour(DisplayedColor(BB_Cells, True, False))
    '            Else
    '                strFontColour = objColour(BB_Cells.Font.Color)
    '                strBackColour = objColour(BB_Cells.Interior.Color)
    '            End If
    '            strAlign = FontAlignment(BB_Cells)
    ' --XX       BB_Code = BB_Code & "[td=" & """" & "bgcolor:" & strBackColour & ", align:" & strAlign & """" & "][COLOR=""" & strFontColour & """]" & IIf(BB_Cells.Font.Bold, "[B]", "") & BB_Cells.Text & IIf(BB_Cells.Font.Bold, "[/B]", "") & "[/COLOR][/td]" & vbNewLine
                strFontColour = objColour(BB_Cells.Font.Color)
                strBackColour = objColour(BB_Cells.Interior.Color)
                strAlign = FontAlignment(BB_Cells)
                strFontName = BB_Cells.Font.Name
                BB_Code = BB_Code & "[td=" & """" & "bgcolor:" & strBackColour & ", align:" & strAlign & """" & "][COLOR=""" & strFontColour & """][Font=""" & strFontName & """]" & IIf(BB_Cells.Font.Bold, "[B]", "") & BB_Cells.Text & IIf(BB_Cells.Font.Bold, "[/B]", "") & "[/Font][/COLOR][/td]" & vbNewLine
            Next BB_Cells
            BB_Code = BB_Code & "[/tr]" ' & vbNewLine
        Next BB_Row
        BB_Code = BB_Code & "[/table][/size]"
        'End of main table
        BB_Code = BB_Code & "[size=" & 0 & "][Table=""width:, class:grid""][tr][td]Sheet: [b]" & BB_Range.Parent.Name & "[/b][/td][/tr][/table][/size]" 'The parent ( One up the OOP change ) of the selects range is used to get at the sheet name.
        ClipBoard_SetData (BB_Code)
    BeepForPoo:  Beep: Beep: Application.Wait (Now + TimeValue("0:00:01")): Beep
    MsgBox prompt:="You Dumped in Clipboard!"
    Beep: Beep: Beep: Beep: Application.Wait (Now + TimeValue("0:00:01")): Beep: Beep
        Set BB_Range = Nothing
    End Sub
    '
    'Some required functions.    http://www.excelfox.com/forum/f17/test-bb-code-2079/#post9644
    Private Function objColour(strCell As String) As String
        objColour = "#" & Right(Right("000000" & Hex(strCell), 6), 2) & Mid(Right("000000" & Hex(strCell), 6), 3, 2) & Left(Right("000000" & Hex(strCell), 6), 2)
    End Function
     
    Private Function FontAlignment(ByVal objCell As Object) As String
        With objCell
            Select Case .HorizontalAlignment
            Case xlLeft
                FontAlignment = "LEFT"
            Case xlRight
                FontAlignment = "RIGHT"
            Case xlCenter
                FontAlignment = "CENTER"
            Case Else
                Select Case VarType(.Value2)
                Case 8
                    FontAlignment = "LEFT"
                Case 10, 11
                    FontAlignment = "CENTER"
                Case Else
                    FontAlignment = "RIGHT"
                End Select
            End Select
        End With
    End Function
     
    Private Function ClipBoard_SetData(MyString As String)
        Dim hGlobalMemory As Long, lpGlobalMemory As Long
        Dim hClipMemory As Long, X As Long
         
        hGlobalMemory = GlobalAlloc(GHND, Len(MyString) + 1)
        lpGlobalMemory = GlobalLock(hGlobalMemory)
        lpGlobalMemory = lstrcpy(lpGlobalMemory, MyString)
        If GlobalUnlock(hGlobalMemory) <> 0 Then
            MsgBox "Could not unlock memory location. Copy aborted."
            GoTo OutOfHere2
        End If
        If OpenClipboard(0&) = 0 Then
            MsgBox "Could not open the Clipboard. Copy aborted."
            Exit Function
        End If
        X = EmptyClipboard()
        hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory)
    OutOfHere2:
        If CloseClipboard() = 0 Then
            MsgBox "Could not close Clipboard."
        End If
    End Function
     
    Private Function DisplayedColor(Cell As Range, Optional CellInterior As Boolean = True, _
        Optional ReturnColorIndex As Long = True) As Long
         
        Dim X As Long, Test As Boolean, CurrentCell As String, dColor   As Variant
        Dim F   As String, R  As Range
         
         '//Original code is written by Rick Rothstein
         '//http://www.excelfox.com/forum/f22/get-displayed-cell-color-whether-from-conditional-formatting-or-not-338/
         
        If Cell.Count > 1 Then Err.Raise vbObjectError - 999, , "Only single cell references allowed for 1st argument."
        CurrentCell = ActiveCell.Address(0, 0)
        For X = 1 To Cell.FormatConditions.Count
            With Cell.FormatConditions(X)
                If .Type = xlCellValue Then
                    Select Case .Operator
                    Case xlBetween:      Test = Cell.Value >= Evaluate(.Formula1) And Cell.Value <= Evaluate(.Formula2)
                    Case xlNotBetween:   Test = Cell.Value <= Evaluate(.Formula1) Or Cell.Value >= Evaluate(.Formula2)
                    Case xlEqual:        Test = Evaluate(.Formula1) = Cell.Value
                    Case xlNotEqual:     Test = Evaluate(.Formula1) <> Cell.Value
                    Case xlGreater:      Test = Cell.Value > Evaluate(.Formula1)
                    Case xlLess:         Test = Cell.Value < Evaluate(.Formula1)
                    Case xlGreaterEqual: Test = Cell.Value >= Evaluate(.Formula1)
                    Case xlLessEqual:    Test = Cell.Value <= Evaluate(.Formula1)
                    End Select
                ElseIf .Type = xlExpression Then
                    Application.ScreenUpdating = False
                     'Cell.Select
                    F = Replace(.Formula1, "$", vbNullString)
                    F = Replace(F, CurrentCell, Cell.Address(0, 0))
                     'Test = Evaluate(.Formula1)
                    Test = Evaluate(F)
                     'Range(CurrentCell).Select
                    Application.ScreenUpdating = True
                End If
                If Test Then
                    If CellInterior Then
                        dColor = IIf(ReturnColorIndex, .Interior.ColorIndex, .Interior.Color)
                        If IsNull(dColor) Then
                            dColor = IIf(ReturnColorIndex, Cell.Interior.ColorIndex, Cell.Interior.Color)
                        End If
                    Else
                        dColor = IIf(ReturnColorIndex, .Font.ColorIndex, .Font.Color)
                        If IsNull(dColor) Then
                            dColor = IIf(ReturnColorIndex, Cell.Font.ColorIndex, Cell.Font.Color)
                        End If
                    End If
                    DisplayedColor = dColor
                    Exit Function
                End If
            End With
        Next
        If CellInterior Then
            dColor = IIf(ReturnColorIndex, Cell.Interior.ColorIndex, Cell.Interior.Color)
        Else
            dColor = IIf(ReturnColorIndex, Cell.Font.ColorIndex, Cell.Font.Color)
        End If
        DisplayedColor = dColor
         
    End Function
    '
    Private Function ExcelVersion() As String
        Dim temp                  As String
    
    
        'On Error Resume Next
    #If Mac Then
        Select Case Val(Application.Version)
            Case 11: temp = "Excel 2004"
            Case 12: temp = "Excel 2008" ' this should NEVER happen!
            Case 14: temp = "Excel 2011"
            Case 15: temp = "vNext"
            Case Else: temp = "Unknown"
        End Select
    #Else
        Select Case Val(Application.Version)
            Case 9: temp = "Excel 2000"
            Case 10: temp = "Excel 2002"
            Case 11: temp = "Excel 2003"
            Case 12: temp = "Excel 2007"
            Case 14: temp = "Excel 2010"
            Case 15: temp = "Excel 2013"
            Case Else: temp = "Unknown"
        End Select
    #End If
        ExcelVersion = temp
    End Function
    '
    '
    Private Function ColLtr(ByVal iCol As Long) As String
    ' shg 2012 Alan 2016 http://www.excelforum.com/tips-and-tutorials/1108643-vba-column-letter-from-column-number-explained.html
    ' Good for any positive Long
        If iCol > 0 Then
        ColLtr = ColLtr((iCol - 1) \ 26) & Chr(65 + (iCol - 1) Mod 26)
        Else
        End If
    End Function
    
    
    'Alan HTML Text for copy in HTML Window Bodge Wonk http://www.excelfox.com/forum/f13/bbcode-table-2077/#post9639
    '_____________________________________________________________________________
    Last edited by DocAElstein; 05-16-2016 at 02:00 PM.

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

    Rory is Playing With his Tool ;)

    ʅ_(ツ)_ʃ
    __|
    __|



    Excel 2007 32 bit
    got a new bit
    G
    H
    I
    5
    Rory appears to
    6
    be Playing with
    7
    his Tool Today
    Sheet: Molly


    http://www.mrexcel.com/forum/about-b...ad-code-2.html





    Using Excel 2007 32 bit
    Row\Col
    G
    H
    I
    5
    Rory appears to
    6
    be Playing with
    7
    his Tool Today
    Molly


    Edit has he lost his row abd column?
    or did I
    Excel 2007 32 bit
    G
    H
    I
    5
    Rory appears to
    6
    be Playing with
    7
    his Tool Today
    Sheet: Molly

    _......................................



    For Info on Add-Ins see my signature and
    http://www.excelforum.com/the-water-...ml#post4109080
    Last edited by DocAElstein; 05-28-2016 at 01:53 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!!

Similar Threads

  1. Replies: 12
    Last Post: 09-22-2023, 03:53 PM
  2. Replies: 5
    Last Post: 06-10-2019, 10:14 PM
  3. HTML Code Test --post8798
    By DocAElstein in forum Test Area
    Replies: 19
    Last Post: 06-17-2018, 03:02 PM
  4. CODE TAG Code Test
    By DocAElstein in forum Test Area
    Replies: 5
    Last Post: 09-16-2015, 05:16 PM

Posting Permissions

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