高手帮忙把纯代码生成二维码改成64位excel可用的

wcj6376tcp

已经完美解决生成和批量导出空白问题。

林程乐

wcj6376tcp 发表于 2024-11-17 20:26
在opiona的vba上给你修改了批量生成，其他自己修改了。

谢谢。谢谢。谢谢。谢谢。

林程乐

wcj6376tcp 发表于 2024-11-17 20:26
在opiona的vba上给你修改了批量生成，其他自己修改了。

朋友，这个不清除生成会偏移，在那里改才不会偏移、谢谢。我用的是office2024----64位的

wcj6376tcp

林程乐 发表于 2024-11-18 09:04
朋友，这个不清除生成会偏移，在那里改才不会偏移、谢谢。我用的是office2024----64位的

你有清除代码啊？先清除在生成，否则就要加个判断二维码列是否有图片

wcj6376tcp

把  If Range("a" & rrow) <> "" Then 改成


            If Range("a" & rrow) <> "" And Range("b" & rrow) = "" Then 这样注释掉call 备份 也可以了

林程乐

wcj6376tcp 发表于 2024-11-18 15:50
把  If Range("a" & rrow)  "" Then 改成

谢谢高手们。

逍遥爱迪生

Public Function QRCodeToPicture(Optional DotColor As Long = 0, Optional BgColor As Long = 16777215, Optional Zoom As Double = 5) As StdPicture
    Set QRCodeToPicture = BitmapToPicture(hBmp, 1)
End Function？？how to use DotColor BgColor ?

逍遥爱迪生

hBmp = CreateCompatibleBitmap(h, R.Right, R.Bottom),这个不需要清除吗？

1. 
   
2. 
   
3. <div>
   
4. <div>Public Function ArrayToBitmap(ByVal lp As LongPtr, ByVal nWidth As Long, ByVal nHeight As Long, Optional ByVal Margin As Long = 1, Optional BgColor As Long = 16777215, Optional Zoom As Double = 5) As Long</div>
   
5. 
   
6. 
   
7. <div> If hBmp <> 0 Then DeleteObject (hDib) '删除位图对象，防止内存泄漏
   
8.     hBmp = CreateCompatibleBitmap(h, R.Right, R.Bottom)</div></div>

复制代码

逍遥爱迪生

    'Set DotRng = Sht.Cells(Y * 1 + 1, X * 1 + 1)
                        'DotRng.Resize(1, 1).Interior.Color = RGB(0, 0, 0)

这些代码是做什么用的？

Sub TestSaveQrcodePicture()
    Dim Pic As StdPicture
    Set Pic = GetQrcodePic("testabc")
    'SavePicture Pic, Application.ActiveWorkbook.Path & "\qrimg.bmp"
    SavePicture Pic, Application.ActiveWorkbook.Path & "\qrimg.emf"
    MsgBox "ok"
End Sub


Private Sub QRDraw(Data As String)
    Dim X As Integer, Y As Integer, i As Integer
    'Dim Sht As Worksheet, DotRng As Range
    'Set Sht = ActiveSheet
    Dim BestMaskNumber As Integer

    ReDim QRBitData(0 To ModuleSize - 1, 0 To ModuleSize - 1)
    ReDim QRMaskedArray(0 To 7, 0 To ModuleSize - 1, 0 To ModuleSize - 1)

    Call QRDrawPatterns
    Call QRDrawData(Data)
    Call QRDrawVersionInfo

    For i = 0 To 7
        Call ApplyMask(QRBitData, QRMaskedArray, i)
        Call QRDrawFormatInfo(QRMaskedArray, i, i)
    Next i

    BestMaskNumber = EvaluateMask(QRMaskedArray)
    If Debug_Draw_On_Excel_Sheet Then
        'Application.ScreenUpdating = False
        For i = BestMaskNumber To BestMaskNumber
            For X = 0 To ModuleSize - 1
                For Y = 0 To ModuleSize - 1
                    If QRMaskedArray(i, X, Y) = 1 Then
                        'Set DotRng = Sht.Cells(Y * 1 + 1, X * 1 + 1)
                        'DotRng.Resize(1, 1).Interior.Color = RGB(0, 0, 0)
                    End If
                Next Y
            Next X
        Next i
        'Application.ScreenUpdating = True
    End If
End Sub

林程乐

谢谢各位高手，问题解决了。