图个有趣，VBA也玩PS图片特效

lixinlin181818 · 发表于 2025-4-12 21:30

厉害

cai2532 · 发表于 2025-4-13 12:35

这个值的去学习。

aman1516 · 发表于 2025-4-15 21:55

本帖最后由 aman1516 于 2025-4-15 22:04 编辑

继续 VBA学PS 扭曲系列之极点图

以图片上边或下边的中心点为极点，直角坐标转极轴图坐标即可
纯作测试，要美观，将原图两边或极点图接合线的地方作过渡处理一下

aman1516 · 发表于 2025-4-15 21:58

核心代码：

'直角坐标转极轴坐标
Function ConvertCartesianToPolar(x As Double, y As Double, ByRef r As Double, ByRef theta As Double)
' 计算极径r
r = Sqr(x ^ 2 + y ^ 2)
' 计算极角θ（弧度）
If x > 0 Then
theta = Atn(y / x)
ElseIf x < 0 Then
theta = Atn(y / x) + Sgn(y) * 3.14159265358979
ElseIf y > 0 Then
theta = 3.14159265358979 / 2
ElseIf y < 0 Then
theta = -3.14159265358979 / 2
Else
theta = 0 ' 原点情况
End If
' 转换为角度（可选）
' theta = theta * 180 / 3.14159265358979
End Function
'极轴坐标转直角坐标
Function ConvertPolarToCartesian(r As Double, theta As Double, ByRef x As Double, ByRef y As Double)
' 将角度转换为弧度（如果输入是角度）
' theta = theta * 3.14159265358979 / 180
' 计算直角坐标
x = r * Cos(theta)
y = r * Sin(theta)
End Function
'使用示例：
Sub TestCoordinateConversion()
Dim x As Double, y As Double
Dim r As Double, theta As Double
' 直角坐标转极坐标示例
x = 3
y = 4
ConvertCartesianToPolar x, y, r, theta
Debug.Print "直角坐标 (" & x & ", " & y & ") 转换为极坐标: r = " & r & ", θ = " & theta & " 弧度"
' 极坐标转直角坐标示例
ConvertPolarToCartesian r, theta, x, y
Debug.Print "极坐标 (r=" & r & ", θ=" & theta & ") 转换为直角坐标: (" & x & ", " & y & ")"
End Sub

复制代码

这个比较简单，往模板里套就行了
PS未完待续......

aman1516 · 发表于 2025-4-17 16:30

继续 VBA学PS 扭曲系列之扇形图：

其实就是极点图的变体，加一个内半径

aman1516 · 发表于 2025-4-17 16:38

由于极点坐标是圆形扩散，越外围越会出现投射不到的“空白点”，
查资料，一般采取双列插值方法进行填充，没学会，想了个先放大再缩小的笨方法，勉强处理一下

扇形图片完整代码如下（未优化）：

Sub SecImg() '扇形效果图
Dim Img, Img1 'As ImageFile
Dim IP 'As ImageProcess
Dim v, v1 'As Vector
Dim f, f1, w As Long, h As Long, w1 As Long, w2 As Long, h1 As Long, h2 As Long, z, t, ps As Integer
Dim i As Long, j As Long, k As Long, k1 As Long, ii As Long, jj As Long, r As Long, a As Double, jd As Double
Const pi = 3.1415926
''1弧度=57.3度, 1度=0.0174533弧度
On Error Resume Next
Set Img = CreateObject("WIA.ImageFile")
Set Img1 = CreateObject("WIA.ImageFile")
Set IP = CreateObject("WIA.ImageProcess")
f1 = ThisWorkbook.Path & "\186.bmp"
Img1.LoadFile f1
w1 = Img1.width
h1 = Img1.height
w = w1 * 1.5
h = h1 * 1.33
x = 2.5 '缩放系数： 0 < x < 1 为缩小，大于 1 为放大
IP.Filters.Add IP.FilterInfos("Scale").FilterID
IP.Filters(1).Properties("MaximumWidth") = w1 * x
IP.Filters(1).Properties("MaximumHeight") = h1 * x
Set Img1 = IP.Apply(Img1)
Set v1 = Img1.ARGBData
w1 = Img1.width
h1 = Img1.height
Set v = CreateObject("WIA.Vector")
For z = 1 To w * h
v.Add &HFFFFFFFF
'v.Add 16777215
Next
r1 = 250
cj = w / 2
ci = h / 2
jd = 0.62 * pi '旋转角度
For i = 1 To h1
For j = 1 To w1
k1 = (i - 1) * w1 + j
'A = 2 * pi * j / w1
a = -0.75 * pi * j / w1 - jd
jj = w / 2 + (h1 - i + r1) / x * Sin(a)
ii = h / 2 + (h1 - i + r1) / x * Cos(a) + r1 - 50
k = (ii - 1) * w + jj
v(k) = v1(k1)
'For t = k - 2 To k
' If v(t) = &HFFFFFFFF Then v(t) = v1(k1)
'Next
Next
Next
Set Img = v.ImageFile(w, h)
f = ThisWorkbook.Path & "\Secp.bmp"
If Dir(f) <> "" Then Kill f
Img.SaveFile f '"Blue." & Img.FileExtension
MsgBox "ok!"
End Sub

复制代码

aman1516 · 发表于 2025-4-17 16:43

详见测试附件：

PS扭曲系列之扇形图.rar (677.54 KB, 下载次数: 21)

PS未完待续，下一节，PS扭曲变形之球形效果......

大灰狼1976 · 发表于 2025-4-17 17:05

aman1516 发表于 2025-4-17 16:38
由于极点坐标是圆形扩散，越外围越会出现投射不到的“空白点”，
查资料，一般采取双列插值方法进行填充， ...

期待球面变换

aman1516 · 发表于 2025-4-17 17:10

先 “知其然，而知其所以然” ——
图像球面化算法-学习笔记
https://blog.csdn.net/sinat_29018995/article/details/113886068

aman1516 · 发表于 2025-4-18 16:52

依葫芦画瓢，原坐标替换新的newX ，newY坐标
int newX = center.x + (int)(pow(rou, 2) / max(center.x, center.y) * cos(theta))
int newY = center.y + (int)(pow(rou, 2) / max(center.x, center.y) * sin(theta))
球面图片大致是下效果：

曲面影射图片会“露点”仍是个问题，算法得优化......

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

[讨论] 图个有趣，VBA也玩PS图片特效

评分

评分

浏览过的版块