Copy Customer VBA mod

First, modify the form to add a button named 'Copy' (see above)

Then, add this code behind.

Private Sub Copy_Changed()
    Dim cn As New ADODB.Connection
    Dim cmd As New ADODB.Command
    Dim rst As New ADODB.Recordset
    Dim strNewCustomerNumber As String
     
    If CustomerID = "" Then
        Exit Sub
    End If
     
    'set the database to the currently logged in db.
    Set cn = UserInfoGet.CreateADOConnection
    cn.DefaultDatabase = UserInfoGet.IntercompanyID
     
    'set up the command object
    cmd.ActiveConnection = cn
    cmd.CommandText = "dd_GetNextNumber2"
    cmd.CommandType = adCmdStoredProc
    cmd.Parameters.Append cmd.CreateParameter("@InputNumber", adVarChar, adParamInput, 15, Me.CustomerID)
    'call a stored procedure to get the 'next number'
    Set rst = cmd.Execute
     
    If Not rst.EOF Then
        strNewCustomerNumber = rst("NewNumber")
    End If
     
    'prompt for the new customer number (give the user a chance to change it)
    strNewCustomerNumber = InputBox("New Customer Number", "Verify the new Customer Number", strNewCustomerNumber)
    If strNewCustomerNumber = "" Then
        Exit Sub
    End If
     
    'create the new customer
    Set cmd = New ADODB.Command
    cmd.ActiveConnection = cn
    cmd.CommandText = "dd_RM00101_COPY"
    cmd.CommandType = adCmdStoredProc
    cmd.Parameters.Append cmd.CreateParameter("@custnmbr", adVarChar, adParamInput, 15, Me.CustomerID)
    cmd.Parameters.Append cmd.CreateParameter("@custnmbr2", adVarChar, adParamInput, 15, strNewCustomerNumber)
    cmd.Execute
     
    MsgBox ("Customer added")
     
    'close database
    If cn.State = adStateOpen Then
        cn.Close
    End If
    Set cn = Nothing
    Set cmd = Nothing
    Set rst = Nothing
 
End Sub

The VBA code above calls two stored procedures. First, the GetNextNumber code, which is actually two procs:

IF exists (select * from INFORMATION_SCHEMA.ROUTINES where ROUTINE_NAME = 'dd_GetNextNumber2') begin
    DROP proc dd_GetNextNumber2
end
GO
 
CREATE proc dd_GetNextNumber2
--  dd_GetNextNumber2 'b12123cde00123'
 
@InputNumber varchar(15)
 
AS
 
--call the 'GetNextNumber' code, which increments the supplied @InputNumber.
--note that the parameter is an OUT param
exec dd_GetNextNumber @InputNumber out
 
--loop until we get a number that does not exist in RM00101
while exists (select 1 from rm00101 where custnmbr = @InputNumber) begin
    exec dd_GetNextNumber @InputNumber out
end
 
--return the number that we obtained
select @InputNumber as NewNumber
 
GO
GRANT EXEC ON dd_GetNextNumber2 TO PUBLIC

 

--this routine take the input number and increments it by 1
--Document numbers commonly are in the format of a few alpha characters followed by a number
--like 'ORD0001' or 'PO0001'
--this routine will strip off the trailing numbers, increment, and then put the two parts
--back together again
 
IF exists (select * from INFORMATION_SCHEMA.ROUTINES where ROUTINE_NAME = 'dd_GetNextNumber') begin
    DROP proc dd_GetNextNumber
end
GO
 
CREATE proc dd_GetNextNumber
 
/*
use this code to test:
 
declare @InputNumber varchar(15)
set @InputNumber = 'ord0001'
exec dd_GetNextNumber @InputNumber out
select @InputNumber
*/
 
 
@InputNumber varchar(15) output
 
AS
set transaction isolation level read uncommitted
 
--validate the input
if @InputNumber = '' begin
    return
end
 
--declare some variables
declare @a varchar(1)
declare @i int
declare @front varchar(15)
declare @back varchar(15)
declare @intback int
 
--get the length of the input
set @i = len(@InputNumber)
 
--prime our variable for the loop with the last character in the input
set @a = substring(@InputNumber,@i,1)
 
--start at the end of the number, walk back until we find a non-numeric character
while 1= 1 begin
    if not ISNUMERIC(@a) = 1 begin
        break
    end
 
    set @i = @i-1
    if @i = 0 begin
        break
    end
    set @a = substring(@InputNumber,@i,1)
end
 
 
--get the front part
set @front = SUBSTRING(@InputNumber,1,@i)
 
--get the back part, increment
--use a varchar type so we can get the length and not lose any leading zeros
set @back = SUBSTRING(@InputNumber,@i+1,len(@InputNumber)-@i)
set @intback = @back + 1
 
--add it all back together
select @InputNumber = @front + right('000000000000000' + convert(varchar(15),@intback),len(@InputNumber)- @i)
 
set @a = 0
 
GO
GRANT EXEC ON dd_GetNextNumber TO PUBLIC

Finally, the code to copy the customer. The client asked that we copy the customer, customer address, and email addresses:

IF exists (select * from INFORMATION_SCHEMA.ROUTINES where ROUTINE_NAME = 'dd_RM00101_COPY') begin
    DROP proc dd_RM00101_COPY
end
GO
 
CREATE proc dd_RM00101_COPY
--  dd_RM00101_COPY '1000002', '1000003'
 
@custnmbr varchar(15),
@custnmbr2 varchar(15)
 
AS
set transaction isolation level read uncommitted
 
insert into rm00101 (CUSTNMBR ,CUSTNAME,CUSTCLAS,CPRCSTNM,CNTCPRSN,STMTNAME,SHRTNAME,ADRSCODE,UPSZONE,SHIPMTHD,TAXSCHID,ADDRESS1,ADDRESS2,ADDRESS3,COUNTRY,CITY,STATE,ZIP,PHONE1, PHONE2,PHONE3,FAX,PRBTADCD,PRSTADCD,STADDRCD,SLPRSNID,CHEKBKID,PYMTRMID,CRLMTTYP,CRLMTAMT,CRLMTPER,CRLMTPAM,CURNCYID,RATETPID,CUSTDISC,PRCLEVEL,MINPYTYP,MINPYDLR,MINPYPCT,FNCHATYP,FNCHPCNT,FINCHDLR,MXWOFTYP, MXWROFAM,COMMENT1,COMMENT2,USERDEF1,USERDEF2,TAXEXMT1,TAXEXMT2,TXRGNNUM,BALNCTYP,STMTCYCL,BANKNAME,BNKBRNCH,SALSTERR,DEFCACTY,RMCSHACC,RMARACC,RMSLSACC,RMIVACC,RMCOSACC,RMTAKACC,RMAVACC,RMFCGACC,RMWRACC,RMSORACC,FRSTINDT,INACTIVE,HOLD,CRCARDID, CRCRDNUM,CCRDXPDT,KPDSTHST,KPCALHST,KPERHIST,KPTRXHST,NOTEINDX,CREATDDT,MODIFDT,Revalue_Customer,Post_Results_To,FINCHID,GOVCRPID,GOVINDID,DISGRPER,DUEGRPER,DOCFMTID,Send_Email_Statements,USERLANG,GPSFOINTEGRATIONID, INTEGRATIONSOURCE,INTEGRATIONID,ORDERFULFILLDEFAULT,CUSTPRIORITY,CCode,DECLID,RMOvrpymtWrtoffAcctIdx,SHIPCOMPLETE,CBVAT,INCLUDEINDP)
    select           @custnmbr2,CUSTNAME,CUSTCLAS,CPRCSTNM,CNTCPRSN,STMTNAME,SHRTNAME,ADRSCODE,UPSZONE,SHIPMTHD,TAXSCHID,ADDRESS1,ADDRESS2,ADDRESS3,COUNTRY,CITY,STATE,ZIP,PHONE1, PHONE2,PHONE3,FAX,PRBTADCD,PRSTADCD,STADDRCD,SLPRSNID,CHEKBKID,PYMTRMID,CRLMTTYP,CRLMTAMT,CRLMTPER,CRLMTPAM,CURNCYID,RATETPID,CUSTDISC,PRCLEVEL,MINPYTYP,MINPYDLR,MINPYPCT,FNCHATYP,FNCHPCNT,FINCHDLR,MXWOFTYP ,MXWROFAM,COMMENT1,COMMENT2,USERDEF1,USERDEF2,TAXEXMT1,TAXEXMT2,TXRGNNUM,BALNCTYP,STMTCYCL,BANKNAME,BNKBRNCH,SALSTERR,DEFCACTY,RMCSHACC,RMARACC,RMSLSACC,RMIVACC,RMCOSACC,RMTAKACC,RMAVACC,RMFCGACC,RMWRACC,RMSORACC,FRSTINDT,INACTIVE,HOLD,CRCARDID, CRCRDNUM,CCRDXPDT,KPDSTHST,KPCALHST,KPERHIST,KPTRXHST,NOTEINDX,CREATDDT,MODIFDT,Revalue_Customer,Post_Results_To,FINCHID,GOVCRPID,GOVINDID,DISGRPER,DUEGRPER,DOCFMTID,Send_Email_Statements,USERLANG,GPSFOINTEGRATIONID, INTEGRATIONSOURCE,INTEGRATIONID,ORDERFULFILLDEFAULT,CUSTPRIORITY,CCode,DECLID,RMOvrpymtWrtoffAcctIdx,SHIPCOMPLETE,CBVAT,INCLUDEINDP
        from rm00101 c
        where c.custnmbr = @custnmbr
 
insert into rm00102 ( CUSTNMBR,ADRSCODE,SLPRSNID,UPSZONE,SHIPMTHD,TAXSCHID,CNTCPRSN,ADDRESS1,ADDRESS2,ADDRESS3,COUNTRY,CITY,STATE,ZIP,PHONE1,PHONE2,PHONE3,FAX,MODIFDT,CREATDDT, GPSFOINTEGRATIONID,INTEGRATIONSOURCE,INTEGRATIONID,CCode,DECLID,LOCNCODE,SALSTERR,USERDEF1,USERDEF2,ShipToName,Print_Phone_NumberGB)
    select            @custnmbr2,ADRSCODE,SLPRSNID,UPSZONE,SHIPMTHD,TAXSCHID,CNTCPRSN,ADDRESS1,ADDRESS2,ADDRESS3,COUNTRY,CITY,STATE,ZIP,PHONE1,PHONE2,PHONE3,FAX,MODIFDT,CREATDDT, GPSFOINTEGRATIONID,INTEGRATIONSOURCE,INTEGRATIONID,CCode,DECLID,LOCNCODE,SALSTERR,USERDEF1,USERDEF2,ShipToName,Print_Phone_NumberGB
        from rm00102 ca
        where ca.CUSTNMBR = @custnmbr
 
 
insert into sy01200 (Master_Type,Master_ID,ADRSCODE,INET1,INET2,INET3,INET4,INET5,INET6,INET7,INET8,Messenger_Address,INETINFO,EmailToAddress,EmailCcAddress,EmailBccAddress)
    select           Master_Type,@custnmbr2,ADRSCODE,INET1,INET2,INET3,INET4,INET5,INET6,INET7,INET8,Messenger_Address,INETINFO,EmailToAddress,EmailCcAddress,EmailBccAddress
        from sy01200
        where Master_Type = 'cus'
            and Master_ID = @custnmbr
 
GO
GRANT EXEC ON dd_RM00101_COPY TO PUBLIC

 

 

 



RealWorldCode gives developers practical, real‑world solutions with clean, working code — no fluff, no theory, just answers.
Links
Home
Knowledge Areas
Sitemap
Contact
Et cetera
Privacy Policy
Terms and Conditions
Cookie Preferences