paper: New Scouting Database from Team 2834

[Ed Law]

Thread created automatically to discuss a document in CD-Media.

New Scouting Database from Team 2834 by Ed Law

[Ed Law]

I try to upload the Scouting Database but it says my file is too big. I will try to reduce the size but I will have to delete some of the data.

[Ed Law]

I split the database into two Excel file. You can stitch it back together if you want or just use part 1 without part 2.

[billbo911]

Originally Posted by Ed Law

I split the database into two Excel file. You can stitch it back together if you want or just use part 1 without part 2.

What size would the entire file be if you zipped it first?

[R.C.]

Originally Posted by billbo911

What size would the entire file be if you zipped it first?

If you email it to me I could upload it for you

[Ed Law]

Originally Posted by billbo911

What size would the entire file be if you zipped it first?

Thanks for reminding me of that option. It reduced it down to 1.4 Mb. I uploaded the zip file but now I can not delete the two files that were split into part 1 and part 2.

[Clinton Bolinger]

Very nice database of OPR and CCWM.

Got a few suggestions that might improve your excel file.

In order to make the getpicture sub to work every time a new query is requested, change your getpicture sub to the following functions:

Function getpicture(teamnum As String) As Boolean
    Dim filen as String
    
    If ActiveSheet.Name = "Query" Then
   
    Else
     GoTo Done
    End If

    Dim AC As Range
    Static P As Shape
    On Error GoTo Done
    Set AC = Application.Caller
    If PicExists(P) Then
    P.Delete
    Else
    'look for a picture already over cell
    For Each P In ActiveSheet.Shapes
    If P.Type = msoLinkedPicture Then
    If P.Left >= AC.Left And P.Left < AC.Left + AC.Width Then
    If P.Top >= AC.Top And P.Top < AC.Top + AC.Height Then
    P.Delete
    Exit For
    End If
    End If
    End If
    Next P
    End If
    filen = CurDir + "\" + Format(teamnum) + ".jpg"
    Set P = ActiveSheet.Shapes.AddPicture(filen, True, True, AC.Left + 2.75, AC.Top + 5, 329.25, 247.5)
    getpicture  = True
    Exit Function
Done:
    getpicture  = False
End Function

Function PicExists(P As Shape) As Boolean
    'Return true if P references an existing shape
    Dim ShapeName As String
    On Error GoTo NoPic
    If P Is Nothing Then GoTo NoPic
    ShapeName = P.Name
    PicExists = True
NoPic:
    PicExists = False
End Function

As for calling the function add the following to "I5":

=getpicture(B2)

Finally to make the query worksheet more user friendly, I would "unlock" cell B2. You can do this by right clicking on B2, Format Cells..., Click Protection, and uncheck Lock. Then you will want to protect the worksheet by going to Tools>Protection>Protect Sheet.. then add a password if you like and uncheck select locked cells. That way the only selectable cell would be "B2" on the Query worksheet.

Hope that helps and Thanks for the information.
-Oris-

[Ed Law]

Originally Posted by Oris

Very nice database of OPR and CCWM.

Got a few suggestions that might improve your excel file.

In order to make the getpicture sub to work every time a new query is requested, change your getpicture sub to the following functions:

Function getpicture(teamnum As String) As Boolean
    Dim filen as String
    
    If ActiveSheet.Name = "Query" Then
   
    Else
     GoTo Done
    End If

    Dim AC As Range
    Static P As Shape
    On Error GoTo Done
    Set AC = Application.Caller
    If PicExists(P) Then
    P.Delete
    Else
    'look for a picture already over cell
    For Each P In ActiveSheet.Shapes
    If P.Type = msoLinkedPicture Then
    If P.Left >= AC.Left And P.Left < AC.Left + AC.Width Then
    If P.Top >= AC.Top And P.Top < AC.Top + AC.Height Then
    P.Delete
    Exit For
    End If
    End If
    End If
    Next P
    End If
    filen = CurDir + "\" + Format(teamnum) + ".jpg"
    Set P = ActiveSheet.Shapes.AddPicture(filen, True, True, AC.Left + 2.75, AC.Top + 5, 329.25, 247.5)
    getpicture  = True
    Exit Function
Done:
    getpicture  = False
End Function

Function PicExists(P As Shape) As Boolean
    'Return true if P references an existing shape
    Dim ShapeName As String
    On Error GoTo NoPic
    If P Is Nothing Then GoTo NoPic
    ShapeName = P.Name
    PicExists = True
NoPic:
    PicExists = False
End Function

As for calling the function add the following to "I5":

=getpicture(B2)

Finally to make the query worksheet more user friendly, I would "unlock" cell B2. You can do this by right clicking on B2, Format Cells..., Click Protection, and uncheck Lock. Then you will want to protect the worksheet by going to Tools>Protection>Protect Sheet.. then add a password if you like and uncheck select locked cells. That way the only selectable cell would be "B2" on the Query worksheet.

Hope that helps and Thanks for the information.
-Oris-

Hi Oris,

Wow, thanks for the code. I spent a little bit of time but couldn't figure out how to do it yet. I will try it out this weekend and repost the database.

Does anybody know why I can not delete the two files that I don't need any more now that I am zipping the file to make it smaller?

Ed

[Clinton Bolinger]

Forgot one thing about protecting the worksheet, you will also have to check the "Edit Objects" box (scroll down 2nd from the bottom). This will allow for the "I8" robot picture to update correctly.

Look forward to seeing the new version.
-Oris-

[Ed Law]

Originally Posted by Oris

Forgot one thing about protecting the worksheet, you will also have to check the "Edit Objects" box (scroll down 2nd from the bottom). This will allow for the "I8" robot picture to update correctly.

Look forward to seeing the new version.
-Oris-

Hi Oris,

It is working now. Thank you. The picture automatically changes when the user type in a new team number in cell B2. One thing I have to change to get it to work is teamnum as Integer instead of teamnum as String.

The picture is okay if the aspect ratio is 4:3 but it get distorted if it is not. How can I maintain the aspect ratio? I tried to do it but was not successful. Can you take a look at the program and see what I did wrong?

I have decided not to protect the worksheet for now since I am still developing it.

Ed

[Clinton Bolinger]

After:

Set P = ActiveSheet.Shapes.AddPicture(filen, True, True, AC.Left + 2.5, AC.Top + 2.5, 329, 250)

Add:

    P.ScaleHeight 1, True
    P.ScaleWidth 1, True
    P.Height = 250

That should keep the aspect ratio of the pictures.

-Oris-

[Ed Law]

Originally Posted by Oris

After:

Set P = ActiveSheet.Shapes.AddPicture(filen, True, True, AC.Left + 2.5, AC.Top + 2.5, 329, 250)

Add:

    P.ScaleHeight 1, True
    P.ScaleWidth 1, True
    P.Height = 250

That should keep the aspect ratio of the pictures.

-Oris-

Hi Oris,

I tried it and it worked. However when I tried it on Excel 2007, I think it changes it back to its original size and then stretch it to Height = 250 without maintaining the aspect ratio. I tried a few things but none seems to work. Can anybody help? I would like to make this work for everybody as more and more people will be using Excel 2007. Thanks.

Ed

[Clinton Bolinger]

Originally Posted by Ed Law

Hi Oris,

I tried it and it worked. However when I tried it on Excel 2007, I think it changes it back to its original size and then stretch it to Height = 250 without maintaining the aspect ratio. I tried a few things but none seems to work. Can anybody help? I would like to make this work for everybody as more and more people will be using Excel 2007. Thanks.

Ed

Try replacing:

P.ScaleHeight 1, True
P.ScaleWidth 1, True
P.Height = 250

with:

P.LockAspectRatio = msoTrue
P.Height = 250

I don't have Excel 2007 on my current computer, so I didn't get a chance to test it.

-Oris-

[Ed Law]

This spreadsheet is working in Excel 2007 now. The change that Oris suggested works. It is now version 4. I still can not delete the old versions.

I will be posting the 2009 Scouting Database during X'mas break so we can see easily which teams are going to which regionals.

Ed

[Clinton Bolinger]

I got another one for you Ed to fix your opening issues.

Replace:

filen = CurDir + "\" + Format(teamnum) + ".jpg"

With:

Dim sCurDir As String
sCurDir = Mid(ThisWorkbook.FullName, 1, Len(ThisWorkbook.FullName) - Len(ThisWorkbook.Name))
filen = sCurDir + "\" + Format(teamnum) + ".jpg"

That way the team pictures will load if you open the file by double clicking, open recent, or file open.

Hope this helps,
-Oris-