如何制作带箭头的站牌

ning84 · 发表于 2024-9-2 21:48

数据源

StationArr = Array("陈官营", "深安大桥南", "兰州城市学院", "兰州海关", "马滩", "土门墩", "兰州西站北广场", "西站什字", "七里河", "小西湖", "文化宫", "西关", "省政府", "东方红广场", "兰州大学", "五里铺", "省气象局", "携星墩", "焦家湾", "东岗")
DistArr = Array(0, 1579, 2340, 955, 2073, 2007, 907, 1614, 1060, 1376, 890, 1066, 969, 1456, 1426, 1293, 1303, 1163, 1116, 933)

Sub dffdsaf()
'Arr = BetweenStation("兰州城市学院", "文化宫")
Arr = BetweenStation("兰州大学", "兰州城市学院")
''
Dim Sht As Worksheet, Rng As Range
Set Sht = Application.ActiveSheet
With Sheet4
.Cells.Clear
.Cells.Font.Size = 9
Set Rng = .Cells(5, 2)
End With
With Application.WorksheetFunction
Rng.Resize(3, UBound(Arr)) = .Transpose(Arr)
End With
End Sub
Function BetweenStation(StationA, StationB)
StationArr = Array("陈官营", "奥体中心", "兰州城市学院", "兰州海关", "马滩", "土门墩", "兰州西站北广场", "西站什字", "七里河", "小西湖", "文化宫", "西关", "省政府", "东方红广场", "兰州大学", "五里铺", "省气象局", "携星墩", "焦家湾", "东岗")
''
DistArr = Array(0, 1579, 2340, 955, 2073, 2007, 907, 1614, 1060, 1376, 890, 1066, 969, 1456, 1426, 1293, 1303, 1163, 1116, 933)
Dim Rr As Integer, Kk
Dim Arr()
'Dim StationA, StationB
Dim Kk1, Kk2
Dim Dist As Integer
For ii = 0 To UBound(StationArr)
If StationA = StationArr(ii) Then
Kk1 = ii
End If
''
If StationB = StationArr(ii) Then
Kk2 = ii
End If
Next ii
''
If Kk1 < Kk2 Then
ReDim Arr(Kk2 - Kk2 - 1, 2)
For ii = Kk1 To Kk2
Debug.Print StationArr(ii)
Next ii
ElseIf Kk1 > Kk2 Then
ReDim Arr(Kk1 - Kk2 - 0, 2)
For ii = Kk1 To Kk2 Step -1
Arr(Kk1 - ii, 0) = StationArr(ii)
''
If ii = Kk1 Then
Dist = 0
Else
Dist = Dist + DistArr(ii)
End If
''
Arr(Kk1 - ii, 1) = Dist
Arr(Kk1 - ii, 2) = retuDist(Dist)
Next ii
End If
BetweenStation = Arr
End Function
Function retuDist(Dist As Integer)
Select Case Dist
Case Is = 0
retuDist = "-"
Case Is <= 4000
retuDist = 2
Case Is <= 8000
retuDist = 3
Case Is <= 12000
retuDist = 4
Case Is <= 18000
retuDist = 5
Case Is <= 24000
retuDist = 6
Case Is <= 32000
retuDist = 7
Case Is <= 40000
retuDist = 8
Case Else
End Select
End Function

复制代码

结果

wengjl · 发表于 2024-9-3 08:43

ning84 · 发表于 2024-9-3 22:23

本帖最后由 ning84 于 2024-9-3 22:25 编辑

wengjl 发表于 2024-9-3 08:43

谢谢回复，进一步学习chrw和chr函数

在VBA中，ChrW 函数与 Chr 函数类似，但它返回的是Unicode字符。对于箭头等特殊字符，它们在Unicode字符集中有对应的编码。以下是一些箭头符号及其对应的 ChrW 函数代码：
1.左箭头（Left Arrow） - ChrW(8592)
2.右箭头（Right Arrow） - ChrW(8594)
3.下箭头（Down Arrow） - ChrW(8595)
4.上箭头（Up Arrow） - ChrW(8593)
你可以使用这些代码来在VBA中插入相应的箭头符号。例如：
Dim myString As String
myString = "←" & " " & "→" ' 使用 ChrW(8592) 和 ChrW(8594)
或者直接使用Unicode字符：
Dim myString As String
myString = ChrW(8592) & " " & ChrW(8594) ' 左箭头和右箭头
请注意，直接使用Unicode字符（如 "←" 和 "→"）可能在某些环境中更直观和方便。

在VBA（Visual Basic for Applications）中，Chr 函数用于返回对应于指定字符代码的字符。这个函数非常有用，尤其是当你需要在代码中插入特殊字符时。
以下是一些常见的特殊字符及其对应的 Chr 函数代码：
1.回车（Carriage Return, CR） - Chr(13)
2.换行（Line Feed, LF） - Chr(10)
3.回车换行（Carriage Return + Line Feed, CRLF） - Chr(13) & Chr(10)
4.水平制表符（Horizontal Tab, HT） - Chr(9)
5.垂直制表符（Vertical Tab, VT） - Chr(11)
6.退格（Backspace, BS） - Chr(8)
7.空字符（Null Character） - Chr(0)
8.响铃（Bell, BEL） - Chr(7)
9.双引号（Double Quote） - Chr(34)
10.单引号（Apostrophe） - Chr(39)
使用这些特殊字符时，你可以将它们插入到字符串中，例如：
Dim myString As String
myString = "Hello" & Chr(13) & "World" ' 会在“Hello”和“World”之间插入一个回车符
请注意，不同的操作系统和应用程序可能对这些特殊字符的处理方式有所不同。例如，Windows 系统中通常使用 Chr(13) & Chr(10) 来表示新的一行，而在 Unix/Linux 系统中，通常只需要 Chr(10)。

ning84 · 发表于 2024-9-4 10:00

learn  carry out Sentence

在Excel VBA中，Callout是一种特殊的形状，用于在图表或其他形状上添加注释或标签。Callout可以指向图表中的特定数据点、趋势线或其他元素，并提供有关这些元素的详细信息。以下是一些关于如何在Excel VBA中使用Callout的基本步骤：

1. 打开Excel，然后按Alt + F11键打开VBA编辑器。

2. 单击“插入”>“模块”，在新模块中粘贴以下代码：

```vba
Sub AddCallout()
Dim ws As Worksheet
Dim cht As Chart
Dim myCallout As Shape

' 设置工作表和图表名称
Set ws = ThisWorkbook.Worksheets("Sheet1")
Set cht = ws.ChartObjects("Chart 1").Chart

' 添加Callout标注线
Set myCallout = cht.Shapes.AddCallout(Left:=100, Top:=100, Width:=100, Height:=50, Type:=msoCalloutStyleRectangular)

' 设置Callout标注线的文本
myCall.out.TextFrame.Characters.Text = "这是一个Callout标注线"

' 设置Callout标注线的字体和颜色
With myCallout.TextFrame.Characters.Font
      .Name = "Arial"
      .Size = 12
      .Color = RGB(255, 0, 0)
End With
End Sub
```

3. 修改代码中的工作表名称、图表名称和其他参数，以匹配您的实际需求。

4. 按F5键运行宏，这将在指定的图表上添加一个Callout标注线。

注意：此示例使用了`msoCalloutStyleRectangular`样式。您可以根据需要更改Callout样式，例如使用`msoCalloutStyleOval`（椭圆形）或`msoCalloutStyleCorner`（圆角矩形）。此外，您还可以调整Callout的位置、大小和其他属性以满足您的需求。

在实际应用中，您可能需要根据数据点的位置动态计算Callout的位置。这可以通过获取数据点的坐标并将其用作Callout的左上角位置来实现。此外，您还可以通过编程方式设置Callout的文本、字体、颜色等属性。

ning84 · 发表于 2024-9-4 11:56

在 VBA 中，Callout.Line.Style 属性用于设置或返回 callout 线条的样式。这个属性是 Shape 对象的 Callout 属性的一部分，它允许你自定义 callout 线条的外观。
以下是一些可用的 msoLine 常量，你可以用它们来设置 Callout.Line.Style 属性：
msoLineSingle：单线样式（默认）。
msoLineThinThin：两条细线，中间有间隔。
msoLineThickThin：一条粗线，两边各有一条细线。
msoLineThinThick：两条细线，中间有一条粗线。
msoLineDash：虚线。
msoLineDashHeavy：粗虚线。
msoLineDotDash：点划线。
msoLineDashDotDot：点划点划线。
msoLineDashDotHeavy：点划粗线。
msoLineLongDash：长虚线。
msoLineLongDashHeavy：粗长虚线。
msoLineDouble：双线。
msoLineSolid：实线（与 msoLineSingle 相同）。
以下是如何在 VBA 中设置 callout 线条样式的示例：
Sub SetCalloutLineStyle()
Dim shp As Shape
' 在工作表中添加一个 callout
Set shp = ActiveSheet.Shapes.AddCallout(Type:=msoCalloutOneBorder, Left:=100, Top:=100, Width:=200, Height:=50)

' 设置 callout 的文本
shp.TextFrame.TextRange.Text = "这是一个 callout 注释"

' 设置 callout 线条的样式为虚线
shp.Callout.Line.Style = msoLineDash

' 还可以设置线条的颜色、粗细等属性
shp.Callout.Line.ForeColor.RGB = RGB(255, 0, 0) ' 红色线条
shp.Callout.Line.Weight = 2 ' 线条粗细
End Sub
在这个例子中，我们首先添加了一个 callout，然后设置了它的文本。接着，我们使用 msoLineDash 常量来将 callout 线条的样式设置为虚线。此外，我们还设置了线条的颜色为红色，并将线条粗细设置为 2磅。

		自动登录	找回密码
密码			免费注册

如何制作带箭头的站牌

评分