Sub CardText()

'for use on player sheets



Dim icard As Integer
Dim irow As Integer
Dim gg As Integer
Dim hh As Integer

ActiveSheet.Select
'Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual



'CHARACTERS
[B5:B14].ClearComments
For gg = 5 To 14
For hh = 2 To 2
    irow = 0
    stext = Null
    If Len(Cells(gg, hh).Value) > 0 Then
        Call cardfind(Cells(gg, hh).Value, irow)
        Call boxme(gg, hh, irow)
    End If
    
Next hh
Next gg
On Error Resume Next

'-------------------------------------


[B17:B25].ClearComments
For gg = 17 To 25
For hh = 2 To 2
    irow = 0
    stext = Null
    If Len(Cells(gg, hh).Value) > 0 Then
        Call cardfind(Cells(gg, hh).Value, irow)
        Call boxme(gg, hh, irow)
    End If
    
Next hh
Next gg
On Error Resume Next


'-------------------------------------


[B27:B34].ClearComments
For gg = 27 To 34
For hh = 2 To 2
    irow = 0
    stext = Null
    If Len(Cells(gg, hh).Value) > 0 Then
        Call cardfind(Cells(gg, hh).Value, irow)
        Call boxme(gg, hh, irow)
    End If
    
Next hh
Next gg
On Error Resume Next


'-------------------------------------


[B36:B41].ClearComments
For gg = 36 To 41
For hh = 2 To 2
    irow = 0
    stext = Null
    If Len(Cells(gg, hh).Value) > 0 Then
        Call cardfind(Cells(gg, hh).Value, irow)
        Call boxme(gg, hh, irow)
    End If
    
Next hh
Next gg
On Error Resume Next








'============================================================
'RESOURCES AND HAZARDS
[N5:z14].ClearComments
'For gg = 5 To 14
'For hh = 14 To 26
For Each mycell In Range("N5:Z14")
    gg = mycell.Row
    hh = mycell.Column
    irow = 0
    stext = Null
    If Len(Cells(gg, hh).Value) > 0 Then
        Call cardfind(Cells(gg, hh).Value, irow)
        Call boxme(gg, hh, irow)
    End If
    
'Next hh
'Next gg
Next
On Error Resume Next

'-------------------------------------


[N17:z25].ClearComments
For gg = 17 To 25
For hh = 14 To 26
    irow = 0
    stext = Null
    If Len(Cells(gg, hh).Value) > 0 Then
        Call cardfind(Cells(gg, hh).Value, irow)
        Call boxme(gg, hh, irow)
    End If
    
Next hh
Next gg
On Error Resume Next


'-------------------------------------


[N27:z34].ClearComments
For gg = 27 To 34
For hh = 14 To 26
    irow = 0
    stext = Null
    If Len(Cells(gg, hh).Value) > 0 Then
        Call cardfind(Cells(gg, hh).Value, irow)
        Call boxme(gg, hh, irow)
    End If
    
Next hh
Next gg
On Error Resume Next


'-------------------------------------


[N36:z41].ClearComments
For gg = 36 To 41
For hh = 14 To 26
    irow = 0
    stext = Null
    If Len(Cells(gg, hh).Value) > 0 Then
        Call cardfind(Cells(gg, hh).Value, irow)
        Call boxme(gg, hh, irow)
    End If
    
Next hh
Next gg
On Error Resume Next


'-------------------------------------
[R46:R80].ClearComments
For gg = 46 To 80
    irow = 0
    stext = Null
    If Len(Cells(gg, 18).Value) > 0 Then
        Call cardfind(Cells(gg, 18).Value, irow)
        Call boxme(gg, 18, irow)
    End If
Next gg
On Error Resume Next

'-------------------------------------
[Y46:Y80].ClearComments
For gg = 46 To 80
    irow = 0
    stext = Null
    If Len(Cells(gg, 25).Value) > 0 Then
        Call cardfind(Cells(gg, 25).Value, irow)
        Call boxme(gg, 25, irow)
    End If
Next gg
On Error Resume Next



'''former slot to update events at top of player sheets.

Call findterr


'Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub

Sub cardfind(meccgcard As String, zrow As Integer)

Dim rall As Range
Set rall = Worksheets("All").Range("C5:C5000")

With rall
    Set c = .Find(meccgcard, LookIn:=xlValues, LookAt:=xlWhole)
    If Not c Is Nothing Then
        firstAddress = c.Address
        Do
            zrow = c.Row
            Set c = .FindNext(c)
        Loop While Not c Is Nothing And c.Address <> firstAddress
    End If
End With


End Sub


Sub boxme(ff As Integer, ii As Integer, xrow As Integer)

Dim mysheet As Worksheet
Dim strchar As String

Set mysheet = Worksheets("All")
strchar = ""

strchar = mysheet.Cells(xrow, 3).Value & Chr(10)
strchar = strchar & mysheet.Cells(xrow, 4).Value & "---" & mysheet.Cells(xrow, 5).Value & "---" & mysheet.Cells(xrow, 6).Value & "---" & mysheet.Cells(xrow, 7).Value & Chr(10)
strchar = strchar & mysheet.Cells(xrow, 8).Value

 With ActiveSheet.Cells(ff, ii)
    .AddComment Text:=strchar
    .Comment.Shape.TextFrame.Characters.Font.Size = 12
    .Comment.Shape.Height = 300
    .Comment.Shape.Width = 350
End With

End Sub

Public Sub findterr()
'Public Sub findterr(player As String)
Dim strterr As String
Dim strsite As String
Dim strregion As String
Dim strhaven As String
Dim strpath As String
Dim mytext As String
Dim player As String
Dim itapped As Byte
Dim alist As String   'string for agents at site

Dim mysheet As Worksheet
Dim myrange As Range
Dim minrange As Range



Set mysheet = ActiveSheet
player = Range("AC1").Value

Select Case player
Case "hero"
    Set myrange = Sheets("Hsites").Range("A4:T514")
Case "minion"
    Set myrange = Sheets("Msites").Range("A4:T514")
Case "balrog"
    Set myrange = Sheets("Bsites").Range("A4:T514")
Case "dragon"
    Set myrange = Sheets("Dsites").Range("A4:T514")
End Select



strterr = ""
strsite = ""
strregion = ""
strpath = ""
alist = ""

Range("B4").ClearComments
'sname = Left(scard, InStr(1, scard, "---") - 1)
strsite = ActiveSheet.Range("B4")
If InStr(1, strsite, ".") > 0 Then
    strsite = Left(strsite, InStr(1, strsite, ".") - 1)
End If
strhaven = "Nearest Haven: " & Application.WorksheetFunction.VLookup(strsite, myrange, 5, False)
strregion = Application.WorksheetFunction.VLookup(strsite, myrange, 2, False)
strpath = Application.WorksheetFunction.VLookup(strsite, myrange, 4, False)
strterr = Application.WorksheetFunction.VLookup(strsite, myrange, 17, False)

mytext = strsite & Chr(10) & strhaven & Chr(10) & strregion & "  +  " & strpath & Chr(10) & "---" & strterr & Chr(10) & Chr(10)
With ActiveSheet.Cells(4, 2)
    .AddComment Text:=mytext
    .Comment.Shape.TextFrame.Characters.Font.Size = 12
    .Comment.Shape.Height = 300
    .Comment.Shape.Width = 300
End With




strterr = ""
strsite = ""
strregion = ""
alist = ""

Range("B16").ClearComments
strsite = ActiveSheet.Range("B16")
If strsite = "." Then GoTo Line2
If InStr(1, strsite, ".") > 0 Then
    strsite = Left(strsite, InStr(1, strsite, ".") - 1)
End If
strhaven = "Nearest Haven: " & Application.WorksheetFunction.VLookup(strsite, myrange, 5, False)
strregion = Application.WorksheetFunction.VLookup(strsite, myrange, 2, False)
strpath = Application.WorksheetFunction.VLookup(strsite, myrange, 4, False)
strterr = Application.WorksheetFunction.VLookup(strsite, myrange, 17, False)

mytext = strsite & Chr(10) & strhaven & Chr(10) & strregion & "  +  " & strpath & Chr(10) & "---" & strterr & Chr(10) & Chr(10)
With ActiveSheet.Cells(16, 2)
    .AddComment Text:=mytext
    .Comment.Shape.TextFrame.Characters.Font.Size = 12
    .Comment.Shape.Height = 300
    .Comment.Shape.Width = 300
End With




Line2:

strterr = ""
strsite = ""
strregion = ""
alist = ""

Range("B26").ClearComments
strsite = ActiveSheet.Range("B26")
If strsite = "." Then GoTo Line3
If InStr(1, strsite, ".") > 0 Then
    strsite = Left(strsite, InStr(1, strsite, ".") - 1)
End If
strhaven = "Nearest Haven: " & Application.WorksheetFunction.VLookup(strsite, myrange, 5, False)
strregion = Application.WorksheetFunction.VLookup(strsite, myrange, 2, False)
strpath = Application.WorksheetFunction.VLookup(strsite, myrange, 4, False)
strterr = Application.WorksheetFunction.VLookup(strsite, myrange, 17, False)

mytext = strsite & Chr(10) & strhaven & Chr(10) & strregion & "  +  " & strpath & Chr(10) & "---" & strterr & Chr(10) & Chr(10)
With ActiveSheet.Cells(26, 2)
    .AddComment Text:=mytext
    .Comment.Shape.TextFrame.Characters.Font.Size = 12
    .Comment.Shape.Height = 300
    .Comment.Shape.Width = 300
End With



Line3:
strterr = ""
strsite = ""
strregion = ""
alist = ""

Range("B35").ClearComments
strsite = ActiveSheet.Range("B35")
If strsite = "." Then GoTo Line4
If InStr(1, strsite, ".") > 0 Then
    strsite = Left(strsite, InStr(1, strsite, ".") - 1)
End If
strhaven = "Nearest Haven: " & Application.WorksheetFunction.VLookup(strsite, myrange, 5, False)
strregion = Application.WorksheetFunction.VLookup(strsite, myrange, 2, False)
strpath = Application.WorksheetFunction.VLookup(strsite, myrange, 4, False)
strterr = Application.WorksheetFunction.VLookup(strsite, myrange, 17, False)


mytext = strsite & Chr(10) & strhaven & Chr(10) & strregion & "  +  " & strpath & Chr(10) & "---" & strterr & Chr(10) & Chr(10)
With ActiveSheet.Cells(35, 2)
    .AddComment Text:=mytext
    .Comment.Shape.TextFrame.Characters.Font.Size = 12
    .Comment.Shape.Height = 300
    .Comment.Shape.Width = 300
End With


Line4:

End Sub



Sub printRegionNames()
' alt F8
'shortcut  ctrl + Shf + E

Dim mysheet As Worksheet
Dim mr()

Set mysheet = ActiveSheet

[B7:B14].Clear

        
Set myShapeRange = Selection.ShapeRange
With myShapeRange
    num = .Count
    ReDim mr(1 To num)
    For ii = 1 To num
        sstr = .Item(ii).Name
        mr(ii) = Val(sstr)
        Debug.Print sstr
        Cells(6 + ii, 2).Value = sstr
    Next ii
End With
    
End Sub


Sub bev_player()

Range("A3").Value = ActiveSheet.Shapes(Application.Caller).TextFrame.Characters.Text
End Sub
Sub bev_company()

Range("A4").Value = ActiveSheet.Shapes(Application.Caller).TextFrame.Characters.Text
End Sub

Sub CopyRegionNames()
Dim mysheet As Worksheet
Dim playersheet As Worksheet
Dim comprange As Range

Set mysheet = ActiveSheet

sht = mysheet.Range("A3").Value
sht = Application.WorksheetFunction.Substitute(sht, " ", "")
comp = mysheet.Range("A4").Value
mysheet.Range("B7:B14").Select
Selection.Copy

Set playersheet = Sheets(sht)
playersheet.Activate

Select Case comp
Case "company 1"
    Set comprange = playersheet.Range("AD5")
Case "company 2"
    Set comprange = playersheet.Range("AD17")
Case "company 3"
    Set comprange = playersheet.Range("AD27")
Case "company 4"
    Set comprange = playersheet.Range("AD36")
End Select


playersheet.Select
comprange.Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
Range("AD1").Select



End Sub





Sub gamepic()

Dim HpermHazrange As Range
Dim HlongHazrange As Range
Dim HpermRESrange As Range
Dim HlongRESrange As Range
Dim cdivision As String
Dim copponent As String
Dim calignment As String

cdivision = Range("AC2").Value
copponent = Range("AB2").Value
calignment = Range("AC1").Value

Call CopyHand(calignment)
Range("A1").Select

cplayer = Range("N1").Value
Call Show_Cards_player(cdivision)


End Sub

Sub CopyHand(player As String)

Dim ref_name As String
ref_name = "images"

Select Case player
Case "hero"
    Sheets(ref_name).Range("AN5:CN14").Copy
Case "minion"
    Sheets(ref_name).Range("AN17:CN26").Copy
Case "balrog"
    Sheets(ref_name).Range("AN30:CN39").Copy
Case "dragon"
    Sheets(ref_name).Range("AN43:CN52").Copy
End Select

    ActiveSheet.Range("AL5").Select
    ActiveSheet.Paste
    Range("A1").Select


End Sub

Sub Show_Cards_player(division As String)


Select Case division
Case "p1Hero"
    Set HpermRESrange = Sheets("p1Hero").Range("AL5:CK14")
Case "p2Hero"
    Set HpermRESrange = Sheets("p2Hero").Range("AL5:CK14")
Case "p1Minion"
    Set HpermRESrange = Sheets("p1Minion").Range("AL5:CK14")
Case "p2Minion"
    Set HpermRESrange = Sheets("p2Minion").Range("AL5:CK14")
Case "p1Balrog"
    Set HpermRESrange = Sheets("p1Balrog").Range("AL5:CK14")
Case "p2Balrog"
    Set HpermRESrange = Sheets("p2Balrog").Range("AL5:CK14")
Case "p1Dragon"
    Set HpermRESrange = Sheets("p1Dragon").Range("AL5:CK14")
Case "p2Dragon"
    Set HpermRESrange = Sheets("p2Dragon").Range("AL5:CK14")


'resource perm
For Each c In HpermRESrange
    If c.Value <> 0 Then
        FnImageInsert (c.Value)
    End If
Next c
End Sub

Function FnImageInsert(strCompleteImagePath)

Dim objWord
Dim objDoc
Dim objSelection
Dim objShapes

   'Set objWord = CreateObject("Word.Application")

Set objDoc = GetObject("E:\metw\OpenMe1.docx")

   'objDoc.Visible = True

   'Set objSelection = objDoc.Selection

   'objSelection.TypeText (vbCrLf & "One Picture will be inserted here....")

Set objShapes = objDoc.InlineShapes
 
objShapes.AddPicture (strCompleteImagePath)


End Function



Sub AddOlEObject()
'used alone, file names written to Column B.
    Dim mainWorkBook As Workbook

    Set mainWorkBook = ActiveWorkbook
    ActiveSheet.Activate
    Folderpath = "D:\Metw\Firstborn_promo"
    Set fso = CreateObject("Scripting.FileSystemObject")
    NoOfFiles = fso.GetFolder(Folderpath).Files.Count
    Set listfiles = fso.GetFolder(Folderpath).Files
    For Each fls In listfiles
       strCompFilePath = Folderpath & "\" & Trim(fls.Name)
        If strCompFilePath <> "" And Right(fls.Name, 6) <> "RW.jpg" Then
            If (InStr(1, strCompFilePath, "jpg", vbTextCompare) > 1 _
            Or InStr(1, strCompFilePath, "jpeg", vbTextCompare) > 1 _
            Or InStr(1, strCompFilePath, "png", vbTextCompare) > 1) Then
                counter = counter + 1
                ActiveSheet.Range("k" & counter).Value = strCompFilePath
                'ActiveSheet.Range("B" & counter).ColumnWidth = 25
                'ActiveSheet.Range("B" & counter).RowHeight = 100
                'ActiveSheet.Range("B" & counter).Activate
                'Call insert(strCompFilePath, counter)
                ActiveSheet.Activate
            End If
        End If
    Next
mainWorkBook.Save
End Sub

Function insert(PicPath, counter)
'MsgBox PicPath
'not used
    With ActiveSheet.Pictures.insert(PicPath)
        With .ShapeRange
            .LockAspectRatio = msoTrue
            .Width = 60
            .Height = 84
        End With
        .Left = ActiveSheet.Range("B" & counter).Left
        .Top = ActiveSheet.Range("B" & counter).Top
        .Placement = 1
        .PrintObject = True
    End With
End Function