用vba加载宏求地图分幅

首先做一个自定义的用户界面

1.新建一个excel表格，将其重命名为zip压缩包格式。

2.打开压缩包在其中新建一个文件夹customUI，在文件夹新建一个xml文档，用于保存自定义用户界面。

3.在xml文档中输入

<?xml version="1.0"?>
<customUI xmlns="http://schemas.microsoft.com/office/2006/01/customui">
<ribbon startFromScratch="false">
<tabs>
<tab label="地图分幅计算" id="fenfujisuan">
<group label="地图分幅计算" id="ditufenfu">
  <button label="分幅"
           id="fenfu"
           size="large"
           onAction="DoButton"
           imageMso="WhatIfAnalysisMenu" />
</group>
        </tab>
      </tabs>
    </ribbon>
  </customUI>

4. 然后将压缩包中的_rels文件夹中的文件打开，将内容修改为

<?xml version="1.0" encoding="UTF-8" standalone="true"?>
<Relationships xmlns="http://schemas.openxmlformats.org/package/2006/relationships">
<Relationship Target="docProps/app.xml" Type="http://schemas.openxmlformats.org/officeDocument/2006/relationships/extended-properties" Id="rId3"/>
<Relationship Target="customUI/customUI.xml" Type="http://schemas.microsoft.com/office/2006/relationships/ui/extensibility" Id="customUIRelID"/>
<Relationship  Target="docProps/core.xml" Type="http://schemas.openxmlformats.org/package/2006/relationships/metadata/core-properties" Id="rId2"/>
<Relationship Target="xl/workbook.xml" Type="http://schemas.openxmlformats.org/officeDocument/2006/relationships/officeDocument" Id="rId1"/>
</Relationships>

5.将压缩包重命名改为原来的文件格式

功能实现

1.打开excel表格，按住alt+f11进入VBE界面

2.首先插入一个用户窗体，添加8个标签以及8个文本框和两个按钮。分别将控件中的文字改为如图所示。（控件大小位置可自行设置）

3.右键用户窗体查看代码，输入以下代码

Private Sub CommandButton1_Click()//点击确定按钮执行此过程

If TextBox1.text = "" Then//判断是否输入经度

MsgBox "请输入纬度",, "输入"

TextBox1.SetFocus

Exit Sub

End If

If TextBox2.text = "" Then//判断是否输入纬度

MsgBox "请输入经度",, "输入"

TextBox2.SetFocus

Exit Sub

End If

Call text

Call text2

End Sub

 

Private Sub CommandButton2_Click()//清空按钮

Call text3

End Sub

 

Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean)//光标离开纬度文本框时执行此过程

If TextBox1.text = "" Then

Exit Sub

End If

TextBox1 = Format(TextBox1,"###°##′##″")//将输入的数字转换成度分秒格式

Call text4

On Error Resume Next

If a = "" Then

Else

If a < 0 Or a > 90 Then//判断输入数据是否有误

MsgBox "纬度错误,请重新输入", , "错误"

TextBox1.text = ""

TextBox1.SetFocus

Stop

Exit Sub

End If

End If

If b = "" Then

Else

If b < 0 Or b > 60 Then

MsgBox "纬度错误,请重新输入", , "错误"

TextBox1.text = ""

TextBox1.SetFocus

Exit Sub

End If

End If

If c = "" Then

Else

If c < 0 Or c > 60 Then

MsgBox "纬度错误,请重新输入", , "错误"

TextBox1.text = ""

TextBox1.SetFocus

End If

End If

End Sub

Private Sub TextBox2_Exit(ByVal Cancel As MSForms.ReturnBoolean)//光标离开经度文本框时执行此过程

If TextBox2.text = "" Then

Exit Sub

End If

TextBox2 = Format(TextBox2,"###°##′##″")//将输入的数字转换成度分秒格式

Call text5

On Error Resume Next

If d = "" Then

Else

If d < 0 Or d > 360 Then//判断数据是否有误

MsgBox "经度错误,请重新输入", , "错误"

TextBox2.text = ""

TextBox2.SetFocus

Exit Sub

End If

End If

If e = "" Then

Else

If e < 0 Or e > 60 Then

MsgBox "经度错误,请重新输入", , "错误"

TextBox2.text = ""

TextBox2.SetFocus

Exit Sub

End If

End If

If f = "" Then

Else

If f < 0 Or f > 60 Then

MsgBox "经度错误,请重新输入", , "错误"

TextBox2.text = ""

TextBox2.SetFocus

End If

End If

End Sub

4.插入一个模块，插入代码

Public a, b, c, d,e, f

Public x1 As Long//定义几个全局变量，用于计算分度编号

Public n1 As Long

Public x2 As Long

Public n2 As Long

Public n3 As Long

Public n4 As Long

Public n5 As Long

Public n6 As Long

Public n7 As Long

Public n8  As Long

Public n9 As Long

Public n10 As Long

Public n11 As Long

Public n12 As Long

Sub DoButton(control As IRibbonControl)//当点击菜单地图分幅时执行此过程

UserForm1.Show

End Sub

Sub text()//计算分幅编号

x1 = a * 3600 + b *60 + c

n1 = Int(x1 / (4 *3600)) + 1

x2 = d * 3600 + e *60 + f

n2 = Int(x2 / (6 *3600)) + 30 + 1

n3 = 2 - Int((x1Mod (4 * 3600)) / (2 * 3600))

n4 = Int((x2 Mod (6* 3600)) / (3 * 3600)) + 1

n5 = 12 - Int((x1Mod (4 * 3600)) / 1200)

n6 = Int((x2 Mod (6* 3600)) / 1800) + 1

n7 = 24 - Int((x1Mod (4 * 3600)) / 600)

n8 = Int((x2 Mod (6* 3600)) / 900) + 1

n9 = 48 - Int((x1Mod (4 * 3600)) / 300)

n10 = Int((x2 Mod(6 * 3600)) / 450) + 1

n11 = 96 - Int((x1Mod (4 * 3600)) / 150)

n12 = Int((x2 Mod(6 * 3600)) / 225) + 1

End Sub

Sub text2()//输出最终结果

Dim daihao() As Variant

daihao() =Array("A", "B", "C", "D","E", "F", "G", "H", "I","J", "K", "L", "M", "N","O", "P", "Q", "R", "S")

UserForm1.TextBox3.text= daihao(n1 - 1) & n2

UserForm1.TextBox4.text= UserForm1.TextBox3.text & "B" & Format(CVar(n3),"000") & Format(CVar(n4), "000")

UserForm1.TextBox5= UserForm1.TextBox3.text & "D" & Format(CVar(n5),"000") & Format(CVar(n6), "000")

UserForm1.TextBox6= UserForm1.TextBox3.text & "E" & Format(CVar(n7),"000") & Format(CVar(n8), "000")

UserForm1.TextBox7= UserForm1.TextBox3.text & "F" & Format(CVar(n9),"000") & Format(CVar(n10), "000")

UserForm1.TextBox8= UserForm1.TextBox3.text & "G" & Format(CVar(n11),"000") & Format(CVar(n12), "000")

End Sub

Sub text3()//清空操作

On Error Resume Next

Dim cnt As control

For Each cnt In UserForm1.Controls

cnt.text =""

Next

End Sub

Sub text4()//用于提取纬度的度分秒

On Error Resume Next

a =Left(UserForm1.TextBox1.text, InStr(UserForm1.TextBox1.text, "°") -1)

b =Mid(UserForm1.TextBox1.text, InStr(UserForm1.TextBox1.text, "°") + 1,InStr(UserForm1.TextBox1.text, "′") - InStr(UserForm1.TextBox1.text,"°") - 1)

c =Mid(UserForm1.TextBox1.text, InStr(UserForm1.TextBox1.text, "′") + 1,InStr(UserForm1.TextBox1.text, "″") - InStr(UserForm1.TextBox1.text,"′") - 1)

End Sub

Sub text5()//用于提取经度的度分秒

On Error Resume
Next

d =Left(UserForm1.TextBox2.text, InStr(UserForm1.TextBox2.text, "°") -1)

e =Mid(UserForm1.TextBox2.text, InStr(UserForm1.TextBox2.text, "°") + 1,InStr(UserForm1.TextBox2.text, "′") - InStr(UserForm1.TextBox2.text,"°") - 1)

f =Mid(UserForm1.TextBox2.text, InStr(UserForm1.TextBox2.text, "′") + 1,InStr(UserForm1.TextBox2.text, "″") - InStr(UserForm1.TextBox2.text,"′") - 1)

End Sub

5.保存文件，将文件保存为xlam格式（excel加载宏）。

最后打开excel将加载宏加载进来，直接输入经度和纬度（只用输入数字），就能计算了。