数码管编码程序

只看该作者 · 2011-3-13 14:51

本帖最后由 sunruiyeyipeng 于 2011-3-13 20:32 编辑

这个VB程序（

CodeMaker.rar (6.78 KB) ）用来生成【共阴/共阳】数码管的字型码。代码如下：
希望高手能看懂，说不定，优化这个代码。
Function creatcode()
'Creat Mask Code By
Dim codes As String
codes = getio(Ldp) & getio(Lg) & getio(Lf) & getio(Le) & getio(Ld) & getio(Lc) & getio(Lb) & getio(La)
Call bintohex(codes)
End Function
Function getio(objt As Object)
If objt.BackColor = vbWhite Then
      getio = "0"
Else
      getio = "1"
End If
End Function
Function bintohex(ByVal str As String)
Dim i As Integer
Dim b, c As Long
'MsgBox str
For i = 1 To 4
      b = b + Val(Mid(str, i, 1)) * 2 ^ (4 - i)
Next i
For i = 5 To 8
      c = c + Val(Mid(str, i, 1)) * 2 ^ (8 - i)
Next i
'MsgBox "b=" & b & "  c=" & c
Text1 = "0x" & hexs(b) & hexs(c)
End Function
Function hexs(ByVal s As Variant)
Select Case Val(s)
      Case 0 To 9
         hexs = s
      Case 10
         hexs = "a"
      Case 11
         hexs = "b"
      Case 12
         hexs = "c"
      Case 13
         hexs = "d"
      Case 14
         hexs = "e"
      Case 15
         hexs = "f"
End Select
End Function
Private Sub Command1_Click()
End
End Sub
Private Sub Command2_Click()
La.BackColor = vbWhite
Lb.BackColor = vbWhite
Lc.BackColor = vbWhite
Ld.BackColor = vbWhite
Le.BackColor = vbWhite
Lf.BackColor = vbWhite
Lg.BackColor = vbWhite
Ldp.BackColor = vbWhite
Text1.Text = ""
End Sub

Private Sub La_Click()
If La.BackColor = vbWhite Then
      La.BackColor = vbRed
Else
      La.BackColor = vbWhite
End If
Call creatcode
End Sub
Private Sub Lb_Click()
If Lb.BackColor = vbWhite Then
      Lb.BackColor = vbRed
Else
      Lb.BackColor = vbWhite
End If
Call creatcode
End Sub
Private Sub Lc_Click()
If Lc.BackColor = vbWhite Then
      Lc.BackColor = vbRed
Else
      Lc.BackColor = vbWhite
End If
Call creatcode
End Sub
Private Sub Ld_Click()
If Ld.BackColor = vbWhite Then
      Ld.BackColor = vbRed
Else
      Ld.BackColor = vbWhite
End If
Call creatcode
End Sub
Private Sub Ldp_Click()
If Ldp.BackColor = vbWhite Then
      Ldp.BackColor = vbRed
Else
      Ldp.BackColor = vbWhite
End If
Call creatcode
End Sub
Private Sub Le_Click()
If Le.BackColor = vbWhite Then
      Le.BackColor = vbRed
Else
      Le.BackColor = vbWhite
End If
Call creatcode
End Sub
Private Sub Lf_Click()
If Lf.BackColor = vbWhite Then
      Lf.BackColor = vbRed
Else
      Lf.BackColor = vbWhite
End If
Call creatcode
End Sub
Private Sub Lg_Click()
If Lg.BackColor = vbWhite Then
      Lg.BackColor = vbRed
Else
      Lg.BackColor = vbWhite
End If
Call creatcode
End Sub