49 各种进制转换Function Bin2Dec(InputData As String) As Double '二进制转变成十进制
Dim DecOut As Double:Dim I As Integer:Dim LenBin As Double:Dim JOne As String
LenBin = Len(InputData) '确认是否为二进制数
For I = 1 To LenBin
JOne = Mid(InputData, I, 1)
If JOne <> "0" And JOne <> "1" Then
MsgBox "NOT A BINARY NUMBER", vbCritical
Exit Function
End If
Next I
DecOut = 0
For I = Len(InputData) To 1 Step -1
If Mid(InputData, I, 1) = "1" Then
DecOut = DecOut + 2 ^ (Len(InputData) - I)
End If
Next I
Bin2Dec = DecOut
End Function
Function Dec2Bin(InputData As Double) As String '十进制转变为二进制
Dim Quot As Double:Dim Remainder As Double:Dim BinOut As String:Dim I As Integer
Dim NewVal As Double:Dim TempString As String:Dim TempVal As Double
Dim BinTemp As String:Dim BinTemp1 As String:Dim PosDot As Integer
Dim Temp2 As String
'检查是否为十进制的小数点
If InStr(1, CStr(InputData), ".") Then
MsgBox "Only Whole Numbers can be converted", vbCritical
GoTo eds
End If
BinOut = ""
NewVal = InputData
DoAgain: '开始计算
NewVal = (NewVal / 2) '如果有余数
If InStr(1, CStr(NewVal), ".") Then
BinOut = BinOut + "1" '得到余数
NewVal = Format(NewVal, "#0")
NewVal = (NewVal - 1)
If NewVal < 1 Then
GoTo DoneIt
End If
Else
BinOut = BinOut + "0"
If NewVal < 1 Then
GoTo DoneIt
End If
End If
GoTo DoAgain
DoneIt:
BinTemp = "" '颠倒结果
For I = Len(BinOut) To 1 Step -1
BinTemp1 = Mid(BinOut, I, 1)
BinTemp = BinTemp + BinTemp1
Next I
BinOut = BinTemp '输出结果
Dec2Bin = BinOut
eds:
End Function
Function Bin2Hex(InputData As String) As String '二进制转变成十六进制
Dim I As Integer:Dim LenBin As Integer:Dim JOne As String:Dim NumBlocks As Integer
Dim FullBin As String:Dim HexOut As String:Dim TempBinBlock As String
Dim TempHex As String
LenBin = Len(InputData)'确认是否为二进制数
For I = 1 To LenBin
JOne = Mid(InputData, I, 1)
If JOne <> "0" And JOne <> "1" Then
MsgBox "NOT A BINARY NUMBER", vbCritical
Exit Function
End If
Next I '设置二进制变量
FullBin = InputData ' 如果这个值的长度小于4,则补0
If LenBin < 4 Then
If LenBin = 3 Then
FullBin = "0" + FullBin
ElseIf LenBin = 2 Then
FullBin = "00" + FullBin
ElseIf LenBin = 1 Then
FullBin = "000" + FullBin
ElseIf LenBin = 0 Then
MsgBox "Nothing Given..", vbCritical
Exit Function
End If
NumBlocks = 1
GoTo DoBlocks
End If
If LenBin = 4 Then
NumBlocks = 1
GoTo DoBlocks
End If
If LenBin > 4 Then
Dim TempHold As Currency
Dim TempDiv As Currency
Dim AfterDot As Integer
Dim Pos As Integer
TempHold = Len(InputData)
TempDiv = (TempHold / 4)
Pos = InStr(1, CStr(TempDiv), ".")
If Pos = 0 Then
NumBlocks = TempDiv
GoTo DoBlocks
End If
AfterDot = Mid(CStr(TempDiv), (Pos + 1))
If AfterDot = 25 Then
FullBin = "000" + FullBin
NumBlocks = (Len(FullBin) / 4)
ElseIf AfterDot = 5 Then
FullBin = "00" + FullBin
NumBlocks = (Len(FullBin) / 4)
ElseIf AfterDot = 75 Then
FullBin = "0" + FullBin
NumBlocks = (Len(FullBin) / 4)
Else
MsgBox "Big Time Screw up happened, WAHHHHHHHHHHH", vbInformation
Exit Function
End If
GoTo DoBlocks
End If
DoBlocks:
HexOut = ""
For I = 1 To Len(FullBin) Step 4
TempBinBlock = Mid(FullBin, I, 4)
If TempBinBlock = "0000" Then
HexOut = HexOut + "0"
ElseIf TempBinBlock = "0001" Then
HexOut = HexOut + "1"
ElseIf TempBinBlock = "0010" Then
HexOut = HexOut + "2"
ElseIf TempBinBlock = "0011" Then
HexOut = HexOut + "3"
ElseIf TempBinBlock = "0100" Then
HexOut = HexOut + "4"
ElseIf TempBinBlock = "0101" Then
HexOut = HexOut + "5"
ElseIf TempBinBlock = "0110" Then
HexOut = HexOut + "6"
ElseIf TempBinBlock = "0111" Then
HexOut = HexOut + "7"
ElseIf TempBinBlock = "1000" Then
HexOut = HexOut + "8"
ElseIf TempBinBlock = "1001" Then
HexOut = HexOut + "9"
ElseIf TempBinBlock = "1010" Then
HexOut = HexOut + "A"
ElseIf TempBinBlock = "1011" Then
HexOut = HexOut + "B"
ElseIf TempBinBlock = "1100" Then
HexOut = HexOut + "C"
ElseIf TempBinBlock = "1101" Then
HexOut = HexOut + "D"
ElseIf TempBinBlock = "1110" Then
HexOut = HexOut + "E"
ElseIf TempBinBlock = "1111" Then
HexOut = HexOut + "F"
End If
Next I
Bin2Hex = HexOut
eds:
End Function
Function Hex2Bin(InputData As String) As String
Dim I As Integer:Dim BinOut As String:Dim Lenhex As Integer
InputData = UCase(InputData)
Lenhex = Len(InputData)
For I = 1 To Lenhex
If IsNumeric(Mid(InputData, I, 1)) Then
GoTo NumOk
ElseIf Mid(InputData, I, 1) = "A" Then
GoTo NumOk
ElseIf Mid(InputData, I, 1) = "B" Then
GoTo NumOk
ElseIf Mid(InputData, I, 1) = "C" Then
GoTo NumOk
ElseIf Mid(InputData, I, 1) = "D" Then
GoTo NumOk
ElseIf Mid(InputData, I, 1) = "E" Then
GoTo NumOk
ElseIf Mid(InputData, I, 1) = "F" Then
GoTo NumOk
Else
MsgBox "Number given is not in Hex format", vbCritical
Exit Function
End If
NumOk:
Next I
BinOut = ""
For I = 1 To Lenhex
If Mid(InputData, I, 1) = "0" Then
BinOut = BinOut + "0000"
ElseIf Mid(InputData, I, 1) = "1" Then
BinOut = BinOut + "0001"
ElseIf Mid(InputData, I, 1) = "2" Then
BinOut = BinOut + "0010"
ElseIf Mid(InputData, I, 1) = "3" Then
BinOut = BinOut + "0011"
ElseIf Mid(InputData, I, 1) = "4" Then
BinOut = BinOut + "0100"
ElseIf Mid(InputData, I, 1) = "5" Then
BinOut = BinOut + "0101"
ElseIf Mid(InputData, I, 1) = "6" Then
BinOut = BinOut + "0110"
ElseIf Mid(InputData, I, 1) = "7" Then
BinOut = BinOut + "0111"
ElseIf Mid(InputData, I, 1) = "8" Then
BinOut = BinOut + "1000"
ElseIf Mid(InputData, I, 1) = "9" Then
BinOut = BinOut + "1001"
ElseIf Mid(InputData, I, 1) = "A" Then
BinOut = BinOut + "1010"
ElseIf Mid(InputData, I, 1) = "B" Then
BinOut = BinOut + "1011"
ElseIf Mid(InputData, I, 1) = "C" Then
BinOut = BinOut + "1100"
ElseIf Mid(InputData, I, 1) = "D" Then
BinOut = BinOut + "1101"
ElseIf Mid(InputData, I, 1) = "E" Then
BinOut = BinOut + "1110"
ElseIf Mid(InputData, I, 1) = "F" Then
BinOut = BinOut + "1111"
Else
MsgBox "Something is Screwed up, Wahhhhhhhhhhh", vbCritical
End If
Next I
Hex2Bin = BinOut
eds:
End Function
Function Hex2Dec(InputData As String) As Double
Dim I As Integer:Dim DecOut As Double:Dim Lenhex As Integer:Dim HexStep As Double
DecOut = 0
InputData = UCase(InputData)
Lenhex = Len(InputData)
For I = 1 To Lenhex
If IsNumeric(Mid(InputData, I, 1)) Then
GoTo NumOk
ElseIf Mid(InputData, I, 1) = "A" Then
GoTo NumOk
ElseIf Mid(InputData, I, 1) = "B" Then
GoTo NumOk
ElseIf Mid(InputData, I, 1) = "C" Then
GoTo NumOk
ElseIf Mid(InputData, I, 1) = "D" Then
GoTo NumOk
ElseIf Mid(InputData, I, 1) = "E" Then
GoTo NumOk
ElseIf Mid(InputData, I, 1) = "F" Then
GoTo NumOk
Else
MsgBox "Number given is not in Hex format", vbCritical
Exit Function
End If
NumOk:
Next I
HexStep = 0
For I = Lenhex To 1 Step -1
HexStep = HexStep * 16
If HexStep = 0 Then
HexStep = 1
End If
If Mid(InputData, I, 1) = "0" Then
DecOut = DecOut + (0 * HexStep)
ElseIf Mid(InputData, I, 1) = "1" Then
DecOut = DecOut + (1 * HexStep)
ElseIf Mid(InputData, I, 1) = "2" Then
DecOut = DecOut + (2 * HexStep)
ElseIf Mid(InputData, I, 1) = "3" Then
DecOut = DecOut + (3 * HexStep)
ElseIf Mid(InputData, I, 1) = "4" Then
DecOut = DecOut + (4 * HexStep)
ElseIf Mid(InputData, I, 1) = "5" Then
DecOut = DecOut + (5 * HexStep)
ElseIf Mid(InputData, I, 1) = "6" Then
DecOut = DecOut + (6 * HexStep)
ElseIf Mid(InputData, I, 1) = "7" Then
DecOut = DecOut + (7 * HexStep)
ElseIf Mid(InputData, I, 1) = "8" Then
DecOut = DecOut + (8 * HexStep)
ElseIf Mid(InputData, I, 1) = "9" Then
DecOut = DecOut + (9 * HexStep)
ElseIf Mid(InputData, I, 1) = "A" Then
DecOut = DecOut + (10 * HexStep)
ElseIf Mid(InputData, I, 1) = "B" Then
DecOut = DecOut + (11 * HexStep)
ElseIf Mid(InputData, I, 1) = "C" Then
DecOut = DecOut + (12 * HexStep)
ElseIf Mid(InputData, I, 1) = "D" Then
DecOut = DecOut + (13 * HexStep)
ElseIf Mid(InputData, I, 1) = "E" Then
DecOut = DecOut + (14 * HexStep)
ElseIf Mid(InputData, I, 1) = "F" Then
DecOut = DecOut + (15 * HexStep)
Else
MsgBox "Something is Screwed up, Wahhhhhhhhhhh", vbCritical
End If
Next I
Hex2Dec = DecOut
eds:
End Function
调用方式：
Private Sub cmdbin2hex_Click()
txthex.Text = Bin2Hex(txtbinary.Text)
End Sub
Private Sub cmddec2bin_Click()
If IsNumeric(txtdec2bin.Text) Then
txtdec2bin2.Text = Dec2Bin(txtdec2bin.Text)
End If
End Sub
Private Sub cmdDecHex_Click()
If IsNumeric(txtDecimal.Text) Then
txtdechex.Text = Hex(CDbl(txtDecimal.Text))
Else
MsgBox "Not a Number.", vbCritical
End If
End Sub
Private Sub cmdhex2bin_Click()
txtbinary2.Text = Hex2Bin(txthex2.Text)
End Sub
Private Sub cmdhexdec_Click()
txtdec2.Text = CStr(Hex2Dec(txthexdec.Text))
End Sub
50. 控制左右声道
Private Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" (ByVal _ lpstrCommand As String, ByVal lpstrReturnString As String, ByVal uReturnLength As _
Long, ByVal hwndCallback As Long) As Long
Private Sub Command1_Click()
PlaySound "F:musicincubus水木年华-再见了最爱的人.mp3"
End Sub
Function PlaySound(ByVal FileName As String) As Boolean
Dim cmd As String, exName As String
exName = Right(FileName, 3)
mciSendString "close " & exName, 0, 0, 0
cmd = "open " & FileName & " alias " & exName
mciSendString cmd, 0, 0, 0
PlaySound = mciSendString("play " & exName, 0, 0, 0)
End Function
Private Sub Command2_Click()
Static flag As Boolean ' 设置左声道开关
mciSendString "set all audio all " & IIf(flag, "on", "off"), 0, 0, 0
If flag = False Then
Command2.Caption = "左声道(关)"
Else
Command2.Caption = "左声道(开)"
End If
flag = Not flag
End Sub
Private Sub Command3_Click()
Static flag As Boolean ' 设置右声道开关
mciSendString "set all audio all " & IIf(flag, "on", "off"), 0, 0, 0
If flag = False Then
Command3.Caption = "右声道(关)"
Else
Command3.Caption = "右声道(开)"
End If
flag = Not flag
End Sub
Private Sub Command4_Click() '' 设置mp3设备音量:0--1000,500表示音量适中
mciSendString "set mp3 audio volume to 500", 0, 0, 0
End Sub
(编辑:aniston)
|
