• Home
 · 
• Math/Dates
 · 
• APIS INDEXES 1.0 This utilty calculate hantel, cubital index and discoidal shifts from Apis sp. for

APIS INDEXES 1.0 This utilty calculate hantel, cubital index and discoidal shifts from Apis sp. for

APIS INDEXES 1.0 This utilty calculate hantel, cubital index and discoidal shifts from Apis sp. forewings image. This software can be use

API Declarations


MsgBox "Author: Serdar Yüksel, Mail : [email protected], [email protected]"
End Sub



Rate APIS INDEXES 1.0 This utilty calculate hantel, cubital index and discoidal shifts from Apis sp. for

• 1
• 2
• 3
• 4
• 5

(2(2 Vote))

Text43.Text = 0
Picture1.Picture = LoadPicture(CommonDialog1.FileName)
Text1.Text = ""
Text2.Text = ""
Text3.Text = ""
Text4.Text = ""
Text5.Text = ""
Text6.Text = ""
Text7.Text = ""
Text8.Text = ""
Text9.Text = ""
Text10.Text = ""
Text11.Text = ""
Text12.Text = ""
Text13.Text = ""
Text14.Text = ""
Text15.Text = ""
Text16.Text = ""
Text17.Text = ""
Text18.Text = ""
Text19.Text = ""
Picture2.Cls
End Sub

Private Sub Command10_Click()
On Error Resume Next
Picture2.Width = Picture1.Width * 0.8
Picture2.Height = Picture1.Height * 0.8
Dim file_name As String

    ' Resize the picture.
    Picture2.AutoRedraw = True
    Picture2.PaintPicture Picture1.Picture, _
        Picture2.ScaleLeft, Picture2.ScaleTop, Picture2.ScaleWidth, Picture2.ScaleHeight, _
        Picture1.ScaleLeft, Picture1.ScaleTop, Picture1.ScaleWidth, Picture1.ScaleHeight
    Picture2.Picture = Picture2.Image

    ' Save the result.
    file_name = App.Path
    If Right$(file_name, 1) <> "\" Then file_name = file_name & "\"
    SavePicture Picture2.Picture, file_name & "specimens.bmp"
End Sub

Private Sub Command11_Click()
On Error Resume Next
Picture2.Width = Picture1.Width * 0.2
Picture2.Height = Picture1.Height * 0.2
Dim file_name As String

    ' Resize the picture.
    Picture2.AutoRedraw = True
    Picture2.PaintPicture Picture1.Picture, _
        Picture2.ScaleLeft, Picture2.ScaleTop, Picture2.ScaleWidth, Picture2.ScaleHeight, _
        Picture1.ScaleLeft, Picture1.ScaleTop, Picture1.ScaleWidth, Picture1.ScaleHeight
    Picture2.Picture = Picture2.Image

    ' Save the result.
    file_name = App.Path
    If Right$(file_name, 1) <> "\" Then file_name = file_name & "\"
    SavePicture Picture2.Picture, file_name & "specimens.bmp"
End Sub

Private Sub Command12_Click()
On Error Resume Next
Picture2.Width = Picture1.Width * 0.1
Picture2.Height = Picture1.Height * 0.1
Dim file_name As String

    ' Resize the picture.
    Picture2.AutoRedraw = True
    Picture2.PaintPicture Picture1.Picture, _
        Picture2.ScaleLeft, Picture2.ScaleTop, Picture2.ScaleWidth, Picture2.ScaleHeight, _
        Picture1.ScaleLeft, Picture1.ScaleTop, Picture1.ScaleWidth, Picture1.ScaleHeight
    Picture2.Picture = Picture2.Image

    ' Save the result.
    file_name = App.Path
    If Right$(file_name, 1) <> "\" Then file_name = file_name & "\"
    SavePicture Picture2.Picture, file_name & "specimens.bmp"
End Sub

Private Sub Command13_Click()
On Error Resume Next
Picture2.Width = Picture1.Width * 3
Picture2.Height = Picture1.Height * 3
Dim file_name As String

    ' Resize the picture.
    Picture2.AutoRedraw = True
    Picture2.PaintPicture Picture1.Picture, _
        Picture2.ScaleLeft, Picture2.ScaleTop, Picture2.ScaleWidth, Picture2.ScaleHeight, _
        Picture1.ScaleLeft, Picture1.ScaleTop, Picture1.ScaleWidth, Picture1.ScaleHeight
    Picture2.Picture = Picture2.Image

    ' Save the result.
    file_name = App.Path
    If Right$(file_name, 1) <> "\" Then file_name = file_name & "\"
    SavePicture Picture2.Picture, file_name & "specimens.bmp"
End Sub







Private Sub Command3_Click()
On Error Resume Next
Dim ab, bc, disk
ab = Sqr(((Val(Text11) - Val(Text9)) ^ 2) + ((Val(Text12) - Val(Text10)) ^ 2))
bc = Sqr(((Val(Text13) - Val(Text11)) ^ 2) + ((Val(Text14) - Val(Text12)) ^ 2))
disk = Round(ab / bc, 3)
Text17.Text = disk
Dim hab, hbc, hant
hab = Sqr(((Val(Text7) - Val(Text5)) ^ 2) + ((Val(Text8) - Val(Text6)) ^ 2))
hbc = Sqr(((Val(Text13) - Val(Text9)) ^ 2) + ((Val(Text14) - Val(Text10)) ^ 2))
hant = Round(hbc / hab, 3)
Text18.Text = hant


Dim ma, mb, Shift, tanq, ta, tb, tc, td, te, tf, tg, th As Single

Dim PI As Integer
PI = 3.14159265358979
ta = Val(Text1)
tb = Val(Text2)
tc = Val(Text3)
td = Val(Text4)
te = Val(Text5)
tf = Val(Text6)
tg = Val(Text15)
th = Val(Text16)
ma = (td - tb) / (tc - ta)
mb = (th - tf) / (tg - te)

tanq = (mb - ma) / (ma * mb + 1)
Shift = Round(Atn(tanq) * 180 / PI, 2)
If Shift > 0 Then
Text19.Text = Shift - 90
End If
If Shift < 0 Then
Text19.Text = 90 + Shift
End If
If Shift = 0 Then
Text19.Text = 0
End If

List1.AddItem "Cubital index"
List1.AddItem Text17.Text
List1.AddItem "Hental index"
List1.AddItem Text18.Text
List1.AddItem "Discoidal Shift Angle"
List1.AddItem Text19.Text
List1.AddItem "Project file name"
List1.AddItem CommonDialog1.FileName


End Sub



Private Sub Command5_Click()
On Error Resume Next
Picture2.Width = Picture1.Width * 1.2
Picture2.Height = Picture1.Height * 1.2
Dim file_name As String

    ' Resize the picture.
    Picture2.AutoRedraw = True
    Picture2.PaintPicture Picture1.Picture, _
        Picture2.ScaleLeft, Picture2.ScaleTop, Picture2.ScaleWidth, Picture2.ScaleHeight, _
        Picture1.ScaleLeft, Picture1.ScaleTop, Picture1.ScaleWidth, Picture1.ScaleHeight
    Picture2.Picture = Picture2.Image

    ' Save the result.
    file_name = App.Path
    If Right$(file_name, 1) <> "\" Then file_name = file_name & "\"
    SavePicture Picture2.Picture, file_name & "specimens.bmp"
End Sub
Private Sub Command6_Click()
On Error Resume Next
Picture2.Width = Picture1.Width * 1.8
Picture2.Height = Picture1.Height * 1.8
Dim file_name As String

    ' Resize the picture.
    Picture2.AutoRedraw = True
    Picture2.PaintPicture Picture1.Picture, _
        Picture2.ScaleLeft, Picture2.ScaleTop, Picture2.ScaleWidth, Picture2.ScaleHeight, _
        Picture1.ScaleLeft, Picture1.ScaleTop, Picture1.ScaleWidth, Picture1.ScaleHeight
    Picture2.Picture = Picture2.Image

    ' Save the result.
    file_name = App.Path
    If Right$(file_name, 1) <> "\" Then file_name = file_name & "\"
    SavePicture Picture2.Picture, file_name & "specimens.bmp"
End Sub

Private Sub Command7_Click()
On Error Resume Next
Picture2.Width = Picture1.Width * 2.4
Picture2.Height = Picture1.Height * 2.4
Dim file_name As String

    ' Resize the picture.
    Picture2.AutoRedraw = True
    Picture2.PaintPicture Picture1.Picture, _
        Picture2.ScaleLeft, Picture2.ScaleTop, Picture2.ScaleWidth, Picture2.ScaleHeight, _
        Picture1.ScaleLeft, Picture1.ScaleTop, Picture1.ScaleWidth, Picture1.ScaleHeight
    Picture2.Picture = Picture2.Image

    ' Save the result.
    file_name = App.Path
    If Right$(file_name, 1) <> "\" Then file_name = file_name & "\"
    SavePicture Picture2.Picture, file_name & "specimens.bmp"
End Sub

Private Sub Command8_Click()
On Error Resume Next
Picture2.Width = Picture1.Width * 1
Picture2.Height = Picture1.Height * 1
Dim file_name As String

    ' Resize the picture.
    Picture2.AutoRedraw = True
    Picture2.PaintPicture Picture1.Picture, _
        Picture2.ScaleLeft, Picture2.ScaleTop, Picture2.ScaleWidth, Picture2.ScaleHeight, _
        Picture1.ScaleLeft, Picture1.ScaleTop, Picture1.ScaleWidth, Picture1.ScaleHeight
    Picture2.Picture = Picture2.Image

    ' Save the result.
    file_name = App.Path
    If Right$(file_name, 1) <> "\" Then file_name = file_name & "\"
    SavePicture Picture2.Picture, file_name & "specimens.bmp"
End Sub

Private Sub Command9_Click()
On Error Resume Next
Picture2.Width = Picture1.Width * 0.5
Picture2.Height = Picture1.Height * 0.5
Dim file_name As String

    ' Resize the picture.
    Picture2.AutoRedraw = True
    Picture2.PaintPicture Picture1.Picture, _
        Picture2.ScaleLeft, Picture2.ScaleTop, Picture2.ScaleWidth, Picture2.ScaleHeight, _
        Picture1.ScaleLeft, Picture1.ScaleTop, Picture1.ScaleWidth, Picture1.ScaleHeight
    Picture2.Picture = Picture2.Image

    ' Save the result.
    file_name = App.Path
    If Right$(file_name, 1) <> "\" Then file_name = file_name & "\"
    SavePicture Picture2.Picture, file_name & "specimens.bmp"
End Sub


Private Sub ext_Click()
Unload Me
End Sub


Private Sub Check1_Click()
If Check1.Value = 1 Then
Image1.Visible = True
End If
If Check1.Value = 0 Then
Image1.Visible = False
End If
End Sub

Private Sub Form_Load()
List1.AddItem "   Apis Indexes Result"
List1.AddItem ""
List1.AddItem "Landmarks (X;Y)"
End Sub

Private Sub Image2_Click()
Command3_Click
End Sub

Private Sub Image3_Click()
savelandmark_Click
End Sub

Private Sub Image4_Click()
oimage_Click
End Sub





Private Sub Image5_Click()
Command1_Click
End Sub

Private Sub oimage_Click()
CommonDialog1.Filter = "JPG files (*.JPG)|*.jpg|BMP files(*.bmp)|*.bmp|JPE files(*.jpe)|*.jpe|GIF files(*.gif)|*.gif|wmf files(*.wmf)|*.wmf|All files(*.*)|*.*|"
CommonDialog1.ShowOpen
On Error Resume Next
Picture1.Picture = LoadPicture(CommonDialog1.FileName)
land.Caption = CommonDialog1.FileName
Command8_Click
End Sub

Private Sub picture2_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim hg
Text44.Text = X
Text45.Text = Y
hg = Picture2.Height / 15.39893



List1.AddItem Text44.Text + ";" + Text45.Text
Text43.Text = Text43.Text + 1

Picture2.Circle (X, Y), 2, vbBlue
If Text43.Text = 1 Then
Text1.Text = X
Text2 = Round(hg - Y)
End If

If Text43.Text = 2 Then
Text3.Text = X
Text4 = Round(hg - Y)
End If

If Text43.Text = 3 Then
Text5.Text = X
Text6.Text = Round(hg - Y)
End If

If Text43.Text = 4 Then
Text7.Text = X
Text8.Text = Round(hg - Y)
End If
If Text43.Text = 5 Then
Text9.Text = X
Text10.Text = Round(hg - Y)

End If
If Text43.Text = 6 Then
Text11.Text = X
Text12.Text = Round(hg - Y)
End If

If Text43.Text = 7 Then
Text13.Text = X
Text14.Text = Round(hg - Y)

End If
If Text43.Text = 8 Then
Text15.Text = X
Text16.Text = Round(hg - Y)

End If

End Sub

Private Sub Picture3_Click()

End Sub

Private Sub savelandmark_Click()
Dim a As String
For X = 0 To List1.ListCount - 1
a = a & List1.List(X) & vbTab & vbCrLf
Next X
Text44.Text = Text44.Text + a

CommonDialog2.Filter = "text files(*.TXT)|*.txt|"
    CommonDialog2.ShowSave      'display Save dialog
    If CommonDialog2.FileName <> "" Then
        Open CommonDialog2.FileName For Output As #1
        Print #1, Text44.Text  'save string to file
        Close #1                'close file
    End If
End Sub