📄 form2.frm
字号:
Top = 960
Width = 810
End
Begin VB.Label Label40
AutoSize = -1 'True
Caption = "占地(东):"
Height = 180
Left = 1800
TabIndex = 23
Top = 720
Width = 810
End
Begin VB.Label Label38
AutoSize = -1 'True
Caption = "图片高度:"
Height = 180
Left = 1800
TabIndex = 22
Top = 480
Width = 810
End
Begin VB.Label Label36
AutoSize = -1 'True
Caption = "图片宽度:"
Height = 180
Left = 1800
TabIndex = 21
Top = 240
Width = 810
End
Begin VB.Label Label34
AutoSize = -1 'True
Caption = "偏移量-Y:"
Height = 180
Left = 120
TabIndex = 20
Top = 1440
Width = 810
End
Begin VB.Label Label32
AutoSize = -1 'True
Caption = "偏移量-X:"
Height = 180
Left = 120
TabIndex = 19
Top = 1200
Width = 810
End
Begin VB.Label Label30
AutoSize = -1 'True
Caption = "块 长 度:"
Height = 180
Left = 120
TabIndex = 18
Top = 960
Width = 810
End
Begin VB.Label Label28
AutoSize = -1 'True
Caption = "Real地址:"
Height = 180
Left = 120
TabIndex = 17
Top = 720
Width = 810
End
Begin VB.Label Label26
AutoSize = -1 'True
Caption = "图片编号:"
Height = 180
Left = 120
TabIndex = 16
Top = 480
Width = 810
End
Begin VB.Label Label7
AutoSize = -1 'True
Caption = "图片序号:"
Height = 180
Left = 120
TabIndex = 15
Top = 240
Width = 810
End
Begin VB.Label Label20
AutoSize = -1 'True
Caption = "修改"
Enabled = 0 'False
Height = 180
Left = 3000
TabIndex = 14
Top = 0
Width = 360
End
End
End
Attribute VB_Name = "Form2"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private Sub Command1_Click()
Dim MyBmp_Header As BITMAPFILEHEADER
Dim MyBmp_Info As BITMAPINFO
Dim BmpData_Byte() As Byte
Dim FileNum As Long
CommonDialog1.ShowOpen
If CommonDialog1.FileName <> "" Then
FileNum = FreeFile
Open CommonDialog1.FileName For Binary Access Read As FileNum
Get FileNum, , MyBmp_Header
Get FileNum, , MyBmp_Info
If MyBmp_Header.bfType(1) = 66 And MyBmp_Header.bfType(2) = 77 Then
ReDim BmpData_Byte(1 To MyBmp_Info.bmiHeader.biHeight * MyBmp_Info.bmiHeader.biWidth) As Byte
Get FileNum, , BmpData_Byte
If MyBmp_Info.bmiHeader.biImage <> 0 Then
Dim ErrLong As Long
Picture1.Cls
StretchDIBits Picture1.hdc, ((Picture1.width / 15) - MyBmp_Info.bmiHeader.biWidth) / 2 _
, ((Picture1.height / 15) - MyBmp_Info.bmiHeader.biHeight) / 2, MyBmp_Info.bmiHeader.biWidth, _
MyBmp_Info.bmiHeader.biHeight, 0, 0, MyBmp_Info.bmiHeader.biWidth, MyBmp_Info.bmiHeader.biHeight, _
BmpData_Byte(1), MyBmp_Info, 0, SRCCOPY
SendMessageBynum& Picture1.hwnd, WM_PAINT, 0, 0
End If
Text1.Text = CommonDialog1.FileName
Else
MsgBox "请选择256色的位图"
End If
Close FileNum
End If
End Sub
Private Sub Picture3_Click()
End Sub
Private Sub Command2_Click()
Dim Temp_MyBmp_Header As BITMAPFILEHEADER
Dim Temp_MyBmp_Info As BITMAPINFO
Dim Temp_MyReal As Real
Dim Temp_MyAdrn As adrn
Dim buff() As Byte
Dim buff1() As Byte
Dim datalen As Long
Dim FileNum, AdrnFileNum, RealFileNum As Long
Dim addr1 As Long
FileNum = FreeFile
If Text1.Text = "" Then
Command1_Click
End If
Open Text1.Text For Binary Access Read As FileNum
Get FileNum, , Temp_MyBmp_Header
Get FileNum, , Temp_MyBmp_Info
ReDim buff(1 To Temp_MyBmp_Info.bmiHeader.biHeight * Temp_MyBmp_Info.bmiHeader.biWidth) As Byte
Get FileNum, , buff
Close FileNum
RealFileNum = FreeFile
Open Form1.Text1.Text & "\real.bak" For Binary Access Write As RealFileNum
addr1 = BmptoReal(VarPtr(buff(1)), Temp_MyBmp_Info.bmiHeader.biWidth, Temp_MyBmp_Info.bmiHeader.biHeight, datalen, 1)
ReDim buff1(1 To datalen) As Byte
CopyMemory buff1(1), ByVal addr1, datalen
CopyMemory Temp_MyReal, buff1(1), LenB(Temp_MyReal)
Text7(0).Text = Chr(Temp_MyReal.hwnd(1)) & Chr(Temp_MyReal.hwnd(2))
Text7(1).Text = Temp_MyReal.Compress
Text7(2).Text = Temp_MyReal.datalen
Text7(3).Text = Temp_MyReal.width
Text7(4).Text = Temp_MyReal.height
Text7(5).Text = Temp_MyReal.RealNotKnow
Text2(1).Text = LOF(RealFileNum)
Text2(2).Text = datalen
Text2(5).Text = Temp_MyBmp_Info.bmiHeader.biWidth
Text2(6).Text = Temp_MyBmp_Info.bmiHeader.biHeight
Dim YesOrNo As Long
YesOrNo = MsgBox("是否确定添加此资源？", vbYesNo)
If YesOrNo = 6 Then
If Val(Text3.Text) - 1 > UBound(AdrnIndex) Then ReDim Preserve AdrnIndex(Text3) As adrn
AdrnIndex(Val(Text3.Text) - 1).Num = Text2(0).Text
AdrnIndex(Val(Text3.Text) - 1).Addr = Text2(1).Text
AdrnIndex(Val(Text3.Text) - 1).datalen = Text2(2).Text
AdrnIndex(Val(Text3.Text) - 1).X = Text2(3).Text
AdrnIndex(Val(Text3.Text) - 1).Y = Text2(4).Text
AdrnIndex(Val(Text3.Text) - 1).width = Text2(5).Text
AdrnIndex(Val(Text3.Text) - 1).height = Text2(6).Text
AdrnIndex(Val(Text3.Text) - 1).EastCover = Text2(7).Text
AdrnIndex(Val(Text3.Text) - 1).SouthCover = Text2(8).Text
AdrnIndex(Val(Text3.Text) - 1).ObstacleFlags = Text2(10).Text
AdrnIndex(Val(Text3.Text) - 1).MapNum = Text2(9).Text
Temp_MyAdrn = AdrnIndex(Val(Text3.Text) - 1)
AdrnFileNum = FreeFile
Open Form1.Text1.Text & "\adrn.bak" For Binary Access Write As AdrnFileNum
Put AdrnFileNum, LOF(AdrnFileNum) + 1, Temp_MyAdrn
Close AdrnFileNum
Put RealFileNum, LOF(RealFileNum) + 1, buff1
Text3.Text = Val(Text3.Text) + 1
End If
If Val(Text3.Text) <= AdrnLine Then
Text2(0).Text = AdrnIndex(Val(Text3.Text) - 1).Num
Text2(1).Text = AdrnIndex(Val(Text3.Text) - 1).Addr
Text2(2).Text = AdrnIndex(Val(Text3.Text) - 1).datalen
Text2(3).Text = AdrnIndex(Val(Text3.Text) - 1).X
Text2(4).Text = AdrnIndex(Val(Text3.Text) - 1).Y
Text2(5).Text = AdrnIndex(Val(Text3.Text) - 1).width
Text2(6).Text = AdrnIndex(Val(Text3.Text) - 1).height
Text2(7).Text = AdrnIndex(Val(Text3.Text) - 1).EastCover
Text2(8).Text = AdrnIndex(Val(Text3.Text) - 1).SouthCover
Text2(10).Text = AdrnIndex(Val(Text3.Text) - 1).ObstacleFlags
Text2(9).Text = AdrnIndex(Val(Text3.Text) - 1).MapNum
Text7(0).Text = ""
Text7(1).Text = ""
Text7(2).Text = ""
Text7(3).Text = ""
Text7(4).Text = ""
Text7(5).Text = ""
Else
MsgBox "已重做资源完毕"
Command2.Enabled = True
End If
Close RealFileNum
End Sub
Private Sub Command3_Click()
Dim lpIDList As Long
Dim sBuffer As String
Dim tBrowseInfo As BrowseInfo
Dim FilePath As String
Dim i As Long
lpIDList = SHBrowseForFolder(tBrowseInfo)
If (lpIDList) Then
sBuffer = Space(MAX_PATH)
SHGetPathFromIDList lpIDList, sBuffer
sBuffer = Left(sBuffer, InStr(sBuffer, vbNullChar) - 1)
For i = 0 To AdrnLine - 1
FilePath = sysFileFind(sBuffer, AdrnIndex(i).Num & ".bmp")
If FilePath <> "" Then
Dim Temp_MyBmp_Header As BITMAPFILEHEADER
Dim Temp_MyBmp_Info As BITMAPINFO
Dim Temp_MyReal As Real
Dim buff() As Byte
Dim buff1() As Byte
Dim datalen As Long
Dim FileNum As Long
Dim addr1 As Long
FileNum = FreeFile
Open FilePath For Binary Access Read As FileNum
Get FileNum, , Temp_MyBmp_Header
Get FileNum, , Temp_MyBmp_Info
ReDim buff(1 To Temp_MyBmp_Info.bmiHeader.biHeight * Temp_MyBmp_Info.bmiHeader.biWidth) As Byte
Get FileNum, , buff
Close FileNum
FileNum = FreeFile
Open Form1.Text1.Text & "\real.bak" For Binary Access Write As FileNum
addr1 = BmptoReal(VarPtr(buff(1)), Temp_MyBmp_Info.bmiHeader.biWidth, Temp_MyBmp_Info.bmiHeader.biHeight, datalen, 1)
ReDim buff1(1 To datalen) As Byte
CopyMemory buff1(1), ByVal addr1, datalen
CopyMemory Temp_MyReal, buff1(1), LenB(Temp_MyReal)
AdrnIndex(i).Addr = LOF(FileNum)
AdrnIndex(i).datalen = datalen
AdrnIndex(i).width = Temp_MyBmp_Info.bmiHeader.biWidth
AdrnIndex(i).height = Temp_MyBmp_Info.bmiHeader.biHeight
Put FileNum, LOF(FileNum) + 1, buff1
Close FileNum
Else
MsgBox "找不到图片:" & AdrnIndex(i).Num & ".bmp"
End If
Next
FileNum = FreeFile
Open Form1.Text1.Text & "\adrn.bak" For Binary Access Write As FileNum
Put FileNum, LOF(FileNum) + 1, AdrnIndex
Close FileNum
MsgBox "已重做资源完毕"
End If
End Sub
Private Sub Form_Load()
On Error Resume Next
If Val(Text3.Text) <= AdrnLine Then
Text2(0).Text = AdrnIndex(Val(Text3.Text) - 1).Num
Text2(1).Text = AdrnIndex(Val(Text3.Text) - 1).Addr
Text2(2).Text = AdrnIndex(Val(Text3.Text) - 1).datalen
Text2(3).Text = AdrnIndex(Val(Text3.Text) - 1).X
Text2(4).Text = AdrnIndex(Val(Text3.Text) - 1).Y
Text2(5).Text = AdrnIndex(Val(Text3.Text) - 1).width
Text2(6).Text = AdrnIndex(Val(Text3.Text) - 1).height
Text2(7).Text = AdrnIndex(Val(Text3.Text) - 1).EastCover
Text2(8).Text = AdrnIndex(Val(Text3.Text) - 1).SouthCover
Text2(10).Text = AdrnIndex(Val(Text3.Text) - 1).ObstacleFlags
Text2(9).Text = AdrnIndex(Val(Text3.Text) - 1).MapNum
Dim i As Long
Text2(11).Text = ""
For i = 1 To 45
Text2(11).Text = Text2(11).Text & str(AdrnIndex(Val(Text3.Text) - 1).AdrnNotKnow(i)) & ","
Next i
Kill Form1.Text1.Text & "\real.bak"
End If
End Sub
Private Sub Form_Unload(Cancel As Integer)
On Error Resume Next
Dim FileSize As Long
FileSize = FileLen(Form1.Text1.Text & "\real.bak")
If FileSize > 0 Then
Dim YesOrNo As Long
YesOrNo = MsgBox("是否保存资源数据？", vbYesNo)
If YesOrNo = 6 Then
Kill Form1.Text1.Text & "\real.bin"
Name Form1.Text1.Text & "\real.bak" As Form1.Text1.Text & "\real.bin"
Kill Form1.Text1.Text & "\adrn.bin"
Name Form1.Text1.Text & "\adrn.bak" As Form1.Text1.Text & "\adrn.bin"
End If
End If
End Sub
Public Function sysFileFind(ByVal WhichRootPath As String, ByVal WhichFileName As String) As String
Dim iNull As Integer
Dim lResult As Long
Dim sBuffer As String
On Error GoTo L_FILEFINDERROR
sBuffer = String$(1024, 0)
'查找文件
lResult = SearchTreeForFile(WhichRootPath, WhichFileName, sBuffer)
'如果文件找到，将返回字符串后续的空格删除
'否则返回一个空字符串
If lResult Then
iNull = InStr(sBuffer, vbNullChar)
If Not iNull Then
sBuffer = Left$(sBuffer, iNull - 1)
End If
sysFileFind = sBuffer
Else
sysFileFind = ""
End If
Exit Function
L_FILEFINDERROR: MsgBox "查找文件过程中遇到错误！", vbInformation, "查找文件错误"
sysFileFind = Format(Err.Number) & " - " & Err.Description
End Function
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -